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 l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
 262   gath _ Fail         = Fail
 263   gath l (Look f)     = Look (\s -> gath l (f s))
 264   gath l (Result k p) = k (l []) `mplus` gath l p
 265   gath _ (Final _)    = error "do not use readS_to_P in gather!"
 266
 267 -- ---------------------------------------------------------------------------
 268 -- Derived operations
 269
 270 satisfy :: (Char -> Bool) -> ReadP Char
 271 -- ^ Consumes and returns the next character, if it satisfies the
 272 --   specified predicate.
 273 satisfy p = do c <- get; if p c then return c else pfail
 274
 275 char :: Char -> ReadP Char
 276 -- ^ Parses and returns the specified character.
 277 char c = satisfy (c ==)
 278
 279 eof :: ReadP ()
 280 -- ^ Succeeds iff we are at the end of input
 281 eof = do { s <- look
 282          ; if null s then return ()
 283                      else pfail }
 284
 285 string :: String -> ReadP String
 286 -- ^ Parses and returns the specified string.
 287 string this = do s <- look; scan this s
 288  where
 289   scan []     _               = do return this
 290   scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys
 291   scan _      _               = do pfail
 292
 293 munch :: (Char -> Bool) -> ReadP String
 294 -- ^ Parses the first zero or more characters satisfying the predicate.
 295 --   Always succeds, exactly once having consumed all the characters
 296 --   Hence NOT the same as (many (satisfy p))
 297 munch p =
 298   do s <- look
 299      scan s
 300  where
 301   scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
 302   scan _            = do return ""
 303
 304 munch1 :: (Char -> Bool) -> ReadP String
 305 -- ^ Parses the first one or more characters satisfying the predicate.
 306 --   Fails if none, else succeeds exactly once having consumed all the characters
 307 --   Hence NOT the same as (many1 (satisfy p))
 308 munch1 p =
 309   do c <- get
 310      if p c then do s <- munch p; return (c:s) else pfail
 311
 312 choice :: [ReadP a] -> ReadP a
 313 -- ^ Combines all parsers in the specified list.
 314 choice []     = pfail
 315 choice [p]    = p
 316 choice (p:ps) = p +++ choice ps
 317
 318 skipSpaces :: ReadP ()
 319 -- ^ Skips all whitespace.
 320 skipSpaces =
 321   do s <- look
 322      skip s
 323  where
 324   skip (c:s) | isSpace c = do _ <- get; skip s
 325   skip _                 = do return ()
 326
 327 count :: Int -> ReadP a -> ReadP [a]
 328 -- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of
 329 --   results is returned.
 330 count n p = sequence (replicate n p)
 331
 332 between :: ReadP open -> ReadP close -> ReadP a -> ReadP a
 333 -- ^ @between open close p@ parses @open@, followed by @p@ and finally
 334 --   @close@. Only the value of @p@ is returned.
 335 between open close p = do _ <- open
 336                           x <- p
 337                           _ <- close
 338                           return x
 339
 340 option :: a -> ReadP a -> ReadP a
 341 -- ^ @option x p@ will either parse @p@ or return @x@ without consuming
 342 --   any input.
 343 option x p = p +++ return x
 344
 345 optional :: ReadP a -> ReadP ()
 346 -- ^ @optional p@ optionally parses @p@ and always returns @()@.
 347 optional p = (p >> return ()) +++ return ()
 348
 349 many :: ReadP a -> ReadP [a]
 350 -- ^ Parses zero or more occurrences of the given parser.
 351 many p = return [] +++ many1 p
 352
 353 many1 :: ReadP a -> ReadP [a]
 354 -- ^ Parses one or more occurrences of the given parser.
 355 many1 p = liftM2 (:) p (many p)
 356
 357 skipMany :: ReadP a -> ReadP ()
 358 -- ^ Like 'many', but discards the result.
 359 skipMany p = many p >> return ()
 360
 361 skipMany1 :: ReadP a -> ReadP ()
 362 -- ^ Like 'many1', but discards the result.
 363 skipMany1 p = p >> skipMany p
 364
 365 sepBy :: ReadP a -> ReadP sep -> ReadP [a]
 366 -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
 367 --   Returns a list of values returned by @p@.
 368 sepBy p sep = sepBy1 p sep +++ return []
 369
 370 sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]
 371 -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
 372 --   Returns a list of values returned by @p@.
 373 sepBy1 p sep = liftM2 (:) p (many (sep >> p))
 374
 375 endBy :: ReadP a -> ReadP sep -> ReadP [a]
 376 -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
 377 --   by @sep@.
 378 endBy p sep = many (do x <- p ; _ <- sep ; return x)
 379
 380 endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
 381 -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
 382 --   by @sep@.
 383 endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
 384
 385 chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
 386 -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
 387 --   Returns a value produced by a /right/ associative application of all
 388 --   functions returned by @op@. If there are no occurrences of @p@, @x@ is
 389 --   returned.
 390 chainr p op x = chainr1 p op +++ return x
 391
 392 chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
 393 -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
 394 --   Returns a value produced by a /left/ associative application of all
 395 --   functions returned by @op@. If there are no occurrences of @p@, @x@ is
 396 --   returned.
 397 chainl p op x = chainl1 p op +++ return x
 398
 399 chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
 400 -- ^ Like 'chainr', but parses one or more occurrences of @p@.
 401 chainr1 p op = scan
 402   where scan   = p >>= rest
 403         rest x = do f <- op
 404                     y <- scan
 405                     return (f x y)
 406                  +++ return x
 407
 408 chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
 409 -- ^ Like 'chainl', but parses one or more occurrences of @p@.
 410 chainl1 p op = p >>= rest
 411   where rest x = do f <- op
 412                     y <- p
 413                     rest (f x y)
 414                  +++ return x
 415
 416 #ifndef __NHC__
 417 manyTill :: ReadP a -> ReadP end -> ReadP [a]
 418 #else
 419 manyTill :: ReadPN [a] a -> ReadPN [a] end -> ReadPN [a] [a]
 420 #endif
 421 -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
 422 --   succeeds. Returns a list of values returned by @p@.
 423 manyTill p end = scan
 424   where scan = (end >> return []) <++ (liftM2 (:) p scan)
 425
 426 -- ---------------------------------------------------------------------------
 427 -- Converting between ReadP and Read
 428
 429 #ifndef __NHC__
 430 readP_to_S :: ReadP a -> ReadS a
 431 #else
 432 readP_to_S :: ReadPN a a -> ReadS a
 433 #endif
 434 -- ^ Converts a parser into a Haskell ReadS-style function.
 435 --   This is the main way in which you can \"run\" a 'ReadP' parser:
 436 --   the expanded type is
 437 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
 438 readP_to_S (R f) = run (f return)
 439
 440 readS_to_P :: ReadS a -> ReadP a
 441 -- ^ Converts a Haskell ReadS-style function into a parser.
 442 --   Warning: This introduces local backtracking in the resulting
 443 --   parser, and therefore a possible inefficiency.
 444 readS_to_P r =
 445   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
 446
 447 -- ---------------------------------------------------------------------------
 448 -- QuickCheck properties that hold for the combinators
 449
 450 {- $properties
 451 The following are QuickCheck specifications of what the combinators do.
 452 These can be seen as formal specifications of the behavior of the
 453 combinators.
 454
 455 We use bags to give semantics to the combinators.
 456
 457 >  type Bag a = [a]
 458
 459 Equality on bags does not care about the order of elements.
 460
 461 >  (=~) :: Ord a => Bag a -> Bag a -> Bool
 462 >  xs =~ ys = sort xs == sort ys
 463
 464 A special equality operator to avoid unresolved overloading
 465 when testing the properties.
 466
 467 >  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
 468 >  (=~.) = (=~)
 469
 470 Here follow the properties:
 471
 472 >  prop_Get_Nil =
 473 >    readP_to_S get [] =~ []
 474 >
 475 >  prop_Get_Cons c s =
 476 >    readP_to_S get (c:s) =~ [(c,s)]
 477 >
 478 >  prop_Look s =
 479 >    readP_to_S look s =~ [(s,s)]
 480 >
 481 >  prop_Fail s =
 482 >    readP_to_S pfail s =~. []
 483 >
 484 >  prop_Return x s =
 485 >    readP_to_S (return x) s =~. [(x,s)]
 486 >
 487 >  prop_Bind p k s =
 488 >    readP_to_S (p >>= k) s =~.
 489 >      [ ys''
 490 >      | (x,s') <- readP_to_S p s
 491 >      , ys''   <- readP_to_S (k (x::Int)) s'
 492 >      ]
 493 >
 494 >  prop_Plus p q s =
 495 >    readP_to_S (p +++ q) s =~.
 496 >      (readP_to_S p s ++ readP_to_S q s)
 497 >
 498 >  prop_LeftPlus p q s =
 499 >    readP_to_S (p <++ q) s =~.
 500 >      (readP_to_S p s +<+ readP_to_S q s)
 501 >   where
 502 >    [] +<+ ys = ys
 503 >    xs +<+ _  = xs
 504 >
 505 >  prop_Gather s =
 506 >    forAll readPWithoutReadS $ \p ->
 507 >      readP_to_S (gather p) s =~
 508 >        [ ((pre,x::Int),s')
 509 >        | (x,s') <- readP_to_S p s
 510 >        , let pre = take (length s - length s') s
 511 >        ]
 512 >
 513 >  prop_String_Yes this s =
 514 >    readP_to_S (string this) (this ++ s) =~
 515 >      [(this,s)]
 516 >
 517 >  prop_String_Maybe this s =
 518 >    readP_to_S (string this) s =~
 519 >      [(this, drop (length this) s) | this `isPrefixOf` s]
 520 >
 521 >  prop_Munch p s =
 522 >    readP_to_S (munch p) s =~
 523 >      [(takeWhile p s, dropWhile p s)]
 524 >
 525 >  prop_Munch1 p s =
 526 >    readP_to_S (munch1 p) s =~
 527 >      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
 528 >
 529 >  prop_Choice ps s =
 530 >    readP_to_S (choice ps) s =~.
 531 >      readP_to_S (foldr (+++) pfail ps) s
 532 >
 533 >  prop_ReadS r s =
 534 >    readP_to_S (readS_to_P r) s =~. r s
 535 -}