never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE GADTs #-}
3 -----------------------------------------------------------------------------
4 -- |
5 --
6 -- Module : Distribution.Deprecated.ReadP
7 -- Copyright : (c) The University of Glasgow 2002
8 -- License : BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer : libraries@haskell.org
11 -- Portability : portable
12 --
13 -- This is a library of parser combinators, originally written by Koen Claessen.
14 -- It parses all alternatives in parallel, so it never keeps hold of
15 -- the beginning of the input string, a common source of space leaks with
16 -- other parsers. The '(+++)' choice combinator is genuinely commutative;
17 -- it makes no difference which branch is \"shorter\".
18 --
19 -- See also Koen's paper /Parallel Parsing Processes/
20 -- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).
21 --
22 -- This version of ReadP has been locally hacked to make it H98, by
23 -- Martin Sjögren <mailto:msjogren@gmail.com>
24 --
25 -- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by
26 -- Mark Lentczner <mailto:mark@glyphic.com>
27 -----------------------------------------------------------------------------
28
29 module Distribution.Deprecated.ReadP
30 (
31 -- * The 'ReadP' type
32 ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
33
34 -- * Primitive operations
35 get, -- :: ReadP Char
36 look, -- :: ReadP String
37 (+++), -- :: ReadP a -> ReadP a -> ReadP a
38 (<++), -- :: ReadP a -> ReadP a -> ReadP a
39 gather, -- :: ReadP a -> ReadP (String, a)
40
41 -- * Other operations
42 pfail, -- :: ReadP a
43 eof, -- :: ReadP ()
44 satisfy, -- :: (Char -> Bool) -> ReadP Char
45 char, -- :: Char -> ReadP Char
46 string, -- :: String -> ReadP String
47 munch, -- :: (Char -> Bool) -> ReadP String
48 munch1, -- :: (Char -> Bool) -> ReadP String
49 skipSpaces, -- :: ReadP ()
50 skipSpaces1,-- :: ReadP ()
51 choice, -- :: [ReadP a] -> ReadP a
52 count, -- :: Int -> ReadP a -> ReadP [a]
53 between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
54 option, -- :: a -> ReadP a -> ReadP a
55 optional, -- :: ReadP a -> ReadP ()
56 many, -- :: ReadP a -> ReadP [a]
57 many1, -- :: ReadP a -> ReadP [a]
58 skipMany, -- :: ReadP a -> ReadP ()
59 skipMany1, -- :: ReadP a -> ReadP ()
60 sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
61 sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
62 endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
63 endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
64 chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
65 chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
66 chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
67 chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
68 manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
69
70 -- * Running a parser
71 ReadS, -- :: *; = String -> [(a,String)]
72 readP_to_S, -- :: ReadP a -> ReadS a
73 readS_to_P, -- :: ReadS a -> ReadP a
74 readP_to_E,
75
76 -- ** Internal
77 Parser,
78 )
79 where
80
81 import Prelude ()
82 import Distribution.Client.Compat.Prelude hiding (many, get)
83
84 import Control.Monad( replicateM, (>=>) )
85
86 import qualified Control.Monad.Fail as Fail
87
88 import Distribution.ReadE (ReadE (..))
89
90 infixr 5 +++, <++
91
92 -- ---------------------------------------------------------------------------
93 -- The P type
94 -- is representation type -- should be kept abstract
95
96 data P s a
97 = Get (s -> P s a)
98 | Look ([s] -> P s a)
99 | Fail
100 | Result a (P s a)
101 | Final [(a,[s])] -- invariant: list is non-empty!
102
103 -- Monad, MonadPlus
104
105 instance Functor (P s) where
106 fmap = liftM
107
108 instance Applicative (P s) where
109 pure x = Result x Fail
110 (<*>) = ap
111
112 instance Monad (P s) where
113 return = pure
114
115 (Get f) >>= k = Get (f >=> k)
116 (Look f) >>= k = Look (f >=> k)
117 Fail >>= _ = Fail
118 (Result x p) >>= k = k x `mplus` (p >>= k)
119 (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
120
121 #if !(MIN_VERSION_base(4,9,0))
122 fail _ = Fail
123 #elif !(MIN_VERSION_base(4,13,0))
124 fail = Fail.fail
125 #endif
126
127 instance Fail.MonadFail (P s) where
128 fail _ = Fail
129
130 instance Alternative (P s) where
131 empty = mzero
132 (<|>) = mplus
133
134 instance MonadPlus (P s) where
135 mzero = Fail
136
137 -- most common case: two gets are combined
138 Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
139
140 -- results are delivered as soon as possible
141 Result x p `mplus` q = Result x (p `mplus` q)
142 p `mplus` Result x q = Result x (p `mplus` q)
143
144 -- fail disappears
145 Fail `mplus` p = p
146 p `mplus` Fail = p
147
148 -- two finals are combined
149 -- final + look becomes one look and one final (=optimization)
150 -- final + sthg else becomes one look and one final
151 Final r `mplus` Final t = Final (r ++ t)
152 Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
153 Final r `mplus` p = Look (\s -> Final (r ++ run p s))
154 Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
155 p `mplus` Final r = Look (\s -> Final (run p s ++ r))
156
157 -- two looks are combined (=optimization)
158 -- look + sthg else floats upwards
159 Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
160 Look f `mplus` p = Look (\s -> f s `mplus` p)
161 p `mplus` Look f = Look (\s -> p `mplus` f s)
162
163 -- ---------------------------------------------------------------------------
164 -- The ReadP type
165
166 newtype Parser r s a = R ((a -> P s r) -> P s r)
167 type ReadP r a = Parser r Char a
168
169 -- Functor, Monad, MonadPlus
170
171 instance Functor (Parser r s) where
172 fmap h (R f) = R (\k -> f (k . h))
173
174 instance Applicative (Parser r s) where
175 pure x = R (\k -> k x)
176 (<*>) = ap
177
178 instance s ~ Char => Alternative (Parser r s) where
179 empty = pfail
180 (<|>) = (+++)
181
182 instance Monad (Parser r s) where
183 return = pure
184 R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
185
186 #if !(MIN_VERSION_base(4,9,0))
187 fail _ = R (const Fail)
188 #elif !(MIN_VERSION_base(4,13,0))
189 fail = Fail.fail
190 #endif
191
192 instance Fail.MonadFail (Parser r s) where
193 fail _ = R (const Fail)
194
195 instance s ~ Char => MonadPlus (Parser r s) where
196 mzero = pfail
197 mplus = (+++)
198
199 -- ---------------------------------------------------------------------------
200 -- Operations over P
201
202 final :: [(a,[s])] -> P s a
203 -- Maintains invariant for Final constructor
204 final [] = Fail
205 final r = Final r
206
207 run :: P c a -> ([c] -> [(a, [c])])
208 run (Get f) (c:s) = run (f c) s
209 run (Look f) s = run (f s) s
210 run (Result x p) s = (x,s) : run p s
211 run (Final r) _ = r
212 run _ _ = []
213
214 -- ---------------------------------------------------------------------------
215 -- Operations over ReadP
216
217 get :: ReadP r Char
218 -- ^ Consumes and returns the next character.
219 -- Fails if there is no input left.
220 get = R Get
221
222 look :: ReadP r String
223 -- ^ Look-ahead: returns the part of the input that is left, without
224 -- consuming it.
225 look = R Look
226
227 pfail :: ReadP r a
228 -- ^ Always fails.
229 pfail = R (const Fail)
230
231 eof :: ReadP r ()
232 -- ^ Succeeds iff we are at the end of input
233 eof = do { s <- look
234 ; if null s then return ()
235 else pfail }
236
237 (+++) :: ReadP r a -> ReadP r a -> ReadP r a
238 -- ^ Symmetric choice.
239 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
240
241 (<++) :: ReadP a a -> ReadP r a -> ReadP r a
242 -- ^ Local, exclusive, left-biased choice: If left parser
243 -- locally produces any result at all, then right parser is
244 -- not used.
245 R f <++ q =
246 do s <- look
247 probe (f return) s 0
248 where
249 probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)
250 probe (Look f') s n = probe (f' s) s n
251 probe p@(Result _ _) _ n = discard n >> R (p >>=)
252 probe (Final r) _ _ = R (Final r >>=)
253 probe _ _ _ = q
254
255 discard 0 = return ()
256 discard n = get >> discard (n-1 :: Int)
257
258 gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
259 -- ^ Transforms a parser into one that does the same, but
260 -- in addition returns the exact characters read.
261 -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
262 -- is built using any occurrences of readS_to_P.
263 gather (R m) =
264 R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
265 where
266 gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
267 gath _ Fail = Fail
268 gath l (Look f) = Look (gath l . f)
269 gath l (Result k p) = k (l []) `mplus` gath l p
270 gath _ (Final _) = error "do not use readS_to_P in gather!"
271
272 -- ---------------------------------------------------------------------------
273 -- Derived operations
274
275 satisfy :: (Char -> Bool) -> ReadP r Char
276 -- ^ Consumes and returns the next character, if it satisfies the
277 -- specified predicate.
278 satisfy p = do c <- get; if p c then return c else pfail
279
280 char :: Char -> ReadP r Char
281 -- ^ Parses and returns the specified character.
282 char c = satisfy (c ==)
283
284 string :: String -> ReadP r String
285 -- ^ Parses and returns the specified string.
286 string this = do s <- look; scan this s
287 where
288 scan [] _ = return this
289 scan (x:xs) (y:ys) | x == y = get >> scan xs ys
290 scan _ _ = pfail
291
292 munch :: (Char -> Bool) -> ReadP r String
293 -- ^ Parses the first zero or more characters satisfying the predicate.
294 munch p =
295 do s <- look
296 scan s
297 where
298 scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
299 scan _ = do return ""
300
301 munch1 :: (Char -> Bool) -> ReadP r String
302 -- ^ Parses the first one or more characters satisfying the predicate.
303 munch1 p =
304 do c <- get
305 if p c then do s <- munch p; return (c:s)
306 else pfail
307
308 choice :: [ReadP r a] -> ReadP r a
309 -- ^ Combines all parsers in the specified list.
310 choice [] = pfail
311 choice [p] = p
312 choice (p:ps) = p +++ choice ps
313
314 skipSpaces :: ReadP r ()
315 -- ^ Skips all whitespace.
316 skipSpaces =
317 do s <- look
318 skip s
319 where
320 skip (c:s) | isSpace c = do _ <- get; skip s
321 skip _ = do return ()
322
323 skipSpaces1 :: ReadP r ()
324 -- ^ Like 'skipSpaces' but succeeds only if there is at least one
325 -- whitespace character to skip.
326 skipSpaces1 = satisfy isSpace >> skipSpaces
327
328 count :: Int -> ReadP r a -> ReadP r [a]
329 -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
330 -- results is returned.
331 count n p = replicateM n p
332
333 between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
334 -- ^ @ between open close p @ parses @open@, followed by @p@ and finally
335 -- @close@. Only the value of @p@ is returned.
336 between open close p = do _ <- open
337 x <- p
338 _ <- close
339 return x
340
341 option :: a -> ReadP r a -> ReadP r a
342 -- ^ @option x p@ will either parse @p@ or return @x@ without consuming
343 -- any input.
344 option x p = p +++ return x
345
346 optional :: ReadP r a -> ReadP r ()
347 -- ^ @optional p@ optionally parses @p@ and always returns @()@.
348 optional p = (p >> return ()) +++ return ()
349
350 many :: ReadP r a -> ReadP r [a]
351 -- ^ Parses zero or more occurrences of the given parser.
352 many p = return [] +++ many1 p
353
354 many1 :: ReadP r a -> ReadP r [a]
355 -- ^ Parses one or more occurrences of the given parser.
356 many1 p = liftM2 (:) p (many p)
357
358 skipMany :: ReadP r a -> ReadP r ()
359 -- ^ Like 'many', but discards the result.
360 skipMany p = many p >> return ()
361
362 skipMany1 :: ReadP r a -> ReadP r ()
363 -- ^ Like 'many1', but discards the result.
364 skipMany1 p = p >> skipMany p
365
366 sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
367 -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
368 -- Returns a list of values returned by @p@.
369 sepBy p sep = sepBy1 p sep +++ return []
370
371 sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
372 -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
373 -- Returns a list of values returned by @p@.
374 sepBy1 p sep = liftM2 (:) p (many (sep >> p))
375
376 endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
377 -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
378 -- by @sep@.
379 endBy p sep = many (do x <- p ; _ <- sep ; return x)
380
381 endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
382 -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
383 -- by @sep@.
384 endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
385
386 chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
387 -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
388 -- Returns a value produced by a /right/ associative application of all
389 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
390 -- returned.
391 chainr p op x = chainr1 p op +++ return x
392
393 chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
394 -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
395 -- Returns a value produced by a /left/ associative application of all
396 -- functions returned by @op@. If there are no occurrences of @p@, @x@ is
397 -- returned.
398 chainl p op x = chainl1 p op +++ return x
399
400 chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
401 -- ^ Like 'chainr', but parses one or more occurrences of @p@.
402 chainr1 p op = scan
403 where scan = p >>= rest
404 rest x = do f <- op
405 y <- scan
406 return (f x y)
407 +++ return x
408
409 chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
410 -- ^ Like 'chainl', but parses one or more occurrences of @p@.
411 chainl1 p op = p >>= rest
412 where rest x = do f <- op
413 y <- p
414 rest (f x y)
415 +++ return x
416
417 manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
418 -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
419 -- succeeds. Returns a list of values returned by @p@.
420 manyTill p end = scan
421 where scan = (end >> return []) <++ (liftM2 (:) p scan)
422
423 -- ---------------------------------------------------------------------------
424 -- Converting between ReadP and Read
425
426 readP_to_S :: ReadP a a -> ReadS a
427 -- ^ Converts a parser into a Haskell ReadS-style function.
428 -- This is the main way in which you can \"run\" a 'ReadP' parser:
429 -- the expanded type is
430 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
431 readP_to_S (R f) = run (f return)
432
433 readS_to_P :: ReadS a -> ReadP r a
434 -- ^ Converts a Haskell ReadS-style function into a parser.
435 -- Warning: This introduces local backtracking in the resulting
436 -- parser, and therefore a possible inefficiency.
437 readS_to_P r =
438 R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
439
440 -------------------------------------------------------------------------------
441 -- ReadE
442 -------------------------------------------------------------------------------
443
444 readP_to_E :: (String -> String) -> ReadP a a -> ReadE a
445 readP_to_E err r =
446 ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt
447 , all isSpace s ]
448 of [] -> Left (err txt)
449 (p:_) -> Right p