module DDC.Source.Tetra.Parser.Module
(
pModule
, pTypeSig
, pTop)
where
import DDC.Source.Tetra.Parser.Exp
import DDC.Source.Tetra.Compounds
import DDC.Source.Tetra.DataDef
import DDC.Source.Tetra.Module
import DDC.Source.Tetra.Prim
import DDC.Source.Tetra.Exp.Annot
import DDC.Core.Lexer.Tokens
import DDC.Base.Pretty
import Control.Monad
import qualified DDC.Type.Exp as T
import qualified DDC.Base.Parser as P
import DDC.Base.Parser ((<?>))
import DDC.Core.Parser
( Parser
, Context (..)
, pModuleName
, pName
, pVar
, pTok, pTokSP)
type SP = P.SourcePos
pModule :: Context Name -> Parser Name (Module (Annot SP))
pModule c
= do
_sp <- pTokSP KModule
name <- pModuleName <?> "a module name"
tExports
<- P.choice
[do pTok KExport
pTok KBraceBra
vars <- P.sepEndBy1 pVar (pTok KSemiColon)
pTok KBraceKet
return vars
, return []]
tImports
<- liftM concat $ P.many (pImportSpecs c)
tops
<- P.choice
[do pTok KWhere
pTok KBraceBra
tops <- P.sepEndBy (pTop c) (pTok KSemiColon)
pTok KBraceKet
return tops
,do return [] ]
return $ Module
{ moduleName = name
, moduleExportTypes = []
, moduleExportValues = tExports
, moduleImportModules = [mn | ImportModule mn <- tImports]
, moduleImportTypes = [(n, s) | ImportType n s <- tImports]
, moduleImportCaps = [(n, s) | ImportCap n s <- tImports]
, moduleImportValues = [(n, s) | ImportValue n s <- tImports]
, moduleTops = tops }
pTypeSig :: Context Name -> Parser Name (Name, T.Type Name)
pTypeSig c
= do var <- pVar
pTokSP (KOp ":")
t <- pType c
return (var, t)
data ImportSpec n
= ImportModule ModuleName
| ImportType n (ImportType n)
| ImportCap n (ImportCap n)
| ImportValue n (ImportValue n)
deriving Show
pImportSpecs :: Context Name -> Parser Name [ImportSpec Name]
pImportSpecs c
= do pTok KImport
P.choice
[ do pTok KForeign
src <- liftM (renderIndent . ppr) pName
P.choice
[
do pTok KType
pTok KBraceBra
sigs <- P.sepEndBy1 (pImportType c src) (pTok KSemiColon)
pTok KBraceKet
return sigs
, do pTok KCapability
pTok KBraceBra
sigs <- P.sepEndBy1 (pImportCapability c src) (pTok KSemiColon)
pTok KBraceKet
return sigs
, do pTok KValue
pTok KBraceBra
sigs <- P.sepEndBy1 (pImportValue c src) (pTok KSemiColon)
pTok KBraceKet
return sigs
]
, do pTok KBraceBra
names <- P.sepEndBy1 pModuleName (pTok KSemiColon)
<?> "module names"
pTok KBraceKet
return [ImportModule n | n <- names]
]
pImportType :: Context Name -> String -> Parser Name (ImportSpec Name)
pImportType c src
| "abstract" <- src
= do n <- pName
pTokSP (KOp ":")
k <- pType c
return (ImportType n (ImportTypeAbstract k))
| "boxed" <- src
= do n <- pName
pTokSP (KOp ":")
k <- pType c
return (ImportType n (ImportTypeBoxed k))
| otherwise
= P.unexpected "import mode for foreign type"
pImportCapability :: Context Name -> String -> Parser Name (ImportSpec Name)
pImportCapability c src
| "abstract" <- src
= do n <- pName
pTokSP (KOp ":")
t <- pType c
return (ImportCap n (ImportCapAbstract t))
| otherwise
= P.unexpected "import mode for foreign capability"
pImportValue :: Context Name -> String -> Parser Name (ImportSpec Name)
pImportValue c src
| "c" <- src
= do n <- pName
pTokSP (KOp ":")
k <- pType c
let symbol = renderIndent (ppr n)
return (ImportValue n (ImportValueSea symbol k))
| otherwise
= P.unexpected "import mode for foreign value"
pTop :: Context Name -> Parser Name (Top (Annot SP))
pTop c
= P.choice
[ do
(l, sp) <- pClauseSP c
return $ TopClause sp l
, do pData c
]
pData :: Context Name -> Parser Name (Top (Annot SP))
pData c
= do sp <- pTokSP KData
n <- pName
ps <- liftM concat $ P.many (pDataParam c)
P.choice
[
do pTok KWhere
pTok KBraceBra
ctors <- P.sepEndBy1 (pDataCtor c) (pTok KSemiColon)
pTok KBraceKet
return $ TopData sp (DataDef n ps ctors)
, do return $ TopData sp (DataDef n ps [])
]
pDataParam :: Context Name -> Parser Name [Bind]
pDataParam c
= do pTok KRoundBra
ns <- P.many1 pName
pTokSP (KOp ":")
k <- pType c
pTok KRoundKet
return [T.BName n k | n <- ns]
pDataCtor :: Context Name -> Parser Name (DataCtor Name)
pDataCtor c
= do n <- pName
pTokSP (KOp ":")
t <- pType c
let (tsArg, tResult)
= takeTFunArgResult t
return $ DataCtor
{ dataCtorName = n
, dataCtorFieldTypes = tsArg
, dataCtorResultType = tResult }