{-# LANGUAGE CPP #-}

{-| This module provides 'throwEither' and 'catchEither' for 'Either'.  These two
    functions reside here because 'throwEither' and 'catchEither' correspond to 'return'
    and ('>>=') for the flipped 'Either' monad: 'EitherR'.  Additionally, this
    module defines 'handleE' as the flipped version of 'catchE' for 'ExceptT'.

    'throwEither' and 'catchEither' improve upon @MonadError@ because:

    * 'catchEither' is more general than 'catch' and allows you to change the left value's type

    * Both are Haskell98

    More advanced users can use 'EitherR' and 'ExceptRT' to program in an
    entirely symmetric \"success monad\" where exceptional results are the norm
    and successful results terminate the computation.  This allows you to chain
    error-handlers using @do@ notation and pass around exceptional values of
    varying types until you can finally recover from the error:

> runExceptRT $ do
>     e2   <- ioExceptionHandler e1
>     bool <- arithmeticExceptionhandler e2
>     when bool $ lift $ putStrLn "DEBUG: Arithmetic handler did something"

    If any of the above error handlers 'succeed', no other handlers are tried.

    If you choose not to typefully distinguish between the error and sucess
    monad, then use 'flipEither' and 'flipET', which swap the type variables without
    changing the type.
-}

module Data.EitherR (
    -- * EitherR
    EitherR(..),

    -- ** Operations in the EitherR monad
    succeed,

    -- ** Conversions to the Either monad
    throwEither,
    catchEither,
    handleEither,
    fmapL,

    -- ** Flip alternative
    flipEither,

    -- * ExceptRT
    ExceptRT(..),

    -- ** Operations in the ExceptRT monad
    succeedT,

    -- ** Conversions to the ExceptT monad
    handleE,
    fmapLT,

    -- ** Flip alternative
    flipET,
    ) where

import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))
import Control.Monad (liftM, ap, MonadPlus(mzero, mplus))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE, catchE)
import Data.Monoid (Monoid(mempty, mappend))

import qualified Control.Monad.Trans.Except

{-| If \"@Either e r@\" is the error monad, then \"@EitherR r e@\" is the
    corresponding success monad, where:

    * 'return' is 'throwEither'.

    * ('>>=') is 'catchEither'.

    * Successful results abort the computation
-}
newtype EitherR r e = EitherR { EitherR r e -> Either e r
runEitherR :: Either e r }

instance Functor (EitherR r) where
    fmap :: (a -> b) -> EitherR r a -> EitherR r b
fmap = (a -> b) -> EitherR r a -> EitherR r b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (EitherR r) where
    pure :: a -> EitherR r a
pure  = a -> EitherR r a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: EitherR r (a -> b) -> EitherR r a -> EitherR r b
(<*>) = EitherR r (a -> b) -> EitherR r a -> EitherR r b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (EitherR r) where
    return :: a -> EitherR r a
return a
e = Either a r -> EitherR r a
forall r e. Either e r -> EitherR r e
EitherR (a -> Either a r
forall a b. a -> Either a b
Left a
e)
    EitherR Either a r
m >>= :: EitherR r a -> (a -> EitherR r b) -> EitherR r b
>>= a -> EitherR r b
f = case Either a r
m of
        Left  a
e -> a -> EitherR r b
f a
e
        Right r
r -> Either b r -> EitherR r b
forall r e. Either e r -> EitherR r e
EitherR (r -> Either b r
forall a b. b -> Either a b
Right r
r)

instance (Monoid r) => Alternative (EitherR r) where
    empty :: EitherR r a
empty = Either a r -> EitherR r a
forall r e. Either e r -> EitherR r e
EitherR (r -> Either a r
forall a b. b -> Either a b
Right r
forall a. Monoid a => a
mempty)
    e1 :: EitherR r a
e1@(EitherR (Left a
_)) <|> :: EitherR r a -> EitherR r a -> EitherR r a
<|> EitherR r a
_ = EitherR r a
e1
    EitherR r a
_ <|> e2 :: EitherR r a
e2@(EitherR (Left a
_)) = EitherR r a
e2
    EitherR (Right r
r1) <|> EitherR (Right r
r2)
        = Either a r -> EitherR r a
forall r e. Either e r -> EitherR r e
EitherR (r -> Either a r
forall a b. b -> Either a b
Right (r -> r -> r
forall a. Monoid a => a -> a -> a
mappend r
r1 r
r2))

instance (Monoid r) => MonadPlus (EitherR r) where
    mzero :: EitherR r a
mzero = EitherR r a
forall (f :: * -> *) a. Alternative f => f a
empty
    mplus :: EitherR r a -> EitherR r a -> EitherR r a
mplus = EitherR r a -> EitherR r a -> EitherR r a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Complete error handling, returning a result
succeed :: r -> EitherR r e
succeed :: r -> EitherR r e
succeed r
r = Either e r -> EitherR r e
forall r e. Either e r -> EitherR r e
EitherR (r -> Either e r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r)

-- | 'throwEither' in the error monad corresponds to 'return' in the success monad
throwEither :: e -> Either e r
throwEither :: e -> Either e r
throwEither e
e = EitherR r e -> Either e r
forall r e. EitherR r e -> Either e r
runEitherR (e -> EitherR r e
forall (m :: * -> *) a. Monad m => a -> m a
return e
e)

-- | 'catchEither' in the error monad corresponds to ('>>=') in the success monad
catchEither :: Either a r -> (a -> Either b r) -> Either b r
Either a r
e catchEither :: Either a r -> (a -> Either b r) -> Either b r
`catchEither` a -> Either b r
f = EitherR r b -> Either b r
forall r e. EitherR r e -> Either e r
runEitherR (EitherR r b -> Either b r) -> EitherR r b -> Either b r
forall a b. (a -> b) -> a -> b
$ Either a r -> EitherR r a
forall r e. Either e r -> EitherR r e
EitherR Either a r
e EitherR r a -> (a -> EitherR r b) -> EitherR r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Either b r -> EitherR r b
forall r e. Either e r -> EitherR r e
EitherR (a -> Either b r
f a
a)

-- | 'catchEither' with the arguments flipped
handleEither :: (a -> Either b r) -> Either a r -> Either b r
handleEither :: (a -> Either b r) -> Either a r -> Either b r
handleEither = (Either a r -> (a -> Either b r) -> Either b r)
-> (a -> Either b r) -> Either a r -> Either b r
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either a r -> (a -> Either b r) -> Either b r
forall a r b. Either a r -> (a -> Either b r) -> Either b r
catchEither

-- | Map a function over the 'Left' value of an 'Either'
fmapL :: (a -> b) -> Either a r -> Either b r
fmapL :: (a -> b) -> Either a r -> Either b r
fmapL a -> b
f = EitherR r b -> Either b r
forall r e. EitherR r e -> Either e r
runEitherR (EitherR r b -> Either b r)
-> (Either a r -> EitherR r b) -> Either a r -> Either b r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> EitherR r a -> EitherR r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (EitherR r a -> EitherR r b)
-> (Either a r -> EitherR r a) -> Either a r -> EitherR r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a r -> EitherR r a
forall r e. Either e r -> EitherR r e
EitherR

-- | Flip the type variables of 'Either'
flipEither :: Either a b -> Either b a
flipEither :: Either a b -> Either b a
flipEither Either a b
e = case Either a b
e of
    Left  a
a -> a -> Either b a
forall a b. b -> Either a b
Right a
a
    Right b
b -> b -> Either b a
forall a b. a -> Either a b
Left  b
b

-- | 'EitherR' converted into a monad transformer
newtype ExceptRT r m e = ExceptRT { ExceptRT r m e -> ExceptT e m r
runExceptRT :: ExceptT e m r }

instance (Monad m) => Functor (ExceptRT r m) where
    fmap :: (a -> b) -> ExceptRT r m a -> ExceptRT r m b
fmap = (a -> b) -> ExceptRT r m a -> ExceptRT r m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance (Monad m) => Applicative (ExceptRT r m) where
    pure :: a -> ExceptRT r m a
pure  = a -> ExceptRT r m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: ExceptRT r m (a -> b) -> ExceptRT r m a -> ExceptRT r m b
(<*>) = ExceptRT r m (a -> b) -> ExceptRT r m a -> ExceptRT r m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Monad m) => Monad (ExceptRT r m) where
    return :: a -> ExceptRT r m a
return a
e = ExceptT a m r -> ExceptRT r m a
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (a -> ExceptT a m r
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE a
e)
    ExceptRT r m a
m >>= :: ExceptRT r m a -> (a -> ExceptRT r m b) -> ExceptRT r m b
>>= a -> ExceptRT r m b
f = ExceptT b m r -> ExceptRT r m b
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (ExceptT b m r -> ExceptRT r m b)
-> ExceptT b m r -> ExceptRT r m b
forall a b. (a -> b) -> a -> b
$ m (Either b r) -> ExceptT b m r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either b r) -> ExceptT b m r)
-> m (Either b r) -> ExceptT b m r
forall a b. (a -> b) -> a -> b
$ do
        Either a r
x <- ExceptT a m r -> m (Either a r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a m r -> m (Either a r))
-> ExceptT a m r -> m (Either a r)
forall a b. (a -> b) -> a -> b
$ ExceptRT r m a -> ExceptT a m r
forall r (m :: * -> *) e. ExceptRT r m e -> ExceptT e m r
runExceptRT ExceptRT r m a
m
        ExceptT b m r -> m (Either b r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT b m r -> m (Either b r))
-> ExceptT b m r -> m (Either b r)
forall a b. (a -> b) -> a -> b
$ ExceptRT r m b -> ExceptT b m r
forall r (m :: * -> *) e. ExceptRT r m e -> ExceptT e m r
runExceptRT (ExceptRT r m b -> ExceptT b m r)
-> ExceptRT r m b -> ExceptT b m r
forall a b. (a -> b) -> a -> b
$ case Either a r
x of
            Left  a
e -> a -> ExceptRT r m b
f a
e
            Right r
r -> ExceptT b m r -> ExceptRT r m b
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (r -> ExceptT b m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r)

instance (Monad m, Monoid r) => Alternative (ExceptRT r m) where
    empty :: ExceptRT r m a
empty = ExceptT a m r -> ExceptRT r m a
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (ExceptT a m r -> ExceptRT r m a)
-> ExceptT a m r -> ExceptRT r m a
forall a b. (a -> b) -> a -> b
$ m (Either a r) -> ExceptT a m r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either a r) -> ExceptT a m r)
-> m (Either a r) -> ExceptT a m r
forall a b. (a -> b) -> a -> b
$ Either a r -> m (Either a r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a r -> m (Either a r)) -> Either a r -> m (Either a r)
forall a b. (a -> b) -> a -> b
$ r -> Either a r
forall a b. b -> Either a b
Right r
forall a. Monoid a => a
mempty
    ExceptRT r m a
e1 <|> :: ExceptRT r m a -> ExceptRT r m a -> ExceptRT r m a
<|> ExceptRT r m a
e2 = ExceptT a m r -> ExceptRT r m a
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (ExceptT a m r -> ExceptRT r m a)
-> ExceptT a m r -> ExceptRT r m a
forall a b. (a -> b) -> a -> b
$ m (Either a r) -> ExceptT a m r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either a r) -> ExceptT a m r)
-> m (Either a r) -> ExceptT a m r
forall a b. (a -> b) -> a -> b
$ do
        Either a r
x1 <- ExceptT a m r -> m (Either a r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a m r -> m (Either a r))
-> ExceptT a m r -> m (Either a r)
forall a b. (a -> b) -> a -> b
$ ExceptRT r m a -> ExceptT a m r
forall r (m :: * -> *) e. ExceptRT r m e -> ExceptT e m r
runExceptRT ExceptRT r m a
e1
        case Either a r
x1 of
            Left  a
l  -> Either a r -> m (Either a r)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a r
forall a b. a -> Either a b
Left a
l)
            Right r
r1 -> do
                Either a r
x2 <- ExceptT a m r -> m (Either a r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a m r -> m (Either a r))
-> ExceptT a m r -> m (Either a r)
forall a b. (a -> b) -> a -> b
$ ExceptRT r m a -> ExceptT a m r
forall r (m :: * -> *) e. ExceptRT r m e -> ExceptT e m r
runExceptRT ExceptRT r m a
e2
                case Either a r
x2 of
                    Left  a
l  -> Either a r -> m (Either a r)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a r
forall a b. a -> Either a b
Left a
l)
                    Right r
r2 -> Either a r -> m (Either a r)
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Either a r
forall a b. b -> Either a b
Right (r -> r -> r
forall a. Monoid a => a -> a -> a
mappend r
r1 r
r2))

instance (Monad m, Monoid r) => MonadPlus (ExceptRT r m) where
    mzero :: ExceptRT r m a
mzero = ExceptRT r m a
forall (f :: * -> *) a. Alternative f => f a
empty
    mplus :: ExceptRT r m a -> ExceptRT r m a -> ExceptRT r m a
mplus = ExceptRT r m a -> ExceptRT r m a -> ExceptRT r m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance MonadTrans (ExceptRT r) where
    lift :: m a -> ExceptRT r m a
lift = ExceptT a m r -> ExceptRT r m a
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (ExceptT a m r -> ExceptRT r m a)
-> (m a -> ExceptT a m r) -> m a -> ExceptRT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either a r) -> ExceptT a m r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either a r) -> ExceptT a m r)
-> (m a -> m (Either a r)) -> m a -> ExceptT a m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either a r) -> m a -> m (Either a r)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either a r
forall a b. a -> Either a b
Left

instance (MonadIO m) => MonadIO (ExceptRT r m) where
    liftIO :: IO a -> ExceptRT r m a
liftIO = m a -> ExceptRT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptRT r m a) -> (IO a -> m a) -> IO a -> ExceptRT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Complete error handling, returning a result
succeedT :: (Monad m) => r -> ExceptRT r m e
succeedT :: r -> ExceptRT r m e
succeedT r
r = ExceptT e m r -> ExceptRT r m e
forall r (m :: * -> *) e. ExceptT e m r -> ExceptRT r m e
ExceptRT (r -> ExceptT e m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r)

-- | 'catchE' with the arguments flipped
handleE :: (Monad m) => (a -> ExceptT b m r) -> ExceptT a m r -> ExceptT b m r
handleE :: (a -> ExceptT b m r) -> ExceptT a m r -> ExceptT b m r
handleE = (ExceptT a m r -> (a -> ExceptT b m r) -> ExceptT b m r)
-> (a -> ExceptT b m r) -> ExceptT a m r -> ExceptT b m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT a m r -> (a -> ExceptT b m r) -> ExceptT b m r
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE

-- | Map a function over the 'Left' value of an 'ExceptT'
#if MIN_VERSION_base(4,8,0)
fmapLT :: Functor m => (a -> b) -> ExceptT a m r -> ExceptT b m r
fmapLT :: (a -> b) -> ExceptT a m r -> ExceptT b m r
fmapLT = (a -> b) -> ExceptT a m r -> ExceptT b m r
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
Control.Monad.Trans.Except.withExceptT
#else
fmapLT :: (Monad m) => (a -> b) -> ExceptT a m r -> ExceptT b m r
fmapLT f = runExceptRT . fmap f . ExceptRT
#endif

-- | Flip the type variables of an 'ExceptT'
flipET :: (Monad m) => ExceptT a m b -> ExceptT b m a
flipET :: ExceptT a m b -> ExceptT b m a
flipET = m (Either b a) -> ExceptT b m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either b a) -> ExceptT b m a)
-> (ExceptT a m b -> m (Either b a))
-> ExceptT a m b
-> ExceptT b m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either a b -> Either b a) -> m (Either a b) -> m (Either b a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either a b -> Either b a
forall a b. Either a b -> Either b a
flipEither (m (Either a b) -> m (Either b a))
-> (ExceptT a m b -> m (Either a b))
-> ExceptT a m b
-> m (Either b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT a m b -> m (Either a b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT