{- ---------------------------------------------------------------------------
-- imported by Main and Need
-}
module PreImport (HideDeclIds,qualRename,preImport) where

import List(nub,intersect,(\\))
import TokenId(TokenId(..),tPrelude,tNHCInternal,tYHCDynamic
                ,t_Arrow,ensureM,forceM,dropM
                ,rpsPrelude,t_List,isTidCon
                ,tRatioMod,visRatio,visRational,visRatioCon)
import SysDeps(PackedString,packString)
import Syntax hiding (TokenId)
import IdKind
import qualified Data.Set as Set
import qualified Data.Map as Map
import Util.Extra
import Flags
import IExtract
import Info hiding (TokenId)
import PreImp(HideDeclIds,HideDeclType,HideDeclData,HideDeclDataPrim
             ,HideDeclClass,HideDeclInstance,HideDeclVarsType)
import Maybe
import Building(Compiler(..),compiler)


-- | Internal, fully coalesced import declaration
type IntImpDecl = (TokenId {-module name-}, ImportedNamesInScope)


-- | There are two sets of names in scope, the NQ-set and the Q-set.
-- For every imported module, an individual import decl can enlarge
-- either both sets together, or just the Q-set.  When the two sets are
-- identical by construction, our representation takes a short-cut and
-- stores only one set, calling it NQ.  When the NQ-set is empty, we store
-- only the Q-set.  When the two sets are different and non-empty, we
-- store both, but the Q-set is always equal to or larger than the NQ-set.
data ImportedNamesInScope =
      NQ NameSetSpec    -- ^represents  Q-set  = NQ-set.
    | Q  NameSetSpec    -- represents  NQ-set = empty.
    | Both NameSetSpec{-notQ-} NameSetSpec{-Q-}
                        -- invariant:  Q-set >= NQ-set.

-- | The representation of a name-set is a mixture of intension and extension.
-- [@Deny []@]      means everything found in the exporting module
-- [@Deny xs@]      means everything excluding the named entities
-- [@Allow xs@]     means only the named entities
-- [@Allow []@]     means no entities, probably a very rare specification
-- Hence,   @Deny []  >  Deny xs  >  Allow xs  >  Allow []@
data NameSetSpec =
      Allow [(TokenId,IE)]
    | Deny [(TokenId,IE)]


-- | Assuming that import decls have been converted to nameset specifications,
-- the 'combine' function joins two given specifications.  Imports are
-- cumulative, so a nameset can only get larger.

combine :: NameSetSpec -> NameSetSpec -> NameSetSpec
combine (Deny [])  _          = Deny []
combine _          (Deny [])  = Deny []
combine (Allow xs) (Deny ys)  = Deny (ys\\xs)
combine (Allow xs) (Allow ys) = Allow (nub (xs++ys))
combine (Deny xs)  (Deny ys)  = Deny (intersect xs ys)
combine (Deny xs)  (Allow ys) = Deny (xs\\ys)


-- | The rules for combining different imports of the same module are complex.
-- The second argument to the 'joinNames' function is the accumulated
-- state of all imports so far, and can thus have the Both constructor,
-- representing differing NQ- and Q-sets.  The first argument is the
-- additional import decl, and can enlarge either both sets (NQ) or just the
-- Q-set, but cannot enlarge the two sets separately (no Both constructor).

joinNames :: ImportedNamesInScope -> ImportedNamesInScope -> ImportedNamesInScope
joinNames (NQ new)        (NQ old)    = NQ (combine old new)
joinNames (Q new)         (Q old)     = Q  (combine old new)
joinNames (Q q)           (NQ nq)     = joinNames (NQ nq) (Q q)

joinNames (NQ (Deny []))  (Q old)     = NQ   (Deny [])
joinNames (NQ new)        (Q old)     = Both new (combine old new)

joinNames (NQ (Deny []))  (Both nq q) = NQ   (Deny [])
joinNames (NQ new)        (Both nq q) = Both (combine nq new) (combine q new)
joinNames (Q new)         (Both nq q) = Both nq (combine q new)


-- | Finally, we need a lookup function that can tell us whether a name
-- is in the permissible set of names specified by the import decls.

nameInScope :: ImportedNamesInScope -> TokenId -> Bool
nameInScope (NQ nameset) tid = tid `inScope` nameset
nameInScope (Q nameset)  tid = tid `inScope` nameset
nameInScope (Both nq q)  tid = (tid `inScope` nq) || (tid `inScope` q)

inScope :: TokenId -> NameSetSpec -> Bool
inScope tid (Deny [])  = True
inScope tid (Deny xs)  = not (tid `elem` (map fst xs))
inScope tid (Allow xs) =     (tid `elem` (map fst xs))

-- | 'mustQualify' assumes a separate test for inclusion in the permissible names
mustQualify :: ImportedNamesInScope -> TokenId -> Bool
mustQualify (NQ nameset) tid = False
mustQualify (Q nameset)  tid = tid `inScope` nameset
mustQualify (Both nq q)  tid = (tid `inScope` q) && not (tid `inScope` nq)

----

qualRename :: TokenId -> [ImpDecl TokenId] -> TokenId -> [TokenId]

qualRename modid impdecls = qualRename' qTree
 where
  qualRename' t q@(Qualified t1 t2)
    | (Visible t1)==modid && t1/=rpsPrelude  = [Visible t2]
    | otherwise =
        case Map.lookup t1 t of
            Nothing -> [q]
            Just ts -> map (\t'-> Qualified t' t2) ts
  qualRename' t v = [v]

  qTree = foldr qualR Map.empty impdecls

  qualR (Import    _ _)  t = t
  qualR (ImportQ   _ _)  t = t
  qualR (ImportQas (_,Visible id) (_,Visible id') _) t = Map.insertWith (++) id' [id] t
  qualR (Importas  (_,Visible id) (_,Visible id') _) t = Map.insertWith (++) id' [id] t


---- ===================================

preImport :: Flags -> TokenId -> Set.Set TokenId
          -> Maybe [Export TokenId] -> [ImpDecl TokenId]
          -> Either String
               ((TokenId->Bool) -> TokenId -> IdKind -> IE
               ,[(PackedString
                 ,(PackedString, PackedString, Set.Set TokenId)
                    -> [[TokenId]]
                    -> Bool
                 ,HideDeclIds
                 )
                ]
               )

-- When the export list is :: Maybe [Export TokenId])
--    Nothing -> export nothing except instances
--    Just [] -> export everything
--    Just xs -> export only entities from the list xs

preImport flags mtid@(Visible mrps) need (Just expdecls) impdecls =
  let impdecls' = transImport impdecls in
  Right ( if null expdecls || (isJust . flip Map.lookup exportAT) (mtid,Modid)
          then reExportAll
          else reExportTid mrps exportAT
        , map (mkNeed need exportAT) impdecls')
  where
  exportAT = mkExportAT expdecls
preImport flags mtid@(Visible mrps) need Nothing impdecls =
  let impdecls' = transImport impdecls in
  Right (reExportTid mrps Map.empty, map (mkNeed need Map.empty) impdecls')


{-
-- transImport orders the import files (with prelude last),
-- inserts qualified import of prelude,
-- and checks that all imports are consistent
-}
transImport :: [ImpDecl TokenId]
            -> [IntImpDecl]

transImport impdecls = impdecls'
  where
  impdecls' =  (reorder [] . {-sortImport .-} traverse Map.empty False)
                (ImportQ (noPos,tNHCInternal) (Hiding [])
                :ImportQ (noPos,tRatioMod) (NoHiding
                                [EntityConClsAll noPos visRational
                                ,EntityConClsAll noPos visRatio
                                ,EntityVar noPos visRatioCon ])
                :impdecls)

  reorder p [] = p
  reorder p (m@(k,v):xs) | k==tPrelude     = reorder (m:p) xs
                         | k==tNHCInternal = reorder (m:p) xs
                         | otherwise       = m: reorder p xs

{-
  -- Place imports into order, ensure Prelude is last
  --   Why?  The order is lexicographic of the /reversed/ module name???
  --         Changed to use simpler 'reorder' above.
  sortImport impdecls =
          ( map snd
          . sortBy cmp
          . map (\(k,v)-> if k==tPrelude || k==tNHCInternal
                          then (Right k,(k,v))
                          else (Left k, (k,v)) )
          ) impdecls

    where cmp (a, _) (b, _) = case compare a b of
                                EQ -> error "Fail in PreImport.transImport\n"
                                x  -> x
-}

  traverse :: Map.Map TokenId ImportedNamesInScope
           -> Bool      -- have we found an explicit Prelude import yet?
           -> [ImpDecl TokenId]
           -> [(TokenId, ImportedNamesInScope)]

  traverse acc True  []      = Map.toList acc
  traverse acc False []      = traverse acc False [Import (noPos,tPrelude)
                                                          (Hiding [])]
  traverse acc prel (x:xs)  =
    case extractImp x of
      (tid,info) ->
        traverse (Map.insertWith joinNames tid info acc) (prel || tid==tPrelude) xs

  extractImp (ImportQ  (pos,tid) impspec) =
    (tid, Q (extractSpec impspec))
  extractImp (ImportQas (pos,tid) (apos,atid) impspec) =
    (tid, Q (extractSpec impspec))
  extractImp (Import (pos,tid) impspec) =
    (tid, NQ (extractSpec impspec))
  extractImp (Importas (pos,tid) (apos,atid) impspec) =
    (tid, NQ (extractSpec impspec))

  extractSpec (NoHiding entities) = Allow (concatMap extractImpEntity entities)
  extractSpec (Hiding entities)   = Deny  (concatMap extractImpEntity entities)

  extractImpEntity e =
    map (\e-> case e of ((tid,kind),ie) -> (tid,ie)) (extractEntity e)

{- Now obsolete  i.e. never report explicit/hiding conflicts
--checkImport :: (TokenId, ([Pos],[TokenId],ImportedNamesInScope))
--            -> [String]
--checkImport (tid,(nq,q,pos_spec)) =
--  case partition (isLeft . snd) pos_spec of
--    ([],hide)  -> []  -- Only explicit hide
--    (imp,[])   -> []  -- Only explicit imports
--    (imp,hide) ->
--      if (null . filter (not.null) . map (dropRight . snd)) hide
--      then []         -- Ok as all hidings are empty
--      else ["Conflicting imports for " ++ show tid ++
--            ", used both explicit imports (at" ++
--            (mixCommaAnd . map (strPos . fst)) imp
--            ++ ") and explicit hidings (at " ++
--            (mixCommaAnd . map (strPos . fst)) hide ++")."]
-}


{- Obsolete in H'98
--checkForMultipleImport imports =
--    case foldr prepare (initAT,[]) imports of
--      (qm,qas) ->
--      case (filter (elemM qm) qas,filter ((1/=) . length) (group qas)) of
--        (qas,qas2) ->
--          map (\tid -> "Can not rename a module to " ++ show tid ++
--              " as another module with that name is imported qualified.") qas
--          ++
--          map (\tids -> "More than one module is renamed to " ++
--                        show (head tids) ++ ".") qas2
-- where
--  prepare (tid,(nq,Just tids,pos_spec)) (qm,qas) = (addM qm tid,tids++qas)
--  prepare _ (qm,qas) = (qm,qas)
-}


------------------------------------------------------------------------------

mkExportAT :: [Export TokenId] -> Map.Map (TokenId,IdKind) IE
mkExportAT expdecls = exportAT
 where
  exportAT :: Map.Map (TokenId,IdKind) IE
  exportAT = foldr export Map.empty (concatMap preX expdecls)

  export (key,value) t = Map.insertWith combIE key value t

  preX (ExportEntity _ e) = extractEntity e
  preX (ExportModid _ tid) = [((tid,Modid),IEall)]


extractEntity :: Entity TokenId -> [((TokenId, IdKind), IE)]
extractEntity (EntityVar  pos tid)       = [((tid,Var),IEall)]
extractEntity (EntityConClsAll pos tid)
    | (tid==t_Arrow || tid==t_List)      = [((dropM tid,TCon),IEall)]
    | otherwise                          = [((tid,TC),IEall)]
extractEntity (EntityConClsSome pos tid [])
    | (tid==t_Arrow || tid==t_List)      = [((dropM tid,TCon),IEabs)]
    | otherwise                          = [((tid,TC),IEabs)]
extractEntity (EntityConClsSome pos tid ids)
    | (tid==t_Arrow || tid==t_List)      =  ((dropM tid,TCon),IEsome) : constrs
    | otherwise                          =  ((tid,TC),IEsome) : subordinates
  where constrs = map (\(pos,tid)-> ((tid,Con),IEsel)) ids
        subordinates = if any (isTidCon.snd) ids then
                            map (\(pos,tid)-> if isTidCon tid then
                                                   ((tid,Con),IEsel)
                                              else ((tid,Field),IEsel))
                                ids
                       else map (\(pos,tid)-> ((tid,Method),IEsel)) ids
                                -- could really be Method or Field...

------

reExportAll :: (TokenId->Bool) -> TokenId -> IdKind -> IE
reExportAll q tid kind = IEall

reExportTid :: PackedString -> Map.Map (TokenId,IdKind) IE
            -> (TokenId->Bool) -> TokenId -> IdKind -> IE
reExportTid modname exportAT mustBeQualified tid kind =
  case Map.lookup (dropM tid, kind) exportAT of
    Just imp | not (mustBeQualified tid) -> imp
    _  ->
      case Map.lookup (forceM modname tid, kind) exportAT of
        Just imp | mustBeQualified tid -> imp
        _                              -> IEnone

--------------------------------------


{-
-- The selectors for (hideDeclType,hideDeclData,hideDeclDataPrim,hideDeclClass,
-- hideDeclInstance,hideDeclVarsType) are defined in PreImp and used in ParseI
-}

mkNeed :: Set.Set TokenId
       -> Map.Map (TokenId,IdKind) IE
       -> IntImpDecl
       -> ( PackedString
          , (PackedString, PackedString, Set.Set TokenId)
               -> [[TokenId]] -> Bool
          , HideDeclIds
          )

mkNeed needM exportSpec (vt@(Visible modname), importSpec) =
   ( modname
   , \needI -> any (needFun needI)
   , (hideDeclType,hideDeclData,hideDeclDataPrim
     ,hideDeclClass,hideDeclInstance,hideDeclVarsType)
   )

 where

  imported = nameInScope importSpec . dropM
  q        = mustQualify importSpec . dropM

  reExport
    | reExportModule = reExportAll
    | otherwise      = reExportTid modname exportSpec

  reExportModule = isJust (Map.lookup (vt,Modid) exportSpec)

--needFun' x y =
--    let result = needFun x y in
--    strace ("needFun: "++show (fst3 x)++"/"++show (snd3 x)++" "
--            ++show y++" "++show result) $ result
  needFun (orps,rps,needI) ns@(n:_) =
        Set.member (ensureM rps n) needI
                                -- is used by other interface (real name)
                                -- (only check first name = type or class)
     || any (\n-> imported n &&
                    (  ((`Set.member` needM) . forceM orps) n
                                -- used qualified and imported (un)qualified
                    || (not (q n)) &&
                          (  ((`Set.member` needM) . dropM) n
                                -- used unqualified and imported unqualified
                          || reExportModule
                                -- reexported whether used or not
                          )
                    ))
            ns


  hideDeclType :: HideDeclType
  hideDeclType st attr (Simple pos tid tvs) typ =
    if imported tid then
      iextractType (reExport q tid TSyn) attr q pos tid tvs typ () st
    else
      iextractType IEnone attr (\_->True) pos tid tvs typ () st
                -- used by an interface file, not directly in source code

  hideDeclData :: HideDeclData
  hideDeclData st attr ctxs (Simple pos tid tvs) constrs needs der =
    if imported tid then
      iextractData (reExport q tid TCon) q attr ctxs pos
                   tid tvs constrs (safetail (concat needs)) () st
   else
      iextractData IEnone (\_->True) attr ctxs pos
                   tid tvs [] {-(if q tid then constrs else [])-} [] () st
   where safetail xs | null xs   = xs
                     | otherwise = tail xs

  hideDeclDataPrim :: HideDeclDataPrim
  hideDeclDataPrim st (pos,tid) size =
    if imported tid then
      iextractDataPrim (reExport q tid TCon) q pos tid size () st
    else
      iextractDataPrim IEnone (\_->True) pos tid size () st

  hideDeclClass :: HideDeclClass
  hideDeclClass st  ctxs (pos,tid) [tvar] methods needs =
    if imported tid then
      iextractClass (reExport q tid TClass) q pos ctxs tid
                    (snd tvar) methods (safetail (concat needs)) () st
    else
      iextractClass IEnone (\_->True) pos ctxs tid
                    (snd tvar) (if q tid then methods else []) [] () st
   where safetail xs | null xs   = xs
                     | otherwise = tail xs

  hideDeclInstance :: HideDeclInstance
  hideDeclInstance st (_,mod) ctxs (pos,cls) [typ] =
    iextractInstance mod ctxs pos cls typ () st
                -- instances are always imported, they cannot be hidden.

  hideDeclVarsType :: HideDeclVarsType
  hideDeclVarsType st postidanots ctxs typ =
                -- interface files should never depend on functions
{- we don't create interface files with more than one function/type
    case filter (isJust . lookupAT impT . dropM . snd . fst) postidanots of
      [] -> st
      postidanots ->
-}
         iextractVarsType (\q tid idkind ->
                              if imported tid && not (q tid)
                              then reExport q tid idkind
                              else IEnone)
                          q postidanots ctxs typ () st