Make Applicative a superclass of Monad
[ghc.git] / libraries / base / Text / ParserCombinators / ReadP.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE NoImplicitPrelude #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE MagicHash #-}
5 {-# LANGUAGE DeriveFunctor #-}
6
7 -----------------------------------------------------------------------------
8 -- |
9 -- Module : Text.ParserCombinators.ReadP
10 -- Copyright : (c) The University of Glasgow 2002
11 -- License : BSD-style (see the file libraries/base/LICENSE)
12 --
13 -- Maintainer : libraries@haskell.org
14 -- Stability : provisional
15 -- Portability : non-portable (local universal quantification)
16 --
17 -- This is a library of parser combinators, originally written by Koen Claessen.
18 -- It parses all alternatives in parallel, so it never keeps hold of
19 -- the beginning of the input string, a common source of space leaks with
20 -- other parsers. The '(+++)' choice combinator is genuinely commutative;
21 -- it makes no difference which branch is \"shorter\".
22
23 -----------------------------------------------------------------------------
24
25 module Text.ParserCombinators.ReadP
26 (
27 -- * The 'ReadP' type
28 ReadP,
29
30 -- * Primitive operations
31 get,
32 look,
33 (+++),
34 (<++),
35 gather,
36
37 -- * Other operations
38 pfail,
39 eof,
40 satisfy,
41 char,
42 string,
43 munch,
44 munch1,
45 skipSpaces,
46 choice,
47 count,
48 between,
49 option,
50 optional,
51 many,
52 many1,
53 skipMany,
54 skipMany1,
55 sepBy,
56 sepBy1,
57 endBy,
58 endBy1,
59 chainr,
60 chainl,
61 chainl1,
62 chainr1,
63 manyTill,
64
65 -- * Running a parser
66 ReadS,
67 readP_to_S,
68 readS_to_P,
69
70 -- * Properties
71 -- $properties
72 )
73 where
74
75 import Control.Monad ( Alternative(empty, (<|>)), MonadPlus(..), sequence )
76 import {-# SOURCE #-} GHC.Unicode ( isSpace )
77 import GHC.List ( replicate, null )
78 import GHC.Base
79
80 infixr 5 +++, <++
81
82 ------------------------------------------------------------------------
83 -- ReadS
84
85 -- | A parser for a type @a@, represented as a function that takes a
86 -- 'String' and returns a list of possible parses as @(a,'String')@ pairs.
87 --
88 -- Note that this kind of backtracking parser is very inefficient;
89 -- reading a large structure may be quite slow (cf 'ReadP').
90 type ReadS a = String -> [(a,String)]
91
92 -- ---------------------------------------------------------------------------
93 -- The P type
94 -- is representation type -- should be kept abstract
95
96 data P a
97 = Get (Char -> P a)
98 | Look (String -> P a)
99 | Fail
100 | Result a (P a)
101 | Final [(a,String)] -- invariant: list is non-empty!
102 deriving Functor
103
104 -- Monad, MonadPlus
105
106 instance Applicative P where
107 pure = return
108 (<*>) = ap
109
110 instance MonadPlus P where
111 mzero = empty
112 mplus = (<|>)
113
114 instance Monad P where
115 return x = Result x Fail
116
117 (Get f) >>= k = Get (\c -> f c >>= k)
118 (Look f) >>= k = Look (\s -> f s >>= k)
119 Fail >>= _ = Fail
120 (Result x p) >>= k = k x <|> (p >>= k)
121 (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
122
123 fail _ = Fail
124
125 instance Alternative P where
126 empty = Fail
127
128 -- most common case: two gets are combined
129 Get f1 <|> Get f2 = Get (\c -> f1 c <|> f2 c)
130
131 -- results are delivered as soon as possible
132 Result x p <|> q = Result x (p <|> q)
133 p <|> Result x q = Result x (p <|> q)
134
135 -- fail disappears
136 Fail <|> p = p
137 p <|> Fail = p
138
139 -- two finals are combined
140 -- final + look becomes one look and one final (=optimization)
141 -- final + sthg else becomes one look and one final
142 Final r <|> Final t = Final (r ++ t)
143 Final r <|> Look f = Look (\s -> Final (r ++ run (f s) s))
144 Final r <|> p = Look (\s -> Final (r ++ run p s))
145 Look f <|> Final r = Look (\s -> Final (run (f s) s ++ r))
146 p <|> Final r = Look (\s -> Final (run p s ++ r))
147
148 -- two looks are combined (=optimization)
149 -- look + sthg else floats upwards
150 Look f <|> Look g = Look (\s -> f s <|> g s)
151 Look f <|> p = Look (\s -> f s <|> p)
152 p <|> Look f = Look (\s -> p <|> f s)
153
154 -- ---------------------------------------------------------------------------
155 -- The ReadP type
156
157 newtype ReadP a = R (forall b . (a -> P b) -> P b)
158
159 -- Functor, Monad, MonadPlus
160
161 instance Functor ReadP where
162 fmap h (R f) = R (\k -> f (k . h))
163
164 instance Applicative ReadP where
165 pure = return
166 (<*>) = ap
167
168 instance Monad ReadP where
169 return x = R (\k -> k x)
170 fail _ = R (\_ -> Fail)
171 R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
172
173 instance Alternative ReadP where
174 empty = mzero
175 (<|>) = mplus
176
177 instance MonadPlus ReadP where
178 mzero = pfail
179 mplus = (+++)
180
181 -- ---------------------------------------------------------------------------
182 -- Operations over P
183
184 final :: [(a,String)] -> P a
185 -- Maintains invariant for Final constructor
186 final [] = Fail
187 final r = Final r
188
189 run :: P a -> ReadS a
190 run (Get f) (c:s) = run (f c) s
191 run (Look f) s = run (f s) s
192 run (Result x p) s = (x,s) : run p s
193 run (Final r) _ = r
194 run _ _ = []
195
196 -- ---------------------------------------------------------------------------
197 -- Operations over ReadP
198
199 get :: ReadP Char
200 -- ^ Consumes and returns the next character.
201 -- Fails if there is no input left.
202 get = R Get
203
204 look :: ReadP String
205 -- ^ Look-ahead: returns the part of the input that is left, without
206 -- consuming it.
207 look = R Look
208
209 pfail :: ReadP a
210 -- ^ Always fails.
211 pfail = R (\_ -> Fail)
212
213 (+++) :: ReadP a -> ReadP a -> ReadP a
214 -- ^ Symmetric choice.
215 R f1 +++ R f2 = R (\k -> f1 k <|> f2 k)
216
217 (<++) :: ReadP a -> ReadP a -> ReadP a
218 -- ^ Local, exclusive, left-biased choice: If left parser
219 -- locally produces any result at all, then right parser is
220 -- not used.
221 R f0 <++ q =
222 do s <- look
223 probe (f0 return) s 0#
224 where
225 probe (Get f) (c:s) n = probe (f c) s (n+#1#)
226 probe (Look f) s n = probe (f s) s n
227 probe p@(Result _ _) _ n = discard n >> R (p >>=)
228 probe (Final r) _ _ = R (Final r >>=)
229 probe _ _ _ = q
230
231 discard 0# = return ()
232 discard n = get >> discard (n-#1#)
233
234 gather :: ReadP a -> ReadP (String, a)
235 -- ^ Transforms a parser into one that does the same, but
236 -- in addition returns the exact characters read.
237 -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
238 -- is built using any occurrences of readS_to_P.
239 gather (R m)
240 = R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
241 where
242 gath :: (String -> String) -> P (String -> P b) -> P b
243 gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
244 gath _ Fail = Fail
245 gath l (Look f) = Look (\s -> gath l (f s))
246 gath l (Result k p) = k (l []) <|> gath l p
247 gath _ (Final _) = error "do not use readS_to_P in gather!"
248
249 -- ---------------------------------------------------------------------------
250 -- Derived operations
251
252 satisfy :: (Char -> Bool) -> ReadP Char
253 -- ^ Consumes and returns the next character, if it satisfies the
254 -- specified predicate.
255 satisfy p = do c <- get; if p c then return c else pfail
256
257 char :: Char -> ReadP Char
258 -- ^ Parses and returns the specified character.
259 char c = satisfy (c ==)
260
261 eof :: ReadP ()
262 -- ^ Succeeds iff we are at the end of input
263 eof = do { s <- look
264 ; if null s then return ()
265 else pfail }
266
267 string :: String -> ReadP String
268 -- ^ Parses and returns the specified string.
269 string this = do s <- look; scan this s
270 where
271 scan [] _ = do return this
272 scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys
273 scan _ _ = do pfail
274
275 munch :: (Char -> Bool) -> ReadP String
276 -- ^ Parses the first zero or more characters satisfying the predicate.
277 -- Always succeds, exactly once having consumed all the characters
278 -- Hence NOT the same as (many (satisfy p))
279 munch p =
280 do s <- look
281 scan s
282 where
283 scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
284 scan _ = do return ""
285
286 munch1 :: (Char -> Bool) -> ReadP String
287 -- ^ Parses the first one or more characters satisfying the predicate.
288 -- Fails if none, else succeeds exactly once having consumed all the characters
289 -- Hence NOT the same as (many1 (satisfy p))
290 munch1 p =
291 do c <- get
292 if p c then do s <- munch p; return (c:s)
293 else pfail
294
295 choice :: [ReadP a] -> ReadP a
296 -- ^ Combines all parsers in the specified list.
297 choice [] = pfail
298 choice [p] = p
299 choice (p:ps) = p +++ choice ps
300
301 skipSpaces :: ReadP ()
302 -- ^ Skips all whitespace.
303 skipSpaces =
304 do s <- look
305 skip s
306 where
307 skip (c:s) | isSpace c = do _ <- get; skip s
308 skip _ = do return ()
309
310 count :: Int -> ReadP a -> ReadP [a]
311 -- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of
312 -- results is returned.
313 count n p = sequence (replicate n p)
314
315 between :: ReadP open -> ReadP close -> ReadP a -> ReadP a
316 -- ^ @between open close p@ parses @open@, followed by @p@ and finally
317 -- @close@. Only the value of @p@ is returned.
318 between open close p = do _ <- open
319 x <- p
320 _ <- close
321 return x
322
323 option :: a -> ReadP a -> ReadP a
324 -- ^ @option x p@ will either parse @p@ or return @x@ without consuming
325 -- any input.
326 option x p = p +++ return x
327
328 optional :: ReadP a -> ReadP ()
329 -- ^ @optional p@ optionally parses @p@ and always returns @()@.
330 optional p = (p >> return ()) +++ return ()
331
332 many :: ReadP a -> ReadP [a]
333 -- ^ Parses zero or more occurrences of the given parser.
334 many p = return [] +++ many1 p
335
336 many1 :: ReadP a -> ReadP [a]
337 -- ^ Parses one or more occurrences of the given parser.
338 many1 p = liftM2 (:) p (many p)
339
340 skipMany :: ReadP a -> ReadP ()
341 -- ^ Like 'many', but discards the result.
342 skipMany p = many p >> return ()
343
344 skipMany1 :: ReadP a -> ReadP ()
345 -- ^ Like 'many1', but discards the result.
346 skipMany1 p = p >> skipMany p
347
348 sepBy :: ReadP a -> ReadP sep -> ReadP [a]
349 -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
350 -- Returns a list of values returned by @p@.
351 sepBy p sep = sepBy1 p sep +++ return []
352
353 sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]
354 -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
355 -- Returns a list of values returned by @p@.
356 sepBy1 p sep = liftM2 (:) p (many (sep >> p))
357
358 endBy :: ReadP a -> ReadP sep -> ReadP [a]
359 -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
360 -- by @sep@.
361 endBy p sep = many (do x <- p ; _ <- sep ; return x)
362
363 endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
364 -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
365 -- by @sep@.
366 endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
367
368 chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
369 -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
370 -- Returns a value produced by a /right/ associative application of all
371 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
372 -- returned.
373 chainr p op x = chainr1 p op +++ return x
374
375 chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
376 -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
377 -- Returns a value produced by a /left/ associative application of all
378 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
379 -- returned.
380 chainl p op x = chainl1 p op +++ return x
381
382 chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
383 -- ^ Like 'chainr', but parses one or more occurrences of @p@.
384 chainr1 p op = scan
385 where scan = p >>= rest
386 rest x = do f <- op
387 y <- scan
388 return (f x y)
389 +++ return x
390
391 chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
392 -- ^ Like 'chainl', but parses one or more occurrences of @p@.
393 chainl1 p op = p >>= rest
394 where rest x = do f <- op
395 y <- p
396 rest (f x y)
397 +++ return x
398
399 manyTill :: ReadP a -> ReadP end -> ReadP [a]
400 -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
401 -- succeeds. Returns a list of values returned by @p@.
402 manyTill p end = scan
403 where scan = (end >> return []) <++ (liftM2 (:) p scan)
404
405 -- ---------------------------------------------------------------------------
406 -- Converting between ReadP and Read
407
408 readP_to_S :: ReadP a -> ReadS a
409 -- ^ Converts a parser into a Haskell ReadS-style function.
410 -- This is the main way in which you can \"run\" a 'ReadP' parser:
411 -- the expanded type is
412 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
413 readP_to_S (R f) = run (f return)
414
415 readS_to_P :: ReadS a -> ReadP a
416 -- ^ Converts a Haskell ReadS-style function into a parser.
417 -- Warning: This introduces local backtracking in the resulting
418 -- parser, and therefore a possible inefficiency.
419 readS_to_P r =
420 R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
421
422 -- ---------------------------------------------------------------------------
423 -- QuickCheck properties that hold for the combinators
424
425 {- $properties
426 The following are QuickCheck specifications of what the combinators do.
427 These can be seen as formal specifications of the behavior of the
428 combinators.
429
430 We use bags to give semantics to the combinators.
431
432 > type Bag a = [a]
433
434 Equality on bags does not care about the order of elements.
435
436 > (=~) :: Ord a => Bag a -> Bag a -> Bool
437 > xs =~ ys = sort xs == sort ys
438
439 A special equality operator to avoid unresolved overloading
440 when testing the properties.
441
442 > (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
443 > (=~.) = (=~)
444
445 Here follow the properties:
446
447 > prop_Get_Nil =
448 > readP_to_S get [] =~ []
449 >
450 > prop_Get_Cons c s =
451 > readP_to_S get (c:s) =~ [(c,s)]
452 >
453 > prop_Look s =
454 > readP_to_S look s =~ [(s,s)]
455 >
456 > prop_Fail s =
457 > readP_to_S pfail s =~. []
458 >
459 > prop_Return x s =
460 > readP_to_S (return x) s =~. [(x,s)]
461 >
462 > prop_Bind p k s =
463 > readP_to_S (p >>= k) s =~.
464 > [ ys''
465 > | (x,s') <- readP_to_S p s
466 > , ys'' <- readP_to_S (k (x::Int)) s'
467 > ]
468 >
469 > prop_Plus p q s =
470 > readP_to_S (p +++ q) s =~.
471 > (readP_to_S p s ++ readP_to_S q s)
472 >
473 > prop_LeftPlus p q s =
474 > readP_to_S (p <++ q) s =~.
475 > (readP_to_S p s +<+ readP_to_S q s)
476 > where
477 > [] +<+ ys = ys
478 > xs +<+ _ = xs
479 >
480 > prop_Gather s =
481 > forAll readPWithoutReadS $ \p ->
482 > readP_to_S (gather p) s =~
483 > [ ((pre,x::Int),s')
484 > | (x,s') <- readP_to_S p s
485 > , let pre = take (length s - length s') s
486 > ]
487 >
488 > prop_String_Yes this s =
489 > readP_to_S (string this) (this ++ s) =~
490 > [(this,s)]
491 >
492 > prop_String_Maybe this s =
493 > readP_to_S (string this) s =~
494 > [(this, drop (length this) s) | this `isPrefixOf` s]
495 >
496 > prop_Munch p s =
497 > readP_to_S (munch p) s =~
498 > [(takeWhile p s, dropWhile p s)]
499 >
500 > prop_Munch1 p s =
501 > readP_to_S (munch1 p) s =~
502 > [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
503 >
504 > prop_Choice ps s =
505 > readP_to_S (choice ps) s =~.
506 > readP_to_S (foldr (+++) pfail ps) s
507 >
508 > prop_ReadS r s =
509 > readP_to_S (readS_to_P r) s =~. r s
510 -}
511