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