module DDC.Core.Parser.Module
(pModule)
where
import DDC.Core.Parser.Type
import DDC.Core.Parser.Exp
import DDC.Core.Parser.Context
import DDC.Core.Parser.Base
import DDC.Core.Parser.ExportSpec
import DDC.Core.Parser.ImportSpec
import DDC.Core.Parser.DataDef
import DDC.Core.Module
import DDC.Core.Lexer.Tokens
import DDC.Core.Exp.Annot
import DDC.Base.Pretty
import Data.Char
import qualified Data.Map as Map
import qualified DDC.Base.Parser as P
import qualified Data.Text as T
pModule :: (Ord n, Pretty n)
=> Context n
-> Parser n (Module P.SourcePos n)
pModule c
= do sp <- pTokSP KModule
name <- pModuleName
heads <- P.many (pHeadDecl c)
let importSpecs_noArity = concat $ [specs | HeadImportSpecs specs <- heads ]
let exportSpecs = concat $ [specs | HeadExportSpecs specs <- heads ]
let defsLocal = [def | HeadDataDef def <- heads ]
let importArities
= Map.fromList [ (n, (iTypes, iValues, iBoxes ))
| HeadPragmaArity n iTypes iValues iBoxes <- heads ]
let attachAritySpec (ImportValue n (ImportValueModule mn v t _))
= ImportValue n (ImportValueModule mn v t (Map.lookup n importArities))
attachAritySpec spec = spec
let importSpecs
= map attachAritySpec importSpecs_noArity
(lts, isHeader)
<- P.choice
[ do pTok KWith
lts <- P.sepBy1 (pLetsSP c) (pTok KIn)
return (lts, False)
, do return ([], True) ]
let body = xLetsAnnot lts (xUnit sp)
return $ ModuleCore
{ moduleName = name
, moduleIsHeader = isHeader
, moduleExportTypes = []
, moduleExportValues = [(n, s) | ExportValue n s <- exportSpecs]
, moduleImportTypes = [(n, s) | ImportType n s <- importSpecs]
, moduleImportCaps = [(n, s) | ImportCap n s <- importSpecs]
, moduleImportValues = [(n, s) | ImportValue n s <- importSpecs]
, moduleImportDataDefs = [def | ImportData def <- importSpecs]
, moduleDataDefsLocal = defsLocal
, moduleBody = body }
data HeadDecl n
= HeadImportSpecs [ImportSpec n]
| HeadExportSpecs [ExportSpec n]
| HeadDataDef (DataDef n)
| HeadPragmaArity n Int Int Int
pHeadDecl :: (Ord n, Pretty n)
=> Context n -> Parser n (HeadDecl n)
pHeadDecl ctx
= P.choice
[ do def <- pDataDef ctx
return $ HeadDataDef def
, do imports <- pImportSpecs ctx
return $ HeadImportSpecs imports
, do exports <- pExportSpecs ctx
return $ HeadExportSpecs exports
, do pHeadPragma ctx ]
pHeadPragma :: Context n -> Parser n (HeadDecl n)
pHeadPragma ctx
= do (txt, sp) <- pPragmaSP
case words $ T.unpack txt of
["ARITY", name, strTypes, strValues, strBoxes]
| all isDigit strTypes
, all isDigit strValues
, all isDigit strBoxes
, Just makeStringName <- contextMakeStringName ctx
-> return $ HeadPragmaArity
(makeStringName sp (T.pack name))
(read strTypes) (read strValues) (read strBoxes)
_ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}"