module Control.Monad.Trans.Resource.Extra
   ( -- * Acquire
    acquire1
   , acquireType1
   , mkAcquire1
   , mkAcquireType1
   , acquireReleaseSelf
   , unAcquire

    -- * MonadResource
   , registerType
   , releaseType
   , unprotectType
   , acquireReleaseKey

    -- * MonadMask
   , runResourceT
   , withAcquire
   , withAcquireRelease

    -- * Restore
   , Restore (..)
   , getRestoreIO
   , withRestoreIO

    -- * Async
   , asyncRestore

    -- * IO
   , once
   , onceK
   ) where

import Control.Concurrent.Async qualified as Async
import Control.Concurrent.MVar
import Control.Exception.Safe qualified as Ex
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift qualified as U
import Control.Monad.Trans.Resource qualified as R
import Control.Monad.Trans.Resource.Internal qualified as R
import Data.Acquire.Internal qualified as A
import Data.IORef
import Data.IntMap.Strict qualified as IntMap
import Data.Kind

--------------------------------------------------------------------------------

-- | Like 'A.mkAcquire1', but the acquire function is provided the current
-- 'Restore'-like function.
acquire1 :: ((forall x. IO x -> IO x) -> IO a) -> (a -> IO ()) -> A.Acquire a
acquire1 :: forall a.
((forall x. IO x -> IO x) -> IO a) -> (a -> IO ()) -> Acquire a
acquire1 (forall x. IO x -> IO x) -> IO a
acq a -> IO ()
rel = ((forall x. IO x -> IO x) -> IO a)
-> (a -> ReleaseType -> IO ()) -> Acquire a
forall a.
((forall x. IO x -> IO x) -> IO a)
-> (a -> ReleaseType -> IO ()) -> Acquire a
acquireType1 (forall x. IO x -> IO x) -> IO a
acq \a
a ReleaseType
_ -> a -> IO ()
rel a
a

-- | Like 'A.mkAcquireType1', but the acquire function is provided the current
-- 'Restore'-like function.
acquireType1
   :: ((forall x. IO x -> IO x) -> IO a)
   -> (a -> A.ReleaseType -> IO ())
   -> A.Acquire a
acquireType1 :: forall a.
((forall x. IO x -> IO x) -> IO a)
-> (a -> ReleaseType -> IO ()) -> Acquire a
acquireType1 (forall x. IO x -> IO x) -> IO a
acq a -> ReleaseType -> IO ()
rel = ((forall x. IO x -> IO x) -> IO (Allocated a)) -> Acquire a
forall a.
((forall x. IO x -> IO x) -> IO (Allocated a)) -> Acquire a
A.Acquire \forall x. IO x -> IO x
res -> do
   (a, ReleaseType) -> IO ()
rel1 <- ((a, ReleaseType) -> IO ()) -> IO ((a, ReleaseType) -> IO ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK (((a, ReleaseType) -> IO ()) -> IO ((a, ReleaseType) -> IO ()))
-> ((a, ReleaseType) -> IO ()) -> IO ((a, ReleaseType) -> IO ())
forall a b. (a -> b) -> a -> b
$ (a -> ReleaseType -> IO ()) -> (a, ReleaseType) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> ReleaseType -> IO ()
rel
   a
a <- (forall x. IO x -> IO x) -> IO a
acq IO x -> IO x
forall x. IO x -> IO x
res
   Allocated a -> IO (Allocated a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Allocated a -> IO (Allocated a))
-> Allocated a -> IO (Allocated a)
forall a b. (a -> b) -> a -> b
$ a -> (ReleaseType -> IO ()) -> Allocated a
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
A.Allocated a
a ((ReleaseType -> IO ()) -> Allocated a)
-> (ReleaseType -> IO ()) -> Allocated a
forall a b. (a -> b) -> a -> b
$ ((a, ReleaseType) -> IO ()) -> a -> ReleaseType -> IO ()
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, ReleaseType) -> IO ()
rel1 a
a

-- | Like 'A.mkAcquire', but the release function will be run at most once.
-- Subsequent executions of the release function will be no-ops.
mkAcquire1 :: IO a -> (a -> IO ()) -> A.Acquire a
mkAcquire1 :: forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire1 IO a
acq = ((forall x. IO x -> IO x) -> IO a) -> (a -> IO ()) -> Acquire a
forall a.
((forall x. IO x -> IO x) -> IO a) -> (a -> IO ()) -> Acquire a
acquire1 \forall x. IO x -> IO x
_ -> IO a
acq

-- | Like 'A.mkAcquireType', but the release function will be run at most once.
-- Subsequent executions of the release function will be no-ops.
mkAcquireType1 :: IO a -> (a -> A.ReleaseType -> IO ()) -> A.Acquire a
mkAcquireType1 :: forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType1 IO a
acq = ((forall x. IO x -> IO x) -> IO a)
-> (a -> ReleaseType -> IO ()) -> Acquire a
forall a.
((forall x. IO x -> IO x) -> IO a)
-> (a -> ReleaseType -> IO ()) -> Acquire a
acquireType1 \forall x. IO x -> IO x
_ -> IO a
acq

-- | Build an 'A.Acquire' having access to its own release function.
--
-- The release function will be run at most once. Subsequent executions of
-- the release function will be no-ops.
acquireReleaseSelf :: A.Acquire ((A.ReleaseType -> IO ()) -> a) -> A.Acquire a
acquireReleaseSelf :: forall a. Acquire ((ReleaseType -> IO ()) -> a) -> Acquire a
acquireReleaseSelf (A.Acquire (forall x. IO x -> IO x)
-> IO (Allocated ((ReleaseType -> IO ()) -> a))
f) = ((forall x. IO x -> IO x) -> IO (Allocated a)) -> Acquire a
forall a.
((forall x. IO x -> IO x) -> IO (Allocated a)) -> Acquire a
A.Acquire \forall x. IO x -> IO x
restore -> do
   A.Allocated (ReleaseType -> IO ()) -> a
g ReleaseType -> IO ()
rel0 <- (forall x. IO x -> IO x)
-> IO (Allocated ((ReleaseType -> IO ()) -> a))
f IO b -> IO b
forall x. IO x -> IO x
restore
   ReleaseType -> IO ()
rel1 <- (ReleaseType -> IO ()) -> IO (ReleaseType -> IO ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK ReleaseType -> IO ()
rel0
   Allocated a -> IO (Allocated a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Allocated a -> IO (Allocated a))
-> Allocated a -> IO (Allocated a)
forall a b. (a -> b) -> a -> b
$ a -> (ReleaseType -> IO ()) -> Allocated a
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
A.Allocated ((ReleaseType -> IO ()) -> a
g ReleaseType -> IO ()
rel1) ReleaseType -> IO ()
rel1

-- | Removes the 'A.Acquire' and 'A.Allocated' wrappers.
unAcquire
   :: (MonadIO m)
   => A.Acquire a
   -> (forall x. IO x -> IO x)
   -- ^ 'Restore'-like function.
   -> m (a, A.ReleaseType -> IO ())
unAcquire :: forall (m :: * -> *) a.
MonadIO m =>
Acquire a
-> (forall x. IO x -> IO x) -> m (a, ReleaseType -> IO ())
unAcquire (A.Acquire (forall x. IO x -> IO x) -> IO (Allocated a)
f) forall x. IO x -> IO x
restore = IO (a, ReleaseType -> IO ()) -> m (a, ReleaseType -> IO ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
   A.Allocated a
a ReleaseType -> IO ()
rel <- (forall x. IO x -> IO x) -> IO (Allocated a)
f IO b -> IO b
forall x. IO x -> IO x
restore
   (a, ReleaseType -> IO ()) -> IO (a, ReleaseType -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, ReleaseType -> IO ()
rel)

--------------------------------------------------------------------------------

-- | Like 'R.runResourceT', but requires only 'Ex.MonadMask'.
runResourceT :: (Ex.MonadMask m, MonadIO m) => R.ResourceT m a -> m a
runResourceT :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ResourceT m a -> m a
runResourceT (R.ResourceT IORef ReleaseMap -> m a
r) = do
   IORef ReleaseMap
istate <- IO (IORef ReleaseMap) -> m (IORef ReleaseMap)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IORef ReleaseMap)
forall (m :: * -> *). MonadIO m => m (IORef ReleaseMap)
R.createInternalState
   ((forall a. m a -> m a) -> m a) -> m a
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. m a -> m a
restoreM -> do
      a
a <-
         m a -> m a
forall a. m a -> m a
restoreM (IORef ReleaseMap -> m a
r IORef ReleaseMap
istate) m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Ex.catchAsync` \SomeException
e -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            Maybe SomeException -> IORef ReleaseMap -> IO ()
R.stateCleanupChecked (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e) IORef ReleaseMap
istate
            SomeException -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM SomeException
e
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IORef ReleaseMap -> IO ()
R.stateCleanupChecked Maybe SomeException
forall a. Maybe a
Nothing IORef ReleaseMap
istate
      a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Like 'withAcquireRelease', but doesn't take the extra release function.
withAcquire :: (Ex.MonadMask m, MonadIO m) => A.Acquire a -> (a -> m b) -> m b
withAcquire :: forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
Acquire a -> (a -> m b) -> m b
withAcquire (A.Acquire (forall x. IO x -> IO x) -> IO (Allocated a)
f) a -> m b
g = do
   Restore forall x. IO x -> IO x
restoreIO <- m (Restore IO)
forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO
   ((forall a. m a -> m a) -> m b) -> m b
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. m a -> m a
restoreM -> do
      A.Allocated a
x ReleaseType -> IO ()
free <- IO (Allocated a) -> m (Allocated a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Allocated a) -> m (Allocated a))
-> IO (Allocated a) -> m (Allocated a)
forall a b. (a -> b) -> a -> b
$ (forall x. IO x -> IO x) -> IO (Allocated a)
f IO b -> IO b
forall x. IO x -> IO x
restoreIO
      b
b <- m b -> (SomeException -> m ()) -> m b
forall (m :: * -> *) e a b.
(HasCallStack, MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (m b -> m b
forall a. m a -> m a
restoreM (a -> m b
g a
x)) \SomeException
e ->
         IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free (ReleaseType -> IO ()) -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> ReleaseType
A.ReleaseExceptionWith SomeException
e
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free ReleaseType
A.ReleaseNormal
      b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

-- | @'withAcquireRelease' acq \\release a -> act@ acquires the @a@ and
-- automaticaly releases it when @mb@ returns or throws an exception.
-- If desired, @release@ can be used to release @a@ earlier.
withAcquireRelease
   :: (Ex.MonadMask m, MonadIO m)
   => A.Acquire a
   -> ((A.ReleaseType -> IO ()) -> a -> m b)
   -> m b
withAcquireRelease :: forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
Acquire a -> ((ReleaseType -> IO ()) -> a -> m b) -> m b
withAcquireRelease (A.Acquire (forall x. IO x -> IO x) -> IO (Allocated a)
f) (ReleaseType -> IO ()) -> a -> m b
g = do
   Restore forall x. IO x -> IO x
restoreIO <- m (Restore IO)
forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO
   ((forall a. m a -> m a) -> m b) -> m b
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. m a -> m a
restoreM -> do
      A.Allocated a
x ReleaseType -> IO ()
free <- IO (Allocated a) -> m (Allocated a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Allocated a) -> m (Allocated a))
-> IO (Allocated a) -> m (Allocated a)
forall a b. (a -> b) -> a -> b
$ (forall x. IO x -> IO x) -> IO (Allocated a)
f IO b -> IO b
forall x. IO x -> IO x
restoreIO
      -- Wrapper so that we don't perform `free` again if `g` already did.
      ReleaseType -> IO ()
free1 <- (ReleaseType -> IO ()) -> m (ReleaseType -> IO ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK ReleaseType -> IO ()
free
      b
b <- m b -> (SomeException -> m ()) -> m b
forall (m :: * -> *) e a b.
(HasCallStack, MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (m b -> m b
forall a. m a -> m a
restoreM ((ReleaseType -> IO ()) -> a -> m b
g ReleaseType -> IO ()
free1 a
x)) \SomeException
e ->
         IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free1 (ReleaseType -> IO ()) -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> ReleaseType
A.ReleaseExceptionWith SomeException
e
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free1 ReleaseType
A.ReleaseNormal
      b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

--------------------------------------------------------------------------------

-- | Like 'R.register', but gives access to the 'A.ReleaseType' too.
registerType
   :: (R.MonadResource m) => (A.ReleaseType -> IO ()) -> m R.ReleaseKey
registerType :: forall (m :: * -> *).
MonadResource m =>
(ReleaseType -> IO ()) -> m ReleaseKey
registerType = ResourceT IO ReleaseKey -> m ReleaseKey
forall a. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
R.liftResourceT (ResourceT IO ReleaseKey -> m ReleaseKey)
-> ((ReleaseType -> IO ()) -> ResourceT IO ReleaseKey)
-> (ReleaseType -> IO ())
-> m ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef ReleaseMap -> IO ReleaseKey) -> ResourceT IO ReleaseKey
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
R.ResourceT ((IORef ReleaseMap -> IO ReleaseKey) -> ResourceT IO ReleaseKey)
-> ((ReleaseType -> IO ()) -> IORef ReleaseMap -> IO ReleaseKey)
-> (ReleaseType -> IO ())
-> ResourceT IO ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef ReleaseMap -> (ReleaseType -> IO ()) -> IO ReleaseKey)
-> (ReleaseType -> IO ()) -> IORef ReleaseMap -> IO ReleaseKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef ReleaseMap -> (ReleaseType -> IO ()) -> IO ReleaseKey
R.registerType

-- | Like 'R.release', but allows specifying the 'A.ReleaseType' too.
releaseType :: (MonadIO m) => R.ReleaseKey -> A.ReleaseType -> m ()
releaseType :: forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> ReleaseType -> m ()
releaseType ReleaseKey
rk ReleaseType
rt = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO ()
-> ((ReleaseType -> IO ()) -> IO ())
-> Maybe (ReleaseType -> IO ())
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall a. Monoid a => a
mempty ((ReleaseType -> IO ()) -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ ReleaseType
rt) (Maybe (ReleaseType -> IO ()) -> IO ())
-> IO (Maybe (ReleaseType -> IO ())) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReleaseKey -> IO (Maybe (ReleaseType -> IO ()))
forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> m (Maybe (ReleaseType -> IO ()))
unprotectType ReleaseKey
rk

-- | Like 'R.unprotect', but allows specifying the 'A.ReleaseType' too.
unprotectType
   :: (MonadIO m) => R.ReleaseKey -> m (Maybe (A.ReleaseType -> IO ()))
unprotectType :: forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> m (Maybe (ReleaseType -> IO ()))
unprotectType (R.ReleaseKey IORef ReleaseMap
istate Int
key) = IO (Maybe (ReleaseType -> IO ()))
-> m (Maybe (ReleaseType -> IO ()))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
   IORef ReleaseMap
-> (ReleaseMap -> (ReleaseMap, Maybe (ReleaseType -> IO ())))
-> IO (Maybe (ReleaseType -> IO ()))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef ReleaseMap
istate \case
      R.ReleaseMap Int
next RefCount
rf IntMap (ReleaseType -> IO ())
im
         | Just ReleaseType -> IO ()
g <- Int
-> IntMap (ReleaseType -> IO ()) -> Maybe (ReleaseType -> IO ())
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
key IntMap (ReleaseType -> IO ())
im ->
            (Int -> RefCount -> IntMap (ReleaseType -> IO ()) -> ReleaseMap
R.ReleaseMap Int
next RefCount
rf (Int
-> IntMap (ReleaseType -> IO ()) -> IntMap (ReleaseType -> IO ())
forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
key IntMap (ReleaseType -> IO ())
im), (ReleaseType -> IO ()) -> Maybe (ReleaseType -> IO ())
forall a. a -> Maybe a
Just ReleaseType -> IO ()
g)
      ReleaseMap
rm -> (ReleaseMap
rm, Maybe (ReleaseType -> IO ())
forall a. Maybe a
Nothing)

-- | 'acquireReleaseKey' will 'unprotectType' the 'R.ReleaseKey',
-- and use 'A.Acquire' to manage the release action instead.
acquireReleaseKey :: R.ReleaseKey -> A.Acquire ()
acquireReleaseKey :: ReleaseKey -> Acquire ()
acquireReleaseKey ReleaseKey
rk =
   Acquire (Maybe (ReleaseType -> IO ())) -> Acquire ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Acquire (Maybe (ReleaseType -> IO ())) -> Acquire ())
-> Acquire (Maybe (ReleaseType -> IO ())) -> Acquire ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe (ReleaseType -> IO ()))
-> (Maybe (ReleaseType -> IO ()) -> ReleaseType -> IO ())
-> Acquire (Maybe (ReleaseType -> IO ()))
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
A.mkAcquireType (ReleaseKey -> IO (Maybe (ReleaseType -> IO ()))
forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> m (Maybe (ReleaseType -> IO ()))
unprotectType ReleaseKey
rk) ((ReleaseType -> IO ())
-> ((ReleaseType -> IO ()) -> ReleaseType -> IO ())
-> Maybe (ReleaseType -> IO ())
-> ReleaseType
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReleaseType -> IO ()
forall a. Monoid a => a
mempty (ReleaseType -> IO ()) -> ReleaseType -> IO ()
forall a. a -> a
id)

--------------------------------------------------------------------------------

-- | Wrapper around a “restore” function like the one given
-- by @'mask' (\\restore -> ...)@, in a particular 'Monad' @m@.
type Restore :: (Type -> Type) -> Type
newtype Restore m = Restore (forall x. m x -> m x)

-- | Get the current 'Restore' action in 'IO', wrapped in 'Restore'.
getRestoreIO :: (MonadIO m) => m (Restore IO)
getRestoreIO :: forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO =
   -- Ugly, but safe. Check the implementation in base.
   IO (Restore IO) -> m (Restore IO)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Restore IO) -> m (Restore IO))
-> IO (Restore IO) -> m (Restore IO)
forall a b. (a -> b) -> a -> b
$ ((forall x. IO x -> IO x) -> IO (Restore IO)) -> IO (Restore IO)
forall b.
HasCallStack =>
((forall x. IO x -> IO x) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall x. IO x -> IO x
f -> Restore IO -> IO (Restore IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall x. IO x -> IO x) -> Restore IO
forall (m :: * -> *). (forall x. m x -> m x) -> Restore m
Restore IO x -> IO x
forall x. IO x -> IO x
f)

-- | Get the current 'Restore' action in 'IO', without the 'Restore' wrapper.
withRestoreIO
   :: (Ex.MonadMask m, MonadIO m) => ((forall x. IO x -> IO x) -> m a) -> m a
withRestoreIO :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
((forall x. IO x -> IO x) -> m a) -> m a
withRestoreIO (forall x. IO x -> IO x) -> m a
f = m (Restore IO)
forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO m (Restore IO) -> (Restore IO -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Restore forall x. IO x -> IO x
g) -> (forall x. IO x -> IO x) -> m a
f IO x -> IO x
forall x. IO x -> IO x
g

--------------------------------------------------------------------------------

-- | Like 'R.resourceFork', but uses 'Async.Async' to communicate with the
-- background thread.
--
-- The 'Async.Async' is initially 'Ex.mask'ed. A 'Restore'-like function is
-- provided to restore to the call-site masking state.
--
-- As a convenience, the 'Async.Async' may optionally be safely 'Async.link'ed
-- by this function, too.
asyncRestore
   :: (U.MonadUnliftIO m)
   => Bool
   -- ^ Whether to 'Async.link' the 'Async.Async'.
   -> ((forall x. IO x -> IO x) -> R.ResourceT m a)
   -- ^ You may use 'U.liftIOOp' on this 'Restore'-like function.
   -> R.ResourceT m (R.ReleaseKey, Async.Async a)
asyncRestore :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> ((forall x. IO x -> IO x) -> ResourceT m a)
-> ResourceT m (ReleaseKey, Async a)
asyncRestore Bool
link (forall x. IO x -> IO x) -> ResourceT m a
k =
   (IORef ReleaseMap -> m (ReleaseKey, Async a))
-> ResourceT m (ReleaseKey, Async a)
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
R.ResourceT \IORef ReleaseMap
r -> ((forall a. m a -> IO a) -> IO (ReleaseKey, Async a))
-> m (ReleaseKey, Async a)
forall b. ((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
U.withRunInIO \forall a. m a -> IO a
m2io -> ((forall x. IO x -> IO x) -> IO (ReleaseKey, Async a))
-> IO (ReleaseKey, Async a)
forall b.
HasCallStack =>
((forall x. IO x -> IO x) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall x. IO x -> IO x
restoreIO -> do
      let R.ResourceT !IORef ReleaseMap -> m a
f = (forall x. IO x -> IO x) -> ResourceT m a
k IO x -> IO x
forall x. IO x -> IO x
restoreIO
      IORef ReleaseMap -> IO ()
R.stateAlloc IORef ReleaseMap
r
      Async a
aa <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
Async.async do
         a
a <- IO a -> (SomeException -> IO ()) -> IO a
forall (m :: * -> *) e a b.
(HasCallStack, MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (m a -> IO a
forall a. m a -> IO a
m2io (IORef ReleaseMap -> m a
f IORef ReleaseMap
r)) \SomeException
e ->
            ReleaseType -> IORef ReleaseMap -> IO ()
R.stateCleanup (SomeException -> ReleaseType
A.ReleaseExceptionWith SomeException
e) IORef ReleaseMap
r
         a
a a -> IO () -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReleaseType -> IORef ReleaseMap -> IO ()
R.stateCleanup ReleaseType
A.ReleaseNormal IORef ReleaseMap
r
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
link (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async a -> IO ()
forall a. Async a -> IO ()
Async.link Async a
aa
      ReleaseKey
key <- IORef ReleaseMap -> IO () -> IO ReleaseKey
R.register' IORef ReleaseMap
r (IO () -> IO ReleaseKey) -> IO () -> IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ Async a -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async a
aa
      (ReleaseKey, Async a) -> IO (ReleaseKey, Async a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, Async a
aa)

--------------------------------------------------------------------------------

-- | @'once' ma@ creates a wrapper for @ma@ which will execute @ma@ at most
-- once. Further executions of the same wrapped @ma@ are a no-op. It's safe to
-- attempt to use the wrapper concurrently; only one thread will get to execute
-- the actual @ma@ at most.
once :: (MonadIO m, MonadIO n, Ex.MonadMask n) => n () -> m (n ())
once :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n, MonadMask n) =>
n () -> m (n ())
once = ((() -> n ()) -> n ()) -> m (() -> n ()) -> m (n ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((() -> n ()) -> () -> n ()
forall a b. (a -> b) -> a -> b
$ ()) (m (() -> n ()) -> m (n ()))
-> (n () -> m (() -> n ())) -> n () -> m (n ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> n ()) -> m (() -> n ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK ((() -> n ()) -> m (() -> n ()))
-> (n () -> () -> n ()) -> n () -> m (() -> n ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n () -> () -> n ()
forall a b. a -> b -> a
const

-- | Kleisli version of 'once'.
onceK :: (MonadIO m, MonadIO n, Ex.MonadMask n) => (a -> n ()) -> m (a -> n ())
onceK :: forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK a -> n ()
kma = do
   MVar Bool
done <- IO (MVar Bool) -> m (MVar Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Bool) -> m (MVar Bool))
-> IO (MVar Bool) -> m (MVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False
   (a -> n ()) -> m (a -> n ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \a
a ->
      n Bool -> (Bool -> n ()) -> (Bool -> n ()) -> n ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
Ex.bracket
         (IO Bool -> n Bool
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> n Bool) -> IO Bool -> n Bool
forall a b. (a -> b) -> a -> b
$ MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
done)
         (\Bool
_ -> IO () -> n ()
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> n ()) -> IO () -> n ()
forall a b. (a -> b) -> a -> b
$ MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done Bool
True)
         (\Bool
d -> Bool -> n () -> n ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (a -> n ()
kma a
a))