{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
module Control.Monad.Trans.Except.Extra (
newExceptT
, runExceptT
, exceptT
, left
, right
, mapExceptT
, hoistEither
, bimapExceptT
, firstExceptT
, secondExceptT
, hoistMaybe
, hoistExceptT
, handleIOExceptT
, handleExceptT
, handlesExceptT
, handleLeftT
, catchIOExceptT
, catchExceptT
, catchesExceptT
, catchLeftT
, bracketExceptT
, bracketExceptionT
, hushM
, onLeft
, onNothing
) where
import Control.Exception (Exception, IOException, SomeException)
import qualified Control.Exception as Exception
import Control.Monad (Monad (..), (=<<))
import Control.Monad.Catch (Handler (..), MonadCatch, MonadMask, catchAll, mask, throwM)
import qualified Control.Monad.Catch as Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Data.Either (Either (..), either)
import Data.Foldable (Foldable, foldr)
import Data.Function (const, flip, id, ($), (.))
import Data.Functor (Functor (..))
import Data.Maybe (Maybe (..), maybe)
import System.IO (IO)
newExceptT :: m (Either x a) -> ExceptT x m a
newExceptT :: forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
{-# INLINE newExceptT #-}
exceptT :: Monad m => (x -> m b) -> (a -> m b) -> ExceptT x m a -> m b
exceptT :: forall (m :: * -> *) x b a.
Monad m =>
(x -> m b) -> (a -> m b) -> ExceptT x m a -> m b
exceptT x -> m b
f a -> m b
g ExceptT x m a
m =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either x -> m b
f a -> m b
g forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT x m a
m
{-# INLINE exceptT #-}
left :: Monad m => x -> ExceptT x m a
left :: forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
{-# INLINE left #-}
right :: Monad m => a -> ExceptT x m a
right :: forall (m :: * -> *) a x. Monad m => a -> ExceptT x m a
right =
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE right #-}
hoistEither :: Monad m => Either x a -> ExceptT x m a
hoistEither :: forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE hoistEither #-}
bimapExceptT :: Functor m => (x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b
bimapExceptT :: forall (m :: * -> *) x y a b.
Functor m =>
(x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b
bimapExceptT x -> y
f a -> b
g =
let
h :: Either x a -> Either y b
h (Left x
e) = forall a b. a -> Either a b
Left (x -> y
f x
e)
h (Right a
a) = forall a b. b -> Either a b
Right (a -> b
g a
a)
in
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either x a -> Either y b
h)
{-# INLINE bimapExceptT #-}
firstExceptT :: Functor m => (x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT :: forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT x -> y
f =
forall (m :: * -> *) x y a b.
Functor m =>
(x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b
bimapExceptT x -> y
f forall a. a -> a
id
{-# INLINE firstExceptT #-}
secondExceptT :: Functor m => (a -> b) -> ExceptT x m a -> ExceptT x m b
secondExceptT :: forall (m :: * -> *) a b x.
Functor m =>
(a -> b) -> ExceptT x m a -> ExceptT x m b
secondExceptT =
forall (m :: * -> *) x y a b.
Functor m =>
(x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b
bimapExceptT forall a. a -> a
id
{-# INLINE secondExceptT #-}
hoistMaybe :: Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe :: forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe x
x =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left x
x) forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE hoistMaybe #-}
hoistExceptT :: (forall b. m b -> n b) -> ExceptT x m a -> ExceptT x n a
hoistExceptT :: forall (m :: * -> *) (n :: * -> *) x a.
(forall b. m b -> n b) -> ExceptT x m a -> ExceptT x n a
hoistExceptT forall b. m b -> n b
f =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. m b -> n b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
{-# INLINE hoistExceptT #-}
handleIOExceptT :: MonadIO m => (IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT :: forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT IOException -> x
wrap =
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT IOException -> x
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
Exception.try
{-# INLINE handleIOExceptT #-}
catchIOExceptT :: MonadIO m => IO a -> (IOException -> x) -> ExceptT x m a
catchIOExceptT :: forall (m :: * -> *) a x.
MonadIO m =>
IO a -> (IOException -> x) -> ExceptT x m a
catchIOExceptT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT
{-# INLINE catchIOExceptT #-}
handleExceptT :: (MonadCatch m, Exception e) => (e -> x) -> m a -> ExceptT x m a
handleExceptT :: forall (m :: * -> *) e x a.
(MonadCatch m, Exception e) =>
(e -> x) -> m a -> ExceptT x m a
handleExceptT e -> x
wrap =
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT e -> x
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try
{-# INLINE handleExceptT #-}
catchExceptT :: (MonadCatch m, Exception e) => m a -> (e -> x) -> ExceptT x m a
catchExceptT :: forall (m :: * -> *) e a x.
(MonadCatch m, Exception e) =>
m a -> (e -> x) -> ExceptT x m a
catchExceptT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e x a.
(MonadCatch m, Exception e) =>
(e -> x) -> m a -> ExceptT x m a
handleExceptT
{-# INLINE catchExceptT #-}
handlesExceptT :: (Foldable f, MonadCatch m) => f (Handler m x) -> m a -> ExceptT x m a
handlesExceptT :: forall (f :: * -> *) (m :: * -> *) x a.
(Foldable f, MonadCatch m) =>
f (Handler m x) -> m a -> ExceptT x m a
handlesExceptT f (Handler m x)
wrappers m a
action =
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right m a
action forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Catch.catch` 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 forall a b. a -> Either a b
Left) SomeException -> m x
handler)
where
handler :: SomeException -> m x
handler SomeException
e =
let probe :: Handler m a -> m a -> m a
probe (Handler e -> m a
h) m a
xs =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
xs e -> m a
h (forall e. Exception e => SomeException -> Maybe e
Exception.fromException SomeException
e)
in
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *} {a}. Handler m a -> m a -> m a
probe (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM SomeException
e) f (Handler m x)
wrappers
catchesExceptT :: (Foldable f, MonadCatch m) => m a -> f (Handler m x) -> ExceptT x m a
catchesExceptT :: forall (f :: * -> *) (m :: * -> *) a x.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m x) -> ExceptT x m a
catchesExceptT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) (m :: * -> *) x a.
(Foldable f, MonadCatch m) =>
f (Handler m x) -> m a -> ExceptT x m a
handlesExceptT
{-# INLINE catchesExceptT #-}
handleLeftT :: Monad m => (e -> ExceptT e m a) -> ExceptT e m a -> ExceptT e m a
handleLeftT :: forall (m :: * -> *) e a.
Monad m =>
(e -> ExceptT e m a) -> ExceptT e m a -> ExceptT e m a
handleLeftT e -> ExceptT e m a
handler ExceptT e m a
thing = do
Either e a
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
thing
case Either e a
r of
Left e
e ->
e -> ExceptT e m a
handler e
e
Right a
a ->
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE handleLeftT #-}
catchLeftT :: Monad m => ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchLeftT :: forall (m :: * -> *) e a.
Monad m =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchLeftT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
Monad m =>
(e -> ExceptT e m a) -> ExceptT e m a -> ExceptT e m a
handleLeftT
{-# INLINE catchLeftT #-}
bracketExceptT :: Monad m => ExceptT e m a -> (a -> ExceptT e m b) -> (a -> ExceptT e m c) -> ExceptT e m c
bracketExceptT :: forall (m :: * -> *) e a b c.
Monad m =>
ExceptT e m a
-> (a -> ExceptT e m b) -> (a -> ExceptT e m c) -> ExceptT e m c
bracketExceptT ExceptT e m a
before a -> ExceptT e m b
after a -> ExceptT e m c
thing = do
a
a <- ExceptT e m a
before
c
r <- (\e
err -> a -> ExceptT e m b
after a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left e
err) forall (m :: * -> *) e a.
Monad m =>
(e -> ExceptT e m a) -> ExceptT e m a -> ExceptT e m a
`handleLeftT` a -> ExceptT e m c
thing a
a
b
_ <- a -> ExceptT e m b
after a
a
forall (m :: * -> *) a. Monad m => a -> m a
return c
r
{-# INLINE bracketExceptT #-}
bracketExceptionT ::
MonadMask m
=> ExceptT e m a
-> (a -> ExceptT e m c)
-> (a -> ExceptT e m b)
-> ExceptT e m b
bracketExceptionT :: forall (m :: * -> *) e a c b.
MonadMask m =>
ExceptT e m a
-> (a -> ExceptT e m c) -> (a -> ExceptT e m b) -> ExceptT e m b
bracketExceptionT ExceptT e m a
acquire a -> ExceptT e m c
release a -> ExceptT e m b
run =
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m (Either b c)) -> (a -> m b) -> m b
bracketF
(forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
acquire)
(\Either e a
r -> case Either e a
r of
Left e
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ()
Right a
r' ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExceptT e m c
release a
r') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either e c
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either e c
x of
Left e
err -> forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left e
err)
Right c
_ -> forall a b. b -> Either a b
Right ())
(\Either e a
r -> case Either e a
r of
Left e
err ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ e
err
Right a
r' ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExceptT e m b
run a
r'))
{-# INLINE bracketExceptionT #-}
data BracketResult a =
BracketOk a
| BracketFailedFinalizerOk SomeException
| BracketFailedFinalizerError a
bracketF :: MonadMask m => m a -> (a -> m (Either b c)) -> (a -> m b) -> m b
bracketF :: forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m (Either b c)) -> (a -> m b) -> m b
bracketF m a
a a -> m (Either b c)
f a -> m b
g =
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
a
a' <- m a
a
BracketResult b
x <- forall a. m a -> m a
restore (forall a. a -> BracketResult a
BracketOk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> m b
g a
a') forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAll`
(\SomeException
ex -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> BracketResult a
BracketFailedFinalizerError (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. SomeException -> BracketResult a
BracketFailedFinalizerOk SomeException
ex) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> m (Either b c)
f a
a')
case BracketResult b
x of
BracketFailedFinalizerOk SomeException
ex ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
ex
BracketFailedFinalizerError b
b ->
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
BracketOk b
b -> do
Either b c
z <- a -> m (Either b c)
f a
a'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. a -> b -> a
const b
b) Either b c
z
{-# INLINE bracketF #-}
hushM :: Monad m => Either e a -> (e -> m ()) -> m (Maybe a)
hushM :: forall (m :: * -> *) e a.
Monad m =>
Either e a -> (e -> m ()) -> m (Maybe a)
hushM Either e a
r e -> m ()
f = case Either e a
r of
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
a)
Left e
e -> e -> m ()
f e
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
{-# INLINE hushM #-}
onLeft :: forall e x m a. Monad m => (e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft :: forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft e -> ExceptT x m a
h ExceptT x m (Either e a)
f = ExceptT x m (Either e a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> ExceptT x m a
h forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE onLeft #-}
onNothing :: forall x m a. Monad m => ExceptT x m a -> ExceptT x m (Maybe a) -> ExceptT x m a
onNothing :: forall x (m :: * -> *) a.
Monad m =>
ExceptT x m a -> ExceptT x m (Maybe a) -> ExceptT x m a
onNothing ExceptT x m a
h ExceptT x m (Maybe a)
f = ExceptT x m (Maybe a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExceptT x m a
h forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE onNothing #-}