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