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