resourcet-extra 0.0.1 → 0.1.0

raw patch · 3 files changed

+92/−32 lines, 3 filesdep +asyncdep +unliftio-corePVP ok

version bump matches the API change (PVP)

Dependencies added: async, unliftio-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• lib/Control/Monad/Trans/Resource/Extra.hs +82/−31
• resourcet-extra.cabal +3/−1

@@ -1,3 +1,10 @@+# Version 0.1.0++* Fix `onceK`, `once`.++* Add `runResourceT`, `asyncRestore`, `releaseType`, `unprotectType`.++ # Version 0.0.1  * Initial version.

@@ -5,10 +5,13 @@    , acquireReleaseSelf      -- * MonadResource-   , acquireReleaseKey    , registerType+   , releaseType+   , unprotectType+   , acquireReleaseKey      -- * MonadMask+   , runResourceT    , withAcquire    , withAcquireRelease @@ -17,41 +20,59 @@    , 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-import System.IO.Unsafe  --------------------------------------------------------------------------------  -- | Like 'A.mkAcquire', but the release function will be run at most once. mkAcquire1 :: IO a -> (a -> IO ()) -> A.Acquire a-mkAcquire1 m f = A.mkAcquire m (onceK f)+mkAcquire1 m f = fst <$> A.mkAcquire ((,) <$> m <*> onceK f) \(a, g) -> g a  -- | Like 'A.mkAcquireType', but the release function will be run at most once. mkAcquireType1 :: IO a -> (a -> A.ReleaseType -> IO ()) -> A.Acquire a-mkAcquireType1 m f = A.mkAcquireType m (curry (onceK (uncurry f)))+mkAcquireType1 m f = fmap fst do+   A.mkAcquireType ((,) <$> m <*> onceK (uncurry f)) \(a, g) t -> g (a, t)  -- | Build an 'A.Acquire' having access to its own release function. acquireReleaseSelf :: A.Acquire ((A.ReleaseType -> IO ()) -> a) -> A.Acquire a acquireReleaseSelf (A.Acquire f) = A.Acquire \restore -> do    A.Allocated g rel0 <- f restore-   let rel1 = onceK rel0+   rel1 <- onceK rel0    pure $ A.Allocated (g rel1) rel1  -------------------------------------------------------------------------------- +-- | Like 'R.runResourceT', but requires only 'Ex.MonadMask'.+runResourceT :: (Ex.MonadMask m, MonadIO m) => R.ResourceT m a -> m a+runResourceT (R.ResourceT r) = do+   istate <- liftIO R.createInternalState+   Ex.mask \restoreM -> do+      a <-+         restoreM (r istate) `Ex.catchAsync` \e -> liftIO do+            R.stateCleanupChecked (Just e) istate+            Ex.throwM e+      liftIO $ R.stateCleanupChecked Nothing istate+      pure 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 (A.Acquire f) g = do@@ -76,7 +97,7 @@    Ex.mask \restoreM -> do       A.Allocated x free <- liftIO $ f restoreIO       -- Wrapper so that we don't perform `free` again if `g` already did.-      let free1 = onceK free+      free1 <- onceK free       b <- Ex.withException (restoreM (g free1 x)) \e ->          liftIO $ free1 $ A.ReleaseExceptionWith e       liftIO $ free1 A.ReleaseNormal@@ -89,24 +110,25 @@    :: (R.MonadResource m) => (A.ReleaseType -> IO ()) -> m R.ReleaseKey registerType = R.liftResourceT . R.ResourceT . flip R.registerType --- | 'acquireReleaseKey' will 'R.unprotect' the 'R.ReleaseKey',+-- | Like 'R.release', but allows specifying the 'A.ReleaseType' too.+releaseType :: (MonadIO m) => R.ReleaseKey -> A.ReleaseType -> m ()+releaseType rk rt = liftIO $ maybe mempty ($ rt) =<< unprotectType rk++-- Like 'R.unprotect', but allows specifying the 'A.ReleaseType' too.+unprotectType+   :: (MonadIO m) => R.ReleaseKey -> m (Maybe (A.ReleaseType -> IO ()))+unprotectType (R.ReleaseKey istate key) = liftIO do+   atomicModifyIORef' istate \case+      R.ReleaseMap next rf im+         | Just g <- IntMap.lookup key im ->+            (R.ReleaseMap next rf (IntMap.delete key im), Just g)+      rm -> (rm, Nothing)++-- | 'acquireReleaseKey' will 'unprotectType' the 'R.ReleaseKey', -- and use 'A.Acquire' to manage the release action instead. acquireReleaseKey :: R.ReleaseKey -> A.Acquire ()-acquireReleaseKey (R.ReleaseKey istate key) =-   void $ A.mkAcquireType acq rel-  where-   acq :: IO (Maybe (A.ReleaseType -> IO ()))-   acq =-      -- The following code does pretty much the same as 'R.unprotect',-      -- which we can't use directly because its result doesn't allow us-      -- to specify the 'A.ReleaseType' during release.-      atomicModifyIORef istate \case-         R.ReleaseMap next rf im-            | Just g <- IntMap.lookup key im ->-               (R.ReleaseMap next rf (IntMap.delete key im), Just g)-         rm -> (rm, Nothing)-   rel :: Maybe (A.ReleaseType -> IO ()) -> A.ReleaseType -> IO ()-   rel = maybe mempty id+acquireReleaseKey rk =+   void $ A.mkAcquireType (unprotectType rk) (maybe mempty id)  -------------------------------------------------------------------------------- @@ -128,17 +150,46 @@  -------------------------------------------------------------------------------- --- | @'once' ma@ wraps @ma@ so that @ma@ is executed at most once. Further--- executions of the same @'once' ma@ are a no-op. It's safe to use the wrapper--- concurrently; only one thread will get to execute the actual @ma@ at most.-once :: (MonadIO m, Ex.MonadMask m) => m () -> m ()-once ma = onceK (const ma) ()+-- | 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 link k =+   R.ResourceT \r -> U.withRunInIO \m2io -> Ex.mask \restoreIO -> do+      let R.ResourceT !f = k restoreIO+      R.stateAlloc r+      aa <- Async.async do+         a <- Ex.withException (m2io (f r)) \e ->+            R.stateCleanup (A.ReleaseExceptionWith e) r+         a <$ R.stateCleanup A.ReleaseNormal r+      when link $ Async.link aa+      key <- R.register' r $ Async.uninterruptibleCancel aa+      pure (key, 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 = fmap ($ ()) . onceK . const+ -- | Kleisli version of 'once'.-onceK :: (MonadIO m, Ex.MonadMask m) => (a -> m ()) -> (a -> m ())-{-# NOINLINE onceK #-}-onceK kma = unsafePerformIO do-   done <- newMVar False+onceK :: (MonadIO m, MonadIO n, Ex.MonadMask n) => (a -> n ()) -> m (a -> n ())+onceK kma = do+   done <- liftIO $ newMVar False    pure \a ->       Ex.bracket          (liftIO $ takeMVar done)

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: resourcet-extra-version: 0.0.1+version: 0.1.0 license: BSD-3-Clause license-file: LICENSE extra-source-files: README.md CHANGELOG.md@@ -29,7 +29,9 @@   hs-source-dirs: lib   exposed-modules: Control.Monad.Trans.Resource.Extra   build-depends:+    async,     resourcet,     containers,     resourcet,     safe-exceptions,+    unliftio-core,