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   -- * Conversions
  43   readP_to_S, -- :: ReadP a -> ReadS a
  44   readS_to_P, -- :: ReadS a -> ReadP a
  45   )
  46  where
  47
  48 import Control.Monad( MonadPlus(..) )
  49 import GHC.Show( isSpace  )
  50 import GHC.Base
  51
  52 infixr 5 +++, <++
  53
  54 -- We define a local version of ReadS here,
  55 -- because its "real" definition site is in GHC.Read
  56 type ReadS a = String -> [(a,String)]
  57
  58 -- ---------------------------------------------------------------------------
  59 -- The P type
  60 -- is representation type -- should be kept abstract
  61
  62 data P a
  63   = Get (Char -> P a)
  64   | Look (String -> P a)
  65   | Fail
  66   | Result a (P a)
  67   | Final [(a,String)] -- invariant: list is non-empty!
  68
  69 -- Monad, MonadPlus
  70
  71 instance Monad P where
  72   return x = Result x Fail
  73
  74   (Get f)      >>= k = Get (\c -> f c >>= k)
  75   (Look f)     >>= k = Look (\s -> f s >>= k)
  76   Fail         >>= k = Fail
  77   (Result x p) >>= k = k x `mplus` (p >>= k)
  78   (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
  79
  80   fail _ = Fail
  81
  82 instance MonadPlus P where
  83   mzero = Fail
  84
  85   -- most common case: two gets are combined
  86   Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)
  87
  88   -- results are delivered as soon as possible
  89   Result x p `mplus` q          = Result x (p `mplus` q)
  90   p          `mplus` Result x q = Result x (p `mplus` q)
  91
  92   -- fail disappears
  93   Fail       `mplus` p          = p
  94   p          `mplus` Fail       = p
  95
  96   -- two finals are combined
  97   -- final + look becomes one look and one final (=optimization)
  98   -- final + sthg else becomes one look and one final
  99   Final r    `mplus` Final t    = Final (r ++ t)
 100   Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))
 101   Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))
 102   Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))
 103   p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))
 104
 105   -- two looks are combined (=optimization)
 106   -- look + sthg else floats upwards
 107   Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)
 108   Look f     `mplus` p          = Look (\s -> f s `mplus` p)
 109   p          `mplus` Look f     = Look (\s -> p `mplus` f s)
 110
 111 -- ---------------------------------------------------------------------------
 112 -- The ReadP type
 113
 114 newtype ReadP a = R (forall b . (a -> P b) -> P b)
 115
 116 -- Functor, Monad, MonadPlus
 117
 118 instance Functor ReadP where
 119   fmap h (R f) = R (\k -> f (k . h))
 120
 121 instance Monad ReadP where
 122   return x  = R (\k -> k x)
 123   fail _    = R (\_ -> Fail)
 124   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
 125
 126 instance MonadPlus ReadP where
 127   mzero = pfail
 128   mplus = (+++)
 129
 130 -- ---------------------------------------------------------------------------
 131 -- Operations over P
 132
 133 final :: [(a,String)] -> P a
 134 -- Maintains invariant for Final constructor
 135 final [] = Fail
 136 final r  = Final r
 137
 138 run :: P a -> ReadS a
 139 run (Get f)      (c:s) = run (f c) s
 140 run (Look f)     s     = run (f s) s
 141 run (Result x p) s     = (x,s) : run p s
 142 run (Final r)    _     = r
 143 run _            _     = []
 144
 145 -- ---------------------------------------------------------------------------
 146 -- Operations over ReadP
 147
 148 get :: ReadP Char
 149 get = R Get
 150
 151 look :: ReadP String
 152 look = R Look
 153
 154 pfail :: ReadP a
 155 pfail = R (\_ -> Fail)
 156
 157 (+++) :: ReadP a -> ReadP a -> ReadP a
 158 -- ^ Symmetric choice.
 159 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
 160
 161 (<++) :: ReadP a -> ReadP a -> ReadP a
 162 -- ^ Local, exclusive, left-biased choice: If left parser
 163 --   locally produces any result at all, then right parser is
 164 --   not used.
 165 R f <++ q =
 166   do s <- look
 167      probe (f return) s 0#
 168  where
 169   probe (Get f)        (c:s) n = probe (f c) s (n+#1#)
 170   probe (Look f)       s     n = probe (f s) s n
 171   probe p@(Result _ _) s     n = discard n >> R (p >>=)
 172   probe (Final r)      _     _ = R (Final r >>=)
 173   probe _              _     _ = q
 174
 175   discard 0# = return ()
 176   discard n  = get >> discard (n-#1#)
 177
 178 gather :: ReadP a -> ReadP (String, a)
 179 -- ^ Transforms a parser into one that does the same, but
 180 --   in addition returns the exact characters read.
 181 --   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
 182 --   is built using any occurrences of readS_to_P.
 183 gather (R m) =
 184   R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
 185  where
 186   gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
 187   gath l Fail         = Fail
 188   gath l (Look f)     = Look (\s -> gath l (f s))
 189   gath l (Result k p) = k (l []) `mplus` gath l p
 190   gath l (Final r)    = error "do not use readS_to_P in gather!"
 191
 192 -- ---------------------------------------------------------------------------
 193 -- Derived operations
 194
 195 satisfy :: (Char -> Bool) -> ReadP Char
 196 satisfy p = do c <- get; if p c then return c else pfail
 197
 198 char :: Char -> ReadP Char
 199 char c = satisfy (c ==)
 200
 201 string :: String -> ReadP String
 202 string s = scan s
 203  where
 204   scan []     = do return s
 205   scan (c:cs) = do char c; scan cs
 206
 207 munch :: (Char -> Bool) -> ReadP String
 208 -- (munch p) parses the first zero or more characters satisfying p
 209 munch p =
 210   do s <- look
 211      scan s
 212  where
 213   scan (c:cs) | p c = do get; s <- scan cs; return (c:s)
 214   scan _            = do return ""
 215
 216 munch1 :: (Char -> Bool) -> ReadP String
 217 -- (munch p) parses the first one or more characters satisfying p
 218 munch1 p =
 219   do c <- get
 220      if p c then do s <- munch p; return (c:s) else pfail
 221
 222 choice :: [ReadP a] -> ReadP a
 223 choice []     = pfail
 224 choice [p]    = p
 225 choice (p:ps) = p +++ choice ps
 226
 227 skipSpaces :: ReadP ()
 228 skipSpaces =
 229   do s <- look
 230      skip s
 231  where
 232   skip (c:s) | isSpace c = do get; skip s
 233   skip _                 = do return ()
 234
 235 -- ---------------------------------------------------------------------------
 236 -- Converting between ReadP and Read
 237
 238 readP_to_S :: ReadP a -> ReadS a
 239 readP_to_S (R f) = run (f return)
 240
 241 readS_to_P :: ReadS a -> ReadP a
 242 readS_to_P r =
 243   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
 244
 245 -- ---------------------------------------------------------------------------
 246 -- QuickCheck properties that are supposed to hold
 247
 248 {-
 249 type Bag a = [a]
 250
 251 (=~) :: Ord a => Bag a -> Bag a -> Bool
 252 xs =~ ys = sort xs == sort ys
 253
 254 prop_Get_Nil =
 255   readP_to_S get [] =~ []
 256
 257 prop_Get_Cons c s =
 258   readP_to_S get (c:s) =~ [(c,s)]
 259
 260 prop_Look s =
 261   readP_to_S look s =~ [(s,s)]
 262
 263 prop_Fail s =
 264   readP_to_S pfail s =~ ([] :: Bag (Int,String))
 265
 266 prop_Return x s =
 267   readP_to_S (return x) s =~ ([(x,s)] :: Bag (Int,String))
 268
 269 prop_ReadS r s =
 270   readP_to_S (readS_to_P r) s =~ (r s :: Bag (Int,String))
 271
 272 prop_Bind p k s =
 273   readP_to_S ((p :: ReadP Int) >>= k) s =~
 274     ([ ys'' | (x,s') <- readP_to_S p s, ys'' <- readP_to_S (k x) s' ]
 275       :: Bag (Int,String)
 276       )
 277
 278 prop_Plus p q s =
 279   readP_to_S ((p :: ReadP Int) +++ q) s =~
 280     (readP_to_S p s ++ readP_to_S q s)
 281
 282 prop_LeftPlus p q s =
 283   readP_to_S ((p :: ReadP Int) <++ q) s =~
 284     (readP_to_S p s +<+ readP_to_S q s)
 285  where
 286   [] +<+ ys = ys
 287   xs +<+ _  = xs
 288 -}