module DDC.Core.Parser.Module
(pModule)
where
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Core.Parser.Type
import DDC.Core.Parser.Exp
import DDC.Core.Parser.Context
import DDC.Core.Parser.Base
import DDC.Core.Lexer.Tokens
import DDC.Core.Compounds
import DDC.Type.DataDef
import DDC.Base.Pretty
import Control.Monad
import qualified DDC.Base.Parser as P
pModule :: (Ord n, Pretty n)
=> Context
-> Parser n (Module P.SourcePos n)
pModule c
= do sp <- pTokSP KModule
name <- pModuleName
tExports <- liftM concat $ P.many (pExportSpecs c)
tImports <- liftM concat $ P.many (pImportSpecs c)
dataDefsLocal <- P.many (pDataDef c)
pTok KWith
lts <- P.sepBy1 (pLetsSP c) (pTok KIn)
let body = xLetsAnnot lts (xUnit sp)
return $ ModuleCore
{ moduleName = name
, moduleExportTypes = []
, moduleExportValues = [(n, s) | ExportValue n s <- tExports]
, moduleImportTypes = [(n, s) | ImportType n s <- tImports]
, moduleImportValues = [(n, s) | ImportValue n s <- tImports]
, moduleDataDefsLocal = dataDefsLocal
, moduleBody = body }
data ExportSpec n
= ExportValue n (ExportSource n)
pExportSpecs
:: (Ord n, Pretty n)
=> Context -> Parser n [ExportSpec n]
pExportSpecs c
= do pTok KExport
P.choice
[
do P.choice [ pTok KValue, return () ]
pTok KBraceBra
specs <- P.sepEndBy1 (pExportValue c) (pTok KSemiColon)
pTok KBraceKet
return specs
, do pTok KForeign
dst <- liftM (renderIndent . ppr) pName
pTok KValue
pTok KBraceBra
specs <- P.sepEndBy1 (pExportForeignValue c dst) (pTok KSemiColon)
pTok KBraceKet
return specs
]
pExportValue
:: (Ord n, Pretty n)
=> Context -> Parser n (ExportSpec n)
pExportValue c
= do
n <- pName
pTokSP (KOp ":")
t <- pType c
return (ExportValue n (ExportSourceLocal n t))
pExportForeignValue
:: (Ord n, Pretty n)
=> Context -> String -> Parser n (ExportSpec n)
pExportForeignValue c dst
| "c" <- dst
= do n <- pName
pTokSP (KOp ":")
k <- pType c
return (ExportValue n (ExportSourceLocal n k))
| otherwise
= P.unexpected "export mode for foreign value."
data ImportSpec n
= ImportType n (ImportSource n)
| ImportValue n (ImportSource n)
pImportSpecs :: (Ord n, Pretty n)
=> Context -> Parser n [ImportSpec n]
pImportSpecs c
= do pTok KImport
P.choice
[
do pTok KType
pTok KBraceBra
specs <- P.sepEndBy1 (pImportType c) (pTok KSemiColon)
pTok KBraceKet
return specs
, do P.choice [ pTok KValue, return () ]
pTok KBraceBra
specs <- P.sepEndBy1 (pImportValue c) (pTok KSemiColon)
pTok KBraceKet
return specs
, do pTok KForeign
src <- liftM (renderIndent . ppr) pName
P.choice
[
do pTok KType
pTok KBraceBra
sigs <- P.sepEndBy1 (pImportForeignType c src) (pTok KSemiColon)
pTok KBraceKet
return sigs
, do pTok KValue
pTok KBraceBra
sigs <- P.sepEndBy1 (pImportForeignValue c src) (pTok KSemiColon)
pTok KBraceKet
return sigs
]
]
pImportType
:: (Ord n, Pretty n)
=> Context -> Parser n (ImportSpec n)
pImportType c
= do n <- pName
pTokSP (KOp ":")
k <- pType c
return $ ImportType n (ImportSourceModule (ModuleName []) n k)
pImportForeignType
:: (Ord n, Pretty n)
=> Context -> String -> Parser n (ImportSpec n)
pImportForeignType c src
| "abstract" <- src
= do n <- pName
pTokSP (KOp ":")
k <- pType c
return (ImportType n (ImportSourceAbstract k))
| otherwise
= P.unexpected "import mode for foreign type."
pImportValue
:: (Ord n, Pretty n)
=> Context -> Parser n (ImportSpec n)
pImportValue c
= do n <- pName
pTokSP (KOp ":")
t <- pType c
return (ImportValue n (ImportSourceModule (ModuleName []) n t))
pImportForeignValue
:: (Ord n, Pretty n)
=> Context -> String -> Parser n (ImportSpec n)
pImportForeignValue c src
| "c" <- src
= do n <- pName
pTokSP (KOp ":")
k <- pType c
let symbol = renderIndent (ppr n)
return (ImportValue n (ImportSourceSea symbol k))
| otherwise
= P.unexpected "import mode for foreign value."
pDataDef :: Ord n => Context -> Parser n (DataDef n)
pDataDef c
= do pTokSP KData
nData <- pName
bsParam <- liftM concat $ P.many (pDataParam c)
P.choice
[
do pTok KWhere
pTok KBraceBra
ctors <- P.sepEndBy1 (pDataCtor c nData bsParam) (pTok KSemiColon)
let ctors' = [ ctor { dataCtorTag = tag }
| ctor <- ctors
| tag <- [0..] ]
pTok KBraceKet
return $ DataDef
{ dataDefTypeName = nData
, dataDefParams = bsParam
, dataDefCtors = Just ctors'
, dataDefIsAlgebraic = True }
, do return $ DataDef
{ dataDefTypeName = nData
, dataDefParams = bsParam
, dataDefCtors = Just []
, dataDefIsAlgebraic = True }
]
pDataParam :: Ord n => Context -> Parser n [Bind n]
pDataParam c
= do pTok KRoundBra
ns <- P.many1 pName
pTokSP (KOp ":")
k <- pType c
pTok KRoundKet
return [BName n k | n <- ns]
pDataCtor
:: Ord n
=> Context
-> n
-> [Bind n]
-> Parser n (DataCtor n)
pDataCtor c nData bsParam
= do n <- pName
pTokSP (KOp ":")
t <- pType c
let (tsArg, tResult)
= takeTFunArgResult t
return $ DataCtor
{ dataCtorName = n
, dataCtorTag = 0
, dataCtorFieldTypes = tsArg
, dataCtorResultType = tResult
, dataCtorTypeName = nData
, dataCtorTypeParams = bsParam }