{-# 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)