module DDC.Core.Module
(
Module (..)
, isMainModule
, moduleDataDefs
, moduleKindEnv
, moduleTypeEnv
, moduleTopBinds
, moduleTopBindTypes
, mapTopBinds
, ModuleMap
, modulesExportTypes
, modulesExportValues
, ModuleName (..)
, readModuleName
, isMainModuleName
, QualName (..)
, ExportSource (..)
, takeTypeOfExportSource
, mapTypeOfExportSource
, ImportType (..)
, kindOfImportType
, mapKindOfImportType
, ImportCap (..)
, typeOfImportCap
, mapTypeOfImportCap
, ImportValue (..)
, typeOfImportValue
, mapTypeOfImportValue)
where
import DDC.Core.Module.Export
import DDC.Core.Module.Import
import DDC.Core.Module.Name
import DDC.Core.Exp.Annot
import DDC.Type.DataDef
import Data.Typeable
import Data.Map.Strict (Map)
import Data.Set (Set)
import DDC.Type.Env as Env
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Control.DeepSeq
import Data.Maybe
data Module a n
= ModuleCore
{
moduleName :: !ModuleName
, moduleIsHeader :: !Bool
, moduleExportTypes :: ![(n, ExportSource n)]
, moduleExportValues :: ![(n, ExportSource n)]
, moduleImportTypes :: ![(n, ImportType n)]
, moduleImportCaps :: ![(n, ImportCap n)]
, moduleImportValues :: ![(n, ImportValue n)]
, moduleImportDataDefs :: ![DataDef n]
, moduleDataDefsLocal :: ![DataDef n]
, moduleBody :: !(Exp a n)
}
deriving (Show, Typeable)
instance (NFData a, NFData n) => NFData (Module a n) where
rnf !mm
= rnf (moduleName mm)
`seq` rnf (moduleIsHeader mm)
`seq` rnf (moduleExportTypes mm)
`seq` rnf (moduleExportValues mm)
`seq` rnf (moduleImportTypes mm)
`seq` rnf (moduleImportCaps mm)
`seq` rnf (moduleImportValues mm)
`seq` rnf (moduleImportDataDefs mm)
`seq` rnf (moduleDataDefsLocal mm)
`seq` rnf (moduleBody mm)
isMainModule :: Module a n -> Bool
isMainModule mm
= isMainModuleName
$ moduleName mm
moduleDataDefs :: Ord n => Module a n -> DataDefs n
moduleDataDefs mm
= fromListDataDefs
$ (moduleImportDataDefs mm ++ moduleDataDefsLocal mm)
moduleKindEnv :: Ord n => Module a n -> KindEnv n
moduleKindEnv mm
= Env.fromList
$ [BName n (kindOfImportType isrc) | (n, isrc) <- moduleImportTypes mm]
moduleTypeEnv :: Ord n => Module a n -> TypeEnv n
moduleTypeEnv mm
= Env.fromList
$ [BName n (typeOfImportValue isrc) | (n, isrc) <- moduleImportValues mm]
moduleTopBinds :: Ord n => Module a n -> Set n
moduleTopBinds mm
= go (moduleBody mm)
where go xx
= case xx of
XLet _ (LLet (BName n _) _) x2
-> Set.insert n (go x2)
XLet _ (LLet _ _) x2
-> go x2
XLet _ (LRec bxs) x2
-> Set.fromList (mapMaybe takeNameOfBind $ map fst bxs)
`Set.union` go x2
_ -> Set.empty
moduleTopBindTypes :: Ord n => Module a n -> Map n (Type n)
moduleTopBindTypes mm
= go Map.empty (moduleBody mm)
where go acc xx
= case xx of
XLet _ (LLet (BName n t) _) x2
-> go (Map.insert n t acc) x2
XLet _ (LLet _ _) x2
-> go acc x2
XLet _ (LRec bxs) x2
-> let nts = Map.fromList [(n, t) | BName n t <- map fst bxs]
in go (Map.union acc nts) x2
_ -> acc
mapTopBinds :: (Bind n -> Exp a n -> b) -> Module a n -> [b]
mapTopBinds f mm
= go [] (moduleBody mm)
where
go acc xx
= case xx of
XLet _ (LLet b1 x1) x2
-> go (f b1 x1 : acc) x2
XLet _ (LRec bxs) x2
-> let rs = reverse $ map (uncurry f) bxs
in go (rs ++ acc) x2
_ -> reverse acc
type ModuleMap a n
= Map ModuleName (Module a n)
modulesExportTypes :: Ord n => ModuleMap a n -> KindEnv n -> KindEnv n
modulesExportTypes mods base
= let envOfModule m
= Env.fromList
$ [BName n t | (n, Just t)
<- map (liftSnd takeTypeOfExportSource) $ moduleExportTypes m]
liftSnd f (x, y) = (x, f y)
in Env.unions $ base : (map envOfModule $ Map.elems mods)
modulesExportValues :: Ord n => ModuleMap a n -> TypeEnv n -> TypeEnv n
modulesExportValues mods base
= let envOfModule m
= Env.fromList
$ [BName n t | (n, Just t)
<- map (liftSnd takeTypeOfExportSource) $ moduleExportValues m]
liftSnd f (x, y) = (x, f y)
in Env.unions $ base : (map envOfModule $ Map.elems mods)