module DDC.Core.Tetra.Convert
( saltOfTetraModule
, Error(..))
where
import DDC.Core.Tetra.Convert.Exp
import DDC.Core.Tetra.Convert.Type
import DDC.Core.Tetra.Convert.Base
import DDC.Core.Salt.Convert (initRuntime)
import DDC.Core.Salt.Platform
import DDC.Core.Module
import DDC.Core.Compounds
import DDC.Core.Exp
import DDC.Core.Check (AnTEC(..))
import qualified DDC.Core.Tetra.Prim as E
import qualified DDC.Core.Salt.Runtime as A
import qualified DDC.Core.Salt.Name as A
import DDC.Type.DataDef
import DDC.Type.Env (KindEnv, TypeEnv)
import qualified DDC.Type.Env as Env
import DDC.Control.Monad.Check (throw, evalCheck)
import qualified Data.Map as Map
import qualified Data.Set as Set
saltOfTetraModule
:: Show a
=> Platform
-> A.Config
-> DataDefs E.Name
-> KindEnv E.Name
-> TypeEnv E.Name
-> Module (AnTEC a E.Name) E.Name
-> Either (Error a) (Module a A.Name)
saltOfTetraModule platform runConfig defs kenv tenv mm
=
evalCheck () $ convertM platform runConfig defs kenv tenv mm
convertM
:: Show a
=> Platform
-> A.Config
-> DataDefs E.Name
-> KindEnv E.Name
-> TypeEnv E.Name
-> Module (AnTEC a E.Name) E.Name
-> ConvertM a (Module a A.Name)
convertM pp runConfig defs kenv tenv mm
= do
tsExports' <- mapM (convertExportM defs) $ moduleExportValues mm
tsImports' <- mapM (convertImportM defs) $ moduleImportValues mm
let ntsImports
= [BName n (typeOfImportSource src)
| (n, src) <- moduleImportValues mm]
let tenv' = Env.extends ntsImports tenv
let defs' = unionDataDefs defs
$ fromListDataDefs (moduleDataDefsLocal mm)
let penv = TopEnv
{ topEnvPlatform = pp
, topEnvDataDefs = defs'
, topEnvSupers = moduleTopBinds mm
, topEnvImportValues = Set.fromList $ map fst $ moduleImportValues mm }
x1 <- convertExpX penv kenv tenv' ExpTop
$ moduleBody mm
let a = annotOfExp x1
let (lts', _) = splitXLets x1
let x2 = xLets a lts' (xUnit a)
let mm_salt
= ModuleCore
{ moduleName = moduleName mm
, moduleExportTypes = []
, moduleExportValues = tsExports'
, moduleImportTypes = Map.toList $ A.runtimeImportKinds
, moduleImportValues = (Map.toList A.runtimeImportTypes) ++ tsImports'
, moduleDataDefsLocal = []
, moduleBody = x2 }
mm_init <- case initRuntime runConfig mm_salt of
Nothing -> throw ErrorMainHasNoMain
Just mm' -> return mm'
return $ mm_init
convertExportM
:: DataDefs E.Name
-> (E.Name, ExportSource E.Name)
-> ConvertM a (A.Name, ExportSource A.Name)
convertExportM defs (n, esrc)
= do n' <- convertBindNameM n
esrc' <- convertExportSourceM defs esrc
return (n', esrc')
convertExportSourceM
:: DataDefs E.Name
-> ExportSource E.Name
-> ConvertM a (ExportSource A.Name)
convertExportSourceM defs esrc
= case esrc of
ExportSourceLocal n t
-> do n' <- convertBindNameM n
t' <- convertRepableT defs Env.empty t
return $ ExportSourceLocal n' t'
ExportSourceLocalNoType n
-> do n' <- convertBindNameM n
return $ ExportSourceLocalNoType n'
convertImportM
:: DataDefs E.Name
-> (E.Name, ImportSource E.Name)
-> ConvertM a (A.Name, ImportSource A.Name)
convertImportM defs (n, isrc)
= do n' <- convertImportNameM n
isrc' <- convertImportSourceM defs isrc
return (n', isrc')
convertImportNameM :: E.Name -> ConvertM a A.Name
convertImportNameM n
= case n of
E.NameVar str -> return $ A.NameVar str
E.NameCon str -> return $ A.NameCon str
_ -> throw $ ErrorInvalidBinder n
convertImportSourceM
:: DataDefs E.Name
-> ImportSource E.Name
-> ConvertM a (ImportSource A.Name)
convertImportSourceM defs isrc
= case isrc of
ImportSourceAbstract t
-> do t' <- convertRepableT defs Env.empty t
return $ ImportSourceAbstract t'
ImportSourceModule mn n t
-> do n' <- convertBindNameM n
t' <- convertRepableT defs Env.empty t
return $ ImportSourceModule mn n' t'
ImportSourceSea str t
-> do t' <- convertRepableT defs Env.empty t
return $ ImportSourceSea str t'