-- The MPTCs and FlexibleInstances are only for
-- mtl:Control.Monad.{Error,Except}.MonadError
{-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}

-- HACK: in GHC 7.10, Haddock complains about unused imports; but,
-- if we use CPP to avoid including them under Haddock, then it
-- will fail!
#ifdef __HADDOCK__
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
#endif

----------------------------------------------------------------
--                                                  ~ 2015.03.29
-- |
-- Module      :  Control.Monad.EitherK
-- License     :  BSD
-- Maintainer  :  wren@community.haskell.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(..), ap)
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))

instance Applicative (EitherK e) where
    pure :: a -> EitherK e a
pure   = a -> EitherK e a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: EitherK e (a -> b) -> EitherK e a -> EitherK e b
(<*>)  = EitherK e (a -> b) -> EitherK e a -> EitherK e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: EitherK e a -> EitherK e b -> EitherK e b
(*>)   = EitherK e a -> EitherK e b -> EitherK e b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
    EitherK e a
x <* :: EitherK e a -> EitherK e b -> EitherK e a
<* EitherK e b
y = EitherK e a
x EitherK e a -> (a -> EitherK e a) -> EitherK e a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> EitherK e b
y EitherK e b -> EitherK e a -> EitherK e a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> EitherK e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance Monad (EitherK e) where
    return :: a -> EitherK e a
return a
a   = (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
a)
    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.

instance (Monoid e) => Alternative (EitherK e) where
    empty :: EitherK e a
empty = EitherK e a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: EitherK e a -> EitherK e a -> EitherK e a
(<|>) = EitherK e a -> EitherK e a -> EitherK e a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Monoid e) => MonadPlus (EitherK e) where
    mzero :: EitherK e a
mzero       = e -> EitherK e a
forall e a. e -> EitherK e a
throwEitherK e
forall a. Monoid a => a
mempty
    EitherK e a
m mplus :: EitherK e a -> EitherK e a -> EitherK e a
`mplus` 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 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 -> do
    Either e a
ea <- 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
    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)
m' -> (a -> m (Either f r)) -> m (Either f r)
forall r. (a -> m (Either f r)) -> m (Either f r)
m' 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))

instance Applicative (EitherKT e m) where
    pure :: a -> EitherKT e m a
pure   = a -> EitherKT e m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: EitherKT e m (a -> b) -> EitherKT e m a -> EitherKT e m b
(<*>)  = EitherKT e m (a -> b) -> EitherKT e m a -> EitherKT e m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
    EitherKT e m a
x <* :: EitherKT e m a -> EitherKT e m b -> EitherKT e m a
<* EitherKT e m b
y = EitherKT e m a
x EitherKT e m a -> (a -> EitherKT e m a) -> EitherKT e m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> EitherKT e m b
y EitherKT e m b -> EitherKT e m a -> EitherKT e m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> EitherKT e m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance Monad (EitherKT e m) where
    return :: a -> EitherKT e m a
return a
a    = (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
a)
    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 = EitherKT e m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: EitherKT e m a -> EitherKT e m a -> EitherKT e m a
(<|>) = EitherKT e m a -> EitherKT e m a -> EitherKT e m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Applicative m, Monad m, Monoid e) => MonadPlus (EitherKT e m) where
    mzero :: EitherKT e m a
mzero       = 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 mplus :: EitherKT e m a -> EitherKT e m a -> EitherKT e m a
`mplus` 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) => 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.