1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
-----------------------------------------------------------------------------
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 }
> | error { Term (Factor (Int 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.
> type Parse = P Exp
> calc :: Parse
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 "+ 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 }
> quit = print "Test failed\n"
> }
|
