1 {-# LANGUAGE CPP, NoImplicitPrelude #-}
3 {-# LANGUAGE Rank2Types #-}
5 #ifdef __GLASGOW_HASKELL__
6 {-# LANGUAGE MagicHash #-}
9 -----------------------------------------------------------------------------
11 -- Module : Text.ParserCombinators.ReadP
12 -- Copyright : (c) The University of Glasgow 2002
13 -- License : BSD-style (see the file libraries/base/LICENSE)
15 -- Maintainer : libraries@haskell.org
16 -- Stability : provisional
17 -- Portability : non-portable (local universal quantification)
19 -- This is a library of parser combinators, originally written by Koen Claessen.
20 -- It parses all alternatives in parallel, so it never keeps hold of
21 -- the beginning of the input string, a common source of space leaks with
22 -- other parsers. The '(+++)' choice combinator is genuinely commutative;
23 -- it makes no difference which branch is \"shorter\".
25 -----------------------------------------------------------------------------
27 module Text.ParserCombinators.ReadP
31 ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
33 ReadPN, -- :: * -> * -> *; instance Functor, Monad, MonadPlus
36 -- * Primitive operations
38 look, -- :: ReadP String
39 (+++), -- :: ReadP a -> ReadP a -> ReadP a
40 (<++), -- :: ReadP a -> ReadP a -> ReadP a
41 gather, -- :: ReadP a -> ReadP (String, a)
46 satisfy, -- :: (Char -> Bool) -> ReadP Char
47 char, -- :: Char -> ReadP Char
48 string, -- :: String -> ReadP String
49 munch, -- :: (Char -> Bool) -> ReadP String
50 munch1, -- :: (Char -> Bool) -> ReadP String
51 skipSpaces, -- :: ReadP ()
52 choice, -- :: [ReadP a] -> ReadP a
53 count, -- :: Int -> ReadP a -> ReadP [a]
54 between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
55 option, -- :: a -> ReadP a -> ReadP a
56 optional, -- :: ReadP a -> ReadP ()
57 many, -- :: ReadP a -> ReadP [a]
58 many1, -- :: ReadP a -> ReadP [a]
59 skipMany, -- :: ReadP a -> ReadP ()
60 skipMany1, -- :: ReadP a -> ReadP ()
61 sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
62 sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
63 endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
64 endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
65 chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
66 chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
67 chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
68 chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
69 manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
72 ReadS, -- :: *; = String -> [(a,String)]
73 readP_to_S, -- :: ReadP a -> ReadS a
74 readS_to_P, -- :: ReadS a -> ReadP a
81 import Control.Monad( MonadPlus(..), sequence, liftM2 )
83 #ifdef __GLASGOW_HASKELL__
85 import {-# SOURCE #-} GHC.Unicode ( isSpace )
87 import GHC.List ( replicate, null )
90 import Data.Char( isSpace )
95 #ifdef __GLASGOW_HASKELL__
96 ------------------------------------------------------------------------
99 -- | A parser for a type @a@, represented as a function that takes a
100 -- 'String' and returns a list of possible parses as @(a,'String')@ pairs.
102 -- Note that this kind of backtracking parser is very inefficient;
103 -- reading a large structure may be quite slow (cf 'ReadP').
104 type ReadS a = String -> [(a,String)]
107 -- ---------------------------------------------------------------------------
109 -- is representation type -- should be kept abstract
113 | Look (String -> P a)
116 | Final [(a,String)] -- invariant: list is non-empty!
120 instance Monad P where
121 return x = Result x Fail
123 (Get f) >>= k = Get (\c -> f c >>= k)
124 (Look f) >>= k = Look (\s -> f s >>= k)
126 (Result x p) >>= k = k x `mplus` (p >>= k)
127 (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
131 instance MonadPlus P where
134 -- most common case: two gets are combined
135 Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
137 -- results are delivered as soon as possible
138 Result x p `mplus` q = Result x (p `mplus` q)
139 p `mplus` Result x q = Result x (p `mplus` q)
145 -- two finals are combined
146 -- final + look becomes one look and one final (=optimization)
147 -- final + sthg else becomes one look and one final
148 Final r `mplus` Final t = Final (r ++ t)
149 Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
150 Final r `mplus` p = Look (\s -> Final (r ++ run p s))
151 Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
152 p `mplus` Final r = Look (\s -> Final (run p s ++ r))
154 -- two looks are combined (=optimization)
155 -- look + sthg else floats upwards
156 Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
157 Look f `mplus` p = Look (\s -> f s `mplus` p)
158 p `mplus` Look f = Look (\s -> p `mplus` f s)
160 -- ---------------------------------------------------------------------------
164 newtype ReadP a = R (forall b . (a -> P b) -> P b)
166 #define ReadP (ReadPN b)
167 newtype ReadPN b a = R ((a -> P b) -> P b)
170 -- Functor, Monad, MonadPlus
172 instance Functor ReadP where
173 fmap h (R f) = R (\k -> f (k . h))
175 instance Monad ReadP where
176 return x = R (\k -> k x)
177 fail _ = R (\_ -> Fail)
178 R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
180 instance MonadPlus ReadP where
184 -- ---------------------------------------------------------------------------
187 final :: [(a,String)] -> P a
188 -- Maintains invariant for Final constructor
192 run :: P a -> ReadS a
193 run (Get f) (c:s) = run (f c) s
194 run (Look f) s = run (f s) s
195 run (Result x p) s = (x,s) : run p s
199 -- ---------------------------------------------------------------------------
200 -- Operations over ReadP
203 -- ^ Consumes and returns the next character.
204 -- Fails if there is no input left.
208 -- ^ Look-ahead: returns the part of the input that is left, without
214 pfail = R (\_ -> Fail)
216 (+++) :: ReadP a -> ReadP a -> ReadP a
217 -- ^ Symmetric choice.
218 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
221 (<++) :: ReadP a -> ReadP a -> ReadP a
223 (<++) :: ReadPN a a -> ReadPN a a -> ReadPN a a
225 -- ^ Local, exclusive, left-biased choice: If left parser
226 -- locally produces any result at all, then right parser is
228 #ifdef __GLASGOW_HASKELL__
231 probe (f0 return) s 0#
233 probe (Get f) (c:s) n = probe (f c) s (n+#1#)
234 probe (Look f) s n = probe (f s) s n
235 probe p@(Result _ _) _ n = discard n >> R (p >>=)
236 probe (Final r) _ _ = R (Final r >>=)
239 discard 0# = return ()
240 discard n = get >> discard (n-#1#)
246 probe (Get f) (c:s) n = probe (f c) s (n+1)
247 probe (Look f) s n = probe (f s) s n
248 probe p@(Result _ _) _ n = discard n >> R (p >>=)
249 probe (Final r) _ _ = R (Final r >>=)
252 discard 0 = return ()
253 discard n = get >> discard (n-1)
257 gather :: ReadP a -> ReadP (String, a)
259 -- gather :: ReadPN (String->P b) a -> ReadPN (String->P b) (String, a)
261 -- ^ Transforms a parser into one that does the same, but
262 -- in addition returns the exact characters read.
263 -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
264 -- is built using any occurrences of readS_to_P.
266 = R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
268 gath :: (String -> String) -> P (String -> P b) -> P b
269 gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
271 gath l (Look f) = Look (\s -> gath l (f s))
272 gath l (Result k p) = k (l []) `mplus` gath l p
273 gath _ (Final _) = error "do not use readS_to_P in gather!"
275 -- ---------------------------------------------------------------------------
276 -- Derived operations
278 satisfy :: (Char -> Bool) -> ReadP Char
279 -- ^ Consumes and returns the next character, if it satisfies the
280 -- specified predicate.
281 satisfy p = do c <- get; if p c then return c else pfail
283 char :: Char -> ReadP Char
284 -- ^ Parses and returns the specified character.
285 char c = satisfy (c ==)
288 -- ^ Succeeds iff we are at the end of input
290 ; if null s then return ()
293 string :: String -> ReadP String
294 -- ^ Parses and returns the specified string.
295 string this = do s <- look; scan this s
297 scan [] _ = do return this
298 scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys
301 munch :: (Char -> Bool) -> ReadP String
302 -- ^ Parses the first zero or more characters satisfying the predicate.
303 -- Always succeds, exactly once having consumed all the characters
304 -- Hence NOT the same as (many (satisfy p))
309 scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
310 scan _ = do return ""
312 munch1 :: (Char -> Bool) -> ReadP String
313 -- ^ Parses the first one or more characters satisfying the predicate.
314 -- Fails if none, else succeeds exactly once having consumed all the characters
315 -- Hence NOT the same as (many1 (satisfy p))
318 if p c then do s <- munch p; return (c:s)
321 choice :: [ReadP a] -> ReadP a
322 -- ^ Combines all parsers in the specified list.
325 choice (p:ps) = p +++ choice ps
327 skipSpaces :: ReadP ()
328 -- ^ Skips all whitespace.
333 skip (c:s) | isSpace c = do _ <- get; skip s
334 skip _ = do return ()
336 count :: Int -> ReadP a -> ReadP [a]
337 -- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of
338 -- results is returned.
339 count n p = sequence (replicate n p)
341 between :: ReadP open -> ReadP close -> ReadP a -> ReadP a
342 -- ^ @between open close p@ parses @open@, followed by @p@ and finally
343 -- @close@. Only the value of @p@ is returned.
344 between open close p = do _ <- open
349 option :: a -> ReadP a -> ReadP a
350 -- ^ @option x p@ will either parse @p@ or return @x@ without consuming
352 option x p = p +++ return x
354 optional :: ReadP a -> ReadP ()
355 -- ^ @optional p@ optionally parses @p@ and always returns @()@.
356 optional p = (p >> return ()) +++ return ()
358 many :: ReadP a -> ReadP [a]
359 -- ^ Parses zero or more occurrences of the given parser.
360 many p = return [] +++ many1 p
362 many1 :: ReadP a -> ReadP [a]
363 -- ^ Parses one or more occurrences of the given parser.
364 many1 p = liftM2 (:) p (many p)
366 skipMany :: ReadP a -> ReadP ()
367 -- ^ Like 'many', but discards the result.
368 skipMany p = many p >> return ()
370 skipMany1 :: ReadP a -> ReadP ()
371 -- ^ Like 'many1', but discards the result.
372 skipMany1 p = p >> skipMany p
374 sepBy :: ReadP a -> ReadP sep -> ReadP [a]
375 -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
376 -- Returns a list of values returned by @p@.
377 sepBy p sep = sepBy1 p sep +++ return []
379 sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]
380 -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
381 -- Returns a list of values returned by @p@.
382 sepBy1 p sep = liftM2 (:) p (many (sep >> p))
384 endBy :: ReadP a -> ReadP sep -> ReadP [a]
385 -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
387 endBy p sep = many (do x <- p ; _ <- sep ; return x)
389 endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
390 -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
392 endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
394 chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
395 -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
396 -- Returns a value produced by a /right/ associative application of all
397 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
399 chainr p op x = chainr1 p op +++ return x
401 chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
402 -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
403 -- Returns a value produced by a /left/ associative application of all
404 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
406 chainl p op x = chainl1 p op +++ return x
408 chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
409 -- ^ Like 'chainr', but parses one or more occurrences of @p@.
411 where scan = p >>= rest
417 chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
418 -- ^ Like 'chainl', but parses one or more occurrences of @p@.
419 chainl1 p op = p >>= rest
420 where rest x = do f <- op
426 manyTill :: ReadP a -> ReadP end -> ReadP [a]
428 manyTill :: ReadPN [a] a -> ReadPN [a] end -> ReadPN [a] [a]
430 -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
431 -- succeeds. Returns a list of values returned by @p@.
432 manyTill p end = scan
433 where scan = (end >> return []) <++ (liftM2 (:) p scan)
435 -- ---------------------------------------------------------------------------
436 -- Converting between ReadP and Read
439 readP_to_S :: ReadP a -> ReadS a
441 readP_to_S :: ReadPN a a -> ReadS a
443 -- ^ Converts a parser into a Haskell ReadS-style function.
444 -- This is the main way in which you can \"run\" a 'ReadP' parser:
445 -- the expanded type is
446 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
447 readP_to_S (R f) = run (f return)
449 readS_to_P :: ReadS a -> ReadP a
450 -- ^ Converts a Haskell ReadS-style function into a parser.
451 -- Warning: This introduces local backtracking in the resulting
452 -- parser, and therefore a possible inefficiency.
454 R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
456 -- ---------------------------------------------------------------------------
457 -- QuickCheck properties that hold for the combinators
460 The following are QuickCheck specifications of what the combinators do.
461 These can be seen as formal specifications of the behavior of the
464 We use bags to give semantics to the combinators.
468 Equality on bags does not care about the order of elements.
470 > (=~) :: Ord a => Bag a -> Bag a -> Bool
471 > xs =~ ys = sort xs == sort ys
473 A special equality operator to avoid unresolved overloading
474 when testing the properties.
476 > (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
479 Here follow the properties:
482 > readP_to_S get [] =~ []
484 > prop_Get_Cons c s =
485 > readP_to_S get (c:s) =~ [(c,s)]
488 > readP_to_S look s =~ [(s,s)]
491 > readP_to_S pfail s =~. []
494 > readP_to_S (return x) s =~. [(x,s)]
497 > readP_to_S (p >>= k) s =~.
499 > | (x,s') <- readP_to_S p s
500 > , ys'' <- readP_to_S (k (x::Int)) s'
504 > readP_to_S (p +++ q) s =~.
505 > (readP_to_S p s ++ readP_to_S q s)
507 > prop_LeftPlus p q s =
508 > readP_to_S (p <++ q) s =~.
509 > (readP_to_S p s +<+ readP_to_S q s)
515 > forAll readPWithoutReadS $ \p ->
516 > readP_to_S (gather p) s =~
517 > [ ((pre,x::Int),s')
518 > | (x,s') <- readP_to_S p s
519 > , let pre = take (length s - length s') s
522 > prop_String_Yes this s =
523 > readP_to_S (string this) (this ++ s) =~
526 > prop_String_Maybe this s =
527 > readP_to_S (string this) s =~
528 > [(this, drop (length this) s) | this `isPrefixOf` s]
531 > readP_to_S (munch p) s =~
532 > [(takeWhile p s, dropWhile p s)]
535 > readP_to_S (munch1 p) s =~
536 > [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
539 > readP_to_S (choice ps) s =~.
540 > readP_to_S (foldr (+++) pfail ps) s
543 > readP_to_S (readS_to_P r) s =~. r s