-----------------------------------------------------------------------------
Test for monadic Happy Parsers, Simon Marlow 1996.
> {
> import Char
> }
> %name calc
> %tokentype { Token }
> %monad { P } { thenP } { returnP }
> %lexer { lexer } { TokenEOF }
> %token
> let { TokenLet }
> in { TokenIn }
> int { TokenInt $$ }
> var { TokenVar $$ }
> '=' { TokenEq }
> '+' { TokenPlus }
> '-' { TokenMinus }
> '*' { TokenTimes }
> '/' { TokenDiv }
> '(' { TokenOB }
> ')' { TokenCB }
> %%
> Exp :: {Exp}
> : let var '=' Exp in Exp {% \s l -> ParseOk (Let l $2 $4 $6) }
> | Exp1 { Exp1 $1 }
>
> Exp1 :: {Exp1}
> : Exp1 '+' Term { Plus $1 $3 }
> | Exp1 '-' Term { Minus $1 $3 }
> | Term { Term $1 }
>
> Term :: {Term}
> : Term '*' Factor { Times $1 $3 }
> | Term '/' Factor { Div $1 $3 }
> | Factor { Factor $1 }
>
> Factor :: {Factor}
> : int { Int $1 }
> | var { Var $1 }
> | '(' Exp ')' { Brack $2 }
> {
-----------------------------------------------------------------------------
The monad serves three purposes:
* it passes the input string around
* it passes the current line number around
* it deals with success/failure.
> data ParseResult a
> = ParseOk a
> | ParseFail String
> type P a = String -> Int -> ParseResult a
> thenP :: P a -> (a -> P b) -> P b
> m `thenP` k = \s l ->
> case m s l of
> ParseFail s -> ParseFail s
> ParseOk a -> k a s l
> returnP :: a -> P a
> returnP a = \s l -> ParseOk a
-----------------------------------------------------------------------------
Now we declare the datastructure that we are parsing.
> data Exp = Let Int String Exp Exp | Exp1 Exp1
> data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term
> data Term = Times Term Factor | Div Term Factor | Factor Factor
> data Factor = Int Int | Var String | Brack Exp
The datastructure for the tokens...
> data Token
> = TokenLet
> | TokenIn
> | TokenInt Int
> | TokenVar String
> | TokenEq
> | TokenPlus
> | TokenMinus
> | TokenTimes
> | TokenDiv
> | TokenOB
> | TokenCB
> | TokenEOF
.. and a simple lexer that returns this datastructure.
> lexer :: (Token -> P a) -> P a
> lexer cont s = case s of
> [] -> cont TokenEOF []
> ('\n':cs) -> \line -> lexer cont cs (line+1)
> (c:cs)
> | isSpace c -> lexer cont cs
> | isAlpha c -> lexVar (c:cs)
> | isDigit c -> lexNum (c:cs)
> ('=':cs) -> cont TokenEq cs
> ('+':cs) -> cont TokenPlus cs
> ('-':cs) -> cont TokenMinus cs
> ('*':cs) -> cont TokenTimes cs
> ('/':cs) -> cont TokenDiv cs
> ('(':cs) -> cont TokenOB cs
> (')':cs) -> cont TokenCB cs
> where
> lexNum cs = cont (TokenInt (read num)) rest
> where (num,rest) = span isDigit cs
> lexVar cs =
> case span isAlpha cs of
> ("let",rest) -> cont TokenLet rest
> ("in",rest) -> cont TokenIn rest
> (var,rest) -> cont (TokenVar var) rest
> runCalc :: String -> Exp
> runCalc s = case calc s 1 of
> ParseOk e -> e
> ParseFail s -> error s
-----------------------------------------------------------------------------
The following functions should be defined for all parsers.
This is the overall type of the parser.
> calc :: P Exp
The next function is called when a parse error is detected. It has
the same type as the top-level parse function.
> happyError :: P a
> happyError = \s i -> error (
> "Parse error in line " ++ show (i::Int) ++ "\n")
-----------------------------------------------------------------------------
Here we test our parser.
> main = case runCalc "1 + 2 + 3" of {
> (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) ->
> case runCalc "1 * 2 + 3" of {
> (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) ->
> case runCalc "1 + 2 * 3" of {
> (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) ->
> case runCalc "let x = 2 in x * (x - 2)" of {
> (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n";
> _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit }
> quit = print "Test failed\n"
> }