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
|
{-
An ambiguous grammar made unambiguous using associativity and
precedences.
frown PrecExpr.g
Try
fmap unparse $ expr (lexer "a+b+c+d") :: Maybe String
fmap unparse $ expr (lexer "a+b*c+d") :: Maybe String
fmap unparse $ expr (lexer "a+b*c*d") :: Maybe String
fmap unparse $ expr (lexer "a+b+-c+d") :: Maybe String
fmap unparse $ expr (lexer "a+-b*c+d") :: Maybe String
-}
module PrecExpr
where
import Char
import Monad
data Expr = Id String
| Negate Expr
| Plus Expr Expr
| Minus Expr Expr
| Times Expr Expr
| Divide Expr Expr
deriving (Show)
unparse (Id s) = s
unparse (Negate e) = "(" ++ "-" ++ unparse e ++ ")"
unparse (Plus e1 e2) = "(" ++ unparse e1 ++ "+" ++ unparse e2 ++ ")"
unparse (Minus e1 e2) = "(" ++ unparse e1 ++ "-" ++ unparse e2 ++ ")"
unparse (Times e1 e2) = "(" ++ unparse e1 ++ "*" ++ unparse e2 ++ ")"
unparse (Divide e1 e2) = "(" ++ unparse e1 ++ "/" ++ unparse e2 ++ ")"
type Result = Maybe
%{
Terminal = IDENT {String}
| left 6 PLUS
| left 6 MINUS
| left 7 TIMES
| left 7 DIVIDE
| nonassoc 8 NEGATE
| LPAR
| RPAR;
Nonterminal = *expr {Expr};
expr {Negate e} : MINUS, expr {e}, prec NEGATE;
{Plus e1 e2} | expr {e1}, PLUS, expr {e2};
{Minus e1 e2} | expr {e1}, MINUS, expr {e2};
{Times e1 e2} | expr {e1}, TIMES, expr {e2};
{Divide e1 e2} | expr {e1}, DIVIDE, expr {e2};
{e} | LPAR, expr {e}, RPAR;
{Id s} | IDENT {s};
}%
frown ts = fail "syntax error"
data Terminal = IDENT String | PLUS | MINUS | TIMES | DIVIDE | LPAR | RPAR
lexer :: String -> [Terminal]
lexer [] = []
lexer ('+' : cs) = PLUS : lexer cs
lexer ('-' : cs) = MINUS : lexer cs
lexer ('*' : cs) = TIMES : lexer cs
lexer ('/' : cs) = DIVIDE : lexer cs
lexer ('(' : cs) = LPAR : lexer cs
lexer (')' : cs) = RPAR : lexer cs
lexer (c : cs)
| isAlpha c = let (n, cs') = span isAlphaNum cs
in IDENT (c : n) : lexer cs'
| otherwise = lexer cs
|
