ddc-source-tetra-0.4.3.1: DDC/Source/Tetra/Parser/Module.hs
-- | Parser for Source Tetra modules.
module DDC.Source.Tetra.Parser.Module
( -- * Modules
pModule
, pTypeSig
-- * Top-level things
, pTop)
where
import DDC.Source.Tetra.Parser.Exp as S
import DDC.Source.Tetra.Parser.Base as S
import DDC.Source.Tetra.Module as S
import DDC.Source.Tetra.DataDef as S
import DDC.Source.Tetra.Exp as S
import DDC.Core.Lexer.Tokens as K
import DDC.Data.Pretty
import Control.Monad
import qualified DDC.Control.Parser as P
import qualified Data.Text as Text
import DDC.Core.Parser
( pModuleName
, pName)
-- Module -----------------------------------------------------------------------------------------
-- | Parse a source tetra module.
pModule :: Parser (Module Source)
pModule
= do
_sp <- pTokSP (KKeyword EModule)
name <- pModuleName <?> "a module name"
-- export { VAR;+ }
tExports
<- P.choice
[ do pKey EExport
pSym SBraceBra
vars <- P.sepEndBy1 pBoundName (pSym SSemiColon)
pSym SBraceKet
return vars
, return []]
-- import { SIG;+ }
tImports
<- liftM concat $ P.many pImportSpecs
-- top-level declarations.
tops
<- P.choice
[ do pKey EWhere
pSym SBraceBra
-- TOP;+
tops <- P.sepEndBy pTop (pSym SSemiColon)
pSym SBraceKet
return tops
, do return [] ]
-- ISSUE #295: Check for duplicate exported names in module parser.
-- The names are added to a unique map, so later ones with the same
-- name will replace earlier ones.
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 }
-- | Parse a type signature.
pTypeSig :: Parser (Bind, Type)
pTypeSig
= do (b, _) <- pBindNameSP
pTokSP (KOp ":")
t <- pType
return (b, t)
---------------------------------------------------------------------------------------------------
-- | An imported foreign type or foreign value.
data ImportSpec
= ImportModule ModuleName
| ImportType TyConBind (ImportType TyConBind Type)
| ImportCap Bind (ImportCap Bind Type)
| ImportValue Bind (ImportValue Bind Type)
deriving Show
-- | Parse some import specs.
pImportSpecs :: Parser [ImportSpec]
pImportSpecs
= do pTok (KKeyword EImport)
P.choice
-- import foreign ...
[ do pTok (KKeyword EForeign)
src <- liftM (renderIndent . ppr) pName
P.choice
[ -- import foreign X type (NAME :: TYPE)+
do pKey EType
pSym SBraceBra
sigs <- P.sepEndBy1 (pImportType src) (pSym SSemiColon)
pSym SBraceKet
return sigs
-- import foreign X capability (NAME :: TYPE)+
, do pKey ECapability
pSym SBraceBra
sigs <- P.sepEndBy1 (pImportCapability src) (pSym SSemiColon)
pSym SBraceKet
return sigs
-- import foreign X value (NAME :: TYPE)+
, do pKey EValue
pSym SBraceBra
sigs <- P.sepEndBy1 (pImportValue src) (pSym SSemiColon)
pSym SBraceKet
return sigs
]
, do pSym SBraceBra
names <- P.sepEndBy1 pModuleName (pSym SSemiColon)
<?> "module names"
pSym SBraceKet
return [ImportModule n | n <- names]
]
-- | Parse a type import spec.
pImportType :: String -> Parser ImportSpec
pImportType src
| "abstract" <- src
= do b <- pTyConBindName
pTokSP (KOp ":")
k <- pType
return (ImportType b (ImportTypeAbstract k))
| "boxed" <- src
= do b <- pTyConBindName
pTokSP (KOp ":")
k <- pType
return (ImportType b (ImportTypeBoxed k))
| otherwise
= P.unexpected "import mode for foreign type"
-- | Parse a capability import.
pImportCapability :: String -> Parser ImportSpec
pImportCapability src
| "abstract" <- src
= do (b, _) <- pBindNameSP
pTokSP (KOp ":")
t <- pType
return (ImportCap b (ImportCapAbstract t))
| otherwise
= P.unexpected "import mode for foreign capability"
-- | Parse a value import spec.
pImportValue :: String -> Parser ImportSpec
pImportValue src
| "c" <- src
= do (b@(BName n), _) <- pBindNameSP
pTokSP (KOp ":")
k <- pType
-- ISSUE #327: Allow external symbol to be specified
-- with foreign C imports and exports.
let symbol = renderIndent (text $ Text.unpack n)
return (ImportValue b (ImportValueSea symbol k))
| otherwise
= P.unexpected "import mode for foreign value"
-- Top Level --------------------------------------------------------------------------------------
pTop :: Parser (Top Source)
pTop
= P.choice
[ do -- A top-level, possibly recursive binding.
(sp, l) <- pClauseSP
return $ TopClause sp l
-- A data type declaration
, do pDataDef
-- A type binding
, do pTypeDef
]
-- Data -------------------------------------------------------------------------------------------
-- | Parse a data type declaration.
pDataDef :: Parser (Top Source)
pDataDef
= do sp <- pTokSP (KKeyword EData)
b <- pTyConBindName
ps <- liftM concat $ P.many pTypeParam
P.choice
[ -- Data declaration with constructors that have explicit types.
do pKey EWhere
pSym SBraceBra
ctors <- P.sepEndBy1 pDataCtor (pSym SSemiColon)
pSym SBraceKet
return $ TopData sp (DataDef b ps ctors)
-- Data declaration with no data constructors.
, do return $ TopData sp (DataDef b ps [])
]
-- | Parse a data constructor declaration.
pDataCtor :: Parser (DataCtor Source)
pDataCtor
= do n <- pDaConBindName
pTokSP (KOp ":")
t <- pType
let (tsArg, tResult) = takeTFuns t
return $ DataCtor
{ dataCtorName = n
, dataCtorFieldTypes = tsArg
, dataCtorResultType = tResult }
-- Type -------------------------------------------------------------------------------------------
pTypeDef :: Parser (Top Source)
pTypeDef
= do sp <- pKey EType
bType <- pTyConBindName
bsParam <- liftM concat $ P.many pTypeParam
_ <- pSym SEquals
tBody <- pType
return $ TopType sp bType
$ foldr (\(b, k) t -> TAbs b k t) tBody bsParam
-- | Parse a type parameter to a data type or type function.
pTypeParam :: Parser [(Bind, Type)]
pTypeParam
= do pSym SRoundBra
bs <- fmap (fst . unzip) $ P.many1 pBindNameSP
pTokSP (KOp ":")
k <- pType
pSym SRoundKet
return [(b, k) | b <- bs]