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
|
{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}
-- Simple expression parser
-- (uses do-notation and operators)
module Main(main) where
import Control.Arrow
import Control.Category
import Data.Char
import Prelude hiding (id, (.))
-- Parsers
class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
symbol :: s -> a b String
data Sym s = Sym { token :: s, value :: String }
-- Simple backtracking instance
newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])
instance Category (BTParser s) where
id = BTParser $ \a ss -> [(a, ss)]
BTParser f . BTParser g = BTParser $ \b ss ->
[(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']
instance Arrow (BTParser s) where
arr f = BTParser $ \a ss -> [(f a, ss)]
first (BTParser f) = BTParser $ \(b,d) ss ->
[((c,d), ss') | (c,ss') <- f b ss]
instance ArrowZero (BTParser s) where
zeroArrow = BTParser $ \b ss -> []
instance ArrowPlus (BTParser s) where
BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss
instance (Eq s, Show s) => ArrowParser s (BTParser s) where
symbol s = BTParser $ \b ss ->
case ss of
Sym s' v:ss' | s' == s -> [(v, ss')]
_ -> []
runBTParser :: BTParser s () c -> [Sym s] -> c
runBTParser (BTParser parser) syms =
head [c | (c, []) <- parser () syms]
-- Expressions
data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
deriving (Show, Eq, Ord)
type ExprParser = BTParser ESym
type ExprSym = Sym ESym
-- The grammar
expr :: ExprParser () Int
expr = proc () -> do
x <- term -< ()
expr' -< x
expr' :: ExprParser Int Int
expr' = proc x -> do
returnA -< x
<+> do
(|(symbol Plus)|)
y <- term -< ()
expr' -< x + y
<+> do
(|(symbol Minus)|)
y <- term -< ()
expr' -< x - y
term :: ExprParser () Int
term = proc () -> do
x <- factor -< ()
term' -< x
term' :: ExprParser Int Int
term' = proc x -> do
returnA -< x
<+> do
(|(symbol Mult)|)
y <- factor -< ()
term' -< x * y
<+> do
(|(symbol Div)|)
y <- factor -< ()
term' -< x `div` y
factor :: ExprParser () Int
factor = proc () -> do
v <- (|(symbol Number)|)
returnA -< read v::Int
<+> do
(|(symbol Minus)|)
v <- factor -< ()
returnA -< -v
<+> do
(|(symbol LPar)|)
v <- expr -< ()
(|(symbol RPar)|)
returnA -< v
-- Lexical analysis
lexer :: String -> [ExprSym]
lexer [] = []
lexer ('(':cs) = Sym LPar "(":lexer cs
lexer (')':cs) = Sym RPar ")":lexer cs
lexer ('+':cs) = Sym Plus "+":lexer cs
lexer ('-':cs) = Sym Minus "-":lexer cs
lexer ('*':cs) = Sym Mult "*":lexer cs
lexer ('/':cs) = Sym Div "/":lexer cs
lexer (c:cs)
| isSpace c = lexer cs
| isDigit c = Sym Number (c:w):lexer cs'
| otherwise = Sym Unknown [c]:lexer cs
where (w,cs') = span isDigit cs
parse = runBTParser expr . lexer
main = do
print (parse "1+2*(3+4)")
print (parse "3*5-17/3+4")
|
