From 31384c7e61394ddf49fff9b8689bb2741ca42410 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 3 Nov 2021 00:13:34 +0100
Subject: [PATCH] Remove MonadAsync

Co-authored-by: Jan Beinke <git@janbeinke.com>
---
 src/Quasar/Async.hs      | 88 ++++++----------------------------------
 test/Quasar/AsyncSpec.hs |  4 +-
 2 files changed, 15 insertions(+), 77 deletions(-)

diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs
index 0608eeb..98f09c6 100644
--- a/src/Quasar/Async.hs
+++ b/src/Quasar/Async.hs
@@ -1,16 +1,9 @@
 module Quasar.Async (
   -- * Async/await
-  MonadAsync(..),
   async,
   async_,
   asyncWithUnmask,
   asyncWithUnmask_,
-  runUnlimitedAsync,
-
-  -- ** Async context
-  IsAsyncContext(..),
-  AsyncContext,
-  unlimitedAsyncContext,
 ) where
 
 import Control.Monad.Reader
@@ -20,83 +13,28 @@ import Quasar.ResourceManager
 import Quasar.Utils.Concurrent
 
 
-
-class IsAsyncContext a where
-  asyncOnContextWithUnmask :: MonadResourceManager m => a -> (forall f. MonadAsync f => (forall b. f b -> f b) -> f r) -> m (Awaitable r)
-  asyncOnContextWithUnmask self = asyncOnContextWithUnmask (toAsyncContext self)
-
-  toAsyncContext :: a -> AsyncContext
-  toAsyncContext = AsyncContext
-
-  {-# MINIMAL toAsyncContext | asyncOnContextWithUnmask #-}
-
-data AsyncContext = forall a. IsAsyncContext a => AsyncContext a
-
-instance IsAsyncContext AsyncContext where
-  asyncOnContextWithUnmask (AsyncContext ctx) = asyncOnContextWithUnmask ctx
-  toAsyncContext = id
-
-data UnlimitedAsyncContext = UnlimitedAsyncContext
-
-unlimitedAsyncContext :: AsyncContext
-unlimitedAsyncContext = toAsyncContext UnlimitedAsyncContext
-
-
-instance IsAsyncContext UnlimitedAsyncContext where
-  asyncOnContextWithUnmask UnlimitedAsyncContext action = do
-    resourceManager <- askResourceManager
-    let asyncContext = unlimitedAsyncContext
-    toAwaitable <$> registerNewResource do
-      unmanagedForkWithUnmask (\unmask -> runReaderT (runReaderT (action (liftUnmask unmask)) asyncContext) resourceManager)
-    where
-      liftUnmask :: (forall b. IO b -> IO b) -> ReaderT AsyncContext (ReaderT ResourceManager IO) a -> ReaderT AsyncContext (ReaderT ResourceManager IO) a
-      liftUnmask unmask innerAction = do
-        resourceManager <- askResourceManager
-        asyncContext <- askAsyncContext
-        liftIO $ unmask $ runReaderT (runReaderT innerAction asyncContext) resourceManager
-
-
-class MonadResourceManager m => MonadAsync m where
-  askAsyncContext :: m AsyncContext
-
-  localAsyncContext :: IsAsyncContext a => a -> m r -> m r
-
-
-instance MonadResourceManager m => MonadAsync (ReaderT AsyncContext m) where
-  askAsyncContext = ask
-  localAsyncContext = local . const . toAsyncContext
-
-instance {-# OVERLAPPABLE #-} MonadAsync m => MonadAsync (ReaderT r m) where
-  askAsyncContext = lift askAsyncContext
-  localAsyncContext asyncContext action = do
-    x <- ask
-    lift $ localAsyncContext asyncContext $ runReaderT action x
-
-
 -- | TODO: Documentation
 --
 -- The action will be run with asynchronous exceptions unmasked.
-async :: MonadAsync m => (forall f. MonadAsync f => f a) -> m (Awaitable a)
+async :: MonadResourceManager m => (ResourceManagerIO a) -> m (Awaitable 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 :: MonadAsync m => (forall f. MonadAsync f => (forall a. f a -> f a) -> f r) -> m (Awaitable r)
+asyncWithUnmask :: MonadResourceManager m => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO r) -> m (Awaitable r)
 asyncWithUnmask action = do
-  asyncContext <- askAsyncContext
-  asyncOnContextWithUnmask asyncContext action
-
-async_ :: MonadAsync m => (forall f. MonadAsync f => f ()) -> m ()
+  resourceManager <- askResourceManager
+  toAwaitable <$> registerNewResource do
+    unmanagedForkWithUnmask (\unmask -> runReaderT (action (liftUnmask unmask)) resourceManager)
+  where
+    liftUnmask :: (forall b. IO b -> IO b) -> ResourceManagerIO a -> ResourceManagerIO a
+    liftUnmask unmask innerAction = do
+      resourceManager <- askResourceManager
+      liftIO $ unmask $ runReaderT innerAction resourceManager
+
+async_ :: MonadResourceManager m => (ResourceManagerIO ()) -> m ()
 async_ action = void $ async action
 
-asyncWithUnmask_ :: MonadAsync m => (forall f. MonadAsync f => (forall a. f a -> f a) -> f ()) -> m ()
+asyncWithUnmask_ :: MonadResourceManager m => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO ()) -> m ()
 asyncWithUnmask_ action = void $ asyncWithUnmask action
-
-
-
--- | Run a computation in `MonadAsync` where `async` is implemented without any thread limits (i.e. every `async` will
--- fork a new (RTS) thread).
-runUnlimitedAsync :: ReaderT AsyncContext m a -> m a
-runUnlimitedAsync action = do
-  runReaderT action unlimitedAsyncContext
diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs
index 870be2c..fd5a614 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
-      withRootResourceManager (runUnlimitedAsync (await =<< async (pure 42))) `shouldReturn` (42 :: Int)
+      withRootResourceManager (await =<< async (pure 42)) `shouldReturn` (42 :: Int)
 
     it "can pass a value through async and await" $ do
-      withRootResourceManager (runUnlimitedAsync (await =<< async (liftIO (threadDelay 100000) >> pure 42))) `shouldReturn` (42 :: Int)
+      withRootResourceManager (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
-- 
GitLab