-- The MPTCs and FlexibleInstances are only for
-- mtl:Control.Monad.{Error,Except}.MonadError
{-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
----------------------------------------------------------------
--                                                  ~ 2021.11.07
-- |
-- Module      :  Control.Monad.EitherK
-- License     :  BSD
-- Maintainer  :  wren@cpan.org
-- Stability   :  provisional
-- Portability :  semi-portable (CPP, Rank2Types, MPTCs, FlexibleInstances)
--
-- A continuation-passing variant of 'Either' for short-circuiting
-- at failure. This code is based on "Control.Monad.MaybeK".
----------------------------------------------------------------
module Control.Monad.EitherK
    (
    -- * The short-circuiting monad
      EitherK()
    , runEitherK
    , toEitherK
    , eitherK
    , throwEitherK
    , catchEitherK
    -- * The short-circuiting monad transformer
    , EitherKT()
    , runEitherKT
    , toEitherKT
    , liftEitherK
    , lowerEitherK
    , throwEitherKT
    , catchEitherKT
    ) where

#if __GLASGOW_HASKELL__ < 710
import Data.Monoid          (Monoid(..))
import Control.Applicative  (Applicative(..))
#endif
import Control.Applicative  (Alternative(..))
import Control.Monad        (MonadPlus(..))
import Control.Monad.Trans  (MonadTrans(..))
#if (MIN_VERSION_mtl(2,2,1))
-- aka: transformers(0,4,1)
import Control.Monad.Except (MonadError(..))
#else
import Control.Monad.Error  (MonadError(..))
#endif
----------------------------------------------------------------
----------------------------------------------------------------

-- | A continuation-passing encoding of 'Either' as an error monad;
-- also known as @Codensity (Either e)@, if you're familiar with
-- that terminology. N.B., this is not the 2-continuation implementation
-- based on the Church encoding of @Either@. The latter tends to
-- have worse performance than non-continuation based implementations.
--
-- This is generally more efficient than using @Either@ (or the
-- MTL's @Error@) for two reasons. First is that it right associates
-- all binds, ensuring that bad associativity doesn't artificially
-- introduce midpoints in short-circuiting to the nearest handler.
-- Second is that it removes the need for intermediate case
-- expressions.
--
-- Another benefit over MTL's @Error@ is that it doesn't artificially
-- restrict the error type. In fact, there's no reason why @e@ must
-- denote \"errors\" per se. This could also denote computations
-- which short-circuit with the final answer, or similar methods
-- of non-local control flow.
--
-- N.B., the 'Alternative' and 'MonadPlus' instances are left-biased
-- in @a@ and monoidal in @e@. Thus, they are not commutative.
newtype EitherK e a = EK (forall r. (a -> Either e r) -> Either e r)


-- | Execute an @EitherK@ and return the concrete @Either@ encoding.
runEitherK :: EitherK e a -> Either e a
{-# INLINE runEitherK #-}
runEitherK :: EitherK e a -> Either e a
runEitherK (EK forall r. (a -> Either e r) -> Either e r
m) = (a -> Either e a) -> Either e a
forall r. (a -> Either e r) -> Either e r
m a -> Either e a
forall a b. b -> Either a b
Right


-- | Lift an @Either@ into an @EitherK@.
toEitherK :: Either e a -> EitherK e a
{-# INLINE toEitherK #-}
toEitherK :: Either e a -> EitherK e a
toEitherK (Left  e
e) = e -> EitherK e a
forall e a. e -> EitherK e a
throwEitherK e
e
toEitherK (Right a
a) = a -> EitherK e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


-- | Throw an error in the @EitherK@ monad. This is identical to
-- 'throwError'.
throwEitherK :: e -> EitherK e a
{-# INLINE throwEitherK #-}
throwEitherK :: e -> EitherK e a
throwEitherK e
e = (forall r. (a -> Either e r) -> Either e r) -> EitherK e a
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\a -> Either e r
_ -> e -> Either e r
forall a b. a -> Either a b
Left e
e)


-- | Handle errors in the @EitherK@ monad. N.B., this type is more
-- general than that of 'catchError', allowing the type of the
-- errors to change.
catchEitherK :: EitherK e a -> (e -> EitherK f a) -> EitherK f a
{-# INLINE catchEitherK #-}
catchEitherK :: EitherK e a -> (e -> EitherK f a) -> EitherK f a
catchEitherK EitherK e a
m e -> EitherK f a
handler = (e -> EitherK f a)
-> (a -> EitherK f a) -> EitherK e a -> EitherK f a
forall e b a. (e -> b) -> (a -> b) -> EitherK e a -> b
eitherK e -> EitherK f a
handler a -> EitherK f a
forall (m :: * -> *) a. Monad m => a -> m a
return EitherK e a
m


-- | A version of 'either' on @EitherK@, for convenience. N.B.,
-- using this function inserts a case match, reducing the range of
-- short-circuiting.
eitherK :: (e -> b) -> (a -> b) -> EitherK e a -> b
{-# INLINE eitherK #-}
eitherK :: (e -> b) -> (a -> b) -> EitherK e a -> b
eitherK e -> b
left a -> b
right EitherK e a
m =
    case EitherK e a -> Either e a
forall e a. EitherK e a -> Either e a
runEitherK EitherK e a
m of
    Left  e
e -> e -> b
left  e
e
    Right a
a -> a -> b
right a
a


instance Functor (EitherK e) where
    fmap :: (a -> b) -> EitherK e a -> EitherK e b
fmap a -> b
f (EK forall r. (a -> Either e r) -> Either e r
m) = (forall r. (b -> Either e r) -> Either e r) -> EitherK e b
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\b -> Either e r
k -> (a -> Either e r) -> Either e r
forall r. (a -> Either e r) -> Either e r
m (b -> Either e r
k (b -> Either e r) -> (a -> b) -> a -> Either e r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
    a
x <$ :: a -> EitherK e b -> EitherK e a
<$ EK forall r. (b -> Either e r) -> Either e r
m     = (forall r. (a -> Either e r) -> Either e r) -> EitherK e a
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\a -> Either e r
k -> (b -> Either e r) -> Either e r
forall r. (b -> Either e r) -> Either e r
m (\b
_ -> a -> Either e r
k a
x))

instance Applicative (EitherK e) where
    pure :: a -> EitherK e a
pure a
x        = (forall r. (a -> Either e r) -> Either e r) -> EitherK e a
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\a -> Either e r
k -> a -> Either e r
k a
x)
    EK forall r. ((a -> b) -> Either e r) -> Either e r
m <*> :: EitherK e (a -> b) -> EitherK e a -> EitherK e b
<*> EK forall r. (a -> Either e r) -> Either e r
n = (forall r. (b -> Either e r) -> Either e r) -> EitherK e b
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\b -> Either e r
k -> ((a -> b) -> Either e r) -> Either e r
forall r. ((a -> b) -> Either e r) -> Either e r
m (\a -> b
f -> (a -> Either e r) -> Either e r
forall r. (a -> Either e r) -> Either e r
n (b -> Either e r
k (b -> Either e r) -> (a -> b) -> a -> Either e r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)))
    EK forall r. (a -> Either e r) -> Either e r
m  *> :: EitherK e a -> EitherK e b -> EitherK e b
*> EK forall r. (b -> Either e r) -> Either e r
n = (forall r. (b -> Either e r) -> Either e r) -> EitherK e b
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\b -> Either e r
k -> (a -> Either e r) -> Either e r
forall r. (a -> Either e r) -> Either e r
m (\a
_ -> (b -> Either e r) -> Either e r
forall r. (b -> Either e r) -> Either e r
n b -> Either e r
k))
    EK forall r. (a -> Either e r) -> Either e r
m <* :: EitherK e a -> EitherK e b -> EitherK e a
<*  EK forall r. (b -> Either e r) -> Either e r
n = (forall r. (a -> Either e r) -> Either e r) -> EitherK e a
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\a -> Either e r
k -> (a -> Either e r) -> Either e r
forall r. (a -> Either e r) -> Either e r
m (\a
x -> (b -> Either e r) -> Either e r
forall r. (b -> Either e r) -> Either e r
n (\b
_ -> a -> Either e r
k a
x)))

-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@.
-- Since ghc-9.2.1 we get a warning about providing any other
-- definition, and should instead define both 'pure' and @(*>)@
-- directly, leaving 'return' and @(>>)@ as their defaults so they
-- can eventually be removed from the class.
-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>
--
-- However, base-4.16 (ghc-9.2.1) still uses the @m >> n = m >>= \_ -> n@
-- default.  In principle, that ought to compile down to the same
-- thing as our @(*>)@; however, there's a decent chance the case
-- analysis on @n@ won't get lifted out from under the lambdas, and
-- thus the default definition would loose the strictness of the
-- second argument.  Therefore, we're going to keep defining @(>>)@
-- until whatever future version of GHC actually removes it from
-- the class to make it a proper alias of @(*>)@.
instance Monad (EitherK e) where
#if (!(MIN_VERSION_base(4,8,0)))
    return     = pure
#endif
    >> :: EitherK e a -> EitherK e b -> EitherK e b
(>>)       = EitherK e a -> EitherK e b -> EitherK e b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    EK forall r. (a -> Either e r) -> Either e r
m >>= :: EitherK e a -> (a -> EitherK e b) -> EitherK e b
>>= a -> EitherK e b
f = (forall r. (b -> Either e r) -> Either e r) -> EitherK e b
forall e a.
(forall r. (a -> Either e r) -> Either e r) -> EitherK e a
EK (\b -> Either e r
k -> (a -> Either e r) -> Either e r
forall r. (a -> Either e r) -> Either e r
m (\a
a -> case a -> EitherK e b
f a
a of EK forall r. (b -> Either e r) -> Either e r
n -> (b -> Either e r) -> Either e r
forall r. (b -> Either e r) -> Either e r
n b -> Either e r
k))
    -- Using case instead of let seems to improve performance
    -- considerably by removing excessive laziness.

-- TODO: is there anything to optimize over the default definitions
-- of 'some' and 'many'?
instance (Monoid e) => Alternative (EitherK e) where
    empty :: EitherK e a
empty   = e -> EitherK e a
forall e a. e -> EitherK e a
throwEitherK e
forall a. Monoid a => a
mempty
    EitherK e a
m <|> :: EitherK e a -> EitherK e a -> EitherK e a
<|> EitherK e a
n = EitherK e a -> (e -> EitherK e a) -> EitherK e a
forall e a f. EitherK e a -> (e -> EitherK f a) -> EitherK f a
catchEitherK EitherK e a
m ((e -> EitherK e a) -> EitherK e a)
-> (e -> EitherK e a) -> EitherK e a
forall a b. (a -> b) -> a -> b
$ \e
me ->
              EitherK e a -> (e -> EitherK e a) -> EitherK e a
forall e a f. EitherK e a -> (e -> EitherK f a) -> EitherK f a
catchEitherK EitherK e a
n ((e -> EitherK e a) -> EitherK e a)
-> (e -> EitherK e a) -> EitherK e a
forall a b. (a -> b) -> a -> b
$ \e
ne ->
              e -> EitherK e a
forall e a. e -> EitherK e a
throwEitherK   (e -> EitherK e a) -> e -> EitherK e a
forall a b. (a -> b) -> a -> b
$ e
me e -> e -> e
forall a. Monoid a => a -> a -> a
`mappend` e
ne

instance (Monoid e) => MonadPlus (EitherK e)
#if (!(MIN_VERSION_base(4,8,0)))
  where
    mzero = empty
    mplus = (<|>)
#endif

instance MonadError e (EitherK e) where
    throwError :: e -> EitherK e a
throwError = e -> EitherK e a
forall e a. e -> EitherK e a
throwEitherK
    catchError :: EitherK e a -> (e -> EitherK e a) -> EitherK e a
catchError = EitherK e a -> (e -> EitherK e a) -> EitherK e a
forall e a f. EitherK e a -> (e -> EitherK f a) -> EitherK f a
catchEitherK

----------------------------------------------------------------
----------------------------------------------------------------

-- | A monad transformer version of 'EitherK'.
newtype EitherKT e m a =
    EKT (forall r. (a -> m (Either e r)) -> m (Either e r))


-- | Execute an @EitherKT@ and return the concrete @Either@ encoding.
runEitherKT :: (Applicative m) => EitherKT e m a -> m (Either e a)
{-# INLINE runEitherKT #-}
runEitherKT :: EitherKT e m a -> m (Either e a)
runEitherKT (EKT forall r. (a -> m (Either e r)) -> m (Either e r)
m) = (a -> m (Either e a)) -> m (Either e a)
forall r. (a -> m (Either e r)) -> m (Either e r)
m (Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (a -> Either e a) -> a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right)


-- | Lift an @Either@ into an @EitherKT@.
toEitherKT :: (Applicative m) => Either e a -> EitherKT e m a
{-# INLINE toEitherKT #-}
toEitherKT :: Either e a -> EitherKT e m a
toEitherKT (Left  e
e) = e -> EitherKT e m a
forall (m :: * -> *) e a. Applicative m => e -> EitherKT e m a
throwEitherKT e
e
toEitherKT (Right a
a) = a -> EitherKT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a


-- | Lift an @EitherK@ into an @EitherKT@.
liftEitherK :: (Applicative m) => EitherK e a -> EitherKT e m a
{-# INLINE liftEitherK #-}
liftEitherK :: EitherK e a -> EitherKT e m a
liftEitherK = Either e a -> EitherKT e m a
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> EitherKT e m a
toEitherKT (Either e a -> EitherKT e m a)
-> (EitherK e a -> Either e a) -> EitherK e a -> EitherKT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EitherK e a -> Either e a
forall e a. EitherK e a -> Either e a
runEitherK
--
-- With the above implementation, when @liftEitherK x@ is forced
-- it will force not only @x = EK m@, but will also force @m@. If
-- we want to force only @x@ and to defer @m@, then we should use
-- the following implementation instead:
--
-- > liftEitherK (EK m) = EKT (\k -> either (return . Left) k (m Right))
--
-- Or if we want to defer both @m@ and @x@, then we could use:
--
-- > liftEitherK x = EKT (\k -> either (return . Left) k (runEitherK x))
--
-- However, all versions need to reify @m@ at some point, and
-- therefore will lose short-circuiting. This is necessary since
-- given some @k :: a -> m (Either e r)@ we have no way of constructing
-- the needed @k' :: a -> Either e r@ from it without prematurely
-- executing the side-effects.


-- | Lower an @EitherKT@ into an @EitherK@.
lowerEitherK :: (Applicative m) => EitherKT e m a -> m (EitherK e a)
{-# INLINE lowerEitherK #-}
lowerEitherK :: EitherKT e m a -> m (EitherK e a)
lowerEitherK = (Either e a -> EitherK e a) -> m (Either e a) -> m (EitherK e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e a -> EitherK e a
forall e a. Either e a -> EitherK e a
toEitherK (m (Either e a) -> m (EitherK e a))
-> (EitherKT e m a -> m (Either e a))
-> EitherKT e m a
-> m (EitherK e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EitherKT e m a -> m (Either e a)
forall (m :: * -> *) e a.
Applicative m =>
EitherKT e m a -> m (Either e a)
runEitherKT


-- | Throw an error in the @EitherKT@ monad. This is identical to
-- 'throwError'.
throwEitherKT :: (Applicative m) => e -> EitherKT e m a
{-# INLINE throwEitherKT #-}
throwEitherKT :: e -> EitherKT e m a
throwEitherKT e
e = (forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\a -> m (Either e r)
_ -> Either e r -> m (Either e r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Either e r
forall a b. a -> Either a b
Left e
e))


-- | Handle errors in the @EitherKT@ monad. N.B., this type is more
-- general than that of 'catchError', allowing the type of the
-- errors to change.
catchEitherKT
    :: (Applicative m, Monad m)
    => EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a
{-# INLINE catchEitherKT #-}
catchEitherKT :: EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a
catchEitherKT EitherKT e m a
m e -> EitherKT f m a
handler = (forall r. (a -> m (Either f r)) -> m (Either f r))
-> EitherKT f m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT ((forall r. (a -> m (Either f r)) -> m (Either f r))
 -> EitherKT f m a)
-> (forall r. (a -> m (Either f r)) -> m (Either f r))
-> EitherKT f m a
forall a b. (a -> b) -> a -> b
$ \a -> m (Either f r)
k ->
    EitherKT e m a -> m (Either e a)
forall (m :: * -> *) e a.
Applicative m =>
EitherKT e m a -> m (Either e a)
runEitherKT EitherKT e m a
m m (Either e a) -> (Either e a -> m (Either f r)) -> m (Either f r)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either e a
ea ->
    case Either e a
ea of
    Left  e
e -> case e -> EitherKT f m a
handler e
e of EKT forall r. (a -> m (Either f r)) -> m (Either f r)
n -> (a -> m (Either f r)) -> m (Either f r)
forall r. (a -> m (Either f r)) -> m (Either f r)
n a -> m (Either f r)
k
    Right a
a -> a -> m (Either f r)
k a
a


instance Functor (EitherKT e m) where
    fmap :: (a -> b) -> EitherKT e m a -> EitherKT e m b
fmap a -> b
f (EKT forall r. (a -> m (Either e r)) -> m (Either e r)
m) = (forall r. (b -> m (Either e r)) -> m (Either e r))
-> EitherKT e m b
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\b -> m (Either e r)
k -> (a -> m (Either e r)) -> m (Either e r)
forall r. (a -> m (Either e r)) -> m (Either e r)
m (b -> m (Either e r)
k (b -> m (Either e r)) -> (a -> b) -> a -> m (Either e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
    a
x <$ :: a -> EitherKT e m b -> EitherKT e m a
<$ EKT forall r. (b -> m (Either e r)) -> m (Either e r)
m     = (forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\a -> m (Either e r)
k -> (b -> m (Either e r)) -> m (Either e r)
forall r. (b -> m (Either e r)) -> m (Either e r)
m (\b
_ -> a -> m (Either e r)
k a
x))

instance Applicative (EitherKT e m) where
    pure :: a -> EitherKT e m a
pure a
x          = (forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\a -> m (Either e r)
k -> a -> m (Either e r)
k a
x)
    EKT forall r. ((a -> b) -> m (Either e r)) -> m (Either e r)
m <*> :: EitherKT e m (a -> b) -> EitherKT e m a -> EitherKT e m b
<*> EKT forall r. (a -> m (Either e r)) -> m (Either e r)
n = (forall r. (b -> m (Either e r)) -> m (Either e r))
-> EitherKT e m b
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\b -> m (Either e r)
k -> ((a -> b) -> m (Either e r)) -> m (Either e r)
forall r. ((a -> b) -> m (Either e r)) -> m (Either e r)
m (\a -> b
f -> (a -> m (Either e r)) -> m (Either e r)
forall r. (a -> m (Either e r)) -> m (Either e r)
n (b -> m (Either e r)
k (b -> m (Either e r)) -> (a -> b) -> a -> m (Either e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)))
    EKT forall r. (a -> m (Either e r)) -> m (Either e r)
m  *> :: EitherKT e m a -> EitherKT e m b -> EitherKT e m b
*> EKT forall r. (b -> m (Either e r)) -> m (Either e r)
n = (forall r. (b -> m (Either e r)) -> m (Either e r))
-> EitherKT e m b
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\b -> m (Either e r)
k -> (a -> m (Either e r)) -> m (Either e r)
forall r. (a -> m (Either e r)) -> m (Either e r)
m (\a
_ -> (b -> m (Either e r)) -> m (Either e r)
forall r. (b -> m (Either e r)) -> m (Either e r)
n b -> m (Either e r)
k))
    EKT forall r. (a -> m (Either e r)) -> m (Either e r)
m <* :: EitherKT e m a -> EitherKT e m b -> EitherKT e m a
<*  EKT forall r. (b -> m (Either e r)) -> m (Either e r)
n = (forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\a -> m (Either e r)
k -> (a -> m (Either e r)) -> m (Either e r)
forall r. (a -> m (Either e r)) -> m (Either e r)
m (\a
x -> (b -> m (Either e r)) -> m (Either e r)
forall r. (b -> m (Either e r)) -> m (Either e r)
n (\b
_ -> a -> m (Either e r)
k a
x)))

instance Monad (EitherKT e m) where
#if (!(MIN_VERSION_base(4,8,0)))
    return      = pure
#endif
    >> :: EitherKT e m a -> EitherKT e m b -> EitherKT e m b
(>>)        = EitherKT e m a -> EitherKT e m b -> EitherKT e m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    EKT forall r. (a -> m (Either e r)) -> m (Either e r)
m >>= :: EitherKT e m a -> (a -> EitherKT e m b) -> EitherKT e m b
>>= a -> EitherKT e m b
f = (forall r. (b -> m (Either e r)) -> m (Either e r))
-> EitherKT e m b
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\b -> m (Either e r)
k -> (a -> m (Either e r)) -> m (Either e r)
forall r. (a -> m (Either e r)) -> m (Either e r)
m (\a
a -> case a -> EitherKT e m b
f a
a of EKT forall r. (b -> m (Either e r)) -> m (Either e r)
n -> (b -> m (Either e r)) -> m (Either e r)
forall r. (b -> m (Either e r)) -> m (Either e r)
n b -> m (Either e r)
k))

-- In order to define a @(<|>)@ which only requires @Applicative m@
-- we'd need a law @m (Either e a) -> Either (m e) (m a)@; or
-- equivalently, we'd need to use a 2-CPS style.
instance (Applicative m, Monad m, Monoid e) => Alternative (EitherKT e m) where
    empty :: EitherKT e m a
empty   = e -> EitherKT e m a
forall (m :: * -> *) e a. Applicative m => e -> EitherKT e m a
throwEitherKT e
forall a. Monoid a => a
mempty
    EitherKT e m a
m <|> :: EitherKT e m a -> EitherKT e m a -> EitherKT e m a
<|> EitherKT e m a
n = EitherKT e m a -> (e -> EitherKT e m a) -> EitherKT e m a
forall (m :: * -> *) e a f.
(Applicative m, Monad m) =>
EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a
catchEitherKT EitherKT e m a
m (EitherKT e m a -> (e -> EitherKT e m a) -> EitherKT e m a
forall (m :: * -> *) e a f.
(Applicative m, Monad m) =>
EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a
catchEitherKT EitherKT e m a
n ((e -> EitherKT e m a) -> EitherKT e m a)
-> (e -> e -> EitherKT e m a) -> e -> EitherKT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> EitherKT e m a
forall (m :: * -> *) e a. Applicative m => e -> EitherKT e m a
throwEitherKT (e -> EitherKT e m a) -> (e -> e) -> e -> EitherKT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((e -> e) -> e -> EitherKT e m a)
-> (e -> e -> e) -> e -> e -> EitherKT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e -> e
forall a. Monoid a => a -> a -> a
mappend)

instance (Applicative m, Monad m, Monoid e) => MonadPlus (EitherKT e m)
#if (!(MIN_VERSION_base(4,8,0)))
  where
    mzero = empty
    mplus = (<|>)
#endif

instance (Applicative m, Monad m) => MonadError e (EitherKT e m) where
    throwError :: e -> EitherKT e m a
throwError = e -> EitherKT e m a
forall (m :: * -> *) e a. Applicative m => e -> EitherKT e m a
throwEitherKT
    catchError :: EitherKT e m a -> (e -> EitherKT e m a) -> EitherKT e m a
catchError = EitherKT e m a -> (e -> EitherKT e m a) -> EitherKT e m a
forall (m :: * -> *) e a f.
(Applicative m, Monad m) =>
EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a
catchEitherKT

instance MonadTrans (EitherKT e) where
    lift :: m a -> EitherKT e m a
lift m a
m = (forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
forall e (m :: * -> *) a.
(forall r. (a -> m (Either e r)) -> m (Either e r))
-> EitherKT e m a
EKT (\a -> m (Either e r)
k -> m a
m m a -> (a -> m (Either e r)) -> m (Either e r)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m (Either e r)
k)

----------------------------------------------------------------
----------------------------------------------------------- fin.