module DDC.Core.Parser.Exp
( pExp
, pExpApp
, pExpAtom
, pLets
, pType
, pTypeApp
, pTypeAtom)
where
import DDC.Core.Exp
import DDC.Core.Parser.Witness
import DDC.Core.Parser.Param
import DDC.Core.Parser.Type
import DDC.Core.Parser.Base
import DDC.Core.Lexer.Tokens
import DDC.Core.Compounds
import DDC.Base.Parser ((<?>))
import qualified DDC.Base.Parser as P
import qualified DDC.Type.Compounds as T
import Control.Monad.Error
pExp :: Ord n => Parser n (Exp () n)
pExp
= P.choice
[ do pTok KBackSlash
bs <- liftM concat
$ P.many1
$ do pTok KRoundBra
bs' <- P.many1 pBinder
pTok KColon
t <- pType
pTok KRoundKet
return (map (\b -> T.makeBindFromBinder b t) bs')
pTok KDot
xBody <- pExp
return $ foldr (XLam ()) xBody bs
, do pTok KBigLambda
bs <- liftM concat
$ P.many1
$ do pTok KRoundBra
bs' <- P.many1 pBinder
pTok KColon
t <- pType
pTok KRoundKet
return (map (\b -> T.makeBindFromBinder b t) bs')
pTok KDot
xBody <- pExp
return $ foldr (XLAM ()) xBody bs
, do lts <- pLets
pTok KIn
x2 <- pExp
return $ XLet () lts x2
, do pTok KDo
pTok KBraceBra
xx <- pStmts
pTok KBraceKet
return $ xx
, do pTok KWithRegion
u <- P.choice
[ do n <- pVar
return $ UName n
, do n <- pCon
return $ UPrim n kRegion]
pTok KIn
x <- pExp
return $ XLet () (LWithRegion u) x
, do pTok KCase
x <- pExp
pTok KOf
pTok KBraceBra
alts <- P.sepEndBy1 pAlt (pTok KSemiColon)
pTok KBraceKet
return $ XCase () x alts
, do pTok KMatch
p <- pPat
pTok KArrowDashLeft
x1 <- pExp
pTok KElse
x2 <- pExp
pTok KIn
x3 <- pExp
return $ XCase () x1 [AAlt p x3, AAlt PDefault x2]
, do pTok KWeakEff
pTok KSquareBra
t <- pType
pTok KSquareKet
pTok KIn
x <- pExp
return $ XCast () (CastWeakenEffect t) x
, do pTok KWeakClo
pTok KBraceBra
xs <- liftM concat $ P.sepEndBy1 pArgs (pTok KSemiColon)
pTok KBraceKet
pTok KIn
x <- pExp
return $ XCast () (CastWeakenClosure xs) x
, do pTok KPurify
pTok KAngleBra
w <- pWitness
pTok KAngleKet
pTok KIn
x <- pExp
return $ XCast () (CastPurify w) x
, do pTok KForget
pTok KAngleBra
w <- pWitness
pTok KAngleKet
pTok KIn
x <- pExp
return $ XCast () (CastForget w) x
, do pExpApp
]
<?> "an expression"
pExpApp :: Ord n => Parser n (Exp () n)
pExpApp
= do x1 <- pExpAtom
P.choice
[ do xs <- liftM concat $ P.many1 pArgs
return $ foldl (XApp ()) x1 xs
, return x1]
<?> "an expression or application"
pArgs :: Ord n => Parser n [Exp () n]
pArgs
= P.choice
[ do pTok KSquareBra
t <- pType
pTok KSquareKet
return [XType t]
, do pTok KSquareColonBra
ts <- P.many1 pTypeAtom
pTok KSquareColonKet
return $ map XType ts
, do pTok KAngleBra
w <- pWitness
pTok KAngleKet
return [XWitness w]
, do pTok KAngleColonBra
ws <- P.many1 pWitnessAtom
pTok KAngleColonKet
return $ map XWitness ws
, do x <- pExpAtom
return [x]
]
<?> "a type, witness or expression argument"
pExpAtom :: Ord n => Parser n (Exp () n)
pExpAtom
= P.choice
[ do pTok KRoundBra
t <- pExp
pTok KRoundKet
return $ t
, do pTok KDaConUnit
return $ XCon () dcUnit
, do con <- pCon
return $ XCon () (mkDaConAlg con (T.tBot T.kData))
, do lit <- pLit
return $ XCon () (mkDaConAlg lit (T.tBot T.kData))
, do i <- pIndex
return $ XVar () (UIx i)
, do var <- pVar
return $ XVar () (UName var)
]
<?> "a variable, constructor, or parenthesised type"
pAlt :: Ord n => Parser n (Alt () n)
pAlt
= do p <- pPat
pTok KArrowDash
x <- pExp
return $ AAlt p x
pPat :: Ord n => Parser n (Pat n)
pPat
= P.choice
[
do pTok KUnderscore
return $ PDefault
, do nLit <- pLit
return $ PData (mkDaConAlg nLit (T.tBot T.kData)) []
, do pTok KDaConUnit
return $ PData dcUnit []
, do nCon <- pCon
bs <- P.many pBindPat
return $ PData (mkDaConAlg nCon (T.tBot T.kData)) bs]
pBindPat :: Ord n => Parser n (Bind n)
pBindPat
= P.choice
[ do b <- pBinder
return $ T.makeBindFromBinder b (T.tBot T.kData)
, do pTok KRoundBra
b <- pBinder
pTok KColon
t <- pType
pTok KRoundKet
return $ T.makeBindFromBinder b t
]
pLets :: Ord n => Parser n (Lets () n)
pLets
= P.choice
[
do pTok KLet
(mode1, b1, x1) <- pLetBinding
return $ LLet mode1 b1 x1
, do pTok KLetRec
P.choice
[ do pTok KBraceBra
lets <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon)
pTok KBraceKet
return $ LRec lets
, do ll <- pLetRecBinding
return $ LRec [ll]
]
, do pTok KLetRegions
brs <- P.manyTill pBinder (P.try $ P.lookAhead $ P.choice [pTok KIn, pTok KWith])
let bs = map (flip T.makeBindFromBinder T.kRegion) brs
pLetWits bs
, do pTok KLetRegion
br <- pBinder
let b = T.makeBindFromBinder br T.kRegion
pLetWits [b]
]
pLetWits :: Ord n => [Bind n] -> Parser n (Lets () n)
pLetWits bs
= P.choice
[ do pTok KWith
pTok KBraceBra
wits <- P.sepBy
(do b <- pBinder
pTok KColon
t <- pTypeApp
return $ T.makeBindFromBinder b t)
(pTok KSemiColon)
pTok KBraceKet
return (LLetRegions bs wits)
, do return (LLetRegions bs [])
]
pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n)
pLetBinding
= do b <- pBinder
P.choice
[ do
pTok KColon
t <- pType
mode <- pLetMode
pTok KEquals
xBody <- pExp
return $ (mode, T.makeBindFromBinder b t, xBody)
, do
mode <- pLetMode
pTok KEquals
xBody <- pExp
let t = T.tBot T.kData
return $ (mode, T.makeBindFromBinder b t, xBody)
, do
ps <- liftM concat
$ P.many pBindParamSpec
P.choice
[ do
pTok KColon
tBody <- pType
mode <- pLetMode
pTok KEquals
xBody <- pExp
let x = expOfParams () ps xBody
let t = funTypeOfParams ps tBody
return (mode, T.makeBindFromBinder b t, x)
, do mode <- pLetMode
pTok KEquals
xBody <- pExp
let x = expOfParams () ps xBody
let t = T.tBot T.kData
return (mode, T.makeBindFromBinder b t, x) ]
]
pLetMode :: Ord n => Parser n (LetMode n)
pLetMode
= do P.choice
[ do pTok KLazy
P.choice
[ do pTok KAngleBra
w <- pWitness
pTok KAngleKet
return $ LetLazy (Just w)
, do return $ LetLazy Nothing ]
, do return $ LetStrict ]
pLetRecBinding :: Ord n => Parser n (Bind n, Exp () n)
pLetRecBinding
= do b <- pBinder
P.choice
[ do
pTok KColon
t <- pType
pTok KEquals
xBody <- pExp
return $ (T.makeBindFromBinder b t, xBody)
, do
ps <- liftM concat
$ P.many pBindParamSpec
pTok KColon
tBody <- pType
let t = funTypeOfParams ps tBody
pTok KEquals
xBody <- pExp
let x = expOfParams () ps xBody
return (T.makeBindFromBinder b t, x) ]
data Stmt n
= StmtBind (Bind n) (Exp () n)
| StmtMatch (Pat n) (Exp () n) (Exp () n)
| StmtNone (Exp () n)
pStmt :: Ord n => Parser n (Stmt n)
pStmt
= P.choice
[
P.try $
do br <- pBinder
pTok KEquals
x1 <- pExp
let t = T.tBot T.kData
let b = T.makeBindFromBinder br t
return $ StmtBind b x1
, P.try $
do p <- pPat
pTok KArrowDashLeft
x1 <- pExp
pTok KElse
x2 <- pExp
return $ StmtMatch p x1 x2
, do x <- pExp
return $ StmtNone x
]
pStmts :: Ord n => Parser n (Exp () n)
pStmts
= do stmts <- P.sepEndBy1 pStmt (pTok KSemiColon)
case makeStmts stmts of
Nothing -> P.unexpected "do-block must end with a statement"
Just x -> return x
makeStmts :: [Stmt n] -> Maybe (Exp () n)
makeStmts ss
= case ss of
[StmtNone x]
-> Just x
StmtNone x1 : rest
| Just x2 <- makeStmts rest
-> Just $ XLet () (LLet LetStrict (BNone (T.tBot T.kData)) x1) x2
StmtBind b x1 : rest
| Just x2 <- makeStmts rest
-> Just $ XLet () (LLet LetStrict b x1) x2
StmtMatch p x1 x2 : rest
| Just x3 <- makeStmts rest
-> Just $ XCase () x1
[ AAlt p x3
, AAlt PDefault x2]
_ -> Nothing