Text/ParserCombinators/ReadP.hs

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