{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes       #-}
-- | A parse result type for parsers from AST to Haskell types.
module Distribution.Fields.ParseResult (
    ParseResult,
    runParseResult,
    recoverWith,
    parseWarning,
    parseWarnings,
    parseFailure,
    parseFatalFailure,
    parseFatalFailure',
    getCabalSpecVersion,
    setCabalSpecVersion,
    withoutWarnings,
    ) where

import           Distribution.Parsec.Error    (PError (..))
import           Distribution.Parsec.Position (Position (..), zeroPos)
import           Distribution.Parsec.Warning  (PWarnType (..), PWarning (..))
import           Distribution.Version         (Version)
import           Prelude ()

-- liftA2 is not in base <4.10, hence we need to only import it explicitly when we're on >=4.10
--
-- Additionally, since liftA2 will be exported from Prelude starting with ~4.18, we should hide
-- it from Prelude and get it from Control.Applicative to be backwards compatible and avoid warnings
#if MIN_VERSION_base(4,10,0)
import           Distribution.Compat.Prelude hiding (Applicative(..))
import           Control.Applicative (Applicative (..))
#else
import           Distribution.Compat.Prelude
#endif

-- | A monad with failure and accumulating errors and warnings.
newtype ParseResult a = PR
    { forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR
        :: forall r. PRState
        -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration
        -> (PRState -> a -> r)             -- success
        -> r
    }

-- Note: we have version here, as we could get any version.
data PRState = PRState ![PWarning] ![PError] !(Maybe Version)

emptyPRState :: PRState
emptyPRState :: PRState
emptyPRState = [PWarning] -> [PError] -> Maybe Version -> PRState
PRState [] [] forall a. Maybe a
Nothing

-- | Forget 'ParseResult's warnings.
--
-- @since 3.4.0.0
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

-- | Destruct a 'ParseResult' into the emitted warnings and either
-- a successful value or
-- list of errors and possibly recovered a spec-version declaration.
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)
    -- If there are any errors, don't return the result
    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 (>>=) #-}

-- | "Recover" the parse result, so we can proceed parsing.
-- 'runParseResult' will still result in 'Nothing', if there are recorded errors.
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

-- | Set cabal spec version.
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) ()

-- | Get cabal spec version.
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

-- | Add a warning. This doesn't fail the parsing process.
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) ()

-- | Add multiple warnings at once.
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) ()

-- | Add an error, but not fail the parser yet.
--
-- For fatal failure use 'parseFatalFailure'
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) ()

-- | Add an fatal error.
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)

-- | A 'mzero'.
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"