From 2ec879d5aad07c24adb376ec81c8301cff143734 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 3 Nov 2021 00:27:12 +0100
Subject: [PATCH] Rename and move unmanaged async helpers
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
quasar.cabal | 2 +-
src/Quasar/Async.hs | 10 ++++--
.../Concurrent.hs => Async/Unmanaged.hs} | 33 +++++++++----------
src/Quasar/ResourceManager.hs | 4 +--
src/Quasar/Timer.hs | 6 ++--
5 files changed, 28 insertions(+), 27 deletions(-)
rename src/Quasar/{Utils/Concurrent.hs => Async/Unmanaged.hs} (81%)
diff --git a/quasar.cabal b/quasar.cabal
index 83d1287..145bdbf 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -85,6 +85,7 @@ library
exposed-modules:
Quasar
Quasar.Async
+ Quasar.Async.Unmanaged
Quasar.Awaitable
Quasar.Disposable
Quasar.Observable
@@ -96,7 +97,6 @@ library
Quasar.ResourceManager
Quasar.Subscribable
Quasar.Timer
- Quasar.Utils.Concurrent
Quasar.Utils.Exceptions
Quasar.Utils.ExtraT
hs-source-dirs:
diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs
index 98f09c6..5c2cb0c 100644
--- a/src/Quasar/Async.hs
+++ b/src/Quasar/Async.hs
@@ -1,16 +1,20 @@
module Quasar.Async (
- -- * Async/await
+ -- * Async
async,
async_,
asyncWithUnmask,
asyncWithUnmask_,
+
+ -- ** Task exceptions
+ CancelTask(..),
+ TaskDisposed(..),
) where
import Control.Monad.Reader
+import Quasar.Async.Unmanaged
import Quasar.Awaitable
import Quasar.Prelude
import Quasar.ResourceManager
-import Quasar.Utils.Concurrent
-- | TODO: Documentation
@@ -26,7 +30,7 @@ asyncWithUnmask :: MonadResourceManager m => ((ResourceManagerIO a -> ResourceMa
asyncWithUnmask action = do
resourceManager <- askResourceManager
toAwaitable <$> registerNewResource do
- unmanagedForkWithUnmask (\unmask -> runReaderT (action (liftUnmask unmask)) resourceManager)
+ unmanagedAsyncWithUnmask (\unmask -> runReaderT (action (liftUnmask unmask)) resourceManager)
where
liftUnmask :: (forall b. IO b -> IO b) -> ResourceManagerIO a -> ResourceManagerIO a
liftUnmask unmask innerAction = do
diff --git a/src/Quasar/Utils/Concurrent.hs b/src/Quasar/Async/Unmanaged.hs
similarity index 81%
rename from src/Quasar/Utils/Concurrent.hs
rename to src/Quasar/Async/Unmanaged.hs
index e5f0420..0ecde0f 100644
--- a/src/Quasar/Utils/Concurrent.hs
+++ b/src/Quasar/Async/Unmanaged.hs
@@ -1,9 +1,10 @@
-module Quasar.Utils.Concurrent (
+module Quasar.Async.Unmanaged (
+ -- ** Unmanaged variant
Task,
- unmanagedFork,
- unmanagedFork_,
- unmanagedForkWithUnmask,
- unmanagedForkWithUnmask_,
+ unmanagedAsync,
+ unmanagedAsync_,
+ unmanagedAsyncWithUnmask,
+ unmanagedAsyncWithUnmask_,
-- ** Task exceptions
CancelTask(..),
@@ -19,8 +20,6 @@ import Quasar.Disposable
import Quasar.Prelude
-
-
-- | A task is an operation (e.g. a thread or a network request) that is running asynchronously and can be cancelled.
-- It has a result and can fail.
--
@@ -68,16 +67,14 @@ instance Exception TaskDisposed where
+unmanagedAsync :: MonadIO m => IO a -> m (Task a)
+unmanagedAsync action = unmanagedAsyncWithUnmask \unmask -> unmask action
+unmanagedAsync_ :: MonadIO m => IO () -> m Disposable
+unmanagedAsync_ action = toDisposable <$> unmanagedAsync action
-unmanagedFork :: MonadIO m => IO a -> m (Task a)
-unmanagedFork action = unmanagedForkWithUnmask \unmask -> unmask action
-
-unmanagedFork_ :: MonadIO m => IO () -> m Disposable
-unmanagedFork_ action = toDisposable <$> unmanagedFork action
-
-unmanagedForkWithUnmask :: MonadIO m => ((forall b. IO b -> IO b) -> IO a) -> m (Task a)
-unmanagedForkWithUnmask action = do
+unmanagedAsyncWithUnmask :: MonadIO m => ((forall b. IO b -> IO b) -> IO a) -> m (Task a)
+unmanagedAsyncWithUnmask action = do
liftIO $ mask_ do
key <- newUnique
resultVar <- newAsyncVar
@@ -86,7 +83,7 @@ unmanagedForkWithUnmask action = do
threadId <- forkIOWithUnmask \unmask ->
handleAll
- do \ex -> fail $ "unmanagedForkWithUnmask thread failed: " <> displayException ex
+ do \ex -> fail $ "unmanagedAsyncWithUnmask thread failed: " <> displayException ex
do
result <- try $ handleIf
do \(CancelTask exKey) -> key == exKey
@@ -115,5 +112,5 @@ unmanagedForkWithUnmask action = do
pure $ Task key stateVar finalizers (toAwaitable resultVar)
-unmanagedForkWithUnmask_ :: MonadIO m => ((forall b. IO b -> IO b) -> IO ()) -> m Disposable
-unmanagedForkWithUnmask_ action = toDisposable <$> unmanagedForkWithUnmask action
+unmanagedAsyncWithUnmask_ :: MonadIO m => ((forall b. IO b -> IO b) -> IO ()) -> m Disposable
+unmanagedAsyncWithUnmask_ action = toDisposable <$> unmanagedAsyncWithUnmask action
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 940cd52..2a101f2 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -48,10 +48,10 @@ import Data.HashMap.Strict qualified as HM
import Data.List.NonEmpty (NonEmpty(..), (<|), nonEmpty)
import Data.Sequence (Seq(..), (|>))
import Data.Sequence qualified as Seq
+import Quasar.Async.Unmanaged
import Quasar.Awaitable
import Quasar.Disposable
import Quasar.Prelude
-import Quasar.Utils.Concurrent
import Quasar.Utils.Exceptions
@@ -249,7 +249,7 @@ newUnmanagedRootResourceManagerInternal = liftIO do
exceptionsVar <- newTMVarIO Empty
finalExceptionsVar <- newAsyncVar
mfix \root -> do
- unmanagedFork_ (disposeThread root)
+ unmanagedAsync_ (disposeThread root)
internal <- newUnmanagedDefaultResourceManagerInternal (toResourceManager root)
pure $ RootResourceManager internal disposingVar exceptionsVar finalExceptionsVar
diff --git a/src/Quasar/Timer.hs b/src/Quasar/Timer.hs
index 99571bd..cc3f341 100644
--- a/src/Quasar/Timer.hs
+++ b/src/Quasar/Timer.hs
@@ -24,11 +24,11 @@ import Data.Heap
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Data.Foldable (toList)
import Quasar.Async
+import Quasar.Async.Unmanaged
import Quasar.Awaitable
import Quasar.Disposable
import Quasar.Prelude
import Quasar.ResourceManager
-import Quasar.Utils.Concurrent
data TimerCancelled = TimerCancelled
@@ -92,7 +92,7 @@ newUnmanagedTimerScheduler = do
}
startSchedulerThread :: TimerScheduler -> IO Disposable
-startSchedulerThread scheduler = unmanagedFork_ (schedulerThread `finally` cancelAll)
+startSchedulerThread scheduler = unmanagedAsync_ (schedulerThread `finally` cancelAll)
where
heap' :: TMVar (Heap Timer)
heap' = heap scheduler
@@ -210,7 +210,7 @@ newDelay :: MonadResourceManager m => Int -> m Delay
newDelay microseconds = registerNewResource $ newUnmanagedDelay microseconds
newUnmanagedDelay :: MonadIO m => Int -> m Delay
-newUnmanagedDelay microseconds = Delay <$> unmanagedFork (liftIO (threadDelay microseconds))
+newUnmanagedDelay microseconds = Delay <$> unmanagedAsync (liftIO (threadDelay microseconds))
--
GitLab