{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}

module Control.Monad.Trans.Resource.Internal(
    InvalidAccess(..)
  , MonadResource(..)
  , ReleaseKey(..)
  , ReleaseMap(..)
  , ResIO
  , ResourceT(..)
  , stateAlloc
  , stateCleanup
  , transResourceT
  , register'
  , registerType
  , ResourceCleanupException (..)
  , stateCleanupChecked
) where

import Control.Exception (throw,Exception,SomeException)
import Control.Applicative (Applicative (..), Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Fail (MonadFail(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class    (MonadTrans (..))
import Control.Monad.Trans.Cont     ( ContT  )
import Control.Monad.Cont.Class   ( MonadCont (..) )
import Control.Monad.Error.Class  ( MonadError (..) )
import Control.Monad.RWS.Class    ( MonadRWS )
import Control.Monad.Reader.Class ( MonadReader (..) )
import Control.Monad.State.Class  ( MonadState (..) )
import Control.Monad.Writer.Class ( MonadWriter (..) )

import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List     ( ListT    )
import Control.Monad.Trans.Maybe    ( MaybeT   )
import Control.Monad.Trans.Except   ( ExceptT  )
import Control.Monad.Trans.Reader   ( ReaderT  )
import Control.Monad.Trans.State    ( StateT   )
import Control.Monad.Trans.Writer   ( WriterT  )
import Control.Monad.Trans.RWS      ( RWST     )

import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Primitive (PrimMonad (..))
import qualified Control.Exception as E

-- FIXME Do we want to only support MonadThrow?
import Control.Monad.Catch (MonadThrow (..), MonadCatch (..), MonadMask (..))
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.IORef as I
import Data.Typeable
import Data.Word(Word)
import Data.Acquire.Internal (ReleaseType (..))

-- | A @Monad@ which allows for safe resource allocation. In theory, any monad
-- transformer stack which includes a @ResourceT@ can be an instance of
-- @MonadResource@.
--
-- Note: @runResourceT@ has a requirement for a @MonadUnliftIO m@ monad,
-- which allows control operations to be lifted. A @MonadResource@ does not
-- have this requirement. This means that transformers such as @ContT@ can be
-- an instance of @MonadResource@. However, the @ContT@ wrapper will need to be
-- unwrapped before calling @runResourceT@.
--
-- Since 0.3.0
class MonadIO m => MonadResource m where
    -- | Lift a @ResourceT IO@ action into the current @Monad@.
    --
    -- Since 0.4.0
    liftResourceT :: ResourceT IO a -> m a


-- | A lookup key for a specific release action. This value is returned by
-- 'register' and 'allocate', and is passed to 'release'.
--
-- Since 0.3.0
data ReleaseKey = ReleaseKey !(I.IORef ReleaseMap) !Int
    deriving Typeable

type RefCount = Word
type NextKey = Int

data ReleaseMap =
    ReleaseMap !NextKey !RefCount !(IntMap (ReleaseType -> IO ()))
  | ReleaseMapClosed

-- | Convenient alias for @ResourceT IO@.
type ResIO = ResourceT IO


instance MonadCont m => MonadCont (ResourceT m) where
  callCC :: ((a -> ResourceT m b) -> ResourceT m a) -> ResourceT m a
callCC (a -> ResourceT m b) -> ResourceT m a
f = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
i -> ((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((a -> m b) -> m a) -> m a) -> ((a -> m b) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \a -> m b
c -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ((a -> ResourceT m b) -> ResourceT m a
f ((IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (a -> IORef ReleaseMap -> m b) -> a -> ResourceT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> IORef ReleaseMap -> m b
forall a b. a -> b -> a
const (m b -> IORef ReleaseMap -> m b)
-> (a -> m b) -> a -> IORef ReleaseMap -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
c)) IORef ReleaseMap
i

instance MonadError e m => MonadError e (ResourceT m) where
  throwError :: e -> ResourceT m a
throwError = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a) -> (e -> m a) -> e -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: ResourceT m a -> (e -> ResourceT m a) -> ResourceT m a
catchError ResourceT m a
r e -> ResourceT m a
h = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
i -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ResourceT m a
r IORef ReleaseMap
i m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
e -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT (e -> ResourceT m a
h e
e) IORef ReleaseMap
i

instance MonadRWS r w s m => MonadRWS r w s (ResourceT m)

instance MonadReader r m => MonadReader r (ResourceT m) where
  ask :: ResourceT m r
ask = m r -> ResourceT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> ResourceT m a -> ResourceT m a
local = (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
mapResourceT ((m a -> m a) -> ResourceT m a -> ResourceT m a)
-> ((r -> r) -> m a -> m a)
-> (r -> r)
-> ResourceT m a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

mapResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b
mapResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b
mapResourceT m a -> n b
f = (IORef ReleaseMap -> n b) -> ResourceT n b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> n b) -> ResourceT n b)
-> (ResourceT m a -> IORef ReleaseMap -> n b)
-> ResourceT m a
-> ResourceT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> n b
f (m a -> n b)
-> (IORef ReleaseMap -> m a) -> IORef ReleaseMap -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((IORef ReleaseMap -> m a) -> IORef ReleaseMap -> n b)
-> (ResourceT m a -> IORef ReleaseMap -> m a)
-> ResourceT m a
-> IORef ReleaseMap
-> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT

instance MonadState s m => MonadState s (ResourceT m) where
  get :: ResourceT m s
get = m s -> ResourceT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> ResourceT m ()
put = m () -> ResourceT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ResourceT m ()) -> (s -> m ()) -> s -> ResourceT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance MonadWriter w m => MonadWriter w (ResourceT m) where
  tell :: w -> ResourceT m ()
tell   = m () -> ResourceT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ResourceT m ()) -> (w -> m ()) -> w -> ResourceT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: ResourceT m a -> ResourceT m (a, w)
listen = (m a -> m (a, w)) -> ResourceT m a -> ResourceT m (a, w)
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
mapResourceT m a -> m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
  pass :: ResourceT m (a, w -> w) -> ResourceT m a
pass   = (m (a, w -> w) -> m a) -> ResourceT m (a, w -> w) -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
mapResourceT m (a, w -> w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass

instance MonadThrow m => MonadThrow (ResourceT m) where
    throwM :: e -> ResourceT m a
throwM = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a) -> (e -> m a) -> e -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
instance MonadCatch m => MonadCatch (ResourceT m) where
  catch :: ResourceT m a -> (e -> ResourceT m a) -> ResourceT m a
catch (ResourceT IORef ReleaseMap -> m a
m) e -> ResourceT m a
c =
      (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> IORef ReleaseMap -> m a
m IORef ReleaseMap
r m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e
e -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT (e -> ResourceT m a
c e
e) IORef ReleaseMap
r
instance MonadMask m => MonadMask (ResourceT m) where
  mask :: ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b)
-> ResourceT m b
mask (forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
a = (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
e -> ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ResourceT m b -> IORef ReleaseMap -> m b
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
a ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b)
-> (forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
q m a -> m a
forall a. m a -> m a
u) IORef ReleaseMap
e
    where q :: (m a -> m a) -> ResourceT m a -> ResourceT m a
q m a -> m a
u (ResourceT IORef ReleaseMap -> m a
b) = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT (m a -> m a
u (m a -> m a)
-> (IORef ReleaseMap -> m a) -> IORef ReleaseMap -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ReleaseMap -> m a
b)
  uninterruptibleMask :: ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b)
-> ResourceT m b
uninterruptibleMask (forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
a =
    (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
e -> ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ResourceT m b -> IORef ReleaseMap -> m b
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
a ((forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b)
-> (forall a. ResourceT m a -> ResourceT m a) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
q m a -> m a
forall a. m a -> m a
u) IORef ReleaseMap
e
      where q :: (m a -> m a) -> ResourceT m a -> ResourceT m a
q m a -> m a
u (ResourceT IORef ReleaseMap -> m a
b) = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT (m a -> m a
u (m a -> m a)
-> (IORef ReleaseMap -> m a) -> IORef ReleaseMap -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ReleaseMap -> m a
b)
#if MIN_VERSION_exceptions(0, 10, 0)
  generalBracket :: ResourceT m a
-> (a -> ExitCase b -> ResourceT m c)
-> (a -> ResourceT m b)
-> ResourceT m (b, c)
generalBracket ResourceT m a
acquire a -> ExitCase b -> ResourceT m c
release a -> ResourceT m b
use =
    (IORef ReleaseMap -> m (b, c)) -> ResourceT m (b, c)
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m (b, c)) -> ResourceT m (b, c))
-> (IORef ReleaseMap -> m (b, c)) -> ResourceT m (b, c)
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r ->
        m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
            ( ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ResourceT m a
acquire IORef ReleaseMap
r )
            ( \a
resource ExitCase b
exitCase ->
                  ResourceT m c -> IORef ReleaseMap -> m c
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ( a -> ExitCase b -> ResourceT m c
release a
resource ExitCase b
exitCase ) IORef ReleaseMap
r
            )
            ( \a
resource -> ResourceT m b -> IORef ReleaseMap -> m b
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT ( a -> ResourceT m b
use a
resource ) IORef ReleaseMap
r )
#elif MIN_VERSION_exceptions(0, 9, 0)
#error exceptions 0.9.0 is not supported
#endif
instance MonadIO m => MonadResource (ResourceT m) where
    liftResourceT :: ResourceT IO a -> ResourceT m a
liftResourceT = (IO a -> m a) -> ResourceT IO a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance PrimMonad m => PrimMonad (ResourceT m) where
    type PrimState (ResourceT m) = PrimState m
    primitive :: (State# (PrimState (ResourceT m))
 -> (# State# (PrimState (ResourceT m)), a #))
-> ResourceT m a
primitive = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a)
-> ((State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> (State# (PrimState m) -> (# State# (PrimState m), a #))
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive

-- | Transform the monad a @ResourceT@ lives in. This is most often used to
-- strip or add new transformers to a stack, e.g. to run a @ReaderT@.
--
-- Note that this function is a slight generalization of 'hoist'.
--
-- Since 0.3.0
transResourceT :: (m a -> n b)
               -> ResourceT m a
               -> ResourceT n b
transResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT m a -> n b
f (ResourceT IORef ReleaseMap -> m a
mx) = (IORef ReleaseMap -> n b) -> ResourceT n b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT (\IORef ReleaseMap
r -> m a -> n b
f (IORef ReleaseMap -> m a
mx IORef ReleaseMap
r))

-- | The Resource transformer. This transformer keeps track of all registered
-- actions, and calls them upon exit (via 'runResourceT'). Actions may be
-- registered via 'register', or resources may be allocated atomically via
-- 'allocate'. @allocate@ corresponds closely to @bracket@.
--
-- Releasing may be performed before exit via the 'release' function. This is a
-- highly recommended optimization, as it will ensure that scarce resources are
-- freed early. Note that calling @release@ will deregister the action, so that
-- a release action will only ever be called once.
--
-- Since 0.3.0
newtype ResourceT m a = ResourceT { ResourceT m a -> IORef ReleaseMap -> m a
unResourceT :: I.IORef ReleaseMap -> m a }
#if __GLASGOW_HASKELL__ >= 707
        deriving Typeable
#else
instance Typeable1 m => Typeable1 (ResourceT m) where
    typeOf1 = goType undefined
      where
        goType :: Typeable1 m => m a -> ResourceT m a -> TypeRep
        goType m _ =
            mkTyConApp
#if __GLASGOW_HASKELL__ >= 704
                (mkTyCon3 "resourcet" "Control.Monad.Trans.Resource" "ResourceT")
#else
                (mkTyCon "Control.Monad.Trans.Resource.ResourceT")
#endif
                [ typeOf1 m
                ]
#endif

-- | Indicates either an error in the library, or misuse of it (e.g., a
-- @ResourceT@'s state is accessed after being released).
--
-- Since 0.3.0
data InvalidAccess = InvalidAccess { InvalidAccess -> String
functionName :: String }
    deriving Typeable

instance Show InvalidAccess where
    show :: InvalidAccess -> String
show (InvalidAccess String
f) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Control.Monad.Trans.Resource."
        , String
f
        , String
": The mutable state is being accessed after cleanup. Please contact the maintainers."
        ]

instance Exception InvalidAccess

-------- All of our monad et al instances
instance Functor m => Functor (ResourceT m) where
    fmap :: (a -> b) -> ResourceT m a -> ResourceT m b
fmap a -> b
f (ResourceT IORef ReleaseMap -> m a
m) = (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IORef ReleaseMap -> m a
m IORef ReleaseMap
r)

instance Applicative m => Applicative (ResourceT m) where
    pure :: a -> ResourceT m a
pure = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (a -> IORef ReleaseMap -> m a) -> a -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IORef ReleaseMap -> m a
forall a b. a -> b -> a
const (m a -> IORef ReleaseMap -> m a)
-> (a -> m a) -> a -> IORef ReleaseMap -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ResourceT IORef ReleaseMap -> m (a -> b)
mf <*> :: ResourceT m (a -> b) -> ResourceT m a -> ResourceT m b
<*> ResourceT IORef ReleaseMap -> m a
ma = (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r ->
        IORef ReleaseMap -> m (a -> b)
mf IORef ReleaseMap
r m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef ReleaseMap -> m a
ma IORef ReleaseMap
r
    ResourceT IORef ReleaseMap -> m a
mf *> :: ResourceT m a -> ResourceT m b -> ResourceT m b
*> ResourceT IORef ReleaseMap -> m b
ma = (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r ->
        IORef ReleaseMap -> m a
mf IORef ReleaseMap
r m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IORef ReleaseMap -> m b
ma IORef ReleaseMap
r
    ResourceT IORef ReleaseMap -> m a
mf <* :: ResourceT m a -> ResourceT m b -> ResourceT m a
<* ResourceT IORef ReleaseMap -> m b
ma = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r ->
        IORef ReleaseMap -> m a
mf IORef ReleaseMap
r m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IORef ReleaseMap -> m b
ma IORef ReleaseMap
r

-- | Since 1.1.5
instance Alternative m => Alternative (ResourceT m) where
    empty :: ResourceT m a
empty = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
_ -> m a
forall (f :: * -> *) a. Alternative f => f a
empty
    (ResourceT IORef ReleaseMap -> m a
mf) <|> :: ResourceT m a -> ResourceT m a -> ResourceT m a
<|> (ResourceT IORef ReleaseMap -> m a
ma) = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> IORef ReleaseMap -> m a
mf IORef ReleaseMap
r m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IORef ReleaseMap -> m a
ma IORef ReleaseMap
r

-- | Since 1.1.5
instance MonadPlus m => MonadPlus (ResourceT m) where
    mzero :: ResourceT m a
mzero = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
_ -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    (ResourceT IORef ReleaseMap -> m a
mf) mplus :: ResourceT m a -> ResourceT m a -> ResourceT m a
`mplus` (ResourceT IORef ReleaseMap -> m a
ma) = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> IORef ReleaseMap -> m a
mf IORef ReleaseMap
r m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` IORef ReleaseMap -> m a
ma IORef ReleaseMap
r

instance Monad m => Monad (ResourceT m) where
    return :: a -> ResourceT m a
return = a -> ResourceT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ResourceT IORef ReleaseMap -> m a
ma >>= :: ResourceT m a -> (a -> ResourceT m b) -> ResourceT m b
>>= a -> ResourceT m b
f = (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> do
        a
a <- IORef ReleaseMap -> m a
ma IORef ReleaseMap
r
        let ResourceT IORef ReleaseMap -> m b
f' = a -> ResourceT m b
f a
a
        IORef ReleaseMap -> m b
f' IORef ReleaseMap
r

-- | @since 1.2.2
instance MonadFail m => MonadFail (ResourceT m) where
    fail :: String -> ResourceT m a
fail = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a)
-> (String -> m a) -> String -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail

-- | @since 1.1.8
instance MonadFix m => MonadFix (ResourceT m) where
  mfix :: (a -> ResourceT m a) -> ResourceT m a
mfix a -> ResourceT m a
f = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r -> (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> m a) -> m a) -> (a -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \a
a -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT (a -> ResourceT m a
f a
a) IORef ReleaseMap
r

instance MonadTrans ResourceT where
    lift :: m a -> ResourceT m a
lift = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (m a -> IORef ReleaseMap -> m a) -> m a -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IORef ReleaseMap -> m a
forall a b. a -> b -> a
const

instance MonadIO m => MonadIO (ResourceT m) where
    liftIO :: IO a -> ResourceT m a
liftIO = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a) -> (IO a -> m a) -> IO a -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | @since 1.1.10
instance MonadUnliftIO m => MonadUnliftIO (ResourceT m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. ResourceT m a -> IO a) -> IO b) -> ResourceT m b
withRunInIO (forall a. ResourceT m a -> IO a) -> IO b
inner =
    (IORef ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m b) -> ResourceT m b)
-> (IORef ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
r ->
    ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. ResourceT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (ResourceT m a -> m a) -> ResourceT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResourceT m a -> IORef ReleaseMap -> m a)
-> IORef ReleaseMap -> ResourceT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
unResourceT IORef ReleaseMap
r)

#define GO(T) instance (MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT
#define GOX(X, T) instance (X, MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GO(ExceptT e)
GO(ReaderT r)
GO(ContT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#undef GO
#undef GOX

stateAlloc :: I.IORef ReleaseMap -> IO ()
stateAlloc :: IORef ReleaseMap -> IO ()
stateAlloc IORef ReleaseMap
istate = do
    IORef ReleaseMap -> (ReleaseMap -> (ReleaseMap, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap -> (ReleaseMap, ())) -> IO ())
-> (ReleaseMap -> (ReleaseMap, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
        case ReleaseMap
rm of
            ReleaseMap Int
nk RefCount
rf IntMap (ReleaseType -> IO ())
m ->
                (Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
ReleaseMap Int
nk (RefCount
rf RefCount -> RefCount -> RefCount
forall a. Num a => a -> a -> a
+ RefCount
1) IntMap (ReleaseType -> IO ())
m, ())
            ReleaseMap
ReleaseMapClosed -> InvalidAccess -> (ReleaseMap, ())
forall a e. Exception e => e -> a
throw (InvalidAccess -> (ReleaseMap, ()))
-> InvalidAccess -> (ReleaseMap, ())
forall a b. (a -> b) -> a -> b
$ String -> InvalidAccess
InvalidAccess String
"stateAlloc"

stateCleanup :: ReleaseType -> I.IORef ReleaseMap -> IO ()
stateCleanup :: ReleaseType -> IORef ReleaseMap -> IO ()
stateCleanup ReleaseType
rtype IORef ReleaseMap
istate = IO () -> IO ()
forall a. IO a -> IO a
E.mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (IntMap (ReleaseType -> IO ()))
mm <- IORef ReleaseMap
-> (ReleaseMap
    -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> IO (Maybe (IntMap (ReleaseType -> IO ())))
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap
  -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
 -> IO (Maybe (IntMap (ReleaseType -> IO ()))))
-> (ReleaseMap
    -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> IO (Maybe (IntMap (ReleaseType -> IO ())))
forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
        case ReleaseMap
rm of
            ReleaseMap Int
nk RefCount
rf IntMap (ReleaseType -> IO ())
m ->
                let rf' :: RefCount
rf' = RefCount
rf RefCount -> RefCount -> RefCount
forall a. Num a => a -> a -> a
- RefCount
1
                 in if RefCount
rf' RefCount -> RefCount -> Bool
forall a. Eq a => a -> a -> Bool
== RefCount
forall a. Bounded a => a
minBound
                        then (ReleaseMap
ReleaseMapClosed, IntMap (ReleaseType -> IO ())
-> Maybe (IntMap (ReleaseType -> IO ()))
forall a. a -> Maybe a
Just IntMap (ReleaseType -> IO ())
m)
                        else (Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
ReleaseMap Int
nk RefCount
rf' IntMap (ReleaseType -> IO ())
m, Maybe (IntMap (ReleaseType -> IO ()))
forall a. Maybe a
Nothing)
            ReleaseMap
ReleaseMapClosed -> InvalidAccess
-> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ())))
forall a e. Exception e => e -> a
throw (InvalidAccess
 -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> InvalidAccess
-> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ())))
forall a b. (a -> b) -> a -> b
$ String -> InvalidAccess
InvalidAccess String
"stateCleanup"
    case Maybe (IntMap (ReleaseType -> IO ()))
mm of
        Just IntMap (ReleaseType -> IO ())
m ->
            ((ReleaseType -> IO ()) -> IO ())
-> [ReleaseType -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ReleaseType -> IO ()
x -> IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
try (ReleaseType -> IO ()
x ReleaseType
rtype) IO (Either SomeException ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ([ReleaseType -> IO ()] -> IO ())
-> [ReleaseType -> IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ IntMap (ReleaseType -> IO ()) -> [ReleaseType -> IO ()]
forall a. IntMap a -> [a]
IntMap.elems IntMap (ReleaseType -> IO ())
m
        Maybe (IntMap (ReleaseType -> IO ()))
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    try :: IO a -> IO (Either SomeException a)
    try :: IO a -> IO (Either SomeException a)
try = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try

register' :: I.IORef ReleaseMap
          -> IO ()
          -> IO ReleaseKey
register' :: IORef ReleaseMap -> IO () -> IO ReleaseKey
register' IORef ReleaseMap
istate IO ()
rel = IORef ReleaseMap
-> (ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey)
-> (ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
    case ReleaseMap
rm of
        ReleaseMap Int
key RefCount
rf IntMap (ReleaseType -> IO ())
m ->
            ( Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
ReleaseMap (Int
key Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) RefCount
rf (Int
-> (ReleaseType -> IO ())
-> IntMap (ReleaseType -> IO ())
-> IntMap (ReleaseType -> IO ())
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
key (IO () -> ReleaseType -> IO ()
forall a b. a -> b -> a
const IO ()
rel) IntMap (ReleaseType -> IO ())
m)
            , IORef ReleaseMap -> Int -> ReleaseKey
ReleaseKey IORef ReleaseMap
istate Int
key
            )
        ReleaseMap
ReleaseMapClosed -> InvalidAccess -> (ReleaseMap, ReleaseKey)
forall a e. Exception e => e -> a
throw (InvalidAccess -> (ReleaseMap, ReleaseKey))
-> InvalidAccess -> (ReleaseMap, ReleaseKey)
forall a b. (a -> b) -> a -> b
$ String -> InvalidAccess
InvalidAccess String
"register'"

-- |
--
-- Since 1.1.2
registerType :: I.IORef ReleaseMap
             -> (ReleaseType -> IO ())
             -> IO ReleaseKey
registerType :: IORef ReleaseMap -> (ReleaseType -> IO ()) -> IO ReleaseKey
registerType IORef ReleaseMap
istate ReleaseType -> IO ()
rel = IORef ReleaseMap
-> (ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey)
-> (ReleaseMap -> (ReleaseMap, ReleaseKey)) -> IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
    case ReleaseMap
rm of
        ReleaseMap Int
key RefCount
rf IntMap (ReleaseType -> IO ())
m ->
            ( Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
ReleaseMap (Int
key Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) RefCount
rf (Int
-> (ReleaseType -> IO ())
-> IntMap (ReleaseType -> IO ())
-> IntMap (ReleaseType -> IO ())
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
key ReleaseType -> IO ()
rel IntMap (ReleaseType -> IO ())
m)
            , IORef ReleaseMap -> Int -> ReleaseKey
ReleaseKey IORef ReleaseMap
istate Int
key
            )
        ReleaseMap
ReleaseMapClosed -> InvalidAccess -> (ReleaseMap, ReleaseKey)
forall a e. Exception e => e -> a
throw (InvalidAccess -> (ReleaseMap, ReleaseKey))
-> InvalidAccess -> (ReleaseMap, ReleaseKey)
forall a b. (a -> b) -> a -> b
$ String -> InvalidAccess
InvalidAccess String
"register'"

-- | Thrown when one or more cleanup functions themselves throw an
-- exception during cleanup.
--
-- @since 1.1.11
data ResourceCleanupException = ResourceCleanupException
  { ResourceCleanupException -> Maybe SomeException
rceOriginalException :: !(Maybe SomeException)
  -- ^ If the 'ResourceT' block exited due to an exception, this is
  -- that exception.
  --
  -- @since 1.1.11
  , ResourceCleanupException -> SomeException
rceFirstCleanupException :: !SomeException
  -- ^ The first cleanup exception. We keep this separate from
  -- 'rceOtherCleanupExceptions' to prove that there's at least one
  -- (i.e., a non-empty list).
  --
  -- @since 1.1.11
  , ResourceCleanupException -> [SomeException]
rceOtherCleanupExceptions :: ![SomeException]
  -- ^ All other exceptions in cleanups.
  --
  -- @since 1.1.11
  }
  deriving (Int -> ResourceCleanupException -> ShowS
[ResourceCleanupException] -> ShowS
ResourceCleanupException -> String
(Int -> ResourceCleanupException -> ShowS)
-> (ResourceCleanupException -> String)
-> ([ResourceCleanupException] -> ShowS)
-> Show ResourceCleanupException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceCleanupException] -> ShowS
$cshowList :: [ResourceCleanupException] -> ShowS
show :: ResourceCleanupException -> String
$cshow :: ResourceCleanupException -> String
showsPrec :: Int -> ResourceCleanupException -> ShowS
$cshowsPrec :: Int -> ResourceCleanupException -> ShowS
Show, Typeable)
instance Exception ResourceCleanupException

-- | Clean up a release map, but throw a 'ResourceCleanupException' if
-- anything goes wrong in the cleanup handlers.
--
-- @since 1.1.11
stateCleanupChecked
  :: Maybe SomeException -- ^ exception that killed the 'ResourceT', if present
  -> I.IORef ReleaseMap -> IO ()
stateCleanupChecked :: Maybe SomeException -> IORef ReleaseMap -> IO ()
stateCleanupChecked Maybe SomeException
morig IORef ReleaseMap
istate = IO () -> IO ()
forall a. IO a -> IO a
E.mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (IntMap (ReleaseType -> IO ()))
mm <- IORef ReleaseMap
-> (ReleaseMap
    -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> IO (Maybe (IntMap (ReleaseType -> IO ())))
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap
  -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
 -> IO (Maybe (IntMap (ReleaseType -> IO ()))))
-> (ReleaseMap
    -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> IO (Maybe (IntMap (ReleaseType -> IO ())))
forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
        case ReleaseMap
rm of
            ReleaseMap Int
nk RefCount
rf IntMap (ReleaseType -> IO ())
m ->
                let rf' :: RefCount
rf' = RefCount
rf RefCount -> RefCount -> RefCount
forall a. Num a => a -> a -> a
- RefCount
1
                 in if RefCount
rf' RefCount -> RefCount -> Bool
forall a. Eq a => a -> a -> Bool
== RefCount
forall a. Bounded a => a
minBound
                        then (ReleaseMap
ReleaseMapClosed, IntMap (ReleaseType -> IO ())
-> Maybe (IntMap (ReleaseType -> IO ()))
forall a. a -> Maybe a
Just IntMap (ReleaseType -> IO ())
m)
                        else (Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
ReleaseMap Int
nk RefCount
rf' IntMap (ReleaseType -> IO ())
m, Maybe (IntMap (ReleaseType -> IO ()))
forall a. Maybe a
Nothing)
            ReleaseMap
ReleaseMapClosed -> InvalidAccess
-> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ())))
forall a e. Exception e => e -> a
throw (InvalidAccess
 -> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ()))))
-> InvalidAccess
-> (ReleaseMap, Maybe (IntMap (ReleaseType -> IO ())))
forall a b. (a -> b) -> a -> b
$ String -> InvalidAccess
InvalidAccess String
"stateCleanupChecked"
    case Maybe (IntMap (ReleaseType -> IO ()))
mm of
        Just IntMap (ReleaseType -> IO ())
m -> do
            [SomeException]
res <- ((ReleaseType -> IO ()) -> IO (Maybe SomeException))
-> [ReleaseType -> IO ()] -> IO [SomeException]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeReverseM (\ReleaseType -> IO ()
x -> IO () -> IO (Maybe SomeException)
try (ReleaseType -> IO ()
x ReleaseType
rtype)) ([ReleaseType -> IO ()] -> IO [SomeException])
-> [ReleaseType -> IO ()] -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$ IntMap (ReleaseType -> IO ()) -> [ReleaseType -> IO ()]
forall a. IntMap a -> [a]
IntMap.elems IntMap (ReleaseType -> IO ())
m
            case [SomeException]
res of
                [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- nothing went wrong
                SomeException
e:[SomeException]
es -> ResourceCleanupException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (ResourceCleanupException -> IO ())
-> ResourceCleanupException -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SomeException
-> SomeException -> [SomeException] -> ResourceCleanupException
ResourceCleanupException Maybe SomeException
morig SomeException
e [SomeException]
es
        Maybe (IntMap (ReleaseType -> IO ()))
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    try :: IO () -> IO (Maybe SomeException)
    try :: IO () -> IO (Maybe SomeException)
try IO ()
io = (Either SomeException () -> Maybe SomeException)
-> IO (Either SomeException ()) -> IO (Maybe SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeException -> Maybe SomeException)
-> (() -> Maybe SomeException)
-> Either SomeException ()
-> Maybe SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (\() -> Maybe SomeException
forall a. Maybe a
Nothing)) (IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO ()
io)

    rtype :: ReleaseType
rtype = ReleaseType
-> (SomeException -> ReleaseType)
-> Maybe SomeException
-> ReleaseType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReleaseType
ReleaseNormal (ReleaseType -> SomeException -> ReleaseType
forall a b. a -> b -> a
const ReleaseType
ReleaseException) Maybe SomeException
morig

-- Note that this returns values in reverse order, which is what we
-- want in the specific case of this function.
mapMaybeReverseM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeReverseM :: (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeReverseM a -> m (Maybe b)
f =
    [b] -> [a] -> m [b]
go []
  where
    go :: [b] -> [a] -> m [b]
go [b]
bs [] = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
bs
    go [b]
bs (a
a:[a]
as) = do
      Maybe b
mb <- a -> m (Maybe b)
f a
a
      case Maybe b
mb of
        Maybe b
Nothing -> [b] -> [a] -> m [b]
go [b]
bs [a]
as
        Just b
b -> [b] -> [a] -> m [b]
go (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs) [a]
as