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