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