From 943d387866a7bbba8229142d749ef6e444419d11 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 30 Nov 2021 22:19:06 +0100
Subject: [PATCH] Add more async helpers

---
 src/Quasar/Async.hs           | 30 ++++++++++++++++++++++++------
 src/Quasar/Async/Unmanaged.hs | 22 ++++++++++++++++++++++
 2 files changed, 46 insertions(+), 6 deletions(-)

diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs
index 1419123..de28326 100644
--- a/src/Quasar/Async.hs
+++ b/src/Quasar/Async.hs
@@ -4,6 +4,7 @@ module Quasar.Async (
   async_,
   asyncWithUnmask,
   asyncWithUnmask_,
+  withAsync,
 
   -- ** Async with explicit error handling
   asyncWithHandler,
@@ -15,25 +16,28 @@ module Quasar.Async (
   CancelAsync(..),
   AsyncDisposed(..),
   AsyncException(..),
+  isCancelAsync,
+  isAsyncDisposed,
 ) where
 
 import Control.Monad.Catch
 import Control.Monad.Reader
 import Quasar.Async.Unmanaged
 import Quasar.Awaitable
+import Quasar.Disposable
 import Quasar.Prelude
 import Quasar.ResourceManager
 
 -- | TODO: Documentation
 --
 -- The action will be run with asynchronous exceptions unmasked.
-async :: MonadResourceManager m => ResourceManagerIO a -> m (Awaitable a)
+async :: MonadResourceManager m => ResourceManagerIO a -> m (Async a)
 async action = asyncWithUnmask \unmask -> unmask action
 
 -- | TODO: Documentation
 --
 -- The action will be run with asynchronous exceptions masked and will be passed an action that can be used to unmask.
-asyncWithUnmask :: MonadResourceManager m => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO r) -> m (Awaitable r)
+asyncWithUnmask :: MonadResourceManager m => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO r) -> m (Async r)
 asyncWithUnmask action = do
   resourceManager <- askResourceManager
   asyncWithHandlerAndUnmask (throwToResourceManager resourceManager . AsyncException) action
@@ -48,10 +52,15 @@ asyncWithUnmask_ action = void $ asyncWithUnmask action
 --
 -- The action will be run with asynchronous exceptions unmasked. When an exception is thrown that is not caused from
 -- the disposable instance (i.e. the task being canceled), the handler is called with that exception.
-asyncWithHandlerAndUnmask :: MonadResourceManager m => (SomeException -> IO ()) -> ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO r) -> m (Awaitable r)
+asyncWithHandlerAndUnmask
+  :: MonadResourceManager m
+  => (SomeException -> IO ())
+  -> ((ResourceManagerIO a -> ResourceManagerIO a)
+  -> ResourceManagerIO r)
+  -> m (Async r)
 asyncWithHandlerAndUnmask handler action = do
   resourceManager <- askResourceManager
-  toAwaitable <$> registerNewResource do
+  registerNewResource do
     unmanagedAsyncWithHandlerAndUnmask wrappedHandler \unmask ->
       onResourceManager resourceManager (action (liftUnmask unmask))
   where
@@ -63,11 +72,20 @@ asyncWithHandlerAndUnmask handler action = do
       resourceManager <- askResourceManager
       liftIO $ unmask $ onResourceManager resourceManager innerAction
 
-asyncWithHandlerAndUnmask_ :: MonadResourceManager m => (SomeException -> IO ()) -> ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO r) -> m ()
+asyncWithHandlerAndUnmask_
+  :: MonadResourceManager m
+  => (SomeException -> IO ())
+  -> ((ResourceManagerIO a -> ResourceManagerIO a)
+  -> ResourceManagerIO r)
+  -> m ()
 asyncWithHandlerAndUnmask_ handler action = void $ asyncWithHandlerAndUnmask handler action
 
-asyncWithHandler :: MonadResourceManager m => (SomeException -> IO ()) -> ResourceManagerIO r -> m (Awaitable r)
+asyncWithHandler :: MonadResourceManager m => (SomeException -> IO ()) -> ResourceManagerIO r -> m (Async r)
 asyncWithHandler handler action = asyncWithHandlerAndUnmask handler \unmask -> unmask action
 
 asyncWithHandler_ :: MonadResourceManager m => (SomeException -> IO ()) -> ResourceManagerIO r -> m ()
 asyncWithHandler_ handler action = void $ asyncWithHandler handler action
+
+
+withAsync :: MonadResourceManager m => ResourceManagerIO r -> (Async r -> m a) -> m a
+withAsync action = bracket (async action) dispose
diff --git a/src/Quasar/Async/Unmanaged.hs b/src/Quasar/Async/Unmanaged.hs
index 4f6bf38..4415471 100644
--- a/src/Quasar/Async/Unmanaged.hs
+++ b/src/Quasar/Async/Unmanaged.hs
@@ -10,6 +10,8 @@ module Quasar.Async.Unmanaged (
   CancelAsync(..),
   AsyncDisposed(..),
   AsyncException(..),
+  isCancelAsync,
+  isAsyncDisposed,
 ) where
 
 
@@ -74,6 +76,15 @@ data AsyncException = AsyncException SomeException
   deriving anyclass Exception
 
 
+isCancelAsync :: SomeException -> Bool
+isCancelAsync (fromException @CancelAsync -> Just _) = True
+isCancelAsync _ = False
+
+isAsyncDisposed :: SomeException -> Bool
+isAsyncDisposed (fromException @AsyncDisposed -> Just _) = True
+isAsyncDisposed _ = False
+
+
 
 -- | Base implementation for the `unmanagedAsync`- and `Quasar.Async.async`-class of functions.
 unmanagedAsyncWithHandlerAndUnmask :: MonadIO m => (SomeException -> IO ()) -> ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
@@ -133,3 +144,14 @@ unmanagedAsyncWithHandler handler action = unmanagedAsyncWithHandlerAndUnmask ha
 
 unmanagedAsyncWithUnmask :: MonadIO m => ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
 unmanagedAsyncWithUnmask = unmanagedAsyncWithHandlerAndUnmask (traceIO . ("Unhandled exception in unmanaged async: " <>) . displayException)
+
+
+-- | Run a computation concurrently to another computation. When the current thread leaves `withAsync`, the async
+-- computation is cancelled.
+--
+-- While the async is disposed when `withUnmanagedAsync` exits, an exception would be ignored if the action fails. This
+-- behavior is similar to the @withAsync@ function from the @async@ package.
+--
+-- For an exception-safe version, see `Quasar.Async.withAsync`.
+withUnmanagedAsync :: (MonadIO m, MonadMask m) => IO r -> (Async r -> m a) -> m a
+withUnmanagedAsync action = bracket (unmanagedAsync action) dispose
-- 
GitLab