ddc-source-tetra-0.4.2.1: DDC/Source/Tetra/Parser/Exp.hs
-- | Parser for Source Tetra expressions.
module DDC.Source.Tetra.Parser.Exp
( context
, pExp
, pExpApp
, pExpAtom, pExpAtomSP
, pLetsSP, pClauseSP
, pType
, pTypeApp
, pTypeAtom)
where
import DDC.Source.Tetra.Transform.Guards
import DDC.Source.Tetra.Parser.Witness
import DDC.Source.Tetra.Parser.Param
import DDC.Source.Tetra.Parser.Atom
import DDC.Source.Tetra.Compounds
import DDC.Source.Tetra.Prim
import DDC.Source.Tetra.Exp.Annot
import DDC.Core.Lexer.Tokens
import Control.Monad.Except
import DDC.Base.Parser ((<?>), SourcePos(..))
import qualified DDC.Base.Parser as P
import qualified DDC.Type.Exp as T
import qualified DDC.Type.Compounds as T
import qualified Data.Text as Text
import DDC.Core.Parser
( Parser
, Context (..)
, pBinder
, pType
, pTypeAtom
, pTypeApp
, pCon, pConSP
, pLit, pLitSP
, pStringSP
, pIndexSP
, pOpSP, pOpVarSP
, pTok
, pTokSP)
type SP = SourcePos
-- | Starting context for the parser.
-- Holds flags about what language features we should accept.
context :: Context Name
context = Context
{ contextTrackedEffects = True
, contextTrackedClosures = True
, contextFunctionalEffects = False
, contextFunctionalClosures = False
, contextMakeStringName = Just (\_ tx -> NameLitTextLit tx) }
-- Exp --------------------------------------------------------------------------------------------
-- | Parse a Tetra Source language expression.
pExp :: Context Name -> Parser Name (Exp SP)
pExp c
= P.choice
-- Level-0 lambda abstractions
-- \(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp
-- \x1 x2 : Type. Exp
[ do sp <- P.choice [ pTokSP KLambda, pTokSP KBackSlash ]
bs <- P.choice
[ fmap concat $ P.many1
$ do pTok KRoundBra
bs' <- P.many1 pBinder
pTok (KOp ":")
t <- pType c
pTok KRoundKet
return (map (\b -> T.makeBindFromBinder b t) bs')
, do bs' <- P.many1 pBinder
pTok (KOp ":")
t <- pType c
return (map (\b -> T.makeBindFromBinder b t) bs')
]
pTok KDot
xBody <- pExp c
return $ foldr (XLam sp) xBody bs
-- Level-1 lambda abstractions.
-- /\(x1 x2 ... : Type) (y1 y2 ... : Type) ... . Exp
, do sp <- P.choice [ pTokSP KBigLambda, pTokSP KBigLambdaSlash ]
bs <- P.choice
[ fmap concat $ P.many1
$ do pTok KRoundBra
bs' <- P.many1 pBinder
pTok (KOp ":")
t <- pType c
pTok KRoundKet
return (map (\b -> T.makeBindFromBinder b t) bs')
, do bs' <- P.many1 pBinder
pTok (KOp ":")
t <- pType c
return (map (\b -> T.makeBindFromBinder b t) bs')
]
pTok KDot
xBody <- pExp c
return $ foldr (XLAM sp) xBody bs
-- let expression
, do (lts, sp) <- pLetsSP c
pTok KIn
x2 <- pExp c
return $ XLet sp lts x2
-- Sugar for a let-expression.
-- do { Stmt;+ }
, do pTok KDo
pTok KBraceBra
xx <- pStmts c
pTok KBraceKet
return $ xx
-- case Exp of { Alt;+ }
, do sp <- pTokSP KCase
x <- pExp c
pTok KOf
pTok KBraceBra
alts <- P.sepEndBy1 (pAlt c) (pTok KSemiColon)
pTok KBraceKet
return $ XCase sp x alts
-- match { | EXP = EXP | EXP = EXP ... }
-- Sugar for cascaded case expressions case-expression.
, do sp <- pTokSP KMatch
pTok KBraceBra
x <- pMatchGuardsAsCase sp c
pTok KBraceKet
return x
, do -- if-then-else
-- Sugar for a case-expression.
sp <- pTokSP KIf
x1 <- pExp c
pTok KThen
x2 <- pExp c
pTok KElse
x3 <- pExp c
return $ XCase sp x1
[ AAlt pTrue [GExp x2]
, AAlt PDefault [GExp x3]]
-- weakeff [Type] in Exp
, do sp <- pTokSP KWeakEff
pTok KSquareBra
t <- pType c
pTok KSquareKet
pTok KIn
x <- pExp c
return $ XCast sp (CastWeakenEffect t) x
-- purify Witness in Exp
, do sp <- pTokSP KPurify
w <- pWitness c
pTok KIn
x <- pExp c
return $ XCast sp (CastPurify w) x
-- box Exp
, do sp <- pTokSP KBox
x <- pExp c
return $ XCast sp CastBox x
-- run Exp
, do sp <- pTokSP KRun
x <- pExp c
return $ XCast sp CastRun x
-- APP
, do pExpApp c
]
<?> "an expression"
-- Applications.
pExpApp :: Context Name -> Parser Name (Exp SP)
pExpApp c
= do xps <- liftM concat $ P.many1 (pArgSPs c)
let (xs, sps) = unzip xps
let sp1 : _ = sps
case xs of
[x] -> return x
_ -> return $ XDefix sp1 xs
<?> "an expression or application"
-- Comp, Witness or Spec arguments.
pArgSPs :: Context Name -> Parser Name [(Exp SP, SP)]
pArgSPs c
= P.choice
-- [Type]
[ do sp <- pTokSP KSquareBra
t <- pType c
pTok KSquareKet
return [(XType sp t, sp)]
-- [: Type0 Type0 ... :]
, do sp <- pTokSP KSquareColonBra
ts <- P.many1 (pTypeAtom c)
pTok KSquareColonKet
return [(XType sp t, sp) | t <- ts]
-- { Witness }
, do sp <- pTokSP KBraceBra
w <- pWitness c
pTok KBraceKet
return [(XWitness sp w, sp)]
-- {: Witness0 Witness0 ... :}
, do sp <- pTokSP KBraceColonBra
ws <- P.many1 (pWitnessAtom c)
pTok KBraceColonKet
return [(XWitness sp w, sp) | w <- ws]
-- Exp0
, do (x, sp) <- pExpAtomSP c
return [(x, sp)]
]
<?> "a type, witness or expression argument"
-- | Parse a variable, constructor or parenthesised expression.
pExpAtom :: Context Name -> Parser Name (Exp SP)
pExpAtom c
= do (x, _) <- pExpAtomSP c
return x
-- | Parse a variable, constructor or parenthesised expression,
-- also returning source position.
pExpAtomSP :: Context Name -> Parser Name (Exp SP, SP)
pExpAtomSP c
= P.choice
[ -- ( Exp2 )
do sp <- pTokSP KRoundBra
t <- pExp c
pTok KRoundKet
return (t, sp)
-- Infix operator used as a variable.
, do (str, sp) <- pOpVarSP
return (XInfixVar sp str, sp)
-- Infix operator used nekkid.
, do (str, sp) <- pOpSP
return (XInfixOp sp str, sp)
-- The unit data constructor.
, do sp <- pTokSP KDaConUnit
return (XCon sp dcUnit, sp)
-- Named algebraic constructors.
, do (con, sp) <- pConSP
return (XCon sp (DaConBound con), sp)
-- Literals.
-- We just fill-in the type with tBot for now, and leave it to
-- the spreader to attach the real type.
-- We also set the literal as being algebraic, which may not be
-- true (as for Floats). The spreader also needs to fix this.
, do (lit, sp) <- pLitSP
return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp)
, do (tx, sp) <- pStringSP
let Just mkString = contextMakeStringName c
let lit = mkString sp tx
return (XCon sp (DaConPrim lit (T.tBot T.kData)), sp)
-- Primitive names.
, do (nPrim, sp) <- pPrimValSP
return (XPrim sp nPrim, sp)
-- Named variables.
, do (sVar, sp) <- pVarStringSP
return (XVar sp (T.UName (NameVar sVar)), sp)
-- Debruijn indices
, do (i, sp) <- pIndexSP
return (XVar sp (T.UIx i), sp)
]
<?> "a variable, constructor, or parenthesised type"
-- Alternatives -----------------------------------------------------------------------------------
-- Case alternatives.
pAlt :: Context Name -> Parser Name (Alt SP)
pAlt c
= do p <- pPat c
P.choice
[ do -- Desugar case guards while we're here.
spgxs <- P.many1 (pGuardedExpSP c (pTokSP KArrowDash))
let gxs = map snd spgxs
return $ AAlt p gxs
, do pTok KArrowDash
x <- pExp c
return $ AAlt p [GExp x] ]
-- Patterns.
pPat :: Context Name -> Parser Name (Pat SP)
pPat c
= P.choice
[ -- Wildcard
do pTok KUnderscore
return $ PDefault
-- Lit
, do nLit <- pLit
return $ PData (DaConPrim nLit (T.tBot T.kData)) []
-- 'Unit'
, do pTok KDaConUnit
return $ PData dcUnit []
-- Con Bind Bind ...
, do nCon <- pCon
bs <- P.many (pBindPat c)
return $ PData (DaConBound nCon) bs]
-- Binds in patterns can have no type annotation,
-- or can have an annotation if the whole thing is in parens.
pBindPat :: Context Name -> Parser Name Bind
pBindPat c
= P.choice
-- Plain binder.
[ do b <- pBinder
return $ T.makeBindFromBinder b (T.tBot T.kData)
-- Binder with type, wrapped in parens.
, do pTok KRoundBra
b <- pBinder
pTok (KOp ":")
t <- pType c
pTok KRoundKet
return $ T.makeBindFromBinder b t
]
-- Guards -----------------------------------------------------------------------------------------
-- | Parse some guards and auto-desugar them to a case-expression.
pBindGuardsAsCaseSP
:: Context Name
-> Parser Name (SP, Exp SP)
pBindGuardsAsCaseSP c
= do
(sp, g) : spgs
<- P.many1 (pGuardedExpSP c (pTokSP KEquals))
-- Desugar guards.
-- If none match then raise a runtime error.
let xx' = desugarGuards sp (g : map snd spgs)
$ xErrorDefault sp
(Text.pack $ sourcePosSource sp)
(fromIntegral $ sourcePosLine sp)
return (sp, xx')
pMatchGuardsAsCase
:: SP -> Context Name
-> Parser Name (Exp SP)
pMatchGuardsAsCase sp c
= do gg <- liftM (map snd)
$ P.sepEndBy1 (pGuardedExpSP c (pTokSP KEquals))
(pTok KSemiColon)
-- Desugar guards.
-- If none match then raise a runtime error.
let xx' = desugarGuards sp gg
$ xErrorDefault sp
(Text.pack $ sourcePosSource sp)
(fromIntegral $ sourcePosLine sp)
return xx'
-- | An guarded expression,
-- like | EXP1 = EXP2.
pGuardedExpSP
:: Context Name -- ^ Parser context.
-> Parser Name SP -- ^ Parser for char between and of guards and exp.
-- usually -> or =
-> Parser Name (SP, GuardedExp SP)
pGuardedExpSP c pTermSP
= pGuardExp (pTokSP KBar)
where pGuardExp pSepSP
= P.choice
[ do sp <- pSepSP
g <- pGuard
gx <- liftM snd $ pGuardExp (pTokSP KComma)
return (sp, GGuard g gx)
, do sp <- pTermSP
x <- pExp c
return (sp, GExp x) ]
pGuard
= P.choice
[ P.try $
do p <- pPat c
pTok KArrowDashLeft
x <- pExp c
return $ GPat p x
, do g <- pExp c
return $ GPred g
, do pTok KOtherwise
return GDefault ]
-- Bindings ---------------------------------------------------------------------------------------
pLetsSP :: Context Name -> Parser Name (Lets SP, SP)
pLetsSP c
= P.choice
[ -- non-recursive let
do sp <- pTokSP KLet
l <- liftM fst $ pClauseSP c
return (LGroup [l], sp)
-- recursive let
, do sp <- pTokSP KLetRec
pTok KBraceBra
ls <- liftM (map fst)
$ P.sepEndBy1 (pClauseSP c) (pTok KSemiColon)
pTok KBraceKet
return (LGroup ls, sp)
-- Private region binding.
-- private Binder+ (with { Binder : Type ... })? in Exp
, do sp <- pTokSP KPrivate
-- new private region names.
brs <- P.manyTill pBinder
$ P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith]
let bs = map (flip T.makeBindFromBinder T.kRegion) brs
-- Witness types.
r <- pLetWits c bs Nothing
return (r, sp)
-- Extend an existing region.
-- extend Binder+ using Type (with { Binder : Type ...})? in Exp
, do sp <- pTokSP KExtend
-- parent region
t <- pType c
pTok KUsing
-- new private region names.
brs <- P.manyTill pBinder
$ P.try $ P.lookAhead
$ P.choice [pTok KUsing, pTok KWith, pTok KIn]
let bs = map (flip T.makeBindFromBinder T.kRegion) brs
-- witness types
r <- pLetWits c bs (Just t)
return (r, sp)
]
pLetWits :: Context Name
-> [Bind] -> Maybe (T.Type Name)
-> Parser Name (Lets SP)
pLetWits c bs mParent
= P.choice
[ do pTok KWith
pTok KBraceBra
wits <- P.sepBy (P.choice
[ -- Named witness binder.
do b <- pBinder
pTok (KOp ":")
t <- pTypeApp c
return $ T.makeBindFromBinder b t
-- Ambient witness binding, used for capabilities.
, do t <- pTypeApp c
return $ T.BNone t
])
(pTok KSemiColon)
pTok KBraceKet
return (LPrivate bs mParent wits)
, do return (LPrivate bs mParent [])
]
-- | A binding for let expression.
pClauseSP :: Context Name
-> Parser Name (Clause SP, SP)
pClauseSP c
= do b <- pBinder
P.choice
[ do -- Binding with full type signature.
sp <- pTokSP (KOp ":")
t <- pType c
(_, xBody) <- pBindGuardsAsCaseSP c
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody]
, sp)
, do -- Non-function binding with no type signature.
sp <- pTokSP KEquals
xBody <- pExp c
let t = T.tBot T.kData
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody]
, sp)
, do -- Binding using function syntax.
ps <- liftM concat
$ P.many (pBindParamSpec c)
P.choice
[ do -- Function syntax with a return type.
-- We can make the full type sig for the let-bound variable.
-- Binder Param1 Param2 .. ParamN : Type = Exp
pTok (KOp ":")
tBody <- pType c
(sp, xBody) <- pBindGuardsAsCaseSP c
let x = expOfParams sp ps xBody
let t = funTypeOfParams c ps tBody
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp x]
, sp)
-- Function syntax with no return type.
-- We can't make the type sig for the let-bound variable,
-- but we can create lambda abstractions with the given
-- parameter types.
-- Binder Param1 Param2 .. ParamN = Exp
, do (sp, xBody) <- pBindGuardsAsCaseSP c
let x = expOfParams sp ps xBody
let t = T.tBot T.kData
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp x]
, sp)
]
]
-- Statements -------------------------------------------------------------------------------------
data Stmt n
= StmtBind SP Bind (Exp SP)
| StmtMatch SP (Pat SP) (Exp SP) (Exp SP)
| StmtNone SP (Exp SP)
-- | Parse a single statement.
pStmt :: Context Name -> Parser Name (Stmt Name)
pStmt c
= P.choice
[ -- Binder = Exp ;
-- We need the 'try' because a VARIABLE binders can also be parsed
-- as a function name in a non-binding statement.
--
P.try $
do br <- pBinder
sp <- pTokSP KEquals
x1 <- pExp c
let t = T.tBot T.kData
let b = T.makeBindFromBinder br t
return $ StmtBind sp b x1
-- Pat <- Exp else Exp ;
-- Sugar for a case-expression.
-- We need the 'try' because the PAT can also be parsed
-- as a function name in a non-binding statement.
, P.try $
do p <- pPat c
sp <- pTokSP KArrowDashLeft
x1 <- pExp c
pTok KElse
x2 <- pExp c
return $ StmtMatch sp p x1 x2
-- Exp
, do x <- pExp c
-- This should always succeed because pExp doesn't
-- parse plain types or witnesses
let Just sp = takeAnnotOfExp x
return $ StmtNone sp x
]
-- | Parse some statements.
pStmts :: Context Name -> Parser Name (Exp SP)
pStmts c
= do stmts <- P.sepEndBy1 (pStmt c) (pTok KSemiColon)
case makeStmts stmts of
Nothing -> P.unexpected "do-block must end with a statement"
Just x -> return x
-- | Make an expression from some statements.
makeStmts :: [Stmt Name] -> Maybe (Exp SP)
makeStmts ss
= case ss of
[StmtNone _ x]
-> Just x
StmtNone sp x1 : rest
| Just x2 <- makeStmts rest
-> Just $ XLet sp (LLet (T.BNone (T.tBot T.kData)) x1) x2
StmtBind sp b x1 : rest
| Just x2 <- makeStmts rest
-> Just $ XLet sp (LLet b x1) x2
StmtMatch sp p x1 x2 : rest
| Just x3 <- makeStmts rest
-> Just $ XCase sp x1
[ AAlt p [GExp x3]
, AAlt PDefault [GExp x2] ]
_ -> Nothing