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