The Parse module contains the following definitions:
newtype Parser s t = P ([s] -> [(t,[s])])
unP (P p) = p
pSym :: Eq s => s -> Parser s s
pSym a = P $ \inp -> case inp of
(s:ss) | s == a -> [(s,ss)]
otherwise -> []
pReturn :: a -> Parser s a
pReturn a = P $ \inp -> [(a,inp)]
pFail :: Parser s t
pFail = P $ const []
infixl 5 <*>
(<*>) :: Parser s (b -> a) -> Parser s b -> Parser s a
P p1 <*> P p2 = P $ \inp -> [ (v1 v2, ss2) | (v1,ss1) <- p1 inp
, (v2, ss2) <- p2 ss1]
infixr 3 <|>
(<|>) :: Parser s a -> Parser s a -> Parser s a
P p1 <|> P p2 = P $ \inp -> p1 inp ++ p2 inp
pChoice :: [Parser s a] -> Parser s a
pChoice ps = foldr (<|>) pFail ps
infix 7 <$>
(<$>) :: (b -> a) -> Parser s b -> Parser s a
f <$> p = pReturn f <*> p
infixl 3 `opt`
infixl 5 <*, *>
infixl 7 <$
f <$ p = const <$> pReturn f <*> p
p <* q = const <$> p <*> q
p *> q = id <$ p <*> q
opt :: Parser s a -> a -> Parser s a
p `opt` v = p <|> pReturn v
pSatisfy :: (s -> Bool) -> Parser s s
pSatisfy p = P $ \inp -> case inp of
(x:xs) | p x -> [(x,xs)]
otherwise -> []
pMany :: Parser s a -> Parser s [a]
pMany p = (:) <$> p <*> pMany p `opt` []
pMany1 :: Parser s a -> Parser s [a]
pMany1 p = (:) <$> p <*> pMany p
applyAll :: a -> [a -> a] -> a
applyAll x [] = x
applyAll x (f:fs) = applyAll (f x) fs
pChainL :: Parser s (a -> a -> a) -> Parser s a -> Parser s a
pChainL op p = applyAll <$> p <*> pMany (flip <$> op <*> p)Recall our SExpr data type:
data SExpr = AppS SExpr SExpr
| LambdaS Name SExpr
| BinopS Op SExpr SExpr
| VarS Name
| ValS Integer
| BoolS Bool
| IFS SExpr SExpr SExpr
| LetS (Name,SExpr) SExpr
| PrintS SExpr
deriving(Show)
Complete the following specification of the parser for SExprs. Feel free to modify the token definition if you have a different set of tokens.
newtype Parser s t = P ([s] -> [(t,[s])])
unP (P p) = p
pSym :: Eq s => s -> Parser s s
pSym a = P $ \inp -> case inp of
(s:ss) | s == a -> [(s,ss)]
otherwise -> []
pReturn :: a -> Parser s a
pReturn a = P $ \inp -> [(a,inp)]
pFail :: Parser s t
pFail = P $ const []
infixl 5 <*>
(<*>) :: Parser s (b -> a) -> Parser s b -> Parser s a
P p1 <*> P p2 = P $ \inp -> [ (v1 v2, ss2) | (v1,ss1) <- p1 inp
, (v2, ss2) <- p2 ss1]
infixr 3 <|>
(<|>) :: Parser s a -> Parser s a -> Parser s a
P p1 <|> P p2 = P $ \inp -> p1 inp ++ p2 inp
pChoice :: [Parser s a] -> Parser s a
pChoice ps = foldr (<|>) pFail ps
infix 7 <$>
(<$>) :: (b -> a) -> Parser s b -> Parser s a
f <$> p = pReturn f <*> p
infixl 3 `opt`
infixl 5 <*, *>
infixl 7 <$
f <$ p = const <$> pReturn f <*> p
p <* q = const <$> p <*> q
p *> q = id <$ p <*> q
opt :: Parser s a -> a -> Parser s a
p `opt` v = p <|> pReturn v
pSatisfy :: (s -> Bool) -> Parser s s
pSatisfy p = P $ \inp -> case inp of
(x:xs) | p x -> [(x,xs)]
otherwise -> []
pMany :: Parser s a -> Parser s [a]
pMany p = (:) <$> p <*> pMany p `opt` []
pMany1 :: Parser s a -> Parser s [a]
pMany1 p = (:) <$> p <*> pMany p
applyAll :: a -> [a -> a] -> a
applyAll x [] = x
applyAll x (f:fs) = applyAll (f x) fs
pChainL :: Parser s (a -> a -> a) -> Parser s a -> Parser s a
pChainL op p = applyAll <$> p <*> pMany (flip <$> op <*> p)
data SExpr = AppS SExpr SExpr
| LambdaS Name SExpr
| BinopS Op SExpr SExpr
| VarS Name
| ValS Integer
| BoolS Bool
| IFS SExpr SExpr SExpr
| LetS (Name,SExpr) SExpr
| PrintS SExpr
deriving(Show)
data Op = Add
| Sub
| Mul
| Div
| Mod
| Eq
| Lt
| Gt
| Leq
| Geq
| OR
| AND
deriving(Show)
type Name = String
-- show
-- Token list corresponding to the "(let (x 5) (+ x 3))" program
-- Adjust this if you used different tokens
tokens = [LParenT,LetT,SpaceT,LParenT,VarT "x",SpaceT,IntT 5,RParenT,SpaceT,LParenT,AddT,SpaceT,VarT "x",SpaceT,IntT 3,RParenT,RParenT]
-- The token definitions
data Token = LParenT
| RParenT
| SpaceT
| LambdaT
| AddT
| MulT
| DivT
| SubT
| ModT
| EqT
| LtT
| GtT
| LeqT
| GeqT
| LetT
| ORT
| ANDT
| IFT
| IntT Integer
| BoolT Bool
| VarT Name
| PrintT
deriving(Show,Eq)
parseExpr :: Parser Token SExpr
parseExpr = parseInt
{-
parseExpr = parseApp
<|> parseLambda
<|> parseBinop
<|> parseVar
<|> parseBool
<|> parseInt
<|> parseIF
<|> parseLet
<|> parsePrint
-}
parseApp = undefined
parseLambda = undefined
parseBinop = undefined
parseVar = undefined
parseBool = undefined
parseIF = undefined
parseLet = undefined
parsePrint = undefined
parseInt :: Parser Token SExpr
parseInt = (\(IntT n) -> ValS n) <$> pSatisfy isIntTok where
isIntTok t = case t of
IntT _ -> True
otherwise -> False
main = do
-- putStrLn $ show $ (unP parseExpr) tokens
putStrLn $ show $ (unP parseExpr) [IntT 53]
-- /show
