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
context :: Context Name
context = Context
{ contextTrackedEffects = True
, contextTrackedClosures = True
, contextFunctionalEffects = False
, contextFunctionalClosures = False
, contextMakeStringName = Just (\_ tx -> NameLitTextLit tx) }
pExp :: Context Name -> Parser Name (Exp SP)
pExp c
= P.choice
[ 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
, 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
, do (lts, sp) <- pLetsSP c
pTok KIn
x2 <- pExp c
return $ XLet sp lts x2
, do pTok KDo
pTok KBraceBra
xx <- pStmts c
pTok KBraceKet
return $ xx
, 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
, do sp <- pTokSP KMatch
pTok KBraceBra
x <- pMatchGuardsAsCase sp c
pTok KBraceKet
return x
, do
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]]
, do sp <- pTokSP KWeakEff
pTok KSquareBra
t <- pType c
pTok KSquareKet
pTok KIn
x <- pExp c
return $ XCast sp (CastWeakenEffect t) x
, do sp <- pTokSP KPurify
w <- pWitness c
pTok KIn
x <- pExp c
return $ XCast sp (CastPurify w) x
, do sp <- pTokSP KBox
x <- pExp c
return $ XCast sp CastBox x
, do sp <- pTokSP KRun
x <- pExp c
return $ XCast sp CastRun x
, do pExpApp c
]
<?> "an expression"
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"
pArgSPs :: Context Name -> Parser Name [(Exp SP, SP)]
pArgSPs c
= P.choice
[ do sp <- pTokSP KSquareBra
t <- pType c
pTok KSquareKet
return [(XType sp t, sp)]
, do sp <- pTokSP KSquareColonBra
ts <- P.many1 (pTypeAtom c)
pTok KSquareColonKet
return [(XType sp t, sp) | t <- ts]
, do sp <- pTokSP KBraceBra
w <- pWitness c
pTok KBraceKet
return [(XWitness sp w, sp)]
, do sp <- pTokSP KBraceColonBra
ws <- P.many1 (pWitnessAtom c)
pTok KBraceColonKet
return [(XWitness sp w, sp) | w <- ws]
, do (x, sp) <- pExpAtomSP c
return [(x, sp)]
]
<?> "a type, witness or expression argument"
pExpAtom :: Context Name -> Parser Name (Exp SP)
pExpAtom c
= do (x, _) <- pExpAtomSP c
return x
pExpAtomSP :: Context Name -> Parser Name (Exp SP, SP)
pExpAtomSP c
= P.choice
[
do sp <- pTokSP KRoundBra
t <- pExp c
pTok KRoundKet
return (t, sp)
, do (str, sp) <- pOpVarSP
return (XInfixVar sp str, sp)
, do (str, sp) <- pOpSP
return (XInfixOp sp str, sp)
, do sp <- pTokSP KDaConUnit
return (XCon sp dcUnit, sp)
, do (con, sp) <- pConSP
return (XCon sp (DaConBound con), sp)
, 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)
, do (nPrim, sp) <- pPrimValSP
return (XPrim sp nPrim, sp)
, do (sVar, sp) <- pVarStringSP
return (XVar sp (T.UName (NameVar sVar)), sp)
, do (i, sp) <- pIndexSP
return (XVar sp (T.UIx i), sp)
]
<?> "a variable, constructor, or parenthesised type"
pAlt :: Context Name -> Parser Name (Alt SP)
pAlt c
= do p <- pPat c
P.choice
[ do
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] ]
pPat :: Context Name -> Parser Name (Pat SP)
pPat c
= P.choice
[
do pTok KUnderscore
return $ PDefault
, do nLit <- pLit
return $ PData (DaConPrim nLit (T.tBot T.kData)) []
, do pTok KDaConUnit
return $ PData dcUnit []
, do nCon <- pCon
bs <- P.many (pBindPat c)
return $ PData (DaConBound nCon) bs]
pBindPat :: Context Name -> Parser Name Bind
pBindPat c
= P.choice
[ do b <- pBinder
return $ T.makeBindFromBinder b (T.tBot T.kData)
, do pTok KRoundBra
b <- pBinder
pTok (KOp ":")
t <- pType c
pTok KRoundKet
return $ T.makeBindFromBinder b t
]
pBindGuardsAsCaseSP
:: Context Name
-> Parser Name (SP, Exp SP)
pBindGuardsAsCaseSP c
= do
(sp, g) : spgs
<- P.many1 (pGuardedExpSP c (pTokSP KEquals))
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)
let xx' = desugarGuards sp gg
$ xErrorDefault sp
(Text.pack $ sourcePosSource sp)
(fromIntegral $ sourcePosLine sp)
return xx'
pGuardedExpSP
:: Context Name
-> Parser Name SP
-> 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 ]
pLetsSP :: Context Name -> Parser Name (Lets SP, SP)
pLetsSP c
= P.choice
[
do sp <- pTokSP KLet
l <- liftM fst $ pClauseSP c
return (LGroup [l], sp)
, do sp <- pTokSP KLetRec
pTok KBraceBra
ls <- liftM (map fst)
$ P.sepEndBy1 (pClauseSP c) (pTok KSemiColon)
pTok KBraceKet
return (LGroup ls, sp)
, do sp <- pTokSP KPrivate
brs <- P.manyTill pBinder
$ P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith]
let bs = map (flip T.makeBindFromBinder T.kRegion) brs
r <- pLetWits c bs Nothing
return (r, sp)
, do sp <- pTokSP KExtend
t <- pType c
pTok KUsing
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
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
[
do b <- pBinder
pTok (KOp ":")
t <- pTypeApp c
return $ T.makeBindFromBinder b t
, do t <- pTypeApp c
return $ T.BNone t
])
(pTok KSemiColon)
pTok KBraceKet
return (LPrivate bs mParent wits)
, do return (LPrivate bs mParent [])
]
pClauseSP :: Context Name
-> Parser Name (Clause SP, SP)
pClauseSP c
= do b <- pBinder
P.choice
[ do
sp <- pTokSP (KOp ":")
t <- pType c
(_, xBody) <- pBindGuardsAsCaseSP c
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody]
, sp)
, do
sp <- pTokSP KEquals
xBody <- pExp c
let t = T.tBot T.kData
return ( SLet sp (T.makeBindFromBinder b t) [] [GExp xBody]
, sp)
, do
ps <- liftM concat
$ P.many (pBindParamSpec c)
P.choice
[ do
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)
, 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)
]
]
data Stmt n
= StmtBind SP Bind (Exp SP)
| StmtMatch SP (Pat SP) (Exp SP) (Exp SP)
| StmtNone SP (Exp SP)
pStmt :: Context Name -> Parser Name (Stmt Name)
pStmt c
= P.choice
[
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
, P.try $
do p <- pPat c
sp <- pTokSP KArrowDashLeft
x1 <- pExp c
pTok KElse
x2 <- pExp c
return $ StmtMatch sp p x1 x2
, do x <- pExp c
let Just sp = takeAnnotOfExp x
return $ StmtNone sp x
]
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
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