diff --git a/quasar.cabal b/quasar.cabal index 83d12875e127fe60a7558263d84f29b22fe291dc..145bdbf04f2a6fbf389ca07e6cec10905cd6407b 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 98f09c6ff54f269bf1e4e2523eb54ae287aebb24..5c2cb0c8ce9f0c64fc2b4cf9f4aa69f2ba6574aa 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 e5f0420d56cd108e90f3b83ead6b18de9a2f3175..0ecde0f4ae41f80f36b3d609af5b0c6b48a5a32b 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 940cd52e5d8928a54f2844f23e15e31427281df2..2a101f2d1da65526a351215f1a6b0a572e49fe7f 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 99571bd3132d1c94f3859fdca1f47eeab9376142..cc3f3417ab5c5527aa500567acd31d30666fe07c 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))