module DDC.Core.Tetra.Convert
( saltOfTetraModule
, Error(..))
where
import DDC.Core.Tetra.Transform.Curry.Callable
import DDC.Core.Tetra.Convert.Exp.Lets
import DDC.Core.Tetra.Convert.Exp.Alt
import DDC.Core.Tetra.Convert.Exp.Base
import DDC.Core.Tetra.Convert.Exp
import DDC.Core.Tetra.Convert.Type
import DDC.Core.Tetra.Convert.Error
import qualified DDC.Core.Tetra.Convert.Type.Base as T
import DDC.Core.Salt.Convert (initRuntime)
import DDC.Core.Salt.Platform
import DDC.Core.Exp.Annot
import DDC.Core.Module
import DDC.Core.Call
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 Data.Map (Map)
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
let defs' = unionDataDefs defs
$ fromListDataDefs
$ moduleImportDataDefs mm ++ moduleDataDefsLocal mm
let nsForeignBoxedTypes
= [n | (n, ImportTypeBoxed _) <- moduleImportTypes mm ]
let tctx' = T.Context
{ T.contextDataDefs = defs'
, T.contextForeignBoxedTypeCtors
= Set.fromList nsForeignBoxedTypes
, T.contextKindEnv = Env.empty }
let ntsImports
= [BName n (typeOfImportValue src)
| (n, src) <- moduleImportValues mm]
let tenv' = Env.extends ntsImports tenv
callables <- either (throw . ErrorCurry) return
$ takeCallablesOfModule mm
let ctx = Context
{ contextPlatform = pp
, contextDataDefs = defs'
, contextForeignBoxedTypeCtors = Set.fromList $ nsForeignBoxedTypes
, contextCallable = callables
, contextKindEnv = kenv
, contextTypeEnv = tenv'
, contextSuperBinds = Map.empty
, contextConvertExp = convertExp
, contextConvertLets = convertLets
, contextConvertAlt = convertAlt }
x1 <- convertExp ExpTop ctx
$ moduleBody mm
let a = annotOfExp x1
let (lts', _) = splitXLets x1
let x2 = xLets a lts' (xUnit a)
ntsImports' <- mapM (convertNameImportValueM tctx')
$ moduleImportValues mm
let ntsImport' = [(n, typeOfImportValue iv) | (n, iv) <- ntsImports']
let ntsSuper' = [(n, t) | BName n t <- concat $ map snd $ map bindsOfLets lts']
let ntsAvail = Map.fromList $ ntsSuper' ++ ntsImport'
ntsExports' <- mapM (convertExportM tctx' ntsAvail)
$ moduleExportValues mm
let mm_salt
= ModuleCore
{ moduleName = moduleName mm
, moduleIsHeader = moduleIsHeader mm
, moduleExportTypes = []
, moduleExportValues = ntsExports'
, moduleImportTypes = Map.toList $ A.runtimeImportKinds
, moduleImportCaps = []
, moduleImportValues = (Map.toList A.runtimeImportTypes) ++ ntsImports'
, moduleImportDataDefs = []
, moduleDataDefsLocal = []
, moduleBody = x2 }
mm_init <- case initRuntime runConfig mm_salt of
Nothing -> throw ErrorMainHasNoMain
Just mm' -> return mm'
return $ mm_init
convertExportM
:: T.Context
-> Map A.Name (Type A.Name)
-> (E.Name, ExportSource E.Name)
-> ConvertM a (A.Name, ExportSource A.Name)
convertExportM tctx tsSalt (n, esrc)
= do n' <- convertBindNameM n
esrc' <- convertExportSourceM tctx tsSalt esrc
return (n', esrc')
convertExportSourceM
:: T.Context
-> Map A.Name (Type A.Name)
-> ExportSource E.Name
-> ConvertM a (ExportSource A.Name)
convertExportSourceM tctx tsSalt esrc
= case esrc of
ExportSourceLocal n t
-> do n' <- convertBindNameM n
case Map.lookup n' tsSalt of
Just t' -> return $ ExportSourceLocal n' t'
Nothing
-> do t' <- convertCtorT tctx t
return $ ExportSourceLocal n' t'
ExportSourceLocalNoType n
-> do n' <- convertBindNameM n
return $ ExportSourceLocalNoType n'
convertNameImportValueM
:: T.Context -> (E.Name, ImportValue E.Name)
-> ConvertM a (A.Name, ImportValue A.Name)
convertNameImportValueM tctx (n, isrc)
= do n' <- convertImportNameM n
isrc' <- convertImportValueM tctx 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
convertImportValueM
:: T.Context -> ImportValue E.Name
-> ConvertM a (ImportValue A.Name)
convertImportValueM tctx isrc
= case isrc of
ImportValueModule mn n t Nothing
-> do let cs = takeCallConsFromType t
n' <- convertBindNameM n
t' <- convertSuperConsT tctx cs t
return $ ImportValueModule mn n' t' Nothing
ImportValueModule mn n t (Just (nType, nValue, nBox))
-> do let Just cs = takeStdCallConsFromTypeArity t nType nValue nBox
n' <- convertBindNameM n
t' <- convertSuperConsT tctx cs t
return $ ImportValueModule mn n' t' Nothing
ImportValueSea str t
-> do t' <- convertCtorT tctx t
return $ ImportValueSea str t'