{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Foundation.Monad.Except
    ( ExceptT(..)
    ) where

import Basement.Imports
import Foundation.Monad.Base
import Foundation.Monad.Reader
#if MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif

newtype ExceptT e m a = ExceptT { forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT :: m (Either e a) }

instance Functor m => Functor (ExceptT e m) where
    fmap :: forall a b. (a -> b) -> ExceptT e m a -> ExceptT e m b
fmap a -> b
f = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

instance Monad m => Applicative (ExceptT e m) where
    pure :: forall a. a -> ExceptT e m a
pure a
a = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
a)
    ExceptT m (Either e (a -> b))
f <*> :: forall a b. ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
<*> ExceptT m (Either e a)
v = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
        Either e (a -> b)
mf <- m (Either e (a -> b))
f
        case Either e (a -> b)
mf of
            Left e
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left e
e)
            Right a -> b
k -> do
                Either e a
mv <- m (Either e a)
v
                case Either e a
mv of
                    Left e
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left e
e)
                    Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (a -> b
k a
x))

instance Monad m => MonadFailure (ExceptT e m) where
    type Failure (ExceptT e m) = e
    mFail :: Failure (ExceptT e m) -> ExceptT e m ()
mFail = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> Either a b
Left

instance Monad m => Monad (ExceptT e m) where
    return :: forall a. a -> ExceptT e m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ExceptT e m a
m >>= :: forall a b. ExceptT e m a -> (a -> ExceptT e m b) -> ExceptT e m b
>>= a -> ExceptT e m b
k = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
        Either e a
a <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
m
        case Either e a
a of
            Left e
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left e
e)
            Right a
x -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExceptT e m b
k a
x)
#if !MIN_VERSION_base(4,13,0)
    fail = ExceptT . fail
#else
instance MonadFail m => MonadFail (ExceptT e m) where
    fail :: forall a. String -> ExceptT e m a
fail = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadFail m => String -> m a
fail
#endif

instance (Monad m, MonadFix m) => MonadFix (ExceptT e m) where
    mfix :: forall a. (a -> ExceptT e m a) -> ExceptT e m a
mfix a -> ExceptT e m a
f = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> ExceptT e m a
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {a} {b}. Either a b -> b
fromEither))
      where
        fromEither :: Either a b -> b
fromEither (Right b
x) = b
x
        fromEither (Left  a
_) = forall a. HasCallStack => String -> a
error String
"mfix (ExceptT): inner computation returned Left value"
    {-# INLINE mfix #-}

instance MonadReader m => MonadReader (ExceptT e m) where
    type ReaderContext (ExceptT e m) = ReaderContext m
    ask :: ExceptT e m (ReaderContext (ExceptT e m))
ask = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadReader m => m (ReaderContext m)
ask)

instance MonadTrans (ExceptT e) where
    lift :: forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
lift m a
f = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f)

instance MonadIO m => MonadIO (ExceptT e m) where
    liftIO :: forall a. IO a -> ExceptT e m a
liftIO IO a
f = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
f)