module DDC.Core.Module
(
Module (..)
, isMainModule
, moduleKindEnv
, moduleTypeEnv
, moduleTopBinds
, moduleTopBindTypes
, ModuleMap
, modulesExportTypes
, modulesExportValues
, QualName (..)
, ModuleName (..)
, isMainModuleName
, ExportSource (..)
, takeTypeOfExportSource
, mapTypeOfExportSource
, ImportSource (..)
, typeOfImportSource
, mapTypeOfImportSource)
where
import DDC.Core.Exp
import DDC.Type.DataDef
import DDC.Type.Compounds
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
, moduleExportTypes :: ![(n, ExportSource n)]
, moduleExportValues :: ![(n, ExportSource n)]
, moduleImportTypes :: ![(n, ImportSource n)]
, moduleImportValues :: ![(n, ImportSource 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 (moduleExportTypes mm)
`seq` rnf (moduleExportValues mm)
`seq` rnf (moduleImportTypes mm)
`seq` rnf (moduleImportValues mm)
`seq` rnf (moduleDataDefsLocal mm)
`seq` rnf (moduleBody mm)
isMainModule :: Module a n -> Bool
isMainModule mm
= isMainModuleName
$ moduleName mm
moduleKindEnv :: Ord n => Module a n -> KindEnv n
moduleKindEnv mm
= Env.fromList
$ [BName n (typeOfImportSource isrc) | (n, isrc) <- moduleImportTypes mm]
moduleTypeEnv :: Ord n => Module a n -> TypeEnv n
moduleTypeEnv mm
= Env.fromList
$ [BName n (typeOfImportSource 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
-> go (Map.union acc (Map.fromList [(n, t) | BName n t <- map fst bxs])) x2
_ -> 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)
data ModuleName
= ModuleName [String]
deriving (Show, Eq, Ord, Typeable)
instance NFData ModuleName where
rnf (ModuleName ss)
= rnf ss
data QualName n
= QualName ModuleName n
deriving Show
instance NFData n => NFData (QualName n) where
rnf (QualName mn n)
= rnf mn `seq` rnf n
isMainModuleName :: ModuleName -> Bool
isMainModuleName mn
= case mn of
ModuleName ["Main"] -> True
_ -> False
data ExportSource n
= ExportSourceLocal
{ exportSourceLocalName :: n
, exportSourceLocalType :: Type n }
| ExportSourceLocalNoType
{ exportSourceLocalName :: n }
deriving (Show, Eq)
instance NFData n => NFData (ExportSource n) where
rnf es
= case es of
ExportSourceLocal n t -> rnf n `seq` rnf t
ExportSourceLocalNoType n -> rnf n
takeTypeOfExportSource :: ExportSource n -> Maybe (Type n)
takeTypeOfExportSource es
= case es of
ExportSourceLocal _ t -> Just t
ExportSourceLocalNoType{} -> Nothing
mapTypeOfExportSource :: (Type n -> Type n) -> ExportSource n -> ExportSource n
mapTypeOfExportSource f esrc
= case esrc of
ExportSourceLocal n t -> ExportSourceLocal n (f t)
ExportSourceLocalNoType n -> ExportSourceLocalNoType n
data ImportSource n
= ImportSourceAbstract
{ importSourceAbstractType :: Type n }
| ImportSourceModule
{ importSourceModuleName :: ModuleName
, importSourceModuleVar :: n
, importSourceModuleType :: Type n }
| ImportSourceSea
{ importSourceSeaVar :: String
, importSourceSeaType :: Type n }
deriving (Show, Eq)
instance NFData n => NFData (ImportSource n) where
rnf is
= case is of
ImportSourceAbstract t -> rnf t
ImportSourceModule mn n t -> rnf mn `seq` rnf n `seq` rnf t
ImportSourceSea v t -> rnf v `seq` rnf t
typeOfImportSource :: ImportSource n -> Type n
typeOfImportSource src
= case src of
ImportSourceAbstract t -> t
ImportSourceModule _ _ t -> t
ImportSourceSea _ t -> t
mapTypeOfImportSource :: (Type n -> Type n) -> ImportSource n -> ImportSource n
mapTypeOfImportSource f isrc
= case isrc of
ImportSourceAbstract t -> ImportSourceAbstract (f t)
ImportSourceModule mn n t -> ImportSourceModule mn n (f t)
ImportSourceSea s t -> ImportSourceSea s (f t)