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
  42   -- * Running a parser
  43   ReadS,      -- :: *; = String -> [(a,String)]
  44   readP_to_S, -- :: ReadP a -> ReadS a
  45   readS_to_P, -- :: ReadS a -> ReadP a
  46
  47   -- * Properties
  48   -- $properties
  49   )
  50  where
  51
  52 import Control.Monad( MonadPlus(..) )
  53 #ifdef __GLASGOW_HASKELL__
  54 #ifndef __HADDOCK__
  55 import {-# SOURCE #-} GHC.Unicode ( isSpace  )
  56 #endif
  57 import GHC.Base
  58 #else
  59 import Data.Char( isSpace )
  60 #endif
  61
  62 infixr 5 +++, <++
  63
  64 #ifdef __GLASGOW_HASKELL__
  65 ------------------------------------------------------------------------
  66 -- ReadS
  67
  68 -- | A parser for a type @a@, represented as a function that takes a
  69 -- 'String' and returns a list of possible parses as @(a,'String')@ pairs.
  70 --
  71 -- Note that this kind of backtracking parser is very inefficient;
  72 -- reading a large structure may be quite slow (cf 'ReadP').
  73 type ReadS a = String -> [(a,String)]
  74 #endif
  75
  76 -- ---------------------------------------------------------------------------
  77 -- The P type
  78 -- is representation type -- should be kept abstract
  79
  80 data P a
  81   = Get (Char -> P a)
  82   | Look (String -> P a)
  83   | Fail
  84   | Result a (P a)
  85   | Final [(a,String)] -- invariant: list is non-empty!
  86
  87 -- Monad, MonadPlus
  88
  89 instance Monad P where
  90   return x = Result x Fail
  91
  92   (Get f)      >>= k = Get (\c -> f c >>= k)
  93   (Look f)     >>= k = Look (\s -> f s >>= k)
  94   Fail         >>= k = Fail
  95   (Result x p) >>= k = k x `mplus` (p >>= k)
  96   (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
  97
  98   fail _ = Fail
  99
 100 instance MonadPlus P where
 101   mzero = Fail
 102
 103   -- most common case: two gets are combined
 104   Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)
 105
 106   -- results are delivered as soon as possible
 107   Result x p `mplus` q          = Result x (p `mplus` q)
 108   p          `mplus` Result x q = Result x (p `mplus` q)
 109
 110   -- fail disappears
 111   Fail       `mplus` p          = p
 112   p          `mplus` Fail       = p
 113
 114   -- two finals are combined
 115   -- final + look becomes one look and one final (=optimization)
 116   -- final + sthg else becomes one look and one final
 117   Final r    `mplus` Final t    = Final (r ++ t)
 118   Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))
 119   Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))
 120   Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))
 121   p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))
 122
 123   -- two looks are combined (=optimization)
 124   -- look + sthg else floats upwards
 125   Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)
 126   Look f     `mplus` p          = Look (\s -> f s `mplus` p)
 127   p          `mplus` Look f     = Look (\s -> p `mplus` f s)
 128
 129 -- ---------------------------------------------------------------------------
 130 -- The ReadP type
 131
 132 newtype ReadP a = R (forall b . (a -> P b) -> P b)
 133
 134 -- Functor, Monad, MonadPlus
 135
 136 instance Functor ReadP where
 137   fmap h (R f) = R (\k -> f (k . h))
 138
 139 instance Monad ReadP where
 140   return x  = R (\k -> k x)
 141   fail _    = R (\_ -> Fail)
 142   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
 143
 144 instance MonadPlus ReadP where
 145   mzero = pfail
 146   mplus = (+++)
 147
 148 -- ---------------------------------------------------------------------------
 149 -- Operations over P
 150
 151 final :: [(a,String)] -> P a
 152 -- Maintains invariant for Final constructor
 153 final [] = Fail
 154 final r  = Final r
 155
 156 run :: P a -> ReadS a
 157 run (Get f)      (c:s) = run (f c) s
 158 run (Look f)     s     = run (f s) s
 159 run (Result x p) s     = (x,s) : run p s
 160 run (Final r)    _     = r
 161 run _            _     = []
 162
 163 -- ---------------------------------------------------------------------------
 164 -- Operations over ReadP
 165
 166 get :: ReadP Char
 167 -- ^ Consumes and returns the next character.
 168 --   Fails if there is no input left.
 169 get = R Get
 170
 171 look :: ReadP String
 172 -- ^ Look-ahead: returns the part of the input that is left, without
 173 --   consuming it.
 174 look = R Look
 175
 176 pfail :: ReadP a
 177 -- ^ Always fails.
 178 pfail = R (\_ -> Fail)
 179
 180 (+++) :: ReadP a -> ReadP a -> ReadP a
 181 -- ^ Symmetric choice.
 182 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
 183
 184 (<++) :: ReadP a -> ReadP a -> ReadP a
 185 -- ^ Local, exclusive, left-biased choice: If left parser
 186 --   locally produces any result at all, then right parser is
 187 --   not used.
 188 #ifdef __GLASGOW_HASKELL__
 189 R f <++ q =
 190   do s <- look
 191      probe (f return) s 0#
 192  where
 193   probe (Get f)        (c:s) n = probe (f c) s (n+#1#)
 194   probe (Look f)       s     n = probe (f s) s n
 195   probe p@(Result _ _) _     n = discard n >> R (p >>=)
 196   probe (Final r)      _     _ = R (Final r >>=)
 197   probe _              _     _ = q
 198
 199   discard 0# = return ()
 200   discard n  = get >> discard (n-#1#)
 201 #else
 202 R f <++ q =
 203   do s <- look
 204      probe (f return) s 0
 205  where
 206   probe (Get f)        (c:s) n = probe (f c) s (n+1)
 207   probe (Look f)       s     n = probe (f s) s n
 208   probe p@(Result _ _) _     n = discard n >> R (p >>=)
 209   probe (Final r)      _     _ = R (Final r >>=)
 210   probe _              _     _ = q
 211
 212   discard 0 = return ()
 213   discard n  = get >> discard (n-1)
 214 #endif
 215
 216 gather :: ReadP a -> ReadP (String, a)
 217 -- ^ Transforms a parser into one that does the same, but
 218 --   in addition returns the exact characters read.
 219 --   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
 220 --   is built using any occurrences of readS_to_P.
 221 gather (R m) =
 222   R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
 223  where
 224   gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
 225   gath l Fail         = Fail
 226   gath l (Look f)     = Look (\s -> gath l (f s))
 227   gath l (Result k p) = k (l []) `mplus` gath l p
 228   gath l (Final r)    = error "do not use readS_to_P in gather!"
 229
 230 -- ---------------------------------------------------------------------------
 231 -- Derived operations
 232
 233 satisfy :: (Char -> Bool) -> ReadP Char
 234 -- ^ Consumes and returns the next character, if it satisfies the
 235 --   specified predicate.
 236 satisfy p = do c <- get; if p c then return c else pfail
 237
 238 char :: Char -> ReadP Char
 239 -- ^ Parses and returns the specified character.
 240 char c = satisfy (c ==)
 241
 242 string :: String -> ReadP String
 243 -- ^ Parses and returns the specified string.
 244 string this = do s <- look; scan this s
 245  where
 246   scan []     _               = do return this
 247   scan (x:xs) (y:ys) | x == y = do get; scan xs ys
 248   scan _      _               = do pfail
 249
 250 munch :: (Char -> Bool) -> ReadP String
 251 -- ^ Parses the first zero or more characters satisfying the predicate.
 252 munch p =
 253   do s <- look
 254      scan s
 255  where
 256   scan (c:cs) | p c = do get; s <- scan cs; return (c:s)
 257   scan _            = do return ""
 258
 259 munch1 :: (Char -> Bool) -> ReadP String
 260 -- ^ Parses the first one or more characters satisfying the predicate.
 261 munch1 p =
 262   do c <- get
 263      if p c then do s <- munch p; return (c:s) else pfail
 264
 265 choice :: [ReadP a] -> ReadP a
 266 -- ^ Combines all parsers in the specified list.
 267 choice []     = pfail
 268 choice [p]    = p
 269 choice (p:ps) = p +++ choice ps
 270
 271 skipSpaces :: ReadP ()
 272 -- ^ Skips all whitespace.
 273 skipSpaces =
 274   do s <- look
 275      skip s
 276  where
 277   skip (c:s) | isSpace c = do get; skip s
 278   skip _                 = do return ()
 279
 280 -- ---------------------------------------------------------------------------
 281 -- Converting between ReadP and Read
 282
 283 readP_to_S :: ReadP a -> ReadS a
 284 -- ^ Converts a parser into a Haskell ReadS-style function.
 285 --   This is the main way in which you can \"run\" a 'ReadP' parser:
 286 --   the expanded type is
 287 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
 288 readP_to_S (R f) = run (f return)
 289
 290 readS_to_P :: ReadS a -> ReadP a
 291 -- ^ Converts a Haskell ReadS-style function into a parser.
 292 --   Warning: This introduces local backtracking in the resulting
 293 --   parser, and therefore a possible inefficiency.
 294 readS_to_P r =
 295   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
 296
 297 -- ---------------------------------------------------------------------------
 298 -- QuickCheck properties that hold for the combinators
 299
 300 {- $properties
 301 The following are QuickCheck specifications of what the combinators do.
 302 These can be seen as formal specifications of the behavior of the
 303 combinators.
 304
 305 We use bags to give semantics to the combinators.
 306
 307 >  type Bag a = [a]
 308
 309 Equality on bags does not care about the order of elements.
 310
 311 >  (=~) :: Ord a => Bag a -> Bag a -> Bool
 312 >  xs =~ ys = sort xs == sort ys
 313
 314 A special equality operator to avoid unresolved overloading
 315 when testing the properties.
 316
 317 >  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
 318 >  (=~.) = (=~)
 319
 320 Here follow the properties:
 321
 322 >  prop_Get_Nil =
 323 >    readP_to_S get [] =~ []
 324 >
 325 >  prop_Get_Cons c s =
 326 >    readP_to_S get (c:s) =~ [(c,s)]
 327 >
 328 >  prop_Look s =
 329 >    readP_to_S look s =~ [(s,s)]
 330 >
 331 >  prop_Fail s =
 332 >    readP_to_S pfail s =~. []
 333 >
 334 >  prop_Return x s =
 335 >    readP_to_S (return x) s =~. [(x,s)]
 336 >
 337 >  prop_Bind p k s =
 338 >    readP_to_S (p >>= k) s =~.
 339 >      [ ys''
 340 >      | (x,s') <- readP_to_S p s
 341 >      , ys''   <- readP_to_S (k (x::Int)) s'
 342 >      ]
 343 >
 344 >  prop_Plus p q s =
 345 >    readP_to_S (p +++ q) s =~.
 346 >      (readP_to_S p s ++ readP_to_S q s)
 347 >
 348 >  prop_LeftPlus p q s =
 349 >    readP_to_S (p <++ q) s =~.
 350 >      (readP_to_S p s +<+ readP_to_S q s)
 351 >   where
 352 >    [] +<+ ys = ys
 353 >    xs +<+ _  = xs
 354 >
 355 >  prop_Gather s =
 356 >    forAll readPWithoutReadS $ \p ->
 357 >      readP_to_S (gather p) s =~
 358 >        [ ((pre,x::Int),s')
 359 >        | (x,s') <- readP_to_S p s
 360 >        , let pre = take (length s - length s') s
 361 >        ]
 362 >
 363 >  prop_String_Yes this s =
 364 >    readP_to_S (string this) (this ++ s) =~
 365 >      [(this,s)]
 366 >
 367 >  prop_String_Maybe this s =
 368 >    readP_to_S (string this) s =~
 369 >      [(this, drop (length this) s) | this `isPrefixOf` s]
 370 >
 371 >  prop_Munch p s =
 372 >    readP_to_S (munch p) s =~
 373 >      [(takeWhile p s, dropWhile p s)]
 374 >
 375 >  prop_Munch1 p s =
 376 >    readP_to_S (munch1 p) s =~
 377 >      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
 378 >
 379 >  prop_Choice ps s =
 380 >    readP_to_S (choice ps) s =~.
 381 >      readP_to_S (foldr (+++) pfail ps) s
 382 >
 383 >  prop_ReadS r s =
 384 >    readP_to_S (readS_to_P r) s =~. r s
 385 -}