From 90cea54d6acf1434f094f0bc3d79b83b0b3d84d4 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sat, 4 Sep 2021 23:59:35 +0200
Subject: [PATCH] Rename disposable helpers
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
src/Quasar/Disposable.hs | 12 +++++++++---
src/Quasar/Observable.hs | 2 +-
test/Quasar/AsyncSpec.hs | 6 +++---
test/Quasar/ObservableSpec.hs | 2 +-
4 files changed, 14 insertions(+), 8 deletions(-)
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index dd53501..787ac7a 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 da31a33..2a62540 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 15f0d2a..e0e506c 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 6987ee1..f7103d6 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
()
--
GitLab