1 {-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}
2 -----------------------------------------------------------------------------
4 -- Module : Text.ParserCombinators.ReadP
5 -- Copyright : (c) The University of Glasgow 2002
6 -- License : BSD-style (see the file libraries/base/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : provisional
10 -- Portability : portable
12 -- This is a library of parser combinators, originally written by Koen Claessen.
13 -- It parses all alternatives in parallel, so it never keeps hold of
14 -- the beginning of the input string, a common source of space leaks with
15 -- other parsers. The '(+++)' choice combinator is genuinely commutative;
16 -- it makes no difference which branch is \"shorter\".
18 -----------------------------------------------------------------------------
20 module Text.ParserCombinators.ReadP
23 ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
25 -- * Primitive operations
27 look, -- :: ReadP String
28 (+++), -- :: ReadP a -> ReadP a -> ReadP a
29 (<++), -- :: ReadP a -> ReadP a -> ReadP a
30 gather, -- :: ReadP a -> ReadP (String, a)
34 satisfy, -- :: (Char -> Bool) -> ReadP Char
35 char, -- :: Char -> ReadP Char
36 string, -- :: String -> ReadP String
37 munch, -- :: (Char -> Bool) -> ReadP String
38 munch1, -- :: (Char -> Bool) -> ReadP String
39 skipSpaces, -- :: ReadP ()
40 choice, -- :: [ReadP a] -> ReadP a
43 readP_to_S, -- :: ReadP a -> ReadS a
44 readS_to_P, -- :: ReadS a -> ReadP a
48 import Control.Monad( MonadPlus(..) )
49 import GHC.Show( isSpace )
54 -- We define a local version of ReadS here,
55 -- because its "real" definition site is in GHC.Read
56 type ReadS a = String -> [(a,String)]
58 -- ---------------------------------------------------------------------------
60 -- is representation type -- should be kept abstract
64 | Look (String -> P a)
67 | Final [(a,String)] -- invariant: list is non-empty!
71 instance Monad P where
72 return x = Result x Fail
74 (Get f) >>= k = Get (\c -> f c >>= k)
75 (Look f) >>= k = Look (\s -> f s >>= k)
77 (Result x p) >>= k = k x `mplus` (p >>= k)
78 (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
82 instance MonadPlus P where
85 -- most common case: two gets are combined
86 Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
88 -- results are delivered as soon as possible
89 Result x p `mplus` q = Result x (p `mplus` q)
90 p `mplus` Result x q = Result x (p `mplus` q)
96 -- two finals are combined
97 -- final + look becomes one look and one final (=optimization)
98 -- final + sthg else becomes one look and one final
99 Final r `mplus` Final t = Final (r ++ t)
100 Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
101 Final r `mplus` p = Look (\s -> Final (r ++ run p s))
102 Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
103 p `mplus` Final r = Look (\s -> Final (run p s ++ r))
105 -- two looks are combined (=optimization)
106 -- look + sthg else floats upwards
107 Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
108 Look f `mplus` p = Look (\s -> f s `mplus` p)
109 p `mplus` Look f = Look (\s -> p `mplus` f s)
111 -- ---------------------------------------------------------------------------
114 newtype ReadP a = R (forall b . (a -> P b) -> P b)
116 -- Functor, Monad, MonadPlus
118 instance Functor ReadP where
119 fmap h (R f) = R (\k -> f (k . h))
121 instance Monad ReadP where
122 return x = R (\k -> k x)
123 fail _ = R (\_ -> Fail)
124 R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
126 instance MonadPlus ReadP where
130 -- ---------------------------------------------------------------------------
133 final :: [(a,String)] -> P a
134 -- Maintains invariant for Final constructor
138 run :: P a -> ReadS a
139 run (Get f) (c:s) = run (f c) s
140 run (Look f) s = run (f s) s
141 run (Result x p) s = (x,s) : run p s
145 -- ---------------------------------------------------------------------------
146 -- Operations over ReadP
155 pfail = R (\_ -> Fail)
157 (+++) :: ReadP a -> ReadP a -> ReadP a
158 -- ^ Symmetric choice.
159 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
161 (<++) :: ReadP a -> ReadP a -> ReadP a
162 -- ^ Local, exclusive, left-biased choice: If left parser
163 -- locally produces any result at all, then right parser is
167 probe (f return) s 0#
169 probe (Get f) (c:s) n = probe (f c) s (n+#1#)
170 probe (Look f) s n = probe (f s) s n
171 probe p@(Result _ _) s n = discard n >> R (p >>=)
172 probe (Final r) _ _ = R (Final r >>=)
175 discard 0# = return ()
176 discard n = get >> discard (n-#1#)
178 gather :: ReadP a -> ReadP (String, a)
179 -- ^ Transforms a parser into one that does the same, but
180 -- in addition returns the exact characters read.
181 -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
182 -- is built using any occurrences of readS_to_P.
184 R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
186 gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
188 gath l (Look f) = Look (\s -> gath l (f s))
189 gath l (Result k p) = k (l []) `mplus` gath l p
190 gath l (Final r) = error "do not use readS_to_P in gather!"
192 -- ---------------------------------------------------------------------------
193 -- Derived operations
195 satisfy :: (Char -> Bool) -> ReadP Char
196 satisfy p = do c <- get; if p c then return c else pfail
198 char :: Char -> ReadP Char
199 char c = satisfy (c ==)
201 string :: String -> ReadP String
204 scan [] = do return s
205 scan (c:cs) = do char c; scan cs
207 munch :: (Char -> Bool) -> ReadP String
208 -- (munch p) parses the first zero or more characters satisfying p
213 scan (c:cs) | p c = do get; s <- scan cs; return (c:s)
214 scan _ = do return ""
216 munch1 :: (Char -> Bool) -> ReadP String
217 -- (munch p) parses the first one or more characters satisfying p
220 if p c then do s <- munch p; return (c:s) else pfail
222 choice :: [ReadP a] -> ReadP a
225 choide (p:ps) = p +++ choice ps
227 skipSpaces :: ReadP ()
232 skip (c:s) | isSpace c = do get; skip s
233 skip _ = do return ()
235 -- ---------------------------------------------------------------------------
236 -- Converting between ReadP and Read
238 readP_to_S :: ReadP a -> ReadS a
239 readP_to_S (R f) = run (f return)
241 readS_to_P :: ReadS a -> ReadP a
243 R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
245 -- ---------------------------------------------------------------------------
246 -- QuickCheck properties that are supposed to hold
251 (=~) :: Ord a => Bag a -> Bag a -> Bool
252 xs =~ ys = sort xs == sort ys
255 readP_to_S get [] =~ []
258 readP_to_S get (c:s) =~ [(c,s)]
261 readP_to_S look s =~ [(s,s)]
264 readP_to_S pfail s =~ ([] :: Bag (Int,String))
267 readP_to_S (return x) s =~ ([(x,s)] :: Bag (Int,String))
270 readP_to_S (readS_to_P r) s =~ (r s :: Bag (Int,String))
273 readP_to_S ((p :: ReadP Int) >>= k) s =~
274 ([ ys'' | (x,s') <- readP_to_S p s, ys'' <- readP_to_S (k x) s' ]
279 readP_to_S ((p :: ReadP Int) +++ q) s =~
280 (readP_to_S p s ++ readP_to_S q s)
282 prop_LeftPlus p q s =
283 readP_to_S ((p :: ReadP Int) <++ q) s =~
284 (readP_to_S p s +<+ readP_to_S q s)