{-# 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 { ExceptT e m a -> m (Either e a)
runExceptT :: m (Either e a) }

instance Functor m => Functor (ExceptT e m) where
    fmap :: (a -> b) -> ExceptT e m a -> ExceptT e m b
fmap a -> b
f = m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> (ExceptT e m a -> m (Either e b))
-> ExceptT e m a
-> ExceptT e m b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Either e a -> Either e b) -> m (Either e a) -> m (Either e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either e a -> Either e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (m (Either e a) -> m (Either e b))
-> (ExceptT e m a -> m (Either e a))
-> ExceptT e m a
-> m (Either e b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

instance Monad m => Applicative (ExceptT e m) where
    pure :: a -> ExceptT e m a
pure a
a = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either e a
forall a b. b -> Either a b
Right a
a)
    ExceptT m (Either e (a -> b))
f <*> :: ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
<*> ExceptT m (Either e a)
v = m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> m (Either e b) -> ExceptT e m b
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 -> Either e b -> m (Either e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Either e b
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 -> Either e b -> m (Either e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Either e b
forall a b. a -> Either a b
Left e
e)
                    Right a
x -> Either e b -> m (Either e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either e b
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 = m (Either e ()) -> ExceptT e m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e ()) -> ExceptT e m ())
-> (e -> m (Either e ())) -> e -> ExceptT e m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either e () -> m (Either e ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e () -> m (Either e ()))
-> (e -> Either e ()) -> e -> m (Either e ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. e -> Either e ()
forall a b. a -> Either a b
Left

instance Monad m => Monad (ExceptT e m) where
    return :: a -> ExceptT e m a
return = a -> ExceptT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ExceptT e m a
m >>= :: ExceptT e m a -> (a -> ExceptT e m b) -> ExceptT e m b
>>= a -> ExceptT e m b
k = m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> m (Either e b) -> ExceptT e m b
forall a b. (a -> b) -> a -> b
$ do
        Either e a
a <- ExceptT e m a -> m (Either e 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 -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e b
forall a b. a -> Either a b
Left e
e)
            Right a
x -> ExceptT e m b -> m (Either e b)
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 :: String -> ExceptT e m a
fail = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> (String -> m (Either e a)) -> String -> ExceptT e m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> m (Either e a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
#endif

instance (Monad m, MonadFix m) => MonadFix (ExceptT e m) where
    mfix :: (a -> ExceptT e m a) -> ExceptT e m a
mfix a -> ExceptT e m a
f = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either e a -> m (Either e a)) -> m (Either e a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m a -> m (Either e a))
-> (Either e a -> ExceptT e m a) -> Either e a -> m (Either e a)
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 (a -> ExceptT e m a)
-> (Either e a -> a) -> Either e a -> ExceptT e m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either e a -> a
forall a p. Either a p -> p
fromEither))
      where
        fromEither :: Either a p -> p
fromEither (Right p
x) = p
x
        fromEither (Left  a
_) = String -> p
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 = m (Either e (ReaderContext m)) -> ExceptT e m (ReaderContext m)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderContext m -> Either e (ReaderContext m)
forall a b. b -> Either a b
Right (ReaderContext m -> Either e (ReaderContext m))
-> m (ReaderContext m) -> m (Either e (ReaderContext m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ReaderContext m)
forall (m :: * -> *). MonadReader m => m (ReaderContext m)
ask)

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

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