module DDC.Core.Parser
( module DDC.Base.Parser
, Parser
, pExp
, pWitness)
where
import DDC.Core.Exp
import DDC.Core.Parser.Tokens
import DDC.Base.Parser ((<?>))
import DDC.Type.Parser (pTok)
import qualified DDC.Base.Parser as P
import qualified DDC.Type.Compounds as T
import qualified DDC.Type.Parser as T
import Control.Monad.Error
type Parser n a
= P.Parser (Tok n) a
pExp :: Ord n => Parser n (Exp () n)
pExp
= P.choice
[ do pTok KBackSlash
bs <- liftM concat
$ P.many1
$ do pTok KRoundBra
bs' <- P.many1 T.pBinder
pTok KColon
t <- 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 T.pBinder
pTok KColon
t <- T.pType
pTok KRoundKet
return (map (\b -> T.makeBindFromBinder b t) bs')
pTok KDot
xBody <- pExp
return $ foldr (XLAM ()) xBody bs
, do pTok KLet
(mode1, b1, x1) <- pLetBinding
pTok KIn
x2 <- pExp
return $ XLet () (LLet mode1 b1 x1) x2
, do pTok KLetRec
pTok KBraceBra
lets <- P.sepEndBy1 pLetRecBinding (pTok KSemiColon)
pTok KBraceKet
pTok KIn
x <- pExp
return $ XLet () (LRec lets) x
, do pTok KLetRegion
br <- T.pBinder
let b = T.makeBindFromBinder br T.kRegion
P.choice
[ do pTok KWith
pTok KBraceBra
wits <- P.sepBy
(do w <- pVar
pTok KColon
t <- T.pTypeApp
return (BName w t))
(pTok KSemiColon)
pTok KBraceKet
pTok KIn
x <- pExp
return $ XLet () (LLetRegion b wits) x
, do pTok KIn
x <- pExp
return $ XLet () (LLetRegion b []) x ]
, do pTok KWithRegion
n <- pVar
pTok KIn
x <- pExp
let u = UName n (T.tBot T.kRegion)
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 KWeakEff
pTok KSquareBra
t <- T.pType
pTok KSquareKet
pTok KIn
x <- pExp
return $ XCast () (CastWeakenEffect t) x
, do pTok KWeakClo
pTok KSquareBra
t <- T.pType
pTok KSquareKet
pTok KIn
x <- pExp
return $ XCast () (CastWeakenClosure t) 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 <- pExp0
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 <- T.pType
pTok KSquareKet
return [XType t]
, do pTok KSquareColonBra
ts <- P.many1 T.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 <- pExp0
return [x]
]
<?> "a type, witness or expression argument"
pExp0 :: Ord n => Parser n (Exp () n)
pExp0
= P.choice
[ do pTok KRoundBra
t <- pExp
pTok KRoundKet
return $ t
, do con <- pCon
return $ XCon () (UName con (T.tBot T.kData))
, do lit <- pLit
return $ XCon () (UName lit (T.tBot T.kData))
, do i <- T.pIndex
return $ XVar () (UIx i (T.tBot T.kData))
, do var <- pVar
return $ XVar () (UName var (T.tBot T.kData))
]
<?> "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 (UName nLit (T.tBot T.kData)) []
, do nCon <- pCon
bs <- P.many pBindPat
return $ PData (UName nCon (T.tBot T.kData)) bs]
pBindPat :: Ord n => Parser n (Bind n)
pBindPat
= P.choice
[ do b <- T.pBinder
return $ T.makeBindFromBinder b (T.tBot T.kData)
, do pTok KRoundBra
b <- T.pBinder
pTok KColon
t <- T.pType
pTok KRoundKet
return $ T.makeBindFromBinder b t
]
pLetBinding :: Ord n => Parser n (LetMode n, Bind n, Exp () n)
pLetBinding
= do b <- T.pBinder
P.choice
[ do
pTok KColon
t <- 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 <- T.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 <- T.pBinder
P.choice
[ do
pTok KColon
t <- T.pType
pTok KEquals
xBody <- pExp
return $ (T.makeBindFromBinder b t, xBody)
, do
ps <- liftM concat
$ P.many pBindParamSpec
pTok KColon
tBody <- T.pType
let t = funTypeOfParams ps tBody
pTok KEquals
xBody <- pExp
let x = expOfParams () ps xBody
return (T.makeBindFromBinder b t, x) ]
pBindParamSpec :: Ord n => Parser n [ParamSpec n]
pBindParamSpec
= P.choice
[ do pTok KSquareBra
bs <- P.many1 T.pBinder
pTok KColon
t <- T.pType
pTok KSquareKet
return [ ParamType b
| b <- zipWith T.makeBindFromBinder bs (repeat t)]
, do pTok KAngleBra
b <- T.pBinder
pTok KColon
t <- T.pType
pTok KAngleKet
return [ ParamWitness $ T.makeBindFromBinder b t]
, do pTok KRoundBra
b <- T.pBinder
pTok KColon
t <- T.pType
pTok KRoundKet
(eff, clo)
<- P.choice
[ do pTok KBraceBra
eff' <- T.pType
pTok KBar
clo' <- T.pType
pTok KBraceKet
return (eff', clo')
, do return (T.tBot T.kEffect, T.tBot T.kClosure) ]
return $ [ParamValue (T.makeBindFromBinder b t) eff clo]
]
data ParamSpec n
= ParamType (Bind n)
| ParamWitness (Bind n)
| ParamValue (Bind n) (Type n) (Type n)
funTypeOfParams
:: [ParamSpec n]
-> Type n
-> Type n
funTypeOfParams [] tBody = tBody
funTypeOfParams (p:ps) tBody
= case p of
ParamType b
-> TForall b
$ funTypeOfParams ps tBody
ParamWitness b
-> T.tImpl (T.typeOfBind b)
$ funTypeOfParams ps tBody
ParamValue b eff clo
-> T.tFun (T.typeOfBind b) eff clo
$ funTypeOfParams ps tBody
expOfParams
:: a
-> [ParamSpec n]
-> Exp a n
-> Exp a n
expOfParams _ [] xBody = xBody
expOfParams a (p:ps) xBody
= case p of
ParamType b
-> XLAM a b $ expOfParams a ps xBody
ParamWitness b
-> XLam a b $ expOfParams a ps xBody
ParamValue b _ _
-> XLam a b $ expOfParams a ps xBody
pWitness :: Ord n => Parser n (Witness n)
pWitness = pWitnessJoin
pWitnessJoin :: Ord n => Parser n (Witness n)
pWitnessJoin
= do w1 <- pWitnessApp
P.choice
[ do pTok KAmpersand
w2 <- pWitnessJoin
return (WJoin w1 w2)
, do return w1 ]
pWitnessApp :: Ord n => Parser n (Witness n)
pWitnessApp
= do (x:xs) <- P.many1 pWitnessArg
return $ foldl WApp x xs
<?> "a witness expression or application"
pWitnessArg :: Ord n => Parser n (Witness n)
pWitnessArg
= P.choice
[
do pTok KSquareBra
t <- T.pType
pTok KSquareKet
return $ WType t
, do pWitnessAtom ]
pWitnessAtom :: Ord n => Parser n (Witness n)
pWitnessAtom
= P.choice
[ do pTok KRoundBra
w <- pWitness
pTok KRoundKet
return $ w
, do con <- pCon
return $ WCon (WiConBound $ UName con (T.tBot T.kWitness))
, do wb <- pWbCon
return $ WCon (WiConBuiltin wb)
, do i <- T.pIndex
return $ WVar (UIx i (T.tBot T.kWitness))
, do var <- pVar
return $ WVar (UName var (T.tBot T.kWitness)) ]
<?> "a witness"
pWbCon :: Parser n WbCon
pWbCon = P.pTokMaybe f
where f (KA (KWbConBuiltin wb)) = Just wb
f _ = Nothing
pVar :: Parser n n
pVar = P.pTokMaybe f
where f (KN (KVar n)) = Just n
f _ = Nothing
pCon :: Parser n n
pCon = P.pTokMaybe f
where f (KN (KCon n)) = Just n
f _ = Nothing
pLit :: Parser n n
pLit = P.pTokMaybe f
where f (KN (KLit n)) = Just n
f _ = Nothing