diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs index dd53501b893e2c290f0d58c2d8af43eb611a1f8e..787ac7a561907a0f6b9c764cae12ae4c7a7bd72d 100644 --- a/src/Quasar/Disposable.hs +++ b/src/Quasar/Disposable.hs @@ -13,7 +13,8 @@ module Quasar.Disposable ( registerDisposable, registerDisposeAction, disposeEventually, - withOnResourceManager, + withResourceManagerM, + withSubResourceManagerM, onResourceManager, captureDisposable, captureTask, @@ -255,6 +256,11 @@ registerDisposeAction :: MonadResourceManager m => IO (Awaitable ()) -> m () registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction +withSubResourceManagerM :: MonadResourceManager m => m a -> m a +withSubResourceManagerM action = + bracket newResourceManager (await <=< dispose) \scope -> localResourceManager scope action + + instance (MonadAwait m, MonadMask m, MonadIO m) => MonadResourceManager (ReaderT ResourceManager m) where localResourceManager resourceManager = local (const resourceManager) @@ -320,8 +326,8 @@ instance IsDisposable ResourceManager where withResourceManager :: (MonadAwait m, MonadMask m, MonadIO m) => (ResourceManager -> m a) -> m a withResourceManager = bracket unsafeNewResourceManager (await <=< liftIO . dispose) -withOnResourceManager :: (MonadAwait m, MonadMask m, MonadIO m) => (ReaderT ResourceManager m a) -> m a -withOnResourceManager action = withResourceManager \resourceManager -> onResourceManager resourceManager action +withResourceManagerM :: (MonadAwait m, MonadMask m, MonadIO m) => (ReaderT ResourceManager m a) -> m a +withResourceManagerM action = withResourceManager \resourceManager -> onResourceManager resourceManager action newResourceManager :: MonadResourceManager m => m ResourceManager newResourceManager = mask_ do diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs index da31a333ad3b6dc8163b927d73e1e217796fdb3c..2a6254093b7be005a89674f0c21e3caf6fbced16 100644 --- a/src/Quasar/Observable.hs +++ b/src/Quasar/Observable.hs @@ -78,7 +78,7 @@ class IsRetrievable v a | a -> v where retrieve :: MonadResourceManager m => a -> m (Awaitable v) retrieveIO :: IsRetrievable v a => a -> IO v -retrieveIO x = withOnResourceManager $ await =<< retrieve x +retrieveIO x = withResourceManagerM $ await =<< retrieve x class IsRetrievable v o => IsObservable v o | o -> v where observe diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs index 15f0d2af03a8f2dfc651bb89121ffd2dfc841794..e0e506c474fafbd9de0eed0b972bcbd0b2535f9d 100644 --- a/test/Quasar/AsyncSpec.hs +++ b/test/Quasar/AsyncSpec.hs @@ -14,10 +14,10 @@ spec :: Spec spec = parallel $ do describe "async" $ do it "can pass a value through async and await" $ do - withOnResourceManager (runUnlimitedAsync (await =<< async (pure 42))) `shouldReturn` (42 :: Int) + withResourceManagerM (runUnlimitedAsync (await =<< async (pure 42))) `shouldReturn` (42 :: Int) it "can pass a value through async and await" $ do - withOnResourceManager (runUnlimitedAsync (await =<< async (liftIO (threadDelay 100000) >> pure 42))) `shouldReturn` (42 :: Int) + withResourceManagerM (runUnlimitedAsync (await =<< async (liftIO (threadDelay 100000) >> pure 42))) `shouldReturn` (42 :: Int) describe "await" $ do it "can await the result of an async that is completed later" $ do @@ -33,6 +33,6 @@ spec = parallel $ do it "can terminate when encountering an asynchronous exception" $ do never <- newAsyncVar :: IO (AsyncVar ()) - result <- timeout 100000 $ withOnResourceManager $ + result <- timeout 100000 $ withResourceManagerM $ await never result `shouldBe` Nothing diff --git a/test/Quasar/ObservableSpec.hs b/test/Quasar/ObservableSpec.hs index 6987ee17f8e449924352e5821509016e0e70564b..f7103d66e8619e1fb22dd2010b1d6402eb3f53d5 100644 --- a/test/Quasar/ObservableSpec.hs +++ b/test/Quasar/ObservableSpec.hs @@ -18,7 +18,7 @@ observableSpec = parallel do it "works" $ io do shouldReturn do - withOnResourceManager do + withResourceManagerM do observeWhile (pure () :: Observable ()) toObservableUpdate ()