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
newtype ParseResult a = PR
{ unPR
:: forall r. PRState
-> (PRState -> r)
-> (PRState -> a -> r)
-> r
}
data PRState = PRState ![PWarning] ![PError] !(Maybe Version)
emptyPRState :: PRState
emptyPRState = PRState [] [] Nothing
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
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)
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)
instance Applicative ParseResult where
pure x = PR $ \ !s _ success -> success s x
f <*> x = PR $ \ !s0 failure success ->
unPR f s0 failure $ \ !s1 f' ->
unPR x s1 failure $ \ !s2 x' ->
success s2 (f' x')
x *> y = PR $ \ !s0 failure success ->
unPR x s0 failure $ \ !s1 _ ->
unPR y s1 failure success
x <* y = PR $ \ !s0 failure success ->
unPR x s0 failure $ \ !s1 x' ->
unPR y s1 failure $ \ !s2 _ ->
success s2 x'
#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')
#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
recoverWith :: ParseResult a -> a -> ParseResult a
recoverWith (PR pr) x = PR $ \ !s _failure success ->
pr s (\ !s' -> success s' x) success
setCabalSpecVersion :: Maybe Version -> ParseResult ()
setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success ->
success (PRState warns errs v) ()
getCabalSpecVersion :: ParseResult (Maybe Version)
getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success ->
success s v
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) ()
parseWarnings :: [PWarning] -> ParseResult ()
parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success ->
success (PRState (newWarns ++ warns) errs v) ()
parseFailure :: Position -> String -> ParseResult ()
parseFailure pos msg = PR $ \(PRState warns errs v) _failure success ->
success (PRState warns (PError pos msg : errs) v) ()
parseFatalFailure :: Position -> String -> ParseResult a
parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success ->
failure (PRState warns (PError pos msg : errs) v)
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"
readAndParseFile
:: (BS.ByteString -> ParseResult a)
-> Verbosity
-> FilePath
-> 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)
-> Verbosity
-> String
-> 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 ++ "\"."