{-# 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,
    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

-- | 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"

-- | Helper combinator to do parsing plumbing for files.
--
-- Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
    -> Verbosity                         -- ^ Verbosity level
    -> FilePath                          -- ^ File to read
    -> 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)  -- ^ File contents to final value parser
    -> Verbosity                         -- ^ Verbosity level
    -> String                            -- ^ File name
    -> 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
"\"."