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 )
52 -- We define a local version of ReadS here,
53 -- because its "real" definition site is in GHC.Read
54 type ReadS a = String -> [(a,String)]
56 -- ---------------------------------------------------------------------------
58 -- is representation type -- should be kept abstract
62 | Look (String -> P a)
65 | Final [(a,String)] -- invariant: list is non-empty!
69 instance Monad P where
70 return x = Result x Fail
72 (Get f) >>= k = Get (\c -> f c >>= k)
73 (Look f) >>= k = Look (\s -> f s >>= k)
75 (Result x p) >>= k = k x `mplus` (p >>= k)
76 (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
80 instance MonadPlus P where
83 -- most common case: two gets are combined
84 Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
86 -- results are delivered as soon as possible
87 Result x p `mplus` q = Result x (p `mplus` q)
88 p `mplus` Result x q = Result x (p `mplus` q)
94 -- two finals are combined
95 -- final + look becomes one look and one final (=optimization)
96 -- final + sthg else becomes one look and one final
97 Final r `mplus` Final t = Final (r ++ t)
98 Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
99 Final r `mplus` p = Look (\s -> Final (r ++ run p s))
100 Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
101 p `mplus` Final r = Look (\s -> Final (run p s ++ r))
103 -- two looks are combined (=optimization)
104 -- look + sthg else floats upwards
105 Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
106 Look f `mplus` p = Look (\s -> f s `mplus` p)
107 p `mplus` Look f = Look (\s -> p `mplus` f s)
109 -- ---------------------------------------------------------------------------
112 newtype ReadP a = R (forall b . (a -> P b) -> P b)
114 -- Functor, Monad, MonadPlus
116 instance Functor ReadP where
117 fmap h (R f) = R (\k -> f (k . h))
119 instance Monad ReadP where
120 return x = R (\k -> k x)
121 fail _ = R (\_ -> Fail)
122 R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
124 instance MonadPlus ReadP where
128 -- ---------------------------------------------------------------------------
131 final :: [(a,String)] -> P a
132 -- Maintains invariant for Final constructor
136 run :: P a -> ReadS a
137 run (Get f) (c:s) = run (f c) s
138 run (Look f) s = run (f s) s
139 run (Result x p) s = (x,s) : run p s
143 -- ---------------------------------------------------------------------------
144 -- Operations over ReadP
153 pfail = R (\_ -> Fail)
155 (+++) :: ReadP a -> ReadP a -> ReadP a
156 -- ^ Symmetric choice.
157 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
159 (<++) :: ReadP a -> ReadP a -> ReadP a
160 -- ^ Local, exclusive, left-biased choice: If left parser
161 -- locally produces any result at all, then right parser is
165 probe (f return) s 0#
167 probe (Get f) (c:s) n = probe (f c) s (n+#1#)
168 probe (Look f) s n = probe (f s) s n
169 probe p@(Result _ _) s n = discard n >> R (p >>=)
170 probe (Final r) _ _ = R (Final r >>=)
173 discard 0# = return ()
174 discard n = get >> discard (n-#1#)
176 gather :: ReadP a -> ReadP (String, a)
177 -- ^ Transforms a parser into one that does the same, but
178 -- in addition returns the exact characters read.
179 -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
180 -- is built using any occurrences of readS_to_P.
182 R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
184 gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
186 gath l (Look f) = Look (\s -> gath l (f s))
187 gath l (Result k p) = k (l []) `mplus` gath l p
188 gath l (Final r) = error "do not use readS_to_P in gather!"
190 -- ---------------------------------------------------------------------------
191 -- Derived operations
193 satisfy :: (Char -> Bool) -> ReadP Char
194 satisfy p = do c <- get; if p c then return c else pfail
196 char :: Char -> ReadP Char
197 char c = satisfy (c ==)
199 string :: String -> ReadP String
202 scan [] = do return s
203 scan (c:cs) = do char c; scan cs
205 munch :: (Char -> Bool) -> ReadP String
206 -- (munch p) parses the first zero or more characters satisfying p
211 scan (c:cs) | p c = do get; s <- scan cs; return (c:s)
212 scan _ = do return ""
214 munch1 :: (Char -> Bool) -> ReadP String
215 -- (munch p) parses the first one or more characters satisfying p
218 if p c then do s <- munch p; return (c:s) else pfail
220 choice :: [ReadP a] -> ReadP a
223 choide (p:ps) = p +++ choice ps
225 skipSpaces :: ReadP ()
230 skip (c:s) | isSpace c = do get; skip s
231 skip _ = do return ()
233 -- ---------------------------------------------------------------------------
234 -- Converting between ReadP and Read
236 readP_to_S :: ReadP a -> ReadS a
237 readP_to_S (R f) = run (f return)
239 readS_to_P :: ReadS a -> ReadP a
241 R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
243 -- ---------------------------------------------------------------------------
244 -- QuickCheck properties that are supposed to hold
249 (=~) :: Ord a => Bag a -> Bag a -> Bool
250 xs =~ ys = sort xs == sort ys
253 readP_to_S get [] =~ []
256 readP_to_S get (c:s) =~ [(c,s)]
259 readP_to_S look s =~ [(s,s)]
262 readP_to_S pfail s =~ ([] :: Bag (Int,String))
265 readP_to_S (return x) s =~ ([(x,s)] :: Bag (Int,String))
268 readP_to_S (readS_to_P r) s =~ (r s :: Bag (Int,String))
271 readP_to_S ((p :: ReadP Int) >>= k) s =~
272 ([ ys'' | (x,s') <- readP_to_S p s, ys'' <- readP_to_S (k x) s' ]
277 readP_to_S ((p :: ReadP Int) +++ q) s =~
278 (readP_to_S p s ++ readP_to_S q s)
280 prop_LeftPlus p q s =
281 readP_to_S ((p :: ReadP Int) <++ q) s =~
282 (readP_to_S p s +<+ readP_to_S q s)