module Control.Monad.Trans.Resource.Extra
(
mkAcquire1
, mkAcquireType1
, acquireReleaseSelf
, registerType
, releaseType
, unprotectType
, acquireReleaseKey
, runResourceT
, withAcquire
, withAcquireRelease
, Restore (..)
, getRestoreIO
, withRestoreIO
, asyncRestore
, 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
mkAcquire1 :: IO a -> (a -> IO ()) -> A.Acquire a
mkAcquire1 :: forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire1 IO a
m a -> IO ()
f = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> (a -> IO ()) -> Acquire a
A.mkAcquire ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK a -> IO ()
f) \(a
a, a -> IO ()
g) -> a -> IO ()
g a
a
mkAcquireType1 :: IO a -> (a -> A.ReleaseType -> IO ()) -> A.Acquire a
mkAcquireType1 :: forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType1 IO a
m a -> ReleaseType -> IO ()
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst do
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
A.mkAcquireType ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> ReleaseType -> IO ()
f)) \(a
a, (a, ReleaseType) -> IO ()
g) ReleaseType
t -> (a, ReleaseType) -> IO ()
g (a
a, ReleaseType
t)
acquireReleaseSelf :: A.Acquire ((A.ReleaseType -> IO ()) -> a) -> A.Acquire a
acquireReleaseSelf :: forall a. Acquire ((ReleaseType -> IO ()) -> a) -> Acquire a
acquireReleaseSelf (A.Acquire (forall b. IO b -> IO b)
-> IO (Allocated ((ReleaseType -> IO ()) -> a))
f) = forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
A.Acquire \forall b. IO b -> IO b
restore -> do
A.Allocated (ReleaseType -> IO ()) -> a
g ReleaseType -> IO ()
rel0 <- (forall b. IO b -> IO b)
-> IO (Allocated ((ReleaseType -> IO ()) -> a))
f forall b. IO b -> IO b
restore
ReleaseType -> IO ()
rel1 <- forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK ReleaseType -> IO ()
rel0
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> (ReleaseType -> IO ()) -> Allocated a
A.Allocated ((ReleaseType -> IO ()) -> a
g ReleaseType -> IO ()
rel1) ReleaseType -> IO ()
rel1
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m (IORef ReleaseMap)
R.createInternalState
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. m a -> m a
restoreM -> do
a
a <-
forall a. m a -> m a
restoreM (IORef ReleaseMap -> m a
r IORef ReleaseMap
istate) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Ex.catchAsync` \SomeException
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
Maybe SomeException -> IORef ReleaseMap -> IO ()
R.stateCleanupChecked (forall a. a -> Maybe a
Just SomeException
e) IORef ReleaseMap
istate
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Ex.throwM SomeException
e
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IORef ReleaseMap -> IO ()
R.stateCleanupChecked forall a. Maybe a
Nothing IORef ReleaseMap
istate
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
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 b. IO b -> IO b) -> IO (Allocated a)
f) a -> m b
g = do
Restore forall b. IO b -> IO b
restoreIO <- forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO
forall (m :: * -> *) b.
MonadMask m =>
((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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall b. IO b -> IO b) -> IO (Allocated a)
f forall b. IO b -> IO b
restoreIO
b
b <- forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (forall a. m a -> m a
restoreM (a -> m b
g a
x)) \SomeException
e ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free forall a b. (a -> b) -> a -> b
$ SomeException -> ReleaseType
A.ReleaseExceptionWith SomeException
e
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free ReleaseType
A.ReleaseNormal
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
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 b. IO b -> IO b) -> IO (Allocated a)
f) (ReleaseType -> IO ()) -> a -> m b
g = do
Restore forall b. IO b -> IO b
restoreIO <- forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO
forall (m :: * -> *) b.
MonadMask m =>
((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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall b. IO b -> IO b) -> IO (Allocated a)
f forall b. IO b -> IO b
restoreIO
ReleaseType -> IO ()
free1 <- forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK ReleaseType -> IO ()
free
b
b <- forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (forall a. m a -> m a
restoreM ((ReleaseType -> IO ()) -> a -> m b
g ReleaseType -> IO ()
free1 a
x)) \SomeException
e ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free1 forall a b. (a -> b) -> a -> b
$ SomeException -> ReleaseType
A.ReleaseExceptionWith SomeException
e
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ReleaseType -> IO ()
free1 ReleaseType
A.ReleaseNormal
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
registerType
:: (R.MonadResource m) => (A.ReleaseType -> IO ()) -> m R.ReleaseKey
registerType :: forall (m :: * -> *).
MonadResource m =>
(ReleaseType -> IO ()) -> m ReleaseKey
registerType = forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
R.liftResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
R.ResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef ReleaseMap -> (ReleaseType -> IO ()) -> IO ReleaseKey
R.registerType
releaseType :: (MonadIO m) => R.ReleaseKey -> A.ReleaseType -> m ()
releaseType :: forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> ReleaseType -> m ()
releaseType ReleaseKey
rk ReleaseType
rt = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a b. (a -> b) -> a -> b
$ ReleaseType
rt) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> m (Maybe (ReleaseType -> IO ()))
unprotectType ReleaseKey
rk
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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
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 <- 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 (forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
key IntMap (ReleaseType -> IO ())
im), forall a. a -> Maybe a
Just ReleaseType -> IO ()
g)
ReleaseMap
rm -> (ReleaseMap
rm, forall a. Maybe a
Nothing)
acquireReleaseKey :: R.ReleaseKey -> A.Acquire ()
acquireReleaseKey :: ReleaseKey -> Acquire ()
acquireReleaseKey ReleaseKey
rk =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
A.mkAcquireType (forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> m (Maybe (ReleaseType -> IO ()))
unprotectType ReleaseKey
rk) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. a -> a
id)
type Restore :: (Type -> Type) -> Type
newtype Restore m = Restore (forall x. m x -> m x)
getRestoreIO :: (MonadIO m) => m (Restore IO)
getRestoreIO :: forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall b. IO b -> IO b
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *). (forall x. m x -> m x) -> Restore m
Restore forall b. IO b -> IO b
f)
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 b. IO b -> IO b) -> m a) -> m a
withRestoreIO (forall b. IO b -> IO b) -> m a
f = forall (m :: * -> *). MonadIO m => m (Restore IO)
getRestoreIO forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Restore forall b. IO b -> IO b
g) -> (forall b. IO b -> IO b) -> m a
f forall b. IO b -> IO b
g
asyncRestore
:: (U.MonadUnliftIO m)
=> Bool
-> ((forall x. IO x -> IO x) -> R.ResourceT m a)
-> R.ResourceT m (R.ReleaseKey, Async.Async a)
asyncRestore :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> ((forall b. IO b -> IO b) -> ResourceT m a)
-> ResourceT m (ReleaseKey, Async a)
asyncRestore Bool
link (forall b. IO b -> IO b) -> ResourceT m a
k =
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
R.ResourceT \IORef ReleaseMap
r -> 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 (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall b. IO b -> IO b
restoreIO -> do
let R.ResourceT !IORef ReleaseMap -> m a
f = (forall b. IO b -> IO b) -> ResourceT m a
k forall b. IO b -> IO b
restoreIO
IORef ReleaseMap -> IO ()
R.stateAlloc IORef ReleaseMap
r
Async a
aa <- forall a. IO a -> IO (Async a)
Async.async do
a
a <- forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException (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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReleaseType -> IORef ReleaseMap -> IO ()
R.stateCleanup ReleaseType
A.ReleaseNormal IORef ReleaseMap
r
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
link forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
Async.link Async a
aa
ReleaseKey
key <- IORef ReleaseMap -> IO () -> IO ReleaseKey
R.register' IORef ReleaseMap
r forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
Async.uninterruptibleCancel Async a
aa
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, Async a
aa)
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n, MonadMask n) =>
(a -> n ()) -> m (a -> n ())
onceK forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure \a
a ->
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Ex.bracket
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar Bool
done)
(\Bool
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done Bool
True)
(\Bool
d -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (a -> n ()
kma a
a))