This is a recursive descent parser for simple language with following grammar:
PROGRAM <- {STATEMENT ';'}* RETURN_STMT ';'
STATEMENT <- NAME_BINDING | TYPE_DECLARATION
TYPE_DECLARATION <- named_param identifier
NAME_BINDING <- identifier '=' EXPRESSION
EXPRESSION <- (simple arithmetics with (), +-*/ and unary minus, arguments can be constants, named parameters or identifiers)
RETURN_STMT = 'return' EXPRESSION {',' EXPRESSION}* ';'
Module entry point is parseGrammar, resulting AST represented as Program
module LangParser(parseGrammar, Token(..), Result(..)) where
import Control.Applicative
import Control.Monad
data Token =
Return |
Simple Char |
DecimalConst String |
HexConst String |
NamedParam String |
Identifier String |
LexError String |
EOF
deriving (Eq, Show)
data Op = ONop | OPlus | OMinus | OStar | OSlash | ONeg deriving (Show, Eq)
instance Ord Op where
compare ONeg _ = GT
compare _ ONeg = LT
compare OStar _ = GT
compare OSlash _ = GT
compare OPlus b
| b == OStar = LT
| b == OSlash = LT
| otherwise = GT
compare OMinus b
| b == OStar = LT
| b == OSlash = LT
| otherwise = GT
compare _ _ = error "invalid comparison"
data Expr =
EList Expr Expr |
EAdd Expr Expr |
ESub Expr Expr |
EMul Expr Expr |
EDiv Expr Expr |
ENeg Expr |
EIntConst Int |
EVariable String |
ENamedParam String
deriving Show
data Stmt =
SReturn [Expr] |
SDecl String String |
SBinding String Expr
deriving Show
type Program = [Stmt]
data ParserState = ParserState {
prog :: Program,
exprStack :: [Expr],
opStack :: [Op],
stmtIdent :: String,
stmtParam :: String,
rest :: [Token]
} deriving Show
data Result a = Error Token | State a deriving Show
instance Monad Result where
(Error e) >>= _ = Error e
(State a) >>= f = f a
return = State
instance Functor Result where
fmap _ (Error t) = Error t
fmap f (State a) = State (f a)
instance Applicative Result where
pure = return
(<*>) = ap
instance Alternative Result where
empty = Error EOF
Error _ <|> p = p
State x <|> _ = State x
epsilon :: ParserState -> Result ParserState
epsilon = State
term :: Token -> ParserState -> Result ParserState
term t state@ParserState {rest = (x:xs)}
| t == x = State state{rest = xs}
| otherwise = Error x
term _ ParserState {rest = []} = Error EOF
termS :: Char -> ParserState -> Result ParserState
termS c = term (Simple c)
termValue :: ParserState -> Result ParserState
termValue state@ParserState {rest = (DecimalConst x:xs)} = State state{exprStack = v : exprStack state, rest = xs}
where v = EIntConst (read x)
termValue state@ParserState {rest = (HexConst x:xs)} = State state{exprStack = v : exprStack state, rest = xs}
where v = EIntConst (read x)
termValue state@ParserState {rest = (NamedParam x:xs)} = State state{exprStack = ENamedParam x : exprStack state, rest = xs}
termValue state@ParserState {rest = (Identifier x:xs)} = State state{exprStack = EVariable x : exprStack state, rest = xs}
termValue ParserState {rest = (x:_)} = Error x
termValue ParserState {rest = []} = Error EOF
termIdent :: ParserState -> Result ParserState
termIdent state@ParserState {rest = (Identifier x:xs)} = State state{stmtIdent = x, rest = xs}
termIdent ParserState {rest = (x:_)} = Error x
termIdent ParserState {rest = []} = Error EOF
foldExpr :: Op -> ParserState -> Result ParserState
foldExpr _ state@ParserState{opStack = []} = State state
foldExpr stop state@ParserState{opStack = (op:_)} | op <= stop = State state
foldExpr stop state@ParserState{exprStack = (e:es), opStack = (ONeg:ops)}
= foldExpr stop state{ exprStack = ENeg e : es, opStack = ops }
foldExpr stop state@ParserState{exprStack = (e1:e2:es), opStack = (op:ops)}
= case op of
OPlus -> foldExpr stop state{ exprStack = EAdd e2 e1 : es, opStack = ops }
OMinus -> foldExpr stop state{ exprStack = ESub e2 e1 : es, opStack = ops }
OStar -> foldExpr stop state{ exprStack = EMul e2 e1 : es, opStack = ops }
OSlash -> foldExpr stop state{ exprStack = EDiv e2 e1 : es, opStack = ops }
_ -> error "invalid op in stack"
foldExpr _ _ = error "invalid state in fold"
exprS :: ParserState -> Result ParserState
exprS = expr >=> foldExpr ONop
expr :: ParserState -> Result ParserState
expr s = expr' s <|> (termNeg >=> expr') s
where
termNeg = termS '-' >=> (\state -> State state{opStack = ONeg : opStack state})
expr' st = (termValue >=> exprRest) st <|>
(termS '(' >=> exprS >=> termS ')' >=> exprRest) st
exprRest :: ParserState -> Result ParserState
exprRest s =
(termOp '+' >=> expr) s <|>
(termOp '-' >=> expr) s <|>
(termOp '*' >=> expr) s <|>
(termOp '/' >=> expr) s <|>
epsilon s
where
termOp c = termS c >=> foldExpr (op c) >=> (\state -> State state{opStack = op c : opStack state})
op '+' = OPlus
op '-' = OMinus
op '*' = OStar
op '/' = OSlash
op _ = error "bad op"
retexprs :: ParserState -> Result ParserState
retexprs = exprS >=> exprList
where
exprList s = (termS ',' >=> retexprs >=> action) s <|> epsilon s
action state@ParserState {exprStack = (e1:e2:es)} = State state{exprStack = EList e2 e1 : es}
action _ = error "2"
retStmt :: ParserState -> Result ParserState
retStmt = term Return >=> retexprs >=> termS ';' >=> action
where
action state@ParserState {exprStack = (e:es)} = State state{prog = SReturn (reverse $ unroll e []) : prog state, exprStack = es}
action _ = error "3"
unroll :: Expr -> [Expr] -> [Expr]
unroll (EList e1 e2) es = unroll e2 (e1:es)
unroll e es = e:es
nameBinding :: ParserState -> Result ParserState
nameBinding = termIdent >=> termS '=' >=> exprS >=> action
where
action state@ParserState {stmtIdent = ident, exprStack = (e:[])}
= State state{prog = SBinding ident e : prog state, exprStack = []}
action _ = error "invalid binding"
paramDecl :: ParserState -> Result ParserState
paramDecl = termNamedParam >=> termIdent >=> action
where
action state@ParserState{stmtParam = param, stmtIdent = ident}
= State state{prog = SDecl param ident: prog state}
termNamedParam state@ParserState {rest = (NamedParam x:xs)} = State state{stmtParam = x, rest = xs}
termNamedParam ParserState {rest = (x:_)} = Error x
termNamedParam ParserState {rest = []} = Error EOF
statements :: ParserState -> Result ParserState
statements s = (statement >=> termS ';' >=> statements) s <|> epsilon s
where statement st = paramDecl st <|> nameBinding st
parseProgram :: ParserState -> Result ParserState
parseProgram s = (statements >=> retStmt) s <|> retStmt s
parseGrammar :: [Token] -> Result ParserState
parseGrammar st = parseProgram (ParserState [] [] [] "" "" st)
I'm looking for code improvements. For example, repeated this lines looks ugly:
NNN ParserState {rest = (x:_)} = Error x
NNN ParserState {rest = []} = Error EOF
Also, I would like to separate parser states for parsing statements and expressions. Writing two separate types will require doubling number of epsilon/term/termIdent functions, which I hope to avoid.
foldExpr
,exprS
,expr
andexprRest
\$\endgroup\$