{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Fields.ParseResult (
ParseResult,
runParseResult,
recoverWith,
parseWarning,
parseWarnings,
parseFailure,
parseFatalFailure,
parseFatalFailure',
getCabalSpecVersion,
setCabalSpecVersion,
readAndParseFile,
parseString,
withoutWarnings,
) where
import qualified Data.ByteString.Char8 as BS
import Distribution.Compat.Prelude
import Distribution.Parsec.Error (PError (..), showPError)
import Distribution.Parsec.Position (Position (..), zeroPos)
import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning)
import Distribution.Simple.Utils (die', warn)
import Distribution.Verbosity (Verbosity)
import Distribution.Version (Version)
import Prelude ()
import System.Directory (doesFileExist)
#if MIN_VERSION_base(4,10,0)
import Control.Applicative (Applicative (..))
#endif
newtype ParseResult a = PR
{ forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR
:: forall r. PRState
-> (PRState -> r)
-> (PRState -> a -> r)
-> r
}
data PRState = PRState ![PWarning] ![PError] !(Maybe Version)
emptyPRState :: PRState
emptyPRState :: PRState
emptyPRState = [PWarning] -> [PError] -> Maybe Version -> PRState
PRState [] [] forall a. Maybe a
Nothing
withoutWarnings :: ParseResult a -> ParseResult a
withoutWarnings :: forall a. ParseResult a -> ParseResult a
withoutWarnings ParseResult a
m = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \PRState
s PRState -> r
failure PRState -> a -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
m PRState
s PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 -> PRState -> a -> r
success (PRState
s1 PRState -> PRState -> PRState
`withWarningsOf` PRState
s)
where
withWarningsOf :: PRState -> PRState -> PRState
withWarningsOf (PRState [PWarning]
_ [PError]
e Maybe Version
v) (PRState [PWarning]
w [PError]
_ Maybe Version
_) = [PWarning] -> [PError] -> Maybe Version -> PRState
PRState [PWarning]
w [PError]
e Maybe Version
v
runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult :: forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult ParseResult a
pr = forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
pr PRState
emptyPRState forall {b}.
PRState -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
failure forall {b}.
PRState
-> b -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
success
where
failure :: PRState -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
failure (PRState [PWarning]
warns [] Maybe Version
v) = ([PWarning]
warns, forall a b. a -> Either a b
Left (Maybe Version
v, Position -> String -> PError
PError Position
zeroPos String
"panic" forall a. a -> [a] -> NonEmpty a
:| []))
failure (PRState [PWarning]
warns (PError
err:[PError]
errs) Maybe Version
v) = ([PWarning]
warns, forall a b. a -> Either a b
Left (Maybe Version
v, PError
err forall a. a -> [a] -> NonEmpty a
:| [PError]
errs)) where
success :: PRState
-> b -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
success (PRState [PWarning]
warns [] Maybe Version
_) b
x = ([PWarning]
warns, forall a b. b -> Either a b
Right b
x)
success (PRState [PWarning]
warns (PError
err:[PError]
errs) Maybe Version
v) b
_ = ([PWarning]
warns, forall a b. a -> Either a b
Left (Maybe Version
v, PError
err forall a. a -> [a] -> NonEmpty a
:| [PError]
errs))
instance Functor ParseResult where
fmap :: forall a b. (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
f (PR forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
pr) = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
failure PRState -> b -> r
success ->
forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
pr PRState
s PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s' a
a ->
PRState -> b -> r
success PRState
s' (a -> b
f a
a)
{-# INLINE fmap #-}
instance Applicative ParseResult where
pure :: forall a. a -> ParseResult a
pure a
x = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
_ PRState -> a -> r
success -> PRState -> a -> r
success PRState
s a
x
{-# INLINE pure #-}
ParseResult (a -> b)
f <*> :: forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
<*> ParseResult a
x = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> b -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult (a -> b)
f PRState
s0 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a -> b
f' ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s1 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s2 a
x' ->
PRState -> b -> r
success PRState
s2 (a -> b
f' a
x')
{-# INLINE (<*>) #-}
ParseResult a
x *> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
*> ParseResult b
y = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> b -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s0 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a
_ ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult b
y PRState
s1 PRState -> r
failure PRState -> b -> r
success
{-# INLINE (*>) #-}
ParseResult a
x <* :: forall a b. ParseResult a -> ParseResult b -> ParseResult a
<* ParseResult b
y = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> a -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s0 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a
x' ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult b
y PRState
s1 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s2 b
_ ->
PRState -> a -> r
success PRState
s2 a
x'
{-# INLINE (<*) #-}
#if MIN_VERSION_base(4,10,0)
liftA2 :: forall a b c.
(a -> b -> c) -> ParseResult a -> ParseResult b -> ParseResult c
liftA2 a -> b -> c
f ParseResult a
x ParseResult b
y = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> c -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s0 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a
x' ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult b
y PRState
s1 PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s2 b
y' ->
PRState -> c -> r
success PRState
s2 (a -> b -> c
f a
x' b
y')
{-# INLINE liftA2 #-}
#endif
instance Monad ParseResult where
return :: forall a. a -> ParseResult a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
>> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
ParseResult a
m >>= :: forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= a -> ParseResult b
k = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
failure PRState -> b -> r
success ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
m PRState
s PRState -> r
failure forall a b. (a -> b) -> a -> b
$ \ !PRState
s' a
a ->
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR (a -> ParseResult b
k a
a) PRState
s' PRState -> r
failure PRState -> b -> r
success
{-# INLINE (>>=) #-}
recoverWith :: ParseResult a -> a -> ParseResult a
recoverWith :: forall a. ParseResult a -> a -> ParseResult a
recoverWith (PR forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
pr) a
x = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
_failure PRState -> a -> r
success ->
forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
pr PRState
s (\ !PRState
s' -> PRState -> a -> r
success PRState
s' a
x) PRState -> a -> r
success
setCabalSpecVersion :: Maybe Version -> ParseResult ()
setCabalSpecVersion :: Maybe Version -> ParseResult ()
setCabalSpecVersion Maybe Version
v = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \(PRState [PWarning]
warns [PError]
errs Maybe Version
_) PRState -> r
_failure PRState -> () -> r
success ->
PRState -> () -> r
success ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState [PWarning]
warns [PError]
errs Maybe Version
v) ()
getCabalSpecVersion :: ParseResult (Maybe Version)
getCabalSpecVersion :: ParseResult (Maybe Version)
getCabalSpecVersion = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \s :: PRState
s@(PRState [PWarning]
_ [PError]
_ Maybe Version
v) PRState -> r
_failure PRState -> Maybe Version -> r
success ->
PRState -> Maybe Version -> r
success PRState
s Maybe Version
v
parseWarning :: Position -> PWarnType -> String -> ParseResult ()
parseWarning :: Position -> PWarnType -> String -> ParseResult ()
parseWarning Position
pos PWarnType
t String
msg = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \(PRState [PWarning]
warns [PError]
errs Maybe Version
v) PRState -> r
_failure PRState -> () -> r
success ->
PRState -> () -> r
success ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState (PWarnType -> Position -> String -> PWarning
PWarning PWarnType
t Position
pos String
msg forall a. a -> [a] -> [a]
: [PWarning]
warns) [PError]
errs Maybe Version
v) ()
parseWarnings :: [PWarning] -> ParseResult ()
parseWarnings :: [PWarning] -> ParseResult ()
parseWarnings [PWarning]
newWarns = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \(PRState [PWarning]
warns [PError]
errs Maybe Version
v) PRState -> r
_failure PRState -> () -> r
success ->
PRState -> () -> r
success ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState ([PWarning]
newWarns forall a. [a] -> [a] -> [a]
++ [PWarning]
warns) [PError]
errs Maybe Version
v) ()
parseFailure :: Position -> String -> ParseResult ()
parseFailure :: Position -> String -> ParseResult ()
parseFailure Position
pos String
msg = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \(PRState [PWarning]
warns [PError]
errs Maybe Version
v) PRState -> r
_failure PRState -> () -> r
success ->
PRState -> () -> r
success ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState [PWarning]
warns (Position -> String -> PError
PError Position
pos String
msg forall a. a -> [a] -> [a]
: [PError]
errs) Maybe Version
v) ()
parseFatalFailure :: Position -> String -> ParseResult a
parseFatalFailure :: forall a. Position -> String -> ParseResult a
parseFatalFailure Position
pos String
msg = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall a b. (a -> b) -> a -> b
$ \(PRState [PWarning]
warns [PError]
errs Maybe Version
v) PRState -> r
failure PRState -> a -> r
_success ->
PRState -> r
failure ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState [PWarning]
warns (Position -> String -> PError
PError Position
pos String
msg forall a. a -> [a] -> [a]
: [PError]
errs) Maybe Version
v)
parseFatalFailure' :: ParseResult a
parseFatalFailure' :: forall a. ParseResult a
parseFatalFailure' = forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR forall {t} {p}. PRState -> (PRState -> t) -> p -> t
pr
where
pr :: PRState -> (PRState -> t) -> p -> t
pr (PRState [PWarning]
warns [] Maybe Version
v) PRState -> t
failure p
_success = PRState -> t
failure ([PWarning] -> [PError] -> Maybe Version -> PRState
PRState [PWarning]
warns [PError
err] Maybe Version
v)
pr PRState
s PRState -> t
failure p
_success = PRState -> t
failure PRState
s
err :: PError
err = Position -> String -> PError
PError Position
zeroPos String
"Unknown fatal error"
readAndParseFile
:: (BS.ByteString -> ParseResult a)
-> Verbosity
-> FilePath
-> IO a
readAndParseFile :: forall a.
(ByteString -> ParseResult a) -> Verbosity -> String -> IO a
readAndParseFile ByteString -> ParseResult a
parser Verbosity
verbosity String
fpath = do
Bool
exists <- String -> IO Bool
doesFileExist String
fpath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"Error Parsing: file \"" forall a. [a] -> [a] -> [a]
++ String
fpath forall a. [a] -> [a] -> [a]
++ String
"\" doesn't exist. Cannot continue."
ByteString
bs <- String -> IO ByteString
BS.readFile String
fpath
forall a.
(ByteString -> ParseResult a)
-> Verbosity -> String -> ByteString -> IO a
parseString ByteString -> ParseResult a
parser Verbosity
verbosity String
fpath ByteString
bs
parseString
:: (BS.ByteString -> ParseResult a)
-> Verbosity
-> String
-> BS.ByteString
-> IO a
parseString :: forall a.
(ByteString -> ParseResult a)
-> Verbosity -> String -> ByteString -> IO a
parseString ByteString -> ParseResult a
parser Verbosity
verbosity String
name ByteString
bs = do
let ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) a
result) = forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ByteString -> ParseResult a
parser ByteString
bs)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PWarning -> String
showPWarning String
name) [PWarning]
warnings
case Either (Maybe Version, NonEmpty PError) a
result of
Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Left (Maybe Version
_, NonEmpty PError
errors) -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PError -> String
showPError String
name) NonEmpty PError
errors
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Failed parsing \"" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"\"."