Cabal/Distribution/Parsec/ParseResult.hs

   1 {-# LANGUAGE BangPatterns     #-}
   2 {-# LANGUAGE CPP              #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE RankNTypes       #-}
   5 -- | A parse result type for parsers from AST to Haskell types.
   6 module Distribution.Parsec.ParseResult (
   7     ParseResult,
   8     runParseResult,
   9     recoverWith,
  10     parseWarning,
  11     parseWarnings,
  12     parseFailure,
  13     parseFatalFailure,
  14     parseFatalFailure',
  15     getCabalSpecVersion,
  16     setCabalSpecVersion,
  17     readAndParseFile,
  18     parseString
  19     ) where
  20
  21 import qualified Data.ByteString.Char8 as BS
  22 import Distribution.Compat.Prelude
  23 import Distribution.Parsec.Common
  24        ( PError (..), PWarnType (..), PWarning (..), Position (..), zeroPos
  25        , showPWarning, showPError)
  26 import Distribution.Simple.Utils   (die', warn)
  27 import Distribution.Verbosity      (Verbosity)
  28 import Distribution.Version        (Version)
  29 import Prelude ()
  30 import System.Directory            (doesFileExist)
  31
  32 #if MIN_VERSION_base(4,10,0)
  33 import Control.Applicative (Applicative (..))
  34 #endif
  35
  36 -- | A monad with failure and accumulating errors and warnings.
  37 newtype ParseResult a = PR
  38     { unPR
  39         :: forall r. PRState
  40         -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration
  41         -> (PRState -> a -> r)             -- success
  42         -> r
  43     }
  44
  45 data PRState = PRState ![PWarning] ![PError] !(Maybe Version)
  46
  47 emptyPRState :: PRState
  48 emptyPRState = PRState [] [] Nothing
  49
  50 -- | Destruct a 'ParseResult' into the emitted warnings and either
  51 -- a successful value or
  52 -- list of errors and possibly recovered a spec-version declaration.
  53 runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, [PError]) a)
  54 runParseResult pr = unPR pr emptyPRState failure success
  55   where
  56     failure (PRState warns errs v)   = (warns, Left (v, errs))
  57     success (PRState warns [] _)   x = (warns, Right x)
  58     -- If there are any errors, don't return the result
  59     success (PRState warns errs v) _ = (warns, Left (v, errs))
  60
  61 instance Functor ParseResult where
  62     fmap f (PR pr) = PR $ \ !s failure success ->
  63         pr s failure $ \ !s' a ->
  64         success s' (f a)
  65     {-# INLINE fmap #-}
  66
  67 instance Applicative ParseResult where
  68     pure x = PR $ \ !s _ success -> success s x
  69     {-# INLINE pure #-}
  70
  71     f <*> x = PR $ \ !s0 failure success ->
  72         unPR f s0 failure $ \ !s1 f' ->
  73         unPR x s1 failure $ \ !s2 x' ->
  74         success s2 (f' x')
  75     {-# INLINE (<*>) #-}
  76
  77     x  *> y = PR $ \ !s0 failure success ->
  78         unPR x s0 failure $ \ !s1 _ ->
  79         unPR y s1 failure success
  80     {-# INLINE (*>) #-}
  81
  82     x  <* y = PR $ \ !s0 failure success ->
  83         unPR x s0 failure $ \ !s1 x' ->
  84         unPR y s1 failure $ \ !s2 _  ->
  85         success s2 x'
  86     {-# INLINE (<*) #-}
  87
  88 #if MIN_VERSION_base(4,10,0)
  89     liftA2 f x y = PR $ \ !s0 failure success ->
  90         unPR x s0 failure $ \ !s1 x' ->
  91         unPR y s1 failure $ \ !s2 y' ->
  92         success s2 (f x' y')
  93     {-# INLINE liftA2 #-}
  94 #endif
  95
  96 instance Monad ParseResult where
  97     return = pure
  98     (>>) = (*>)
  99
 100     m >>= k = PR $ \ !s failure success ->
 101         unPR m s failure $ \ !s' a ->
 102         unPR (k a) s' failure success
 103     {-# INLINE (>>=) #-}
 104
 105 -- | "Recover" the parse result, so we can proceed parsing.
 106 -- 'runParseResult' will still result in 'Nothing', if there are recorded errors.
 107 recoverWith :: ParseResult a -> a -> ParseResult a
 108 recoverWith (PR pr) x = PR $ \ !s _failure success ->
 109     pr s (\ !s' -> success s' x) success
 110
 111 -- | Set cabal spec version.
 112 setCabalSpecVersion :: Maybe Version -> ParseResult ()
 113 setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success ->
 114     success (PRState warns errs v) ()
 115
 116 -- | Get cabal spec version.
 117 getCabalSpecVersion :: ParseResult (Maybe Version)
 118 getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success ->
 119     success s v
 120
 121 -- | Add a warning. This doesn't fail the parsing process.
 122 parseWarning :: Position -> PWarnType -> String -> ParseResult ()
 123 parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success ->
 124     success (PRState (PWarning t pos msg : warns) errs v) ()
 125
 126 -- | Add multiple warnings at once.
 127 parseWarnings :: [PWarning] -> ParseResult ()
 128 parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success ->
 129     success (PRState (newWarns ++ warns) errs v) ()
 130
 131 -- | Add an error, but not fail the parser yet.
 132 --
 133 -- For fatal failure use 'parseFatalFailure'
 134 parseFailure :: Position -> String -> ParseResult ()
 135 parseFailure pos msg = PR $ \(PRState warns errs v) _failure success ->
 136     success (PRState warns (PError pos msg : errs) v) ()
 137
 138 -- | Add an fatal error.
 139 parseFatalFailure :: Position -> String -> ParseResult a
 140 parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success ->
 141     failure (PRState warns (PError pos msg : errs) v)
 142
 143 -- | A 'mzero'.
 144 parseFatalFailure' :: ParseResult a
 145 parseFatalFailure' = PR pr
 146   where
 147     pr (PRState warns [] v) failure _success = failure (PRState warns [err] v)
 148     pr s                    failure _success = failure s
 149
 150     err = PError zeroPos "Unknown fatal error"
 151
 152 -- | Helper combinator to do parsing plumbing for files.
 153 --
 154 -- Given a parser and a filename, return the parse of the file,
 155 -- after checking if the file exists.
 156 --
 157 -- Argument order is chosen to encourage partial application.
 158 readAndParseFile
 159     :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
 160     -> Verbosity                         -- ^ Verbosity level
 161     -> FilePath                          -- ^ File to read
 162     -> IO a
 163 readAndParseFile parser verbosity fpath = do
 164     exists <- doesFileExist fpath
 165     unless exists $
 166       die' verbosity $
 167         "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
 168     bs <- BS.readFile fpath
 169     parseString parser verbosity fpath bs
 170
 171 parseString
 172     :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
 173     -> Verbosity                         -- ^ Verbosity level
 174     -> String                            -- ^ File name
 175     -> BS.ByteString
 176     -> IO a
 177 parseString parser verbosity name bs = do
 178     let (warnings, result) = runParseResult (parser bs)
 179     traverse_ (warn verbosity . showPWarning name) warnings
 180     case result of
 181         Right x -> return x
 182         Left (_, errors) -> do
 183             traverse_ (warn verbosity . showPError name) errors
 184             die' verbosity $ "Failed parsing \"" ++ name ++ "\"."