Text/ParserCombinators/ReadP.hs

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