{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
#if MIN_VERSION_mtl(2,3,0)
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
#endif
module Control.Monad.Trans.Fail (
Fail,
runFail,
runFailLast,
runFailAgg,
errorFail,
errorFailWithoutStackTrace,
FailT (..),
FailException (..),
failT,
failManyT,
runFailT,
runFailLastT,
runFailAggT,
hoistFailT,
mapFailT,
mapErrorFailT,
mapErrorsFailT,
exceptFailT,
throwErrorFailT,
throwFailT,
liftCatch,
liftListen,
liftPass,
) where
import Control.Applicative
import Control.Exception
import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Cont
import Control.Monad.Except
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Fix
#endif
import qualified Control.Monad.Fail as F
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Zip
import Data.Bifunctor (first)
import Data.Functor.Classes
import Data.Functor.Identity
import Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
import Data.Typeable
import GHC.Exts
import GHC.Stack
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Accum
import Control.Monad.Select
#endif
#if !(MIN_VERSION_base(4,13,0))
#define IS_MONAD_STRING IsString e,
#else
#define IS_MONAD_STRING
#endif
type Fail e = FailT e Identity
runFail :: (IsString e, Semi.Semigroup e) => Fail e a -> Either e a
runFail :: forall e a. (IsString e, Semigroup e) => Fail e a -> Either e a
runFail = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a.
(IsString e, Semigroup e, Functor m) =>
FailT e m a -> m (Either e a)
runFailT
{-# INLINE runFail #-}
runFailLast :: IsString e => Fail e a -> Either e a
runFailLast :: forall e a. IsString e => Fail e a -> Either e a
runFailLast = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a.
(IsString e, Functor m) =>
FailT e m a -> m (Either e a)
runFailLastT
{-# INLINE runFailLast #-}
runFailAgg :: Fail e a -> Either [e] a
runFailAgg :: forall e a. Fail e a -> Either [e] a
runFailAgg = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT
{-# INLINE runFailAgg #-}
errorFail :: (Show e, HasCallStack) => Fail e a -> a
errorFail :: forall e a. (Show e, HasCallStack) => Fail e a -> a
errorFail = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (IsString e, Semigroup e) => [e] -> e
toFailureDelimited forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> [Char]
show) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Fail e a -> Either [e] a
runFailAgg
errorFailWithoutStackTrace :: Show e => Fail e a -> a
errorFailWithoutStackTrace :: forall e a. Show e => Fail e a -> a
errorFailWithoutStackTrace =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> a
errorWithoutStackTrace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (IsString e, Semigroup e) => [e] -> e
toFailureDelimited forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> [Char]
show) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Fail e a -> Either [e] a
runFailAgg
newtype FailT e m a = FailT (m (Either [e] a))
failT :: Applicative m => e -> FailT e m a
failT :: forall (m :: * -> *) e a. Applicative m => e -> FailT e m a
failT = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE failT #-}
failManyT :: Applicative m => [e] -> FailT e m a
failManyT :: forall (m :: * -> *) e a. Applicative m => [e] -> FailT e m a
failManyT = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
{-# INLINE failManyT #-}
runFailT :: (IsString e, Semi.Semigroup e, Functor m) => FailT e m a -> m (Either e a)
runFailT :: forall e (m :: * -> *) a.
(IsString e, Semigroup e, Functor m) =>
FailT e m a -> m (Either e a)
runFailT (FailT m (Either [e] a)
f) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (IsString e, Semigroup e) => [e] -> e
toFailureDelimited) forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either [e] a)
f
{-# INLINE runFailT #-}
runFailLastT :: (IsString e, Functor m) => FailT e m a -> m (Either e a)
runFailLastT :: forall e (m :: * -> *) a.
(IsString e, Functor m) =>
FailT e m a -> m (Either e a)
runFailLastT (FailT m (Either [e] a)
f) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. IsString e => [e] -> NonEmpty e
toFailureNonEmpty) forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either [e] a)
f
{-# INLINE runFailLastT #-}
runFailAggT :: FailT e m a -> m (Either [e] a)
runFailAggT :: forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT (FailT m (Either [e] a)
f) = m (Either [e] a)
f
{-# INLINE runFailAggT #-}
hoistFailT :: (forall a. m a -> n a) -> FailT e m b -> FailT e n b
hoistFailT :: forall (m :: * -> *) (n :: * -> *) e b.
(forall a. m a -> n a) -> FailT e m b -> FailT e n b
hoistFailT forall a. m a -> n a
f = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT
{-# INLINE hoistFailT #-}
mapFailT :: (m (Either [e] a) -> n (Either [e] b)) -> FailT e m a -> FailT e n b
mapFailT :: forall (m :: * -> *) e a (n :: * -> *) b.
(m (Either [e] a) -> n (Either [e] b))
-> FailT e m a -> FailT e n b
mapFailT m (Either [e] a) -> n (Either [e] b)
f = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either [e] a) -> n (Either [e] b)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT
{-# INLINE mapFailT #-}
mapErrorFailT :: Functor m => (e -> e') -> FailT e m a -> FailT e' m a
mapErrorFailT :: forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> FailT e m a -> FailT e' m a
mapErrorFailT e -> e'
f = forall (m :: * -> *) e e' a.
Functor m =>
([e] -> [e']) -> FailT e m a -> FailT e' m a
mapErrorsFailT (forall a b. (a -> b) -> [a] -> [b]
map e -> e'
f)
{-# INLINE mapErrorFailT #-}
mapErrorsFailT :: Functor m => ([e] -> [e']) -> FailT e m a -> FailT e' m a
mapErrorsFailT :: forall (m :: * -> *) e e' a.
Functor m =>
([e] -> [e']) -> FailT e m a -> FailT e' m a
mapErrorsFailT [e] -> [e']
f (FailT m (Either [e] a)
m) = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [e] -> [e']
f) m (Either [e] a)
m)
{-# INLINE mapErrorsFailT #-}
exceptFailT :: (HasCallStack, Typeable e, Show e, Monad m) => FailT e m a -> ExceptT FailException m a
exceptFailT :: forall e (m :: * -> *) a.
(HasCallStack, Typeable e, Show e, Monad m) =>
FailT e m a -> ExceptT FailException m a
exceptFailT FailT e m a
m =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT FailT e m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
x
Left [e]
errMsgs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
FailException
{ failMessages :: [e]
failMessages = [e]
errMsgs
, failCallStack :: CallStack
failCallStack = HasCallStack
?callStack
}
{-# INLINE exceptFailT #-}
throwErrorFailT
:: (HasCallStack, Typeable e, Show e, MonadError FailException m)
=> FailT e m a
-> m a
throwErrorFailT :: forall e (m :: * -> *) a.
(HasCallStack, Typeable e, Show e, MonadError FailException m) =>
FailT e m a -> m a
throwErrorFailT FailT e m a
m =
forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT FailT e m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left [e]
errMsgs ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
FailException
{ failMessages :: [e]
failMessages = [e]
errMsgs
, failCallStack :: CallStack
failCallStack = HasCallStack
?callStack
}
{-# INLINE throwErrorFailT #-}
data FailException where
FailException
:: (Typeable e, Show e)
=> { ()
failMessages :: [e]
, FailException -> CallStack
failCallStack :: CallStack
}
-> FailException
instance Show FailException where
show :: FailException -> [Char]
show FailException{[e]
failMessages :: [e]
failMessages :: ()
failMessages, CallStack
failCallStack :: CallStack
failCallStack :: FailException -> CallStack
failCallStack} =
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
forall a. a -> [a] -> [a]
intersperse [Char]
"\n" forall a b. (a -> b) -> a -> b
$
[Char]
"FailException"
forall a. a -> [a] -> [a]
: forall a. NonEmpty a -> [a]
NE.toList (forall e. IsString e => [e] -> NonEmpty e
toFailureNonEmpty (forall a. Show a => a -> [Char]
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e]
failMessages))
forall a. [a] -> [a] -> [a]
++ [CallStack -> [Char]
prettyCallStack CallStack
failCallStack]
instance Exception FailException
toFailureNonEmpty :: IsString e => [e] -> NE.NonEmpty e
toFailureNonEmpty :: forall e. IsString e => [e] -> NonEmpty e
toFailureNonEmpty [e]
xs =
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [e]
xs of
Maybe (NonEmpty e)
Nothing -> e
"No failure reason given" forall a. a -> [a] -> NonEmpty a
NE.:| []
Just NonEmpty e
ne -> NonEmpty e
ne
toFailureDelimited :: (IsString e, Semi.Semigroup e) => [e] -> e
toFailureDelimited :: forall e. (IsString e, Semigroup e) => [e] -> e
toFailureDelimited = forall a. Semigroup a => NonEmpty a -> a
Semi.sconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse e
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. IsString e => [e] -> NonEmpty e
toFailureNonEmpty
throwFailT :: (HasCallStack, Typeable e, Show e, MonadThrow m) => FailT e m a -> m a
throwFailT :: forall e (m :: * -> *) a.
(HasCallStack, Typeable e, Show e, MonadThrow m) =>
FailT e m a -> m a
throwFailT FailT e m a
f = do
forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT FailT e m a
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left [e]
errMsgs ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
FailException
{ failMessages :: [e]
failMessages = [e]
errMsgs
, failCallStack :: CallStack
failCallStack = HasCallStack
?callStack
}
{-# INLINEABLE throwFailT #-}
instance Functor m => Functor (FailT e m) where
fmap :: forall a b. (a -> b) -> FailT e m a -> FailT e m b
fmap a -> b
f (FailT m (Either [e] a)
m) = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (Either [e] a)
m)
{-# INLINE fmap #-}
instance (IS_MONAD_STRING Monad m) => Applicative (FailT e m) where
pure :: forall a. a -> FailT e m a
pure = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
{-# INLINE pure #-}
FailT m (Either [e] (a -> b))
m <*> :: forall a b. FailT e m (a -> b) -> FailT e m a -> FailT e m b
<*> FailT m (Either [e] a)
k =
forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$
m (Either [e] (a -> b))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left [e]
merr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [e]
merr
Right a -> b
f ->
m (Either [e] a)
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left [e]
kerr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [e]
kerr
Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a -> b
f a
a)
{-# INLINE (<*>) #-}
FailT e m a
m *> :: forall a b. FailT e m a -> FailT e m b -> FailT e m b
*> FailT e m b
k = FailT e m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> FailT e m b
k
{-# INLINE (*>) #-}
instance (IS_MONAD_STRING Monad m) => Monad (FailT e m) where
FailT m (Either [e] a)
m >>= :: forall a b. FailT e m a -> (a -> FailT e m b) -> FailT e m b
>>= a -> FailT e m b
k =
forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$
m (Either [e] a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left [e]
merr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [e]
merr
Right a
a -> forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT forall a b. (a -> b) -> a -> b
$ a -> FailT e m b
k a
a
{-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
fail = FailT . return . Left . pure . fromString
{-# INLINE fail #-}
#endif
instance (IsString e, Monad m) => F.MonadFail (FailT e m) where
fail :: forall a. [Char] -> FailT e m a
fail = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString
{-# INLINE fail #-}
instance Foldable f => Foldable (FailT e f) where
foldMap :: forall m a. Monoid m => (a -> m) -> FailT e f a -> m
foldMap a -> m
f (FailT f (Either [e] a)
m) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) a -> m
f) f (Either [e] a)
m
{-# INLINE foldMap #-}
instance Traversable f => Traversable (FailT e f) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FailT e f a -> f (FailT e f b)
traverse a -> f b
f (FailT f (Either [e] a)
m) = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)) f (Either [e] a)
m
{-# INLINE traverse #-}
instance (IS_MONAD_STRING Monad m) => Alternative (FailT e m) where
empty :: forall a. FailT e m a
empty = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left [])
{-# INLINE empty #-}
FailT m (Either [e] a)
m <|> :: forall a. FailT e m a -> FailT e m a -> FailT e m a
<|> FailT m (Either [e] a)
k = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ do
m (Either [e] a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left [e]
merr ->
m (Either [e] a)
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left [e]
kerr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [e]
merr forall a. [a] -> [a] -> [a]
++ [e]
kerr
Right a
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
result
Right a
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
result
{-# INLINEABLE (<|>) #-}
instance (IS_MONAD_STRING Monad m, Semi.Semigroup a) => Semi.Semigroup (FailT e m a) where
<> :: FailT e m a -> FailT e m a -> FailT e m a
(<>) (FailT m (Either [e] a)
m) (FailT m (Either [e] a)
k) = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ do
Either [e] a
mres <- m (Either [e] a)
m
Either [e] a
kres <- m (Either [e] a)
k
case Either [e] a
mres of
Left [e]
merr ->
case Either [e] a
kres of
Left [e]
kerr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [e]
merr forall a. [a] -> [a] -> [a]
++ [e]
kerr
Right a
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
y
Right a
x ->
case Either [e] a
kres of
Left [e]
_kerr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
x
Right a
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a
x forall a. Semigroup a => a -> a -> a
Semi.<> a
y)
{-# INLINEABLE (<>) #-}
instance (IS_MONAD_STRING Monad m, Semi.Semigroup a) => Monoid (FailT e m a) where
mempty :: FailT e m a
mempty = forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
mappend = (Semi.<>)
#endif
instance (IS_MONAD_STRING MonadIO m) => MonadIO (FailT e m) where
liftIO :: forall a. IO a -> FailT e m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE liftIO #-}
instance MonadTrans (FailT e) where
lift :: forall (m :: * -> *) a. Monad m => m a -> FailT e m a
lift = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right
{-# INLINE lift #-}
instance (IS_MONAD_STRING MonadZip m) => MonadZip (FailT e m) where
mzipWith :: forall a b c.
(a -> b -> c) -> FailT e m a -> FailT e m b -> FailT e m c
mzipWith a -> b -> c
f (FailT m (Either [e] a)
a) (FailT m (Either [e] b)
b) = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f) m (Either [e] a)
a m (Either [e] b)
b
{-# INLINE mzipWith #-}
instance (IS_MONAD_STRING MonadFix m) => MonadFix (FailT e m) where
mfix :: forall a. (a -> FailT e m a) -> FailT e m a
mfix a -> FailT e m a
f = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FailT e m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {p} {a}. p -> a
explode forall a. a -> a
id))
where
explode :: p -> a
explode p
_errMsgs = forall a. HasCallStack => [Char] -> a
error [Char]
"mfix (FailT): inner computation returned Left value"
{-# INLINE mfix #-}
#if MIN_VERSION_base(4,12,0)
instance Contravariant f => Contravariant (FailT e f) where
contramap :: forall a' a. (a' -> a) -> FailT e f a -> FailT e f a'
contramap a' -> a
f = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a' -> a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT
{-# INLINE contramap #-}
#endif
instance (Eq e, Eq1 m) => Eq1 (FailT e m) where
liftEq :: forall a b. (a -> b -> Bool) -> FailT e m a -> FailT e m b -> Bool
liftEq a -> b -> Bool
eq (FailT m (Either [e] a)
x) (FailT m (Either [e] b)
y) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq) m (Either [e] a)
x m (Either [e] b)
y
{-# INLINE liftEq #-}
instance (Ord e, Ord1 m) => Ord1 (FailT e m) where
liftCompare :: forall a b.
(a -> b -> Ordering) -> FailT e m a -> FailT e m b -> Ordering
liftCompare a -> b -> Ordering
comp (FailT m (Either [e] a)
x) (FailT m (Either [e] b)
y) =
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
comp) m (Either [e] a)
x m (Either [e] b)
y
{-# INLINE liftCompare #-}
instance (Read e, Read1 m) => Read1 (FailT e m) where
liftReadsPrec :: forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (FailT e m a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl =
forall a. ([Char] -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
forall a t.
(Int -> ReadS a) -> [Char] -> (a -> t) -> [Char] -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Either [e] a)
rp' ReadS [Either [e] a]
rl') [Char]
"FailT" forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT
where
rp' :: Int -> ReadS (Either [e] a)
rp' = forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl
rl' :: ReadS [Either [e] a]
rl' = forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl
instance (Show e, Show1 m) => Show1 (FailT e m) where
liftShowsPrec :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FailT e m a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (FailT m (Either [e] a)
m) =
forall a. (Int -> a -> ShowS) -> [Char] -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> Either [e] a -> ShowS
sp' [Either [e] a] -> ShowS
sl') [Char]
"FailT" Int
d m (Either [e] a)
m
where
sp' :: Int -> Either [e] a -> ShowS
sp' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl
sl' :: [Either [e] a] -> ShowS
sl' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl
instance (Eq e, Eq1 m, Eq a) => Eq (FailT e m a) where
== :: FailT e m a -> FailT e m a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1
{-# INLINE (==) #-}
instance (Ord e, Ord1 m, Ord a) => Ord (FailT e m a) where
compare :: FailT e m a -> FailT e m a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1
{-# INLINE compare #-}
instance (Read e, Read1 m, Read a) => Read (FailT e m a) where
readsPrec :: Int -> ReadS (FailT e m a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1
instance (Show e, Show1 m, Show a) => Show (FailT e m a) where
showsPrec :: Int -> FailT e m a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
instance (IS_MONAD_STRING MonadThrow m) => MonadThrow (FailT e m) where
throwM :: forall e a. Exception e => e -> FailT e m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
{-# INLINE throwM #-}
instance (IS_MONAD_STRING MonadReader r m) => MonadReader r (FailT e m) where
ask :: FailT e m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
{-# INLINE ask #-}
local :: forall a. (r -> r) -> FailT e m a -> FailT e m a
local = forall (m :: * -> *) e a (n :: * -> *) b.
(m (Either [e] a) -> n (Either [e] b))
-> FailT e m a -> FailT e n b
mapFailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
{-# INLINE local #-}
reader :: forall a. (r -> a) -> FailT e m a
reader = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader
{-# INLINE reader #-}
instance (IS_MONAD_STRING MonadState s m) => MonadState s (FailT e m) where
get :: FailT e m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
{-# INLINE get #-}
put :: s -> FailT e m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put
{-# INLINE put #-}
state :: forall a. (s -> (a, s)) -> FailT e m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
{-# INLINE state #-}
instance (IS_MONAD_STRING MonadError e m) => MonadError e (FailT e m) where
throwError :: forall a. e -> FailT e m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
{-# INLINE throwError #-}
catchError :: forall a. FailT e m a -> (e -> FailT e m a) -> FailT e m a
catchError = forall (m :: * -> *) e a.
(m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a))
-> FailT e m a -> (e -> FailT e m a) -> FailT e m a
liftCatch forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
{-# INLINE catchError #-}
instance (IS_MONAD_STRING MonadWriter w m) => MonadWriter w (FailT e m) where
writer :: forall a. (a, w) -> FailT e m a
writer = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer
{-# INLINE writer #-}
tell :: w -> FailT e m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
{-# INLINE tell #-}
listen :: forall a. FailT e m a -> FailT e m (a, w)
listen = forall (m :: * -> *) e a w.
Monad m =>
(m (Either [e] a) -> m (Either [e] a, w))
-> FailT e m a -> FailT e m (a, w)
liftListen forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
{-# INLINE listen #-}
pass :: forall a. FailT e m (a, w -> w) -> FailT e m a
pass = forall (m :: * -> *) e a w.
Monad m =>
(m (Either [e] a, w -> w) -> m (Either [e] a))
-> FailT e m (a, w -> w) -> FailT e m a
liftPass forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass
{-# INLINE pass #-}
instance (IS_MONAD_STRING MonadRWS r w s m) => MonadRWS r w s (FailT e m)
instance (IS_MONAD_STRING MonadCont m) => MonadCont (FailT e m) where
callCC :: forall a b. ((a -> FailT e m b) -> FailT e m a) -> FailT e m a
callCC = forall e a (m :: * -> *) b.
(((Either [e] a -> m (Either [e] b)) -> m (Either [e] a))
-> m (Either [e] a))
-> ((a -> FailT e m b) -> FailT e m a) -> FailT e m a
liftCallCC forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC
{-# INLINE callCC #-}
liftCallCC
:: (((Either [e] a -> m (Either [e] b)) -> m (Either [e] a)) -> m (Either [e] a))
-> ((a -> FailT e m b) -> FailT e m a)
-> FailT e m a
liftCallCC :: forall e a (m :: * -> *) b.
(((Either [e] a -> m (Either [e] b)) -> m (Either [e] a))
-> m (Either [e] a))
-> ((a -> FailT e m b) -> FailT e m a) -> FailT e m a
liftCallCC ((Either [e] a -> m (Either [e] b)) -> m (Either [e] a))
-> m (Either [e] a)
ccc (a -> FailT e m b) -> FailT e m a
f = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ ((Either [e] a -> m (Either [e] b)) -> m (Either [e] a))
-> m (Either [e] a)
ccc forall a b. (a -> b) -> a -> b
$ \Either [e] a -> m (Either [e] b)
c ->
forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT ((a -> FailT e m b) -> FailT e m a
f (forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either [e] a -> m (Either [e] b)
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right))
{-# INLINE liftCallCC #-}
liftCatch
:: (m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a))
-> FailT e m a
-> (e -> FailT e m a)
-> FailT e m a
liftCatch :: forall (m :: * -> *) e a.
(m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a))
-> FailT e m a -> (e -> FailT e m a) -> FailT e m a
liftCatch m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a)
f FailT e m a
m e -> FailT e m a
h = forall e (m :: * -> *) a. m (Either [e] a) -> FailT e m a
FailT forall a b. (a -> b) -> a -> b
$ m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a)
f (forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT FailT e m a
m) (forall e (m :: * -> *) a. FailT e m a -> m (Either [e] a)
runFailAggT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FailT e m a
h)
{-# INLINE liftCatch #-}
liftListen
:: Monad m
=> (m (Either [e] a) -> m (Either [e] a, w))
-> (FailT e m) a
-> (FailT e m) (a, w)
liftListen :: forall (m :: * -> *) e a w.
Monad m =>
(m (Either [e] a) -> m (Either [e] a, w))
-> FailT e m a -> FailT e m (a, w)
liftListen m (Either [e] a) -> m (Either [e] a, w)
l = forall (m :: * -> *) e a (n :: * -> *) b.
(m (Either [e] a) -> n (Either [e] b))
-> FailT e m a -> FailT e n b
mapFailT forall a b. (a -> b) -> a -> b
$ \m (Either [e] a)
m -> do
(Either [e] a
a, w
w) <- m (Either [e] a) -> m (Either [e] a, w)
l m (Either [e] a)
m
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
r -> (a
r, w
w)) Either [e] a
a
{-# INLINE liftListen #-}
liftPass
:: Monad m
=> (m (Either [e] a, w -> w) -> m (Either [e] a))
-> (FailT e m) (a, w -> w)
-> (FailT e m) a
liftPass :: forall (m :: * -> *) e a w.
Monad m =>
(m (Either [e] a, w -> w) -> m (Either [e] a))
-> FailT e m (a, w -> w) -> FailT e m a
liftPass m (Either [e] a, w -> w) -> m (Either [e] a)
p = forall (m :: * -> *) e a (n :: * -> *) b.
(m (Either [e] a) -> n (Either [e] b))
-> FailT e m a -> FailT e n b
mapFailT forall a b. (a -> b) -> a -> b
$ \m (Either [e] (a, w -> w))
m -> m (Either [e] a, w -> w) -> m (Either [e] a)
p forall a b. (a -> b) -> a -> b
$ do
Either [e] (a, w -> w)
a <- m (Either [e] (a, w -> w))
m
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Either [e] (a, w -> w)
a of
Left [e]
errs -> (forall a b. a -> Either a b
Left [e]
errs, forall a. a -> a
id)
Right (a
v, w -> w
f) -> (forall a b. b -> Either a b
Right a
v, w -> w
f)
{-# INLINE liftPass #-}
#if MIN_VERSION_mtl(2,3,0)
deriving via
(LiftingAccum (FailT e) m)
instance
(MonadAccum w m) =>
MonadAccum w (FailT e m)
deriving via
(LiftingSelect (FailT e) m)
instance
(MonadSelect r m) =>
MonadSelect r (FailT e m)
#endif