{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Control.Monad.Trans.Fail
-- Copyright   : (c) Alexey Kuleshevich 2022-2023
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>
-- Stability   : experimental
-- Portability : non-portable
module Control.Monad.Trans.Fail (
  -- * Fail
  Fail,
  runFail,
  runFailLast,
  runFailAgg,
  errorFail,
  errorFailWithoutStackTrace,

  -- * FailT
  FailT (..),
  FailException (..),
  failT,
  runFailT,
  runFailLastT,
  runFailAggT,
  hoistFailT,
  mapFailT,
  mapErrorFailT,
  mapErrorsFailT,
  exceptFailT,
  throwFailT,

  -- * Helpers
  liftCatch,
  liftListen,
  liftPass,
) where

import Control.Applicative
import Control.Exception
import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Cont
import Control.Monad.Except
import qualified Control.Monad.Fail as F
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 Data.Semigroup
import Data.Typeable
import GHC.Exts
import GHC.Stack
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif

-- | `FailT` transformer with `Identity` as the base monad.
type Fail e = FailT e Identity

-- | Unwrap the pure `Fail` monad and reveal the underlying result of monadic
-- computation.
--
-- >>> runFail (fail "Something went wrong") :: Either String ()
-- Left "Something went wrong"
-- >>> runFail (failT "Something went wrong" >> pure ())
-- Left "Something went wrong"
-- >>> import Control.Applicative
-- >>> runFail (failT "Something could have gone wrong" <|> pure ())
-- Right ()
--
-- All errors accrued during the monadic computation will be combined using the
-- `Semigroup` instance and delimited by a comma:
--
-- >>> runFail (fail "One thing went wrong" <|> fail "Another thing went wrong") :: Either String ()
-- Left "One thing went wrong, Another thing went wrong"
--
-- Failing with one of instances functions `mempty` or `empty` will yield a no-reason
-- error report:
--
-- >>> runFail mempty :: Either String ()
-- Left "No failure reason given"
runFail :: (IsString e, 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 #-}

-- | This is a variant of `runFailAgg` where only the error reported for the very last
-- failed computation will be produced and others discarded. This is useful when it is not
-- relevant to retain information about all the attempts and only the last one matters,
-- eg. parsing with backtracking.
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 #-}

-- | Convert a `Fail` monad computation in an `Either`, where the `Left` will contain all
-- failures in the same order they where received, or `Right` upon a successful computation.
--
-- >>> runFailAgg (fail "One bad thing" <|> fail "Another bad thing") :: Either [String] ()
-- Left ["One bad thing","Another bad thing"]
-- >>> runFailAgg (fail "A bad thing" <|> pure "A good thing") :: Either [String] String
-- Right "A good thing"
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 #-}

-- | Throw an error if there was a failure, otherwise return the result of
-- computation. Use `throwFailT` in case you'd like to handle an actual exception in some
-- other underlying monad.
--
-- >>> errorFail (fail "This didn't work" :: Fail String ())
-- *** Exception: "This didn't work"
-- CallStack (from HasCallStack):
-- ...
-- >>> errorFail (fail "This didn't work" <|> pure "That Worked" :: Fail String String)
-- "That Worked"
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

-- | Same as `errorFail`, but without the stack trace:
--
-- >>> errorFailWithoutStackTrace (fail "This didn't work" :: Fail String ())
-- *** Exception: "This didn't work"
-- >>> errorFailWithoutStackTrace (fail "This didn't work" <|> pure "That Worked" :: Fail String String)
-- "That Worked"
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

-- | Fail monad transformer that plays well with `F.MonadFail` type class.
newtype FailT e m a = FailT (m (Either [e] a))

-- | Similar to `fail`, but it is not restricted to `String`.
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

-- | Similar to `runFail`, except underlying monad is not restricted to `Identity`.
--
-- Unwrap the `FailT` monad transformer and produce an action that can be executed in
-- the underlying monad and, which will produce either a comma delimited error message
-- upon a failure or the result otherwise.
--
-- >>> runFailT (failT "Could have failed" <|> liftIO (putStrLn "Nothing went wrong"))
-- Nothing went wrong
-- Right ()
runFailT :: (IsString e, 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 #-}

-- | Similar to `runFailLast`, except underlying monad is not restricted to `Identity`.
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 #-}

-- | Similar to `runFailAgg`, except underlying monad is not restricted to `Identity`.
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 #-}

-- | Change the underlying monad with the hoisting function.
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 #-}

-- | Map a function over the underlying representation of the `FailT` monad.
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 #-}

-- | Map a function over the error type in the `FailT` monad.
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 #-}

-- | Map a function over the aggregation of errors in the `FailT` monad. Could be used for
-- example for clearing our all of the aggregated error messages:
--
-- >>> runFail (mapErrorsFailT (const []) $ failT "Something went wrong") :: Either String ()
-- Left "No failure reason given"
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 #-}

-- | Convert a `FailT` computation into an `ExceptT`.
--
-- >>> exceptFailT (fail "A bad thing" >> pure () :: Fail String ())
-- ExceptT (Identity (Left FailException
-- "A bad thing"
-- CallStack (from HasCallStack):
-- ...
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 #-}

-- | An exception that is produced by the `FailT` monad transformer.
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, Semigroup e) => [e] -> e
toFailureDelimited :: forall e. (IsString e, Semigroup e) => [e] -> e
toFailureDelimited = forall a. Semigroup a => NonEmpty a -> a
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

-- | Use the `MonadThrow` instance to raise a `FailException` in the underlying monad.
--
-- >>> throwFailT (failT "One thing went wrong")
-- *** Exception: FailException
-- "One thing went wrong"
-- ...
-- >>> throwFailT (failT "One thing went wrong") :: Maybe ()
-- Nothing
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 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 m (Either [e] a)
m *> :: forall a b. FailT e m a -> FailT e m b -> FailT e m b
*> FailT m (Either [e] 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (Either [e] b)
k
  {-# INLINE (*>) #-}

-- | Short-circuites on the first failing operation.
instance (IsString e, 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 #-}

-- | Short-circuits on the first successful operation, combines failures otherwise.
instance 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 forall a b. (a -> b) -> a -> b
$ a
result
      Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
x)
  {-# INLINEABLE (<|>) #-}

-- | Executes all monadic actions and combines all successful results using a `Semigroup`
-- instance. Combines together all failures as well, until a successful operation.
instance (Monad m, Semigroup a) => 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
<> a
y)
  {-# INLINEABLE (<>) #-}

instance (Monad m, Semigroup a) => Monoid (FailT e m a) where
  mempty :: FailT e m a
mempty = forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE mempty #-}

instance (IsString e, 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 (IsString e, 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 #-}

#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 (IsString e, 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 (IsString e, 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 (IsString e, 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 (IsString e, 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 (IsString e, 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 #-}

-- | Lift a @callCC@ operation to the new monad.
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 (\a
a -> 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)
c (forall a b. b -> Either a b
Right a
a)))
{-# INLINE liftCallCC #-}

-- | Lift a @`catchE`@ operation to the new monad.
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 #-}

-- | Lift a @`listen`@ operation to the new monad.
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 #-}

-- | Lift a @`pass`@ operation to the new monad.
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 #-}