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 ++ "\"."