{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Description : Monads that can cleanup within a single monaadic scope
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Control.Monad.Cleanup where

import Control.Exception.Safe
import Control.Monad.Catch (ExitCase (..))
import Control.Monad.ST
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
import qualified Control.Monad.Trans.State.Lazy as LazyS
import qualified Control.Monad.Trans.State.Strict as StrictS
import qualified Control.Monad.Trans.Writer.Lazy as LazyW
import qualified Control.Monad.Trans.Writer.Strict as StrictW
import Data.Coerce
import Data.Functor.Identity

-- | Monads that can cleanup within a single monadic scope.
--
-- 'MonadCleanup's allow for acquiring some resource and
-- guaranteeing that it will be released,
-- __if computation might continue within that monad__.
--
-- This is very similar to 'MonadMask', with the following differences:
--
-- 1. 'MonadCleanup's may not be able to throw or catch exceptions (no 'MonadCatch'
--    superclass) or mask exceptions.
-- 2. The guarantee of 'generalCleanup' is not as absolute as 'generalBracket' (though the latter
--    always has the @SIGKILL@/power goes out exception). If we can't handle exceptions
--    at all in the monad (at least not without @unsafePerformIO@), then sometimes the cleanup
--    function won't be called, but only in cases where the entire computation the monad is
--    running is going to be aborted.
--
-- This allows 'MonadCleanup' to be used in pure contexts (see 'CleanupNoException') and still
-- provide meaningful semantics.
class (Monad m) => MonadCleanup m where
  -- | Acquire some resource, use it, and clean it up.
  --
  -- cleanup is guaranteed to run
  -- __if computation in the surrounding monadic scope might continue__.
  --
  -- Similar to 'generalBracket', see documentation of 'MonadCleanup' for the differences.
  generalCleanup ::
    -- | Acquire some resource
    m a ->
    -- | Release the resource, observing the outcome of the inner action
    (a -> ExitCase b -> m c) ->
    -- | Inner action to perform with the resource
    (a -> m b) ->
    m (b, c)

-- | An 'Exception' corresponding to the 'ExitCaseAbort' exit case.
data AbortException = AbortException
  deriving stock (Int -> AbortException -> ShowS
[AbortException] -> ShowS
AbortException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbortException] -> ShowS
$cshowList :: [AbortException] -> ShowS
show :: AbortException -> String
$cshow :: AbortException -> String
showsPrec :: Int -> AbortException -> ShowS
$cshowsPrec :: Int -> AbortException -> ShowS
Show)
  deriving anyclass (Show AbortException
Typeable AbortException
SomeException -> Maybe AbortException
AbortException -> String
AbortException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: AbortException -> String
$cdisplayException :: AbortException -> String
fromException :: SomeException -> Maybe AbortException
$cfromException :: SomeException -> Maybe AbortException
toException :: AbortException -> SomeException
$ctoException :: AbortException -> SomeException
Exception)

-- | Acquire some resource, use it, and clean it up.
--
-- This is to 'bracketWithError' as 'generalCleanup' is to 'generalBracket', see documentation
-- of 'generalCleanup' for more details.
withCleanup ::
  (MonadCleanup m) =>
  m a ->
  (Maybe SomeException -> a -> m b) ->
  (a -> m c) ->
  m c
withCleanup :: forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
withCleanup m a
acquire Maybe SomeException -> a -> m b
cleanup a -> m c
go = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup m a
acquire forall {a}. a -> ExitCase a -> m b
release a -> m c
go
  where
    release :: a -> ExitCase a -> m b
release a
x (ExitCaseSuccess a
_) = Maybe SomeException -> a -> m b
cleanup forall a. Maybe a
Nothing a
x
    release a
x ExitCase a
ExitCaseAbort = Maybe SomeException -> a -> m b
cleanup (forall a. a -> Maybe a
Just (forall e. Exception e => e -> SomeException
toException AbortException
AbortException)) a
x
    release a
x (ExitCaseException SomeException
e) = Maybe SomeException -> a -> m b
cleanup (forall a. a -> Maybe a
Just SomeException
e) a
x

-- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) helper for deriving 'MonadCleanup' from 'MonadMask'.
newtype CleanupFromMask m a = CleanupFromMask (m a) deriving newtype (forall a b. a -> CleanupFromMask m b -> CleanupFromMask m a
forall a b. (a -> b) -> CleanupFromMask m a -> CleanupFromMask m b
forall (m :: * -> *) a b.
Functor m =>
a -> CleanupFromMask m b -> CleanupFromMask m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CleanupFromMask m a -> CleanupFromMask m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CleanupFromMask m b -> CleanupFromMask m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> CleanupFromMask m b -> CleanupFromMask m a
fmap :: forall a b. (a -> b) -> CleanupFromMask m a -> CleanupFromMask m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CleanupFromMask m a -> CleanupFromMask m b
Functor, forall a. a -> CleanupFromMask m a
forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m a
forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
forall a b.
CleanupFromMask m (a -> b)
-> CleanupFromMask m a -> CleanupFromMask m b
forall a b c.
(a -> b -> c)
-> CleanupFromMask m a
-> CleanupFromMask m b
-> CleanupFromMask m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (CleanupFromMask m)
forall (m :: * -> *) a. Applicative m => a -> CleanupFromMask m a
forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m a
forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m (a -> b)
-> CleanupFromMask m a -> CleanupFromMask m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> CleanupFromMask m a
-> CleanupFromMask m b
-> CleanupFromMask m c
<* :: forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m a
*> :: forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
liftA2 :: forall a b c.
(a -> b -> c)
-> CleanupFromMask m a
-> CleanupFromMask m b
-> CleanupFromMask m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> CleanupFromMask m a
-> CleanupFromMask m b
-> CleanupFromMask m c
<*> :: forall a b.
CleanupFromMask m (a -> b)
-> CleanupFromMask m a -> CleanupFromMask m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
CleanupFromMask m (a -> b)
-> CleanupFromMask m a -> CleanupFromMask m b
pure :: forall a. a -> CleanupFromMask m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> CleanupFromMask m a
Applicative, forall a. a -> CleanupFromMask m a
forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
forall a b.
CleanupFromMask m a
-> (a -> CleanupFromMask m b) -> CleanupFromMask m b
forall {m :: * -> *}. Monad m => Applicative (CleanupFromMask m)
forall (m :: * -> *) a. Monad m => a -> CleanupFromMask m a
forall (m :: * -> *) a b.
Monad m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
forall (m :: * -> *) a b.
Monad m =>
CleanupFromMask m a
-> (a -> CleanupFromMask m b) -> CleanupFromMask m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CleanupFromMask m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CleanupFromMask m a
>> :: forall a b.
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CleanupFromMask m a -> CleanupFromMask m b -> CleanupFromMask m b
>>= :: forall a b.
CleanupFromMask m a
-> (a -> CleanupFromMask m b) -> CleanupFromMask m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CleanupFromMask m a
-> (a -> CleanupFromMask m b) -> CleanupFromMask m b
Monad)

instance (MonadMask m) => MonadCleanup (CleanupFromMask m) where
  generalCleanup :: forall a b c. CleanupFromMask m a -> (a -> ExitCase b -> CleanupFromMask m c) -> (a -> CleanupFromMask m b) -> CleanupFromMask m (b, c)
  generalCleanup :: forall a b c.
CleanupFromMask m a
-> (a -> ExitCase b -> CleanupFromMask m c)
-> (a -> CleanupFromMask m b)
-> CleanupFromMask m (b, c)
generalCleanup = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket @m @a @b @c

deriving via CleanupFromMask IO instance MonadCleanup IO

-- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) for deriving 'MonadCleanup' in a 'Monad' which
-- __can't__ handle exceptions.
--
-- If cleanup runs at all, it will run in 'ExitCaseSuccess'
--
-- __Note that the associated 'MonadCleanup' instance is invalid if it is possible to catch exceptions in the monad!__
newtype CleanupNoException m a = CleanupNoException (m a) deriving newtype (forall a b. a -> CleanupNoException m b -> CleanupNoException m a
forall a b.
(a -> b) -> CleanupNoException m a -> CleanupNoException m b
forall (m :: * -> *) a b.
Functor m =>
a -> CleanupNoException m b -> CleanupNoException m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CleanupNoException m a -> CleanupNoException m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CleanupNoException m b -> CleanupNoException m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> CleanupNoException m b -> CleanupNoException m a
fmap :: forall a b.
(a -> b) -> CleanupNoException m a -> CleanupNoException m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CleanupNoException m a -> CleanupNoException m b
Functor, forall a. a -> CleanupNoException m a
forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m a
forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
forall a b.
CleanupNoException m (a -> b)
-> CleanupNoException m a -> CleanupNoException m b
forall a b c.
(a -> b -> c)
-> CleanupNoException m a
-> CleanupNoException m b
-> CleanupNoException m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}.
Applicative m =>
Functor (CleanupNoException m)
forall (m :: * -> *) a.
Applicative m =>
a -> CleanupNoException m a
forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m a
forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m (a -> b)
-> CleanupNoException m a -> CleanupNoException m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> CleanupNoException m a
-> CleanupNoException m b
-> CleanupNoException m c
<* :: forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m a
*> :: forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
liftA2 :: forall a b c.
(a -> b -> c)
-> CleanupNoException m a
-> CleanupNoException m b
-> CleanupNoException m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> CleanupNoException m a
-> CleanupNoException m b
-> CleanupNoException m c
<*> :: forall a b.
CleanupNoException m (a -> b)
-> CleanupNoException m a -> CleanupNoException m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
CleanupNoException m (a -> b)
-> CleanupNoException m a -> CleanupNoException m b
pure :: forall a. a -> CleanupNoException m a
$cpure :: forall (m :: * -> *) a.
Applicative m =>
a -> CleanupNoException m a
Applicative, forall a. a -> CleanupNoException m a
forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
forall a b.
CleanupNoException m a
-> (a -> CleanupNoException m b) -> CleanupNoException m b
forall {m :: * -> *}. Monad m => Applicative (CleanupNoException m)
forall (m :: * -> *) a. Monad m => a -> CleanupNoException m a
forall (m :: * -> *) a b.
Monad m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
forall (m :: * -> *) a b.
Monad m =>
CleanupNoException m a
-> (a -> CleanupNoException m b) -> CleanupNoException m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CleanupNoException m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CleanupNoException m a
>> :: forall a b.
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CleanupNoException m a
-> CleanupNoException m b -> CleanupNoException m b
>>= :: forall a b.
CleanupNoException m a
-> (a -> CleanupNoException m b) -> CleanupNoException m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CleanupNoException m a
-> (a -> CleanupNoException m b) -> CleanupNoException m b
Monad)

instance (Monad m) => MonadCleanup (CleanupNoException m) where
  generalCleanup :: forall a b c.
CleanupNoException m a
-> (a -> ExitCase b -> CleanupNoException m c)
-> (a -> CleanupNoException m b)
-> CleanupNoException m (b, c)
generalCleanup CleanupNoException m a
acquire a -> ExitCase b -> CleanupNoException m c
release a -> CleanupNoException m b
go = do
    a
x <- CleanupNoException m a
acquire
    b
res <- a -> CleanupNoException m b
go a
x
    c
carry <- a -> ExitCase b -> CleanupNoException m c
release a
x (forall a. a -> ExitCase a
ExitCaseSuccess b
res)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
res, c
carry)

deriving via CleanupNoException (ST s) instance MonadCleanup (ST s)

deriving via CleanupNoException Identity instance MonadCleanup Identity

instance (MonadCleanup m) => MonadCleanup (IdentityT m) where
  generalCleanup :: forall a b c.
IdentityT m a
-> (a -> ExitCase b -> IdentityT m c)
-> (a -> IdentityT m b)
-> IdentityT m (b, c)
generalCleanup IdentityT m a
acquire a -> ExitCase b -> IdentityT m c
release a -> IdentityT m b
use =
    forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT m a
acquire)
        (\a
resource ExitCase b
exitCase -> forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (a -> ExitCase b -> IdentityT m c
release a
resource ExitCase b
exitCase))
        (\a
resource -> forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (a -> IdentityT m b
use a
resource))

instance MonadCleanup m => MonadCleanup (LazyS.StateT s m) where
  generalCleanup :: forall a b c.
StateT s m a
-> (a -> ExitCase b -> StateT s m c)
-> (a -> StateT s m b)
-> StateT s m (b, c)
generalCleanup StateT s m a
acquire a -> ExitCase b -> StateT s m c
release a -> StateT s m b
use = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
LazyS.StateT forall a b. (a -> b) -> a -> b
$ \s
s0 -> do
    ((b
b, s
_s2), (c
c, s
s3)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LazyS.runStateT StateT s m a
acquire s
s0)
        ( \(a
resource, s
s1) ExitCase (b, s)
exitCase -> case ExitCase (b, s)
exitCase of
            ExitCaseSuccess (b
b, s
s2) -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LazyS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)) s
s2
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @s1@.
            ExitCaseException SomeException
e -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LazyS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)) s
s1
            ExitCase (b, s)
ExitCaseAbort -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LazyS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource forall a. ExitCase a
ExitCaseAbort) s
s1
        )
        (\(a
resource, s
s1) -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LazyS.runStateT (a -> StateT s m b
use a
resource) s
s1)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), s
s3)

instance MonadCleanup m => MonadCleanup (StrictS.StateT s m) where
  generalCleanup :: forall a b c.
StateT s m a
-> (a -> ExitCase b -> StateT s m c)
-> (a -> StateT s m b)
-> StateT s m (b, c)
generalCleanup StateT s m a
acquire a -> ExitCase b -> StateT s m c
release a -> StateT s m b
use = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StrictS.StateT forall a b. (a -> b) -> a -> b
$ \s
s0 -> do
    ((b
b, s
_s2), (c
c, s
s3)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StrictS.runStateT StateT s m a
acquire s
s0)
        ( \(a
resource, s
s1) ExitCase (b, s)
exitCase -> case ExitCase (b, s)
exitCase of
            ExitCaseSuccess (b
b, s
s2) -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StrictS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)) s
s2
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @s1@.
            ExitCaseException SomeException
e -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StrictS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)) s
s1
            ExitCase (b, s)
ExitCaseAbort -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StrictS.runStateT (a -> ExitCase b -> StateT s m c
release a
resource forall a. ExitCase a
ExitCaseAbort) s
s1
        )
        (\(a
resource, s
s1) -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StrictS.runStateT (a -> StateT s m b
use a
resource) s
s1)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), s
s3)

instance MonadCleanup m => MonadCleanup (ReaderT r m) where
  generalCleanup :: forall a b c.
ReaderT r m a
-> (a -> ExitCase b -> ReaderT r m c)
-> (a -> ReaderT r m b)
-> ReaderT r m (b, c)
generalCleanup ReaderT r m a
acquire a -> ExitCase b -> ReaderT r m c
release a -> ReaderT r m b
use = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
    forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
      (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
acquire r
r)
      (\a
resource ExitCase b
exitCase -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ExitCase b -> ReaderT r m c
release a
resource ExitCase b
exitCase) r
r)
      (\a
resource -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
use a
resource) r
r)

instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictW.WriterT w m) where
  generalCleanup :: forall a b c.
WriterT w m a
-> (a -> ExitCase b -> WriterT w m c)
-> (a -> WriterT w m b)
-> WriterT w m (b, c)
generalCleanup WriterT w m a
acquire a -> ExitCase b -> WriterT w m c
release a -> WriterT w m b
use = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
StrictW.WriterT forall a b. (a -> b) -> a -> b
$ do
    ((b
b, w
_w12), (c
c, w
w123)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictW.runWriterT WriterT w m a
acquire)
        ( \(a
resource, w
w1) ExitCase (b, w)
exitCase -> case ExitCase (b, w)
exitCase of
            ExitCaseSuccess (b
b, w
w12) -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b))
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w12 w
w3)
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @w1@.
            ExitCaseException SomeException
e -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e))
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
            ExitCase (b, w)
ExitCaseAbort -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource forall a. ExitCase a
ExitCaseAbort)
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
        )
        ( \(a
resource, w
w1) -> do
            (b
a, w
w2) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictW.runWriterT (a -> WriterT w m b
use a
resource)
            forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2)
        )
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), w
w123)

instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyW.WriterT w m) where
  generalCleanup :: forall a b c.
WriterT w m a
-> (a -> ExitCase b -> WriterT w m c)
-> (a -> WriterT w m b)
-> WriterT w m (b, c)
generalCleanup WriterT w m a
acquire a -> ExitCase b -> WriterT w m c
release a -> WriterT w m b
use = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
LazyW.WriterT forall a b. (a -> b) -> a -> b
$ do
    ((b
b, w
_w12), (c
c, w
w123)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyW.runWriterT WriterT w m a
acquire)
        ( \(a
resource, w
w1) ExitCase (b, w)
exitCase -> case ExitCase (b, w)
exitCase of
            ExitCaseSuccess (b
b, w
w12) -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b))
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w12 w
w3)
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @w1@.
            ExitCaseException SomeException
e -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e))
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
            ExitCase (b, w)
ExitCaseAbort -> do
              (c
c, w
w3) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyW.runWriterT (a -> ExitCase b -> WriterT w m c
release a
resource forall a. ExitCase a
ExitCaseAbort)
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
        )
        ( \(a
resource, w
w1) -> do
            (b
a, w
w2) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyW.runWriterT (a -> WriterT w m b
use a
resource)
            forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2)
        )
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), w
w123)

instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyRWS.RWST r w s m) where
  generalCleanup :: forall a b c.
RWST r w s m a
-> (a -> ExitCase b -> RWST r w s m c)
-> (a -> RWST r w s m b)
-> RWST r w s m (b, c)
generalCleanup RWST r w s m a
acquire a -> ExitCase b -> RWST r w s m c
release a -> RWST r w s m b
use = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
LazyRWS.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s0 -> do
    ((b
b, s
_s2, w
_w12), (c
c, s
s3, w
w123)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
LazyRWS.runRWST RWST r w s m a
acquire r
r s
s0)
        ( \(a
resource, s
s1, w
w1) ExitCase (b, s, w)
exitCase -> case ExitCase (b, s, w)
exitCase of
            ExitCaseSuccess (b
b, s
s2, w
w12) -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
LazyRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)) r
r s
s2
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w12 w
w3)
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @s1@ and @w1@.
            ExitCaseException SomeException
e -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
LazyRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)) r
r s
s1
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
            ExitCase (b, s, w)
ExitCaseAbort -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
LazyRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource forall a. ExitCase a
ExitCaseAbort) r
r s
s1
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
        )
        ( \(a
resource, s
s1, w
w1) -> do
            (b
a, s
s2, w
w2) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
LazyRWS.runRWST (a -> RWST r w s m b
use a
resource) r
r s
s1
            forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, s
s2, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2)
        )
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), s
s3, w
w123)

instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictRWS.RWST r w s m) where
  generalCleanup :: forall a b c.
RWST r w s m a
-> (a -> ExitCase b -> RWST r w s m c)
-> (a -> RWST r w s m b)
-> RWST r w s m (b, c)
generalCleanup RWST r w s m a
acquire a -> ExitCase b -> RWST r w s m c
release a -> RWST r w s m b
use = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
StrictRWS.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s0 -> do
    ((b
b, s
_s2, w
_w12), (c
c, s
s3, w
w123)) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
StrictRWS.runRWST RWST r w s m a
acquire r
r s
s0)
        ( \(a
resource, s
s1, w
w1) ExitCase (b, s, w)
exitCase -> case ExitCase (b, s, w)
exitCase of
            ExitCaseSuccess (b
b, s
s2, w
w12) -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
StrictRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)) r
r s
s2
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w12 w
w3)
            -- In the two other cases, the base monad overrides @use@'s state
            -- changes and the state reverts to @s1@ and @w1@.
            ExitCaseException SomeException
e -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
StrictRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)) r
r s
s1
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
            ExitCase (b, s, w)
ExitCaseAbort -> do
              (c
c, s
s3, w
w3) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
StrictRWS.runRWST (a -> ExitCase b -> RWST r w s m c
release a
resource forall a. ExitCase a
ExitCaseAbort) r
r s
s1
              forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, s
s3, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w3)
        )
        ( \(a
resource, s
s1, w
w1) -> do
            (b
a, s
s2, w
w2) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
StrictRWS.runRWST (a -> RWST r w s m b
use a
resource) r
r s
s1
            forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, s
s2, forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2)
        )
    forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, c
c), s
s3, w
w123)

instance MonadCleanup m => MonadCleanup (MaybeT m) where
  generalCleanup :: forall a b c.
MaybeT m a
-> (a -> ExitCase b -> MaybeT m c)
-> (a -> MaybeT m b)
-> MaybeT m (b, c)
generalCleanup MaybeT m a
acquire a -> ExitCase b -> MaybeT m c
release a -> MaybeT m b
use = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ do
    (Maybe b
eb, Maybe c
ec) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT m a
acquire)
        ( \Maybe a
resourceMay ExitCase (Maybe b)
exitCase -> case Maybe a
resourceMay of
            Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- nothing to release, acquire didn't succeed
            Just a
resource -> case ExitCase (Maybe b)
exitCase of
              ExitCaseSuccess (Just b
b) -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> ExitCase b -> MaybeT m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b))
              ExitCaseException SomeException
e -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> ExitCase b -> MaybeT m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e))
              ExitCase (Maybe b)
_ -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> ExitCase b -> MaybeT m c
release a
resource forall a. ExitCase a
ExitCaseAbort)
        )
        ( \Maybe a
resourceMay -> case Maybe a
resourceMay of
            Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just a
resource -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m b
use a
resource)
        )
    -- The order in which we perform those two 'Maybe' effects doesn't matter,
    -- since the error message is the same regardless.
    forall (m :: * -> *) a. Monad m => a -> m a
return ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe b
eb forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe c
ec)

instance MonadCleanup m => MonadCleanup (ExceptT e m) where
  generalCleanup :: forall a b c.
ExceptT e m a
-> (a -> ExitCase b -> ExceptT e m c)
-> (a -> ExceptT e m b)
-> ExceptT e m (b, c)
generalCleanup ExceptT e m a
acquire a -> ExitCase b -> ExceptT e m c
release a -> ExceptT e m b
use = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
    (Either e b
eb, Either e c
ec) <-
      forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalCleanup
        (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
acquire)
        ( \Either e a
eresource ExitCase (Either e b)
exitCase -> case Either e a
eresource of
            Left e
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left e
e) -- nothing to release, acquire didn't succeed
            Right a
resource -> case ExitCase (Either e b)
exitCase of
              ExitCaseSuccess (Right b
b) -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b))
              ExitCaseException SomeException
e -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e))
              ExitCase (Either e b)
_ -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource forall a. ExitCase a
ExitCaseAbort)
        )
        (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (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 e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ExceptT e m b
use))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      -- The order in which we perform those two 'Either' effects determines
      -- which error will win if they are both 'Left's. We want the error from
      -- 'release' to win.
      c
c <- Either e c
ec
      b
b <- Either e b
eb
      forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)