cabal-install/src/Distribution/Deprecated/ReadP.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE GADTs #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 --
  10 -- Module      :  Distribution.Deprecated.ReadP
  11 -- Copyright   :  (c) The University of Glasgow 2002
  12 -- License     :  BSD-style (see the file libraries/base/LICENSE)
  13 --
  14 -- Maintainer  :  libraries@haskell.org
  15 -- Portability :  portable
  16 --
  17 -- This is a library of parser combinators, originally written by Koen Claessen.
  18 -- It parses all alternatives in parallel, so it never keeps hold of
  19 -- the beginning of the input string, a common source of space leaks with
  20 -- other parsers.  The '(+++)' choice combinator is genuinely commutative;
  21 -- it makes no difference which branch is \"shorter\".
  22 --
  23 -- See also Koen's paper /Parallel Parsing Processes/
  24 -- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).
  25 --
  26 -- This version of ReadP has been locally hacked to make it H98, by
  27 -- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
  28 --
  29 -- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by
  30 -- Mark Lentczner <mailto:mark@glyphic.com>
  31 module Distribution.Deprecated.ReadP
  32   ( -- * The 'ReadP' type
  33     ReadP -- :: * -> *; instance Functor, Monad, MonadPlus
  34
  35     -- * Primitive operations
  36   , get -- :: ReadP Char
  37   , look -- :: ReadP String
  38   , (+++) -- :: ReadP a -> ReadP a -> ReadP a
  39   , (<++) -- :: ReadP a -> ReadP a -> ReadP a
  40   , gather -- :: ReadP a -> ReadP (String, a)
  41
  42     -- * Other operations
  43   , pfail -- :: ReadP a
  44   , eof -- :: ReadP ()
  45   , satisfy -- :: (Char -> Bool) -> ReadP Char
  46   , char -- :: Char -> ReadP Char
  47   , string -- :: String -> ReadP String
  48   , munch -- :: (Char -> Bool) -> ReadP String
  49   , munch1 -- :: (Char -> Bool) -> ReadP String
  50   , skipSpaces -- :: ReadP ()
  51   , skipSpaces1 -- :: ReadP ()
  52   , choice -- :: [ReadP a] -> ReadP a
  53   , count -- :: Int -> ReadP a -> ReadP [a]
  54   , between -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
  55   , option -- :: a -> ReadP a -> ReadP a
  56   , optional -- :: ReadP a -> ReadP ()
  57   , many -- :: ReadP a -> ReadP [a]
  58   , many1 -- :: ReadP a -> ReadP [a]
  59   , skipMany -- :: ReadP a -> ReadP ()
  60   , skipMany1 -- :: ReadP a -> ReadP ()
  61   , sepBy -- :: ReadP a -> ReadP sep -> ReadP [a]
  62   , sepBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]
  63   , endBy -- :: ReadP a -> ReadP sep -> ReadP [a]
  64   , endBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]
  65   , chainr -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
  66   , chainl -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
  67   , chainl1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
  68   , chainr1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
  69   , manyTill -- :: ReadP a -> ReadP end -> ReadP [a]
  70
  71     -- * Running a parser
  72   , ReadS -- :: *; = String -> [(a,String)]
  73   , readP_to_S -- :: ReadP a -> ReadS a
  74   , readS_to_P -- :: ReadS a -> ReadP a
  75   , readP_to_E
  76
  77     -- ** Internal
  78   , Parser
  79   )
  80 where
  81
  82 import Distribution.Client.Compat.Prelude hiding (get, many)
  83 import Prelude ()
  84
  85 import Control.Monad (replicateM, (>=>))
  86
  87 import qualified Control.Monad.Fail as Fail
  88
  89 import Distribution.ReadE (ReadE (..))
  90
  91 infixr 5 +++, <++
  92
  93 -- ---------------------------------------------------------------------------
  94 -- The P type
  95 -- is representation type -- should be kept abstract
  96
  97 data P s a
  98   = Get (s -> P s a)
  99   | Look ([s] -> P s a)
 100   | Fail
 101   | Result a (P s a)
 102   | Final [(a, [s])] -- invariant: list is non-empty!
 103
 104 -- Monad, MonadPlus
 105
 106 instance Functor (P s) where
 107   fmap = liftM
 108
 109 instance Applicative (P s) where
 110   pure x = Result x Fail
 111   (<*>) = ap
 112
 113 instance Monad (P s) where
 114   return = pure
 115
 116   (Get f) >>= k = Get (f >=> k)
 117   (Look f) >>= k = Look (f >=> k)
 118   Fail >>= _ = Fail
 119   (Result x p) >>= k = k x `mplus` (p >>= k)
 120   (Final r) >>= k = final [ys' | (x, s) <- r, ys' <- run (k x) s]
 121
 122 instance Fail.MonadFail (P s) where
 123   fail _ = Fail
 124
 125 instance Alternative (P s) where
 126   empty = mzero
 127   (<|>) = mplus
 128
 129 instance MonadPlus (P s) where
 130   mzero = Fail
 131
 132   -- most common case: two gets are combined
 133   Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
 134   -- results are delivered as soon as possible
 135   Result x p `mplus` q = Result x (p `mplus` q)
 136   p `mplus` Result x q = Result x (p `mplus` q)
 137   -- fail disappears
 138   Fail `mplus` p = p
 139   p `mplus` Fail = p
 140   -- two finals are combined
 141   -- final + look becomes one look and one final (=optimization)
 142   -- final + sthg else becomes one look and one final
 143   Final r `mplus` Final t = Final (r ++ t)
 144   Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
 145   Final r `mplus` p = Look (\s -> Final (r ++ run p s))
 146   Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
 147   p `mplus` Final r = Look (\s -> Final (run p s ++ r))
 148   -- two looks are combined (=optimization)
 149   -- look + sthg else floats upwards
 150   Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
 151   Look f `mplus` p = Look (\s -> f s `mplus` p)
 152   p `mplus` Look f = Look (\s -> p `mplus` f s)
 153
 154 -- ---------------------------------------------------------------------------
 155 -- The ReadP type
 156
 157 newtype Parser r s a = R ((a -> P s r) -> P s r)
 158 type ReadP r a = Parser r Char a
 159
 160 -- Functor, Monad, MonadPlus
 161
 162 instance Functor (Parser r s) where
 163   fmap h (R f) = R (\k -> f (k . h))
 164
 165 instance Applicative (Parser r s) where
 166   pure x = R (\k -> k x)
 167   (<*>) = ap
 168
 169 instance s ~ Char => Alternative (Parser r s) where
 170   empty = pfail
 171   (<|>) = (+++)
 172
 173 instance Monad (Parser r s) where
 174   return = pure
 175   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
 176
 177 instance Fail.MonadFail (Parser r s) where
 178   fail _ = R (const Fail)
 179
 180 instance s ~ Char => MonadPlus (Parser r s) where
 181   mzero = pfail
 182   mplus = (+++)
 183
 184 -- ---------------------------------------------------------------------------
 185 -- Operations over P
 186
 187 final :: [(a, [s])] -> P s a
 188 -- Maintains invariant for Final constructor
 189 final [] = Fail
 190 final r = Final r
 191
 192 run :: P c a -> ([c] -> [(a, [c])])
 193 run (Get f) (c : s) = run (f c) s
 194 run (Look f) s = run (f s) s
 195 run (Result x p) s = (x, s) : run p s
 196 run (Final r) _ = r
 197 run _ _ = []
 198
 199 -- ---------------------------------------------------------------------------
 200 -- Operations over ReadP
 201
 202 get :: ReadP r Char
 203 -- ^ Consumes and returns the next character.
 204 --   Fails if there is no input left.
 205 get = R Get
 206
 207 look :: ReadP r String
 208 -- ^ Look-ahead: returns the part of the input that is left, without
 209 --   consuming it.
 210 look = R Look
 211
 212 pfail :: ReadP r a
 213 -- ^ Always fails.
 214 pfail = R (const Fail)
 215
 216 eof :: ReadP r ()
 217 -- ^ Succeeds iff we are at the end of input
 218 eof = do
 219   s <- look
 220   if null s
 221     then return ()
 222     else pfail
 223
 224 (+++) :: ReadP r a -> ReadP r a -> ReadP r a
 225 -- ^ Symmetric choice.
 226 R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
 227
 228 (<++) :: ReadP a a -> ReadP r a -> ReadP r a
 229 -- ^ Local, exclusive, left-biased choice: If left parser
 230 --   locally produces any result at all, then right parser is
 231 --   not used.
 232 R f <++ q =
 233   do
 234     s <- look
 235     probe (f return) s 0
 236   where
 237     probe (Get f') (c : s) n = probe (f' c) s (n + 1 :: Int)
 238     probe (Look f') s n = probe (f' s) s n
 239     probe p@(Result _ _) _ n = discard n >> R (p >>=)
 240     probe (Final r) _ _ = R (Final r >>=)
 241     probe _ _ _ = q
 242
 243     discard 0 = return ()
 244     discard n = get >> discard (n - 1 :: Int)
 245
 246 gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
 247 -- ^ Transforms a parser into one that does the same, but
 248 --   in addition returns the exact characters read.
 249 --   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
 250 --   is built using any occurrences of readS_to_P.
 251 gather (R m) =
 252   R (\k -> gath id (m (\a -> return (\s -> k (s, a)))))
 253   where
 254     gath l (Get f) = Get (\c -> gath (l . (c :)) (f c))
 255     gath _ Fail = Fail
 256     gath l (Look f) = Look (gath l . f)
 257     gath l (Result k p) = k (l []) `mplus` gath l p
 258     gath _ (Final _) = error "do not use readS_to_P in gather!"
 259
 260 -- ---------------------------------------------------------------------------
 261 -- Derived operations
 262
 263 satisfy :: (Char -> Bool) -> ReadP r Char
 264 -- ^ Consumes and returns the next character, if it satisfies the
 265 --   specified predicate.
 266 satisfy p = do c <- get; if p c then return c else pfail
 267
 268 char :: Char -> ReadP r Char
 269 -- ^ Parses and returns the specified character.
 270 char c = satisfy (c ==)
 271
 272 string :: String -> ReadP r String
 273 -- ^ Parses and returns the specified string.
 274 string this = do s <- look; scan this s
 275   where
 276     scan [] _ = return this
 277     scan (x : xs) (y : ys) | x == y = get >> scan xs ys
 278     scan _ _ = pfail
 279
 280 munch :: (Char -> Bool) -> ReadP r String
 281 -- ^ Parses the first zero or more characters satisfying the predicate.
 282 munch p =
 283   do
 284     s <- look
 285     scan s
 286   where
 287     scan (c : cs) | p c = do _ <- get; s <- scan cs; return (c : s)
 288     scan _ = do return ""
 289
 290 munch1 :: (Char -> Bool) -> ReadP r String
 291 -- ^ Parses the first one or more characters satisfying the predicate.
 292 munch1 p =
 293   do
 294     c <- get
 295     if p c
 296       then do s <- munch p; return (c : s)
 297       else pfail
 298
 299 choice :: [ReadP r a] -> ReadP r a
 300 -- ^ Combines all parsers in the specified list.
 301 choice [] = pfail
 302 choice [p] = p
 303 choice (p : ps) = p +++ choice ps
 304
 305 skipSpaces :: ReadP r ()
 306 -- ^ Skips all whitespace.
 307 skipSpaces =
 308   do
 309     s <- look
 310     skip s
 311   where
 312     skip (c : s) | isSpace c = do _ <- get; skip s
 313     skip _ = do return ()
 314
 315 skipSpaces1 :: ReadP r ()
 316 -- ^ Like 'skipSpaces' but succeeds only if there is at least one
 317 -- whitespace character to skip.
 318 skipSpaces1 = satisfy isSpace >> skipSpaces
 319
 320 count :: Int -> ReadP r a -> ReadP r [a]
 321 -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
 322 --   results is returned.
 323 count n p = replicateM n p
 324
 325 between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
 326 -- ^ @ between open close p @ parses @open@, followed by @p@ and finally
 327 --   @close@. Only the value of @p@ is returned.
 328 between open close p = do
 329   _ <- open
 330   x <- p
 331   _ <- close
 332   return x
 333
 334 option :: a -> ReadP r a -> ReadP r a
 335 -- ^ @option x p@ will either parse @p@ or return @x@ without consuming
 336 --   any input.
 337 option x p = p +++ return x
 338
 339 optional :: ReadP r a -> ReadP r ()
 340 -- ^ @optional p@ optionally parses @p@ and always returns @()@.
 341 optional p = (p >> return ()) +++ return ()
 342
 343 many :: ReadP r a -> ReadP r [a]
 344 -- ^ Parses zero or more occurrences of the given parser.
 345 many p = return [] +++ many1 p
 346
 347 many1 :: ReadP r a -> ReadP r [a]
 348 -- ^ Parses one or more occurrences of the given parser.
 349 many1 p = liftM2 (:) p (many p)
 350
 351 skipMany :: ReadP r a -> ReadP r ()
 352 -- ^ Like 'many', but discards the result.
 353 skipMany p = many p >> return ()
 354
 355 skipMany1 :: ReadP r a -> ReadP r ()
 356 -- ^ Like 'many1', but discards the result.
 357 skipMany1 p = p >> skipMany p
 358
 359 sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
 360 -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
 361 --   Returns a list of values returned by @p@.
 362 sepBy p sep = sepBy1 p sep +++ return []
 363
 364 sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
 365 -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
 366 --   Returns a list of values returned by @p@.
 367 sepBy1 p sep = liftM2 (:) p (many (sep >> p))
 368
 369 endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
 370 -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
 371 --   by @sep@.
 372 endBy p sep = many (do x <- p; _ <- sep; return x)
 373
 374 endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
 375 -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
 376 --   by @sep@.
 377 endBy1 p sep = many1 (do x <- p; _ <- sep; return x)
 378
 379 chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
 380 -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
 381 --   Returns a value produced by a /right/ associative application of all
 382 --   functions returned by @op@. If there are no occurrences of @p@, @x@ is
 383 --   returned.
 384 chainr p op x = chainr1 p op +++ return x
 385
 386 chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
 387 -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
 388 --   Returns a value produced by a /left/ associative application of all
 389 --   functions returned by @op@. If there are no occurrences of @p@, @x@ is
 390 --   returned.
 391 chainl p op x = chainl1 p op +++ return x
 392
 393 chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
 394 -- ^ Like 'chainr', but parses one or more occurrences of @p@.
 395 chainr1 p op = scan
 396   where
 397     scan = p >>= rest
 398     rest x =
 399       do
 400         f <- op
 401         y <- scan
 402         return (f x y)
 403         +++ return x
 404
 405 chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
 406 -- ^ Like 'chainl', but parses one or more occurrences of @p@.
 407 chainl1 p op = p >>= rest
 408   where
 409     rest x =
 410       do
 411         f <- op
 412         y <- p
 413         rest (f x y)
 414         +++ return x
 415
 416 manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
 417 -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
 418 --   succeeds. Returns a list of values returned by @p@.
 419 manyTill p end = scan
 420   where
 421     scan = (end >> return []) <++ (liftM2 (:) p scan)
 422
 423 -- ---------------------------------------------------------------------------
 424 -- Converting between ReadP and Read
 425
 426 readP_to_S :: ReadP a a -> ReadS a
 427 -- ^ Converts a parser into a Haskell ReadS-style function.
 428 --   This is the main way in which you can \"run\" a 'ReadP' parser:
 429 --   the expanded type is
 430 -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
 431 readP_to_S (R f) = run (f return)
 432
 433 readS_to_P :: ReadS a -> ReadP r a
 434 -- ^ Converts a Haskell ReadS-style function into a parser.
 435 --   Warning: This introduces local backtracking in the resulting
 436 --   parser, and therefore a possible inefficiency.
 437 readS_to_P r =
 438   R (\k -> Look (\s -> final [bs'' | (a, s') <- r s, bs'' <- run (k a) s']))
 439
 440 -------------------------------------------------------------------------------
 441 -- ReadE
 442 -------------------------------------------------------------------------------
 443
 444 readP_to_E :: (String -> String) -> ReadP a a -> ReadE a
 445 readP_to_E err r =
 446   ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt, all isSpace s
 447                        ] of
 448     [] -> Left (err txt)
 449     (p : _) -> Right p