Cabal/src/Distribution/ReadE.hs

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