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