uhc-light-1.1.9.2: src/UHC/Light/Compiler/Module/ImportExport.hs
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