{-# 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.Compat.Prelude
import Distribution.Parsec.Error (PError (..))
import Distribution.Parsec.Position (Position (..), zeroPos)
import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
import Distribution.Version (Version)

-- | 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 [] [] Maybe Version
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 r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
 -> ParseResult a)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a b. (a -> b) -> a -> b
$ \PRState
s PRState -> r
failure PRState -> a -> r
success ->
  ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
m PRState
s PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
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 = ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
pr PRState
emptyPRState PRState -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
forall {b}.
PRState -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
failure PRState
-> a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
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, (Maybe Version, NonEmpty PError)
-> Either (Maybe Version, NonEmpty PError) b
forall a b. a -> Either a b
Left (Maybe Version
v, Position -> String -> PError
PError Position
zeroPos String
"panic" PError -> [PError] -> NonEmpty PError
forall a. a -> [a] -> NonEmpty a
:| []))
    failure (PRState [PWarning]
warns (PError
err : [PError]
errs) Maybe Version
v) = ([PWarning]
warns, (Maybe Version, NonEmpty PError)
-> Either (Maybe Version, NonEmpty PError) b
forall a b. a -> Either a b
Left (Maybe Version
v, PError
err PError -> [PError] -> NonEmpty PError
forall a. a -> [a] -> NonEmpty a
:| [PError]
errs))

    success :: PRState
-> b -> ([PWarning], Either (Maybe Version, NonEmpty PError) b)
success (PRState [PWarning]
warns [] Maybe Version
_) b
x = ([PWarning]
warns, b -> Either (Maybe Version, NonEmpty PError) b
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, (Maybe Version, NonEmpty PError)
-> Either (Maybe Version, NonEmpty PError) b
forall a b. a -> Either a b
Left (Maybe Version
v, PError
err PError -> [PError] -> NonEmpty PError
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 r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
 -> ParseResult b)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
failure PRState -> b -> r
success ->
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
pr PRState
s PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
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 r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
 -> ParseResult a)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
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 r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
 -> ParseResult b)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> b -> r
success ->
    ParseResult (a -> b)
-> forall r.
   PRState -> (PRState -> r) -> (PRState -> (a -> b) -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult (a -> b)
f PRState
s0 PRState -> r
failure ((PRState -> (a -> b) -> r) -> r)
-> (PRState -> (a -> b) -> r) -> r
forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a -> b
f' ->
      ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s1 PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
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 r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
 -> ParseResult b)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> b -> r
success ->
    ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s0 PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a
_ ->
      ParseResult b
-> forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r
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 r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
 -> ParseResult a)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a b. (a -> b) -> a -> b
$ \ !PRState
s0 PRState -> r
failure PRState -> a -> r
success ->
    ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
x PRState
s0 PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \ !PRState
s1 a
x' ->
      ParseResult b
-> forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r
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) -> r) -> (PRState -> b -> r) -> r
forall a b. (a -> b) -> a -> b
$ \ !PRState
s2 b
_ ->
        PRState -> a -> r
success PRState
s2 a
x'
  {-# INLINE (<*) #-}

instance Monad ParseResult where
  return :: forall a. a -> ParseResult a
return = a -> ParseResult a
forall a. a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
(>>) = ParseResult a -> ParseResult b -> ParseResult b
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 r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
 -> ParseResult b)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> b -> r) -> r)
-> ParseResult b
forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
failure PRState -> b -> r
success ->
    ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall a.
ParseResult a
-> forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
unPR ParseResult a
m PRState
s PRState -> r
failure ((PRState -> a -> r) -> r) -> (PRState -> a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \ !PRState
s' a
a ->
      ParseResult b
-> forall r. PRState -> (PRState -> r) -> (PRState -> b -> r) -> r
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 r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
 -> ParseResult a)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a b. (a -> b) -> a -> b
$ \ !PRState
s PRState -> r
_failure PRState -> a -> r
success ->
  PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
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 r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
 -> ParseResult ())
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
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 r.
 PRState -> (PRState -> r) -> (PRState -> Maybe Version -> r) -> r)
-> ParseResult (Maybe Version)
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r.
  PRState -> (PRState -> r) -> (PRState -> Maybe Version -> r) -> r)
 -> ParseResult (Maybe Version))
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> Maybe Version -> r) -> r)
-> ParseResult (Maybe Version)
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 r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
 -> ParseResult ())
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
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 PWarning -> [PWarning] -> [PWarning]
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 r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
 -> ParseResult ())
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
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 [PWarning] -> [PWarning] -> [PWarning]
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 r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
 -> ParseResult ())
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> () -> r) -> r)
-> ParseResult ()
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 PError -> [PError] -> [PError]
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 r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR ((forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
 -> ParseResult a)
-> (forall r.
    PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
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 PError -> [PError] -> [PError]
forall a. a -> [a] -> [a]
: [PError]
errs) Maybe Version
v)

-- | A 'mzero'.
parseFatalFailure' :: ParseResult a
parseFatalFailure' :: forall a. ParseResult a
parseFatalFailure' = (forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
forall a.
(forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r)
-> ParseResult a
PR PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
forall r. PRState -> (PRState -> r) -> (PRState -> a -> r) -> r
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"