module UHC.Light.Compiler.Module.ImportExport
( ModEnt (..), ModExp (..), ModEntSpec (..), ModEntSubSpec (..), ModImp (..), Mod (..), ModEntRel, ModEntDomMp, ModEntRngMp
, emptyMod
, mentrelStrip
, ModEntRelFilterMp, mentrelFilterMpUnion, mentrelFilterMpUnions, mentrelToFilterMp, mentrelToFilterMp'
, mentrelFilterMpModuleNames
, mentrelFilterMpSingleton
, modImpBuiltin
, emptyMod'
, modBuiltin
, ModMpInfo (..), ModMp, emptyModMpInfo, mkModMpInfo
, ppModMp
, modMpAddHiddenExps
, modMpCombine', modMpCombine
, modImpPrelude )
where
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.NameAspect
import Data.Maybe
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import UHC.Util.Utils
import UHC.Util.Pretty
import qualified UHC.Util.Rel as Rel
import UHC.Light.Compiler.CodeGen.ValAccess as VA
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Gam.TyGam (initTyGam)
import UHC.Light.Compiler.Gam.KiGam (initKiGam)
import UHC.Light.Compiler.CodeGen.RefGenerator
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize







{-# LINE 59 "src/ehc/Module/ImportExport.chs" #-}
data ModEnt
  = ModEnt
      { mentKind    :: !IdOccKind
      , mentIdOcc   :: !IdOcc
      , mentOwns    :: !(Set.Set ModEnt)
      , mentRange	:: !Range
      }
  deriving (Show)

instance Eq ModEnt where
  e1 == e2 = mentKind e1 == mentKind e2 && mentIdOcc e1 == mentIdOcc e2

instance Ord ModEnt where
  e1 `compare` e2
    = case mentKind e1 `compare` mentKind e2 of
        EQ -> mentIdOcc e1 `compare` mentIdOcc e2
        c  -> c

type ModEntRel     = Rel.Rel HsName  ModEnt
type ModEntDomMp   = Map.Map HsName [ModEnt]
type ModEntRngMp   = Map.Map IdOcc  [HsName]

mentIsCon :: ModEnt -> Bool
mentIsCon e = mentKind e == IdOcc_Data || mentKind e == IdOcc_Class


{-# LINE 87 "src/ehc/Module/ImportExport.chs" #-}
mentStrip :: ModEnt -> ModEnt
mentStrip e = e {mentRange = emptyRange}

mentrelStrip :: ModEntRel -> ModEntRel
mentrelStrip = Rel.mapDomRng (\(n,e) -> (n,mentStrip e))

{-# LINE 95 "src/ehc/Module/ImportExport.chs" #-}
deriving instance Typeable ModEnt

{-# LINE 99 "src/ehc/Module/ImportExport.chs" #-}
-- intended for parsing
ppModEnt :: ModEnt -> PP_Doc
ppModEnt e
  = ppCurlysCommasBlock (l1 ++ l2)
  where l1 = [pp (mentKind e),pp (mentIdOcc e)]
        l2 = if Set.null (mentOwns e) then [] else [ppCurlysCommasBlock (map ppModEnt $ Set.toList $ mentOwns e)]

-- intended for parsing
ppModEntRel :: ModEntRel -> PP_Doc
ppModEntRel = ppCurlysAssocL pp ppModEnt . Rel.toList


{-# LINE 115 "src/ehc/Module/ImportExport.chs" #-}
instance PP ModEnt where
  pp = ppModEnt

instance PP ModEntRel where
  pp = ppModEntRel

{-# LINE 127 "src/ehc/Module/ImportExport.chs" #-}
-- | names used per category of identifier
type ModEntRelFilterMp = Map.Map IdOccKind HsNameS

mentrelFilterMpUnion :: ModEntRelFilterMp -> ModEntRelFilterMp -> ModEntRelFilterMp
mentrelFilterMpUnion = Map.unionWith Set.union

mentrelFilterMpUnions :: [ModEntRelFilterMp] -> ModEntRelFilterMp
mentrelFilterMpUnions [] = Map.empty
mentrelFilterMpUnions l  = foldr mentrelFilterMpUnion Map.empty l

-- | extract ModEntRelFilterMp from export relation
mentrelToFilterMp' :: Bool -> [HsName] -> ModEntRel -> ModEntRelFilterMp
mentrelToFilterMp' inclOwns exclModNmL r
  = rget True $ Rel.rng r
  where get (ModEnt {mentIdOcc=(IdOcc {ioccKind=k, ioccNm=n}), mentOwns=owns})
                       = mentrelFilterMpUnion (mentrelFilterMpSingleton exclModNmL k n) (rget inclOwns owns)
        rget True occs = mentrelFilterMpUnions [ get e | e <- Set.toList occs ]
        rget _    _    = Map.empty

-- | extract ModEntRelFilterMp from export relation
mentrelToFilterMp :: [HsName] -> ModEntRel -> ModEntRelFilterMp
mentrelToFilterMp = mentrelToFilterMp' True

{-# LINE 152 "src/ehc/Module/ImportExport.chs" #-}
-- | extract used module names from ModEntRelFilterMp
mentrelFilterMpModuleNames :: ModEntRelFilterMp -> HsNameS
mentrelFilterMpModuleNames m = Set.unions [ Set.map fromJust $ Set.filter isJust $ Set.map hsnQualifier s | s <- Map.elems m ]

{-# LINE 158 "src/ehc/Module/ImportExport.chs" #-}
-- | construct a singleton, only not of the current module
mentrelFilterMpSingleton :: [HsName] -> IdOccKind -> HsName -> ModEntRelFilterMp
mentrelFilterMpSingleton exclModNmL k n
  = case hsnQualifier n of
      Just m | not (m `elem` exclModNmL)
        -> Map.singleton k (Set.singleton n)
        where
      _ -> Map.empty

{-# LINE 173 "src/ehc/Module/ImportExport.chs" #-}
data ModExp
  = ModExpEnt !ModEntSpec
  | ModExpMod !HsName
  deriving (Show,Typeable)

data ModEntSpec
  = ModEntSpec !HsName !Range !(Maybe ModEntSubSpec)
  deriving (Show,Typeable)

data ModEntSubSpec
  = ModEntSubAll
  | ModEntSubs ![HsName]
  deriving (Show,Typeable)

data ModImp
  = ModImp
      { mimpQualified   :: !Bool
      , mimpSource      :: !HsName
      , mimpAs          :: !HsName
      , mimpHiding      :: !Bool
      , mimpImpL        :: ![ModEntSpec]
      , mimpRange		:: !Range
      }
  deriving (Show,Typeable)

emptyModImp :: ModImp
emptyModImp = ModImp False hsnUnknown hsnUnknown True [] emptyRange


{-# LINE 204 "src/ehc/Module/ImportExport.chs" #-}
modImpBuiltin :: ModImp
modImpBuiltin
  = emptyModImp
      { mimpSource      = hsnModBuiltin
      , mimpAs          = hsnModBuiltin
      }

{-# LINE 213 "src/ehc/Module/ImportExport.chs" #-}
modImpPrelude :: ModImp
modImpPrelude
  = emptyModImp
      { mimpSource      = hsnModPrelude
      , mimpAs          = hsnModPrelude
      }

{-# LINE 222 "src/ehc/Module/ImportExport.chs" #-}
instance PP ModExp where
  pp (ModExpEnt s) = pp s
  pp (ModExpMod m) = "module" >#< m

instance PP ModEntSpec where
  pp (ModEntSpec n _ s) = n >|< maybe empty pp s

instance PP ModEntSubSpec where
  pp ModEntSubAll = pp "(..)"
  pp (ModEntSubs ns) = ppParensCommas ns

instance PP ModImp where
  pp i = mimpSource i >|< ppParensCommas (mimpImpL i)

{-# LINE 242 "src/ehc/Module/ImportExport.chs" #-}
data Mod
  = Mod
      { modName         :: !HsName
      , modNameInSrc    :: !(Maybe HsName)
      , modExpL         :: !(Maybe [ModExp])
      , modImpL         :: ![ModImp]
      , modDefs         :: !ModEntRel
      , modHiddenExps   :: !ModEntRel
      , modInstNmL      :: ![HsName]
      }
  deriving (Show,Typeable)

emptyMod' n = Mod n Nothing Nothing [] Rel.empty Rel.empty []
emptyMod = emptyMod' hsnUnknown

{-# LINE 259 "src/ehc/Module/ImportExport.chs" #-}
modBuiltin
  = emptyMod
      { modName         = hsnModBuiltin
      , modDefs         = defs
      }
  where defs
          = Rel.fromList [ (n,ModEnt IdOcc_Type (IdOcc n IdOcc_Type) Set.empty emptyRange) | (n,_) <- gamToAssocL initTyGam ]
            `Rel.union` Rel.fromList [ (n,ModEnt IdOcc_Kind (IdOcc n IdOcc_Kind) Set.empty emptyRange) | (n,_) <- gamToAssocL initKiGam ]

{-# LINE 270 "src/ehc/Module/ImportExport.chs" #-}
instance PP Mod where
  pp m = modName m >|< "/" >|< modNameInSrc m
         >-< indent 2 (   "IMP" >#< ppParensCommas (modImpL m)
                      >-< "EXP" >#< maybe empty ppParensCommas (modExpL m)
                      >-< "HID" >#< pp (modHiddenExps m)
                      >-< "DEF" >#< pp (modDefs m)
                      )

{-# LINE 284 "src/ehc/Module/ImportExport.chs" #-}
modEntSpec :: Bool -> ModEntRel -> ModEntSpec -> ModEntRel
modEntSpec isHiding rel (ModEntSpec x _ subspec)
  | isHiding && isNothing subspec
              = mSpec
  | otherwise = Rel.unions [mSpec,mSub mSpec]
  where mSpec       = Rel.restrictDom (==x) rel
        mSub spec   = case subspec of
                        Nothing              -> Rel.empty
                        Just ModEntSubAll    -> subs
                        Just (ModEntSubs xs) -> Rel.restrictDom ((`elem` xs) . hsnQualified) subs
                    where allSubs     = mentOwns `unionMapSet` Rel.rng spec
                          subs        = Rel.restrictRng (`Set.member` allSubs) rel

{-# LINE 303 "src/ehc/Module/ImportExport.chs" #-}
modExports :: Mod -> ModEntRel -> ModEntRel
modExports mod inscp
  = case modExpL mod of
      Nothing -> modDefs mod
      Just es -> hsnQualified `Rel.mapDom` Rel.unions exps
              where exps = modExpListEntry inscp `map` es

{-# LINE 312 "src/ehc/Module/ImportExport.chs" #-}
modExpListEntry :: ModEntRel -> ModExp -> ModEntRel
modExpListEntry inscp (ModExpEnt it)
  = modEntSpec False inscp it
modExpListEntry inscp (ModExpMod m)
  = (hsnSetQual m `Rel.mapDom` unqs) `Rel.intersection` qs
  where (qs,unqs) = Rel.partitionDom hsnIsQual inscp

{-# LINE 325 "src/ehc/Module/ImportExport.chs" #-}
modInscope :: Mod -> (HsName -> ModEntRel) -> ModEntRel
modInscope m expsOf
  = Rel.unions [imports,locals]
  where defEnts = modDefs m
        locals  = Rel.unions
                    [ hsnQualified `Rel.mapDom` defEnts
                    , hsnSetQual (modName m) `Rel.mapDom` defEnts
                    ]
        imports = Rel.unions $ map (impOf expsOf) impL
        impL    = -- (\v -> tr "modInscope.impL: " (modName m >#< v) v) $
                  modImpL m
        impOf e n
                = -- (\v -> tr "modInscope.impOf: " (modName m >#< n >#< v) v) $
                  modImp e n

{-# LINE 342 "src/ehc/Module/ImportExport.chs" #-}
modImp :: (HsName -> ModEntRel) -> ModImp -> ModEntRel
modImp expsOf imp
  | mimpQualified imp = qs
  | otherwise         = Rel.unions [unqs,qs]
  where qs       = hsnSetQual (mimpAs imp) `Rel.mapDom` incoming
        unqs     = hsnQualified `Rel.mapDom` incoming
        listed   = Rel.unions $ map (modEntSpec isHiding exps) (mimpImpL imp)
        isHiding = mimpHiding imp
        exps     = expsOf (mimpSource imp)
        incoming
          | isHiding  = exps `Rel.difference` listed
          | otherwise = listed

{-# LINE 361 "src/ehc/Module/ImportExport.chs" #-}
modInsOuts :: (HsName -> ModEntRel) -> [Mod] -> [(ModEntRel,ModEntRel)]
modInsOuts otherExps mods
  = inscps `zip` exps
  where inscps       = computeIs exps
        exps         = lfpAfter nextExps $ replicate (length mods) Rel.empty
        nextExps     = computeEs . computeIs
        computeEs is = zipWith modExports mods is
        computeIs es = map (`modInscope` toFun es) mods
        toFun es m   = maybe (otherExps m) (es !!) (lookup m modIxs)
        modIxs       = map modName mods `zip` [0..]

{-# LINE 374 "src/ehc/Module/ImportExport.chs" #-}
lfpAfter :: Eq x => (x -> x) -> x -> x
lfpAfter f x
  = if fx == x then fx else lfpAfter f fx
  where fx = f x

{-# LINE 385 "src/ehc/Module/ImportExport.chs" #-}
checkMod :: (HsName -> Maybe ModEntRel) -> ModEntRel -> Mod -> [Err]
checkMod expsOf inscp mod
  = checkAmbigExps modExports
    ++ if null missingModules
       then checkExpSpec inscp mod
            ++ [ err | (imp,Just exps) <- impSources, err <- checkImp exps imp ]
       else [rngLift emptyRange mkErr_NamesNotIntrod' "module" missingModules]
  where Just modExports = expsOf (modName mod)
        impSources      = [ (imp,expsOf (mimpSource imp)) | imp <- modImpL mod ]
        missingModules  = nubOn fst [ mkThingAnd1Range (mimpRange imp) (mimpSource imp) | (imp,Nothing) <- impSources ]

{-# LINE 398 "src/ehc/Module/ImportExport.chs" #-}
checkAmbigExps :: ModEntRel -> [Err]
checkAmbigExps exps
  = concatMap isAmbig (Set.toList (Rel.dom exps))
  where isAmbig n = ambig n cons ++ ambig n other
                  where (cons,other) = partition mentIsCon (Rel.apply exps n)
        ambig n ents@(_:_:_) | not (null a)
                             = [rngLift emptyRange Err_AmbiguousExport n (map mkn $ concat $ a)]
                             where a   = [ l | l@(_:_:_) <- groupSortOn (ioccKind . mentIdOcc) ents ]
                                   mkn o = (ioccNm $ mentIdOcc o, Just [(mentRange o,Nothing)])
        ambig n _            = []

{-# LINE 415 "src/ehc/Module/ImportExport.chs" #-}
checkEntSpec :: Bool -> (HsName -> Range -> Err) -> (HsName -> HsName -> Err) -> ModEntSpec -> ModEntRel -> [Err]
checkEntSpec isHiding errUndef errUndefSub (ModEntSpec x xrange subspec) rel
  | isHiding && isNothing subspec
              = case xents of
                  []   -> [errUndef x xrange]
                  _    -> []
  | otherwise = case xents of
                  []   -> [errUndef x xrange]
                  ents -> concatMap chk $ filter mentIsCon $ ents
  where xents   = Rel.apply rel x
        chk ent = case subspec of
                    Just (ModEntSubs subs)
                      -> map (errUndefSub x) (filter (not . (`Set.member` subsInScope)) subs)
                      where subsInScope
                              = Set.map hsnQualified
                                $ Rel.dom
                                $ Rel.restrictRng (`Set.member` mentOwns ent) rel
                    _ -> []

{-# LINE 436 "src/ehc/Module/ImportExport.chs" #-}
checkExpSpec :: ModEntRel -> Mod -> [Err]
checkExpSpec inscp mod
  = case modExpL mod of
      Nothing   -> []
      Just exps -> concatMap chk exps
  where aliases = modName mod : mimpAs `map` modImpL mod
        chk (ModExpMod x)
          | x `elem` aliases = []
          | otherwise        = [rngLift emptyRange mkErr_NamesNotIntrod "module alias" [x]]
        chk (ModExpEnt spec) = checkEntSpec False err1 err2 spec inscp
        err1   x r = rngLift emptyRange mkErr_NamesNotIntrod' ("export") [mkThingAnd1Range r x]
        err2 e x   = rngLift emptyRange mkErr_NamesNotIntrod  ("subexport of export " ++ show e) [x]

{-# LINE 451 "src/ehc/Module/ImportExport.chs" #-}
checkImp :: ModEntRel -> ModImp -> [Err]
checkImp exps imp
  = concatMap chk (mimpImpL imp)
  where src = mimpSource imp
        chk spec = checkEntSpec (mimpHiding imp) err1 err2 spec exps
        err1   x r = rngLift emptyRange mkErr_NamesNotIntrod' ("module " ++ show src ++ " import") [mkThingAnd1Range r x]
        err2 i x   = rngLift emptyRange mkErr_NamesNotIntrod  ("module " ++ show src ++ " subimport of import " ++ show i) [x]

{-# LINE 465 "src/ehc/Module/ImportExport.chs" #-}
data ModMpInfo
  = ModMpInfo
      { mmiInscps   		:: !ModEntRel
      , mmiExps     		:: !ModEntRel
      , mmiHiddenExps     	:: !ModEntRel
      , mmiNmOffMp  		:: !HsName2FldMp		-- cached mapping of names to offsets, for all that is exported, visible or hidden
      }
  deriving (Typeable)

instance Show ModMpInfo where
  show _ = "ModMpInfo"

instance PP ModMpInfo where
  pp i =   "In scp     :" >#< (ppAssocL $ Rel.toList $ mmiInscps       i)
       >-< "Exps       :" >#< (ppAssocL $ Rel.toList $ mmiExps         i)
       >-< "Hidden Exps:" >#< (ppAssocL $ Rel.toList $ mmiHiddenExps   i)

emptyModMpInfo :: ModMpInfo
emptyModMpInfo = mkModMpInfo hsnUnknown Rel.empty Rel.empty Rel.empty

mkModMpInfo :: HsName -> ModEntRel -> ModEntRel -> ModEntRel -> ModMpInfo
mkModMpInfo modNm i e he
  = -- (\v -> tr "mkModMpInfo" (modNm >-< i) v) $
      resetModMpInfo modNm
    $ ModMpInfo
        { mmiInscps   		= i
        , mmiExps     		= e
        , mmiHiddenExps     = he
        , mmiNmOffMp  		= Map.empty
        }

resetModMpInfo :: HsName -> ModMpInfo -> ModMpInfo
resetModMpInfo modNm i = i {mmiNmOffMp = expsNmOffMp modNm $ mmiExps i `Rel.union` mmiHiddenExps i}

{-# LINE 509 "src/ehc/Module/ImportExport.chs" #-}
type ModMp = Map.Map HsName ModMpInfo

ppModMp :: ModMp -> PP_Doc
ppModMp = vlist . map (\(n,i) -> n >#< pp i) . Map.toList

{-# LINE 516 "src/ehc/Module/ImportExport.chs" #-}
modMpAddHiddenExps :: HsName -> [(HsName,IdOccKind)] -> ModMp -> ModMp
modMpAddHiddenExps modNm newExpNms mm
  = Map.update (\i@(ModMpInfo {mmiHiddenExps=he})
                  -> Just $ resetModMpInfo modNm
                          $ i { mmiHiddenExps
                                  = Rel.fromList [ (n, ModEnt occk (IdOcc n occk) Set.empty emptyRange) | (n,occk) <- newExpNms ]
                                    `Rel.union` he
                              }
               ) modNm mm

{-# LINE 530 "src/ehc/Module/ImportExport.chs" #-}
expsNmOffMp :: HsName -> ModEntRel -> HsName2FldMp
expsNmOffMp modNm exps
  = Map.fromList
    $ refGen 0 1
    $ sortBy cmpHsNameOnNm
    $ nub
    $ [ nm
      | e <- Set.toList $ Rel.rng exps
      , mentKind e == IdOcc_Val
      , let nm     = ioccNm (mentIdOcc e)
            mbqual = hsnQualifier nm
      , isJust mbqual		-- unqualified names cannot be exported, but they should not intro'd in the 1st place!! TBD 20100303 AD
      , panicJust ("Module.expsNmOffMp: " ++ show nm) mbqual == modNm
      ]

{-# LINE 547 "src/ehc/Module/ImportExport.chs" #-}
modMpCombine' :: (HsName -> ModMpInfo) -> [Mod] -> ModMp -> (ModMp,[Err])
modMpCombine' dfltMod ms mp
  = (newMp,concat errs)
  where expsOf mp n     = mmiExps $ Map.findWithDefault (dfltMod n) n mp
        -- expsOf mp n     = mmiExps $ Map.findWithDefault emptyModMpInfo n mp
        rels            = modInsOuts (expsOf mp) ms
        (inscps,exps)   = unzip rels
        newMp           = (Map.fromList $ zipWith4 (\n i o ho -> (n,mkModMpInfo n i o ho)) (map modName ms) inscps exps (map modHiddenExps ms))
                           `Map.union` mp
        errs            = zipWith (checkMod (fmap mmiExps . (`Map.lookup` newMp))) inscps ms

modMpCombine ::  [Mod] -> ModMp -> (ModMp,[Err])
modMpCombine = modMpCombine' (const emptyModMpInfo)

{-# LINE 576 "src/ehc/Module/ImportExport.chs" #-}
instance Serialize ModEnt where
  sput (ModEnt a b c d) = sput a >> sput b >> sput c >> sput d
  sget = liftM4 ModEnt sget sget sget sget