@@ -0,0 +1,223 @@
1+{-
2+ Simple monadic parser module, based heavily on that by
3+ Graham Hutton.
4+-}
5+
6+module SimpleParser
7+
8+import Prelude
9+import Prelude.Monad
10+import Prelude.Applicative
11+import Prelude.List
12+import Builtins
13+
14+%access public
15+
16+infixr 5 |||
17+
18+{-
19+The monad of parsers
20+--------------------
21+-}
22+
23+data Parser a = P (String -> Either String (a, String))
24+
25+parse : Parser a -> String -> Either String (a, String)
26+parse (P p) inp = p inp
27+
28+instance Functor Parser where
29+ -- fmap : (a -> b) -> f a -> f b
30+ -- fmap : (a -> b) -> Parser a -> Parser b
31+ -- Given a function (a -> b), and a parser a, make a parser b
32+ fmap f p = P (\inp => case parse p inp of
33+ (Left err) => Left err
34+ -- Apply f to the v that we got from parsing
35+ (Right (v, rest)) => Right ((f v), rest))
36+
37+
38+instance Applicative Parser where
39+ pure v = P (\inp => Right (v, inp))
40+ -- Parse to get the function, then parse to get the first argument
41+ a <$> b = P (\inp => do (f, rest) <- parse a inp
42+ (x, rest') <- parse b rest
43+ pure ((f x), rest'))
44+
45+instance Monad Parser where
46+-- pure v = P (\inp => Right (v,inp))
47+ -- m a -> (a -> m b) -> m b
48+ p >>= f = P (\inp => case parse p inp of
49+ (Left err) => Left err
50+ (Right (v,rest)) => parse (f v) rest)
51+
52+--mplus : Monad m => m a -> m a -> m a
53+mplus : Parser a -> Parser a -> Parser a
54+mplus p q = P (\inp => case parse p inp of
55+ Left msg => parse q inp
56+ Right (v,out) => Right(v,out))
57+
58+
59+{-
60+Basic parsers
61+-------------
62+-}
63+
64+failure : String -> Parser a
65+failure msg = P (\inp => Left msg)
66+
67+item : Parser Char
68+item = P (\inp => case unpack inp of
69+ [] => Left "Error! Parsing empty list."
70+ (x::xs) => Right (x, pack xs))
71+
72+
73+{-
74+Choice
75+--------
76+---}
77+
78+(|||) : Parser a -> Parser a -> Parser a
79+p ||| q = p `mplus` q
80+
81+
82+--{-
83+--Derived primitives
84+---}
85+
86+sat : (Char -> Bool) -> Parser Char
87+sat p = item >>= (\x => if p x then pure x else failure "failed")
88+
89+oneof : List Char -> Parser Char
90+oneof xs = sat (\x => elem x xs)
91+
92+digit : Parser Char
93+digit = sat isDigit
94+
95+lower : Parser Char
96+lower = sat isLower
97+
98+upper : Parser Char
99+upper = sat isUpper
100+
101+letter : Parser Char
102+letter = sat isAlpha
103+
104+alphanum : Parser Char
105+alphanum = sat isAlphaNum
106+
107+char : Char -> Parser Char
108+char x = sat (== x)
109+
110+helper : List Char -> Parser (List Char)
111+string : String -> Parser String
112+string s = do result <- helper (unpack s)
113+ pure (pack result)
114+
115+helper [] = pure Prelude.List.Nil
116+helper (x::xs) = do char x
117+ string (cast xs)
118+ pure (x :: xs)
119+
120+many : Parser a -> Parser (List a)
121+many1 : Parser a -> Parser (List a)
122+many1 p = do v <- p
123+ vs <- many p
124+ pure $ Prelude.List.(::) v vs
125+
126+
127+bool : Parser Bool
128+bool = parseTrue ||| parseFalse
129+ where parseTrue : Parser Bool
130+ parseTrue = do oneof ['T', 't']
131+ string "rue"
132+ pure True
133+ parseFalse = do oneof ['F', 'f']
134+ string "alse"
135+ pure False
136+
137+
138+
139+
140+many p = many1 p `mplus` pure Prelude.List.Nil
141+
142+
143+
144+ident : Parser String
145+ident = do x <- letter
146+ xs <- many1 alphanum
147+ pure (pack(x::xs))
148+
149+nat : Parser Int
150+nat = do xs <- many digit
151+ pure (cast (cast xs))
152+
153+
154+int : Parser Int
155+int = neg ||| nat
156+ where neg : Parser Int
157+ neg = do char '-'
158+ n <- nat
159+ pure (-n)
160+
161+space : Parser ()
162+space = do many (sat isSpace)
163+ pure ()
164+--{-
165+--Ignoring spacing
166+---}
167+
168+token : Parser a -> Parser a
169+token p = do space
170+ v <- p
171+ space
172+ pure v
173+
174+identifier : Parser String
175+identifier = token ident
176+
177+natural : Parser Int
178+natural = token nat
179+
180+integer : Parser Int
181+integer = token int
182+
183+symbol : String -> Parser String
184+symbol xs = token (string xs)
185+
186+strToken : Parser String
187+strToken = fmap pack (token (many1 alphanum))
188+
189+--apply : Parser a -> String -> List (a,String)
190+--apply p = parse (space >>= (\_ => p))
191+
192+--{-
193+-- Expressions
194+---}
195+
196+factor : Parser Int
197+term : Parser Int
198+expr : Parser Int
199+expr = do t <- term
200+ do symbol "+"
201+ e <- expr
202+ pure $ t + e
203+ `mplus` pure t
204+
205+
206+factor = do symbol "("
207+ do e <- expr
208+ symbol ")"
209+ pure e
210+ `mplus` natural
211+
212+term = do f <- factor
213+ do symbol "*"
214+ t <- term
215+ pure (f * t)
216+ `mplus` pure f
217+
218+
219+
220+eval : String -> Maybe Int
221+eval xs = case (parse expr xs) of
222+ Right (n,rest) => if rest == "" then Just n else Nothing
223+ Left msg => Nothing