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

import qualified Data.ByteString.Char8 as BS
import Distribution.Compat.Prelude
import Distribution.Parsec.Common
       ( PError (..), PWarnType (..), PWarning (..), Position (..), zeroPos
       , showPWarning, showPError)
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
    }

data PRState = PRState ![PWarning] ![PError] !(Maybe Version)

emptyPRState :: PRState
emptyPRState = PRState [] [] Nothing

-- | 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, [PError]) a)
runParseResult pr = unPR pr emptyPRState failure success
  where
    failure (PRState warns errs v)   = (warns, Left (v, errs))
    success (PRState warns [] _)   x = (warns, Right x)
    -- If there are any errors, don't return the result
    success (PRState warns errs v) _ = (warns, Left (v, 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 ++ "\"."