module DDC.Core.Salt.Convert
( seaOfSaltModule
, initRuntime
, seaNameOfSuper
, seaNameOfLocal
, sanitizeName
, Error (..))
where
import DDC.Core.Salt.Convert.Type
import DDC.Core.Salt.Convert.Init
import DDC.Core.Salt.Convert.Name
import DDC.Core.Salt.Convert.Super
import DDC.Core.Salt.Convert.Base
import DDC.Core.Salt.Name
import DDC.Core.Salt.Platform
import DDC.Core.Compounds
import DDC.Core.Module as C
import DDC.Core.Exp
import DDC.Base.Pretty
import DDC.Control.Monad.Check (throw, evalCheck)
import qualified DDC.Type.Env as Env
seaOfSaltModule
:: Show a
=> Bool
-> Platform
-> Module a Name
-> Either (Error a) Doc
seaOfSaltModule withPrelude pp mm
=
evalCheck () $ convModuleM withPrelude pp mm
convModuleM :: Show a => Bool -> Platform -> Module a Name -> ConvertM a Doc
convModuleM withPrelude pp mm@(ModuleCore{})
| ([LRec bxs], _) <- splitXLets $ moduleBody mm
= do
let cIncludes
| not withPrelude = empty
| otherwise
= vcat
$ [ text "// Includes for helper macros and the runtime system. -----------------"
, text "#include \"Runtime.h\""
, text "#include \"Primitive.h\""
, line ]
let cGlobals
| not withPrelude = empty
| isMainModule mm
= vcat
$ [ text "// Definitions of the runtime system variables. -----------------------"
, text "addr_t _DDC__heapTop = 0;"
, text "addr_t _DDC__heapMax = 0;"
, line ]
| otherwise
= vcat
$ [ text "// External definitions for the runtime system variables. -------------"
, text "extern addr_t _DDC__heapTop;"
, text "extern addr_t _DDC__heapMax;"
, line ]
dsImport
<- mapM (\(misrc, nSuper, tSuper)
-> convSuperTypeM Env.empty misrc Nothing nSuper tSuper)
[ (Just isrc, nSuper, tSuper)
| (nSuper, isrc) <- C.moduleImportValues mm
, let tSuper = typeOfImportSource isrc ]
let cExterns
| not withPrelude = empty
| otherwise
= vcat
$ [ text "// External definitions for imported symbols. -------------------------"]
++ [ text "extern " <> doc <> semi | doc <- dsImport ]
++ [ line ]
dsProto
<- mapM (\(mesrc, nSuper, tSuper)
-> convSuperTypeM Env.empty Nothing mesrc nSuper tSuper)
[ (mesrc, nSuper, tSuper)
| (BName nSuper tSuper, _) <- bxs
, let mesrc = lookup nSuper (moduleExportValues mm) ]
let cProtos
| not withPrelude = empty
| otherwise
= vcat
$ [ text "// Function prototypes for locally defined supers. --------------------"]
++ [ doc <> semi | doc <- dsProto ]
++ [ line ]
let kenv = Env.fromList
$ [ BName n (typeOfImportSource isrc)
| (n, isrc) <- moduleImportTypes mm ]
let tenv = Env.fromList
$ [ BName n (typeOfImportSource isrc)
| (n, isrc) <- moduleImportValues mm ]
let convSuperM' (BName n t) x
= convSuperM pp mm kenv tenv n t x
convSuperM' _ x
= throw $ ErrorFunctionInvalid x
dsSupers <- mapM (uncurry convSuperM') bxs
let cSupers
= vcat
$ [ text "// Code for locally defined supers. -----------------------------------"]
++ dsSupers
return $ cIncludes
<> cGlobals
<> cExterns
<> cProtos
<> cSupers
| otherwise
= throw $ ErrorNoTopLevelLetrec mm