Cabal/src/Distribution/ReadE.hs

   1 {-# LANGUAGE LambdaCase #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -- |
   6 -- Module      :  Distribution.ReadE
   7 -- Copyright   :  Jose Iborra 2008
   8 -- License     :  BSD3
   9 --
  10 -- Maintainer  :  cabal-devel@haskell.org
  11 -- Portability :  portable
  12 --
  13 -- Simple parsing with failure
  14 module Distribution.ReadE
  15   ( -- * ReadE
  16     ReadE (..)
  17   , succeedReadE
  18   , failReadE
  19
  20     -- * Projections
  21   , parsecToReadE
  22   , parsecToReadEErr
  23
  24     -- * Parse Errors
  25   , unexpectMsgString
  26   ) where
  27
  28 import qualified Data.Bifunctor as Bi (first)
  29 import Distribution.Compat.Prelude
  30 import Prelude ()
  31
  32 import Distribution.Parsec
  33 import Distribution.Parsec.FieldLineStream
  34 import qualified Text.Parsec.Error as Parsec
  35
  36 -- | Parser with simple error reporting
  37 newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}
  38
  39 type ErrorMsg = String
  40
  41 instance Functor ReadE where
  42   fmap f (ReadE p) = ReadE $ \txt -> case p txt of
  43     Right a -> Right (f a)
  44     Left err -> Left err
  45
  46 succeedReadE :: (String -> a) -> ReadE a
  47 succeedReadE f = ReadE (Right . f)
  48
  49 failReadE :: ErrorMsg -> ReadE a
  50 failReadE = ReadE . const . Left
  51
  52 runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a
  53 runParsecFromString p txt =
  54   runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt)
  55
  56 parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a
  57 parsecToReadE err p = ReadE $ \txt ->
  58   const (err txt) `Bi.first` runParsecFromString p txt
  59
  60 parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a
  61 parsecToReadEErr err p =
  62   ReadE $
  63     Bi.first err . runParsecFromString p
  64
  65 -- Show only unexpected error messages
  66 unexpectMsgString :: Parsec.ParseError -> String
  67 unexpectMsgString =
  68   unlines
  69     . map Parsec.messageString
  70     . filter (\case Parsec.UnExpect _ -> True; _ -> False)
  71     . Parsec.errorMessages