CSCE 314 Lecture 16

« previous | Monday, October 3, 2011 | next »

Implementing a parser from scratch

import Char (isSpace, isDigit)

-------------
-- Grammar --
-------------

-- expr ::= expr addop term | term
-- term ::= term mulop factor | factor
-- factor ::= digit | ( expr )
-- digit ::= 0 | 1 | ... | 9
-- addop ::= + | -
-- mulop ::= * | /

-- Transform away left recursion:

-- expr ::= term termSeq 
-- termSeq ::= addop term termSeq | e
-- term ::= factor factorSeq
-- factorSeq ::= mulop factor factorSeq | e
-- factor ::= digit | ( expr )
-- digit ::= 0 | 1 | ... | 9
-- addop ::= + | -
-- mulop ::= * | /

----------
-- AST  --
----------

data Tree = Lit Integer | BinOp Char Tree Tree 
          deriving Show

----------------
-- Evaluator  --
----------------

getOp '+' = (+)
getOp '-' = (-)
getOp '*' = (*)
getOp '/' = div

eval (Lit i) = i
eval (BinOp op l r) = getOp op (eval l) (eval r) 

------------
-- Parser --
------------

-- wrap a function in a constructor and call it a parser
data Parser a = P (String -> [(a, String)])

start :: Parser Tree
start = whitespace >> expr

expr :: Parser Tree
expr = term >>= \lhs -> termSeq lhs  -- send the left-hand-side to the termSeq parser so it can process left association

termSeq :: Tree -> Parser Tree
termSeq lhs = (
        addop >>= \op ->
        term >>= \rhs ->
        termSeq (BinOp op lhs rhs)
    ) +++ (
        return lhs
    )

term :: Parser Tree
term = factor >>= \lhs -> factorSeq lhs

factorSeq :: Tree -> Parser Tree
factorSeq lhs = (
        mulop >>= \op ->
        factor >>= \rhs ->
        factorSeq (BinOp op lhs rhs)
    ) +++ (
        return lhs
    )
    
factor :: Parser Tree
factor = (integer >>= \i -> return $ Lit i) +++ parens expr

addop :: Parser Char
addop = sat $ flip elem "+-"

mulop :: Parser Char
mulop = sat $ flip elem "*/"

digit :: Parser Char
digit = sat isDigit

integer :: Parser Integer
integer = many1 digit >>= \s -> return $ read s


-- Generally useful parsers

parens :: Parser a -> Parser a
parens p = openParen >>
           p >>= \r ->
           closeParen >>
           return r

openParen :: Parser Char
openParen = sat (== '(')

closeParen :: Parser Char
closeParen = sat (== ')')

sat :: (Char -> Bool) -> Parser Char
sat p = item >>= \v -> 
        whitespace >>
        if p v then return v else failure 

whitespace :: Parser String
whitespace = many $ sat isSpace

many1 :: Parser a -> Parser [a]
many1 p = p >>= \v ->
          many p >>= \vs ->
          return (v:vs)

many :: Parser a -> Parser [a]
many p = many1 p +++ return []


item :: Parser Char
item = P (\inp -> case inp of
    [] -> []
    (x:xs) -> [(x,xs)])

failure :: Parser a
failure = P (\inp -> [])


(+++) :: Parser a -> Parser a -> Parser a
p +++ q = P $ \inp -> case parse p inp of
    [] -> parse q inp
    [(v, out)] -> [(v, out)]


parse :: Parser a -> String -> [(a, String)]
parse (P p) inp = p inp

-----------------------
-- Parser is a monad --
-----------------------
instance Monad Parser where
    return v = P $ \inp -> [(v, inp)]
    p >>= f = P $ \inp -> case parse p inp of
        [] -> []
        [(v, out)] -> parse (f v) out 

----------
-- Test --
----------

test = 
    let [(tree, _)] = parse start " 44+44*3/2*(1+ 2-3) " 
    in
      tree