summaryrefslogtreecommitdiff
path: root/parser.hs
blob: 6d8ed6dcc13df0dc2bfae16c6b2b48b8d0d2db93 (plain)
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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
module Parser (parseExpression) where

import Control.Applicative
import Control.Monad
import Data.Char
import Data.Maybe

import AST
import Utility


parseExpression :: String -> Either String AST
parseExpression s = case parse pexpression s of
    ((node,rest):_) -> case rest of
        "" -> Right node
        s -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'"
    _ -> Left "No valid parse"


newtype Parser a = Parser (String -> [(a,String)])

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

instance Functor Parser where
    fmap f p = Parser (\cs -> map (\(a,s) -> (f a,s)) $ parse p cs)

instance Applicative Parser where
    pure x = Parser (\cs -> [(x,cs)])
    (<*>) f p = Parser (\cs -> concat $
        map (\(a,s) -> parse (fmap a p) s) $ parse f cs)

instance Monad Parser where
    p >>= f = Parser (\cs -> concat $
        map (\(a,s) -> parse (f a) s) $ parse p cs)

instance Alternative Parser where
    empty = Parser (\_ -> [])
    (<|>) p q = Parser (\cs -> parse p cs ++ parse q cs)

instance MonadPlus Parser


--The deterministic choice operator: choose the first possibile parse (if
--available at all) from the results given by the two parsers.
--mplus is the non-deterministic choice operator; it would give all results.
mplus1 :: Parser a -> Parser a -> Parser a
mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of
    [] -> []
    (x:_) -> [x]

--(++) = mplus
(+++) = mplus1


pitem :: Parser Char
pitem = Parser $ \s -> case s of
    "" -> []
    (c:cs) -> [(c,cs)]

psat :: (Char -> Bool) -> Parser Char
psat f = do
    c <- pitem
    if f c then return c else mzero

--checks that the next char satisfies the predicate; does NOT consume characters
passert :: (Char -> Bool) -> Parser ()
passert p = Parser $ \s -> case s of
    "" -> []
    (c:_) -> if p c then [((),s)] else []

pchar :: Char -> Parser Char
pchar c = psat (==c)

pstring :: String -> Parser String
pstring "" = return ""
pstring (c:cs) = do
    pchar c
    pstring cs
    return (c:cs)

pmany :: Parser a -> Parser [a]
pmany p = pmany1 p +++ return []

pmany1 :: Parser a -> Parser [a]
pmany1 p = do
    a <- p
    as <- pmany p
    return (a:as)

pinteger :: Parser Int
pinteger = do
    s <- pmany $ psat isDigit
    return $ read s

pdouble :: Parser Double
pdouble = Parser reads

pquotstring :: Parser String
pquotstring = Parser reads

poptws :: Parser String
poptws = Parser $ pure . span isSpace

pws :: Parser String
pws = Parser $ \s -> case span isSpace s of
    ("",_) -> []
    tup@(_,_) -> [tup]

pword :: Parser String
pword = do
    c <- psat $ options [isAlpha,(=='_')]
    cs <- pmany $ psat $ options [isAlpha,isDigit,(=='_')]
    return (c:cs)


pnumber :: Parser AST
pnumber = liftM Number pdouble

pvariable :: Parser AST
pvariable = liftM Variable $ pstring "PI" +++ (liftM pure (psat isAlpha))

pinfixoperator :: (Char,Char)  -- +/- symbols
               -> Parser AST  -- term parser
               -> ([AST] -> AST)  -- Sum constructor
               -> (AST -> AST)  -- Negative constructor
               -> Bool  -- whether the plus sign is optional
               -> Bool  -- whether a negative sign cannot follow after a term
               -> Parser AST  -- Resulting parser
pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do
    term <- pterm
    pmoreterms term +++ return (sumconstr [term])
    where
        pmoreterms term = if plusopt
            then pmoretermsplus term +++ pmoretermsminus term +++ pmoretermsnothing term
            else pmoretermsplus term +++ pmoretermsminus term

        pmoretermsplus term = do
            poptws
            pchar plus
            poptws
            nextterm <- pterm
            let thissum = sumconstr [term,nextterm]
            pmoreterms thissum +++ return thissum
        pmoretermsminus term = do
            poptws
            pchar minus
            poptws
            nextterm <- pterm
            let thissum = sumconstr [term,negconstr nextterm]
            pmoreterms thissum +++ return thissum
        pmoretermsnothing term = do
            poptws
            if noneg then passert (/='-') else return ()
            nextterm <- pterm
            let thissum = sumconstr [term,nextterm]
            pmoreterms thissum +++ return thissum

psum :: Parser AST
psum = pinfixoperator ('+','-') pproduct Sum Negative False False

pproduct :: Parser AST
pproduct = pinfixoperator ('*','/') pfactor Product Reciprocal True True

pfactor :: Parser AST
pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm

pnegative :: Parser AST
pnegative = do {pchar '-'; poptws; f <- pfactor; return $ Negative f} +++ pfactornoneg

pfactornoneg :: Parser AST
pfactornoneg = do
    fact <- pnumber +++ pparenthetical +++ pfunctioncall +++ pvariable
    ppower fact +++ pfactorial fact +++ return fact
    where
        ppower fact = do
            poptws
            pchar '^'
            poptws
            fact2 <- pfactornoneg
            return $ Apply "pow" [fact,fact2]
        pfactorial fact = do
            poptws
            pchar '!'
            return $ Apply "fact" [fact]


pparenthetical :: Parser AST
pparenthetical = do
    pchar '('
    poptws
    sum <- psum
    poptws
    pchar ')'
    return sum

pfunctioncall :: Parser AST
pfunctioncall = do
    name <- pword
    poptws
    pchar '('
    poptws
    args <- parglist
    poptws
    pchar ')'
    return $ Apply name args
    where
        parglist = do
            arg <- parg
            poptws
            pmoreargs arg +++ return [arg]
        pmoreargs arg = do
            pchar ','
            poptws
            args <- parglist
            return (arg:args)
        parg = pexpression

pcapture :: Parser AST
pcapture = do
    pchar '['
    name <- pmany1 $ psat (/=']')
    pchar ']'
    return $ Capture name

pcaptureterm :: Parser AST
pcaptureterm = do
    pchar '['
    pchar '['
    name <- pmany1 $ psat (/=']')
    pchar ']'
    pchar ']'
    return $ CaptureTerm name

pexpression :: Parser AST
pexpression = psum