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