src/Distribution/Fields/ParseResult.hs

    {-# 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
        { 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 [] [] Nothing

    -- | Forget 'ParseResult's warnings.
    --
    -- @since 3.4.0.0
    withoutWarnings :: ParseResult a -> ParseResult a
    withoutWarnings m = PR $ \s failure success ->
        unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s)
      where
        withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e 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 pr = unPR pr emptyPRState failure success
      where
        failure (PRState warns []         v)   = (warns, Left (v, PError zeroPos "panic" :| []))
        failure (PRState warns (err:errs) v)   = (warns, Left (v, err :| errs)) where
        success (PRState warns []         _)   x = (warns, Right x)
        -- If there are any errors, don't return the result
        success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs))

    instance Functor ParseResult where
        fmap f (PR pr) = PR $ \ !s failure success ->
            pr s failure $ \ !s' a ->
            success s' (f a)
        {-# INLINE fmap #-}

    instance Applicative ParseResult where
        pure x = PR $ \ !s _ success -> success s x
        {-# INLINE pure #-}

        f <*> x = PR $ \ !s0 failure success ->
            unPR f s0 failure $ \ !s1 f' ->
            unPR x s1 failure $ \ !s2 x' ->
            success s2 (f' x')
        {-# INLINE (<*>) #-}

        x  *> y = PR $ \ !s0 failure success ->
            unPR x s0 failure $ \ !s1 _ ->
            unPR y s1 failure success
        {-# INLINE (*>) #-}

        x  <* y = PR $ \ !s0 failure success ->
            unPR x s0 failure $ \ !s1 x' ->
            unPR y s1 failure $ \ !s2 _  ->
            success s2 x'
        {-# INLINE (<*) #-}

    #if MIN_VERSION_base(4,10,0)
        liftA2 f x y = PR $ \ !s0 failure success ->
            unPR x s0 failure $ \ !s1 x' ->
            unPR y s1 failure $ \ !s2 y' ->
            success s2 (f x' y')
        {-# INLINE liftA2 #-}
    #endif

    instance Monad ParseResult where
        return = pure
        (>>) = (*>)

        m >>= k = PR $ \ !s failure success ->
            unPR m s failure $ \ !s' a ->
            unPR (k a) s' failure 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 (PR pr) x = PR $ \ !s _failure success ->
        pr s (\ !s' -> success s' x) success

    -- | Set cabal spec version.
    setCabalSpecVersion :: Maybe Version -> ParseResult ()
    setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success ->
        success (PRState warns errs v) ()

    -- | Get cabal spec version.
    getCabalSpecVersion :: ParseResult (Maybe Version)
    getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success ->
        success s v

    -- | Add a warning. This doesn't fail the parsing process.
    parseWarning :: Position -> PWarnType -> String -> ParseResult ()
    parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success ->
        success (PRState (PWarning t pos msg : warns) errs v) ()

    -- | Add multiple warnings at once.
    parseWarnings :: [PWarning] -> ParseResult ()
    parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success ->
        success (PRState (newWarns ++ warns) errs v) ()

    -- | Add an error, but not fail the parser yet.
    --
    -- For fatal failure use 'parseFatalFailure'
    parseFailure :: Position -> String -> ParseResult ()
    parseFailure pos msg = PR $ \(PRState warns errs v) _failure success ->
        success (PRState warns (PError pos msg : errs) v) ()

    -- | Add an fatal error.
    parseFatalFailure :: Position -> String -> ParseResult a
    parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success ->
        failure (PRState warns (PError pos msg : errs) v)

    -- | A 'mzero'.
    parseFatalFailure' :: ParseResult a
    parseFatalFailure' = PR pr
      where
        pr (PRState warns [] v) failure _success = failure (PRState warns [err] v)
        pr s                    failure _success = failure s

        err = PError zeroPos "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 parser verbosity fpath = do
        exists <- doesFileExist fpath
        unless exists $
          die' verbosity $
            "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
        bs <- BS.readFile fpath
        parseString parser verbosity fpath bs

    parseString
        :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
        -> Verbosity                         -- ^ Verbosity level
        -> String                            -- ^ File name
        -> BS.ByteString
        -> IO a
    parseString parser verbosity name bs = do
        let (warnings, result) = runParseResult (parser bs)
        traverse_ (warn verbosity . showPWarning name) warnings
        case result of
            Right x -> return x
            Left (_, errors) -> do
                traverse_ (warn verbosity . showPError name) errors
                die' verbosity $ "Failed parsing \"" ++ name ++ "\"."