From 5d37a8426abeb23fc5b55dab786e6223474d5493 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sat, 12 Feb 2022 03:05:44 +0100
Subject: [PATCH] Move fork functions for STM to Quasar.Async.Fork

---
 quasar.cabal                  |  1 +
 src/Quasar/Async/Fork.hs      | 51 +++++++++++++++++++++++++++++++++++
 src/Quasar/Async/STMHelper.hs | 26 ++----------------
 src/Quasar/Async/V2.hs        |  1 +
 4 files changed, 55 insertions(+), 24 deletions(-)
 create mode 100644 src/Quasar/Async/Fork.hs

diff --git a/quasar.cabal b/quasar.cabal
index 8e62dac..3ecf818 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -85,6 +85,7 @@ library
     unordered-containers,
   exposed-modules:
     Quasar
+    Quasar.Async.Fork
     Quasar.Async.STMHelper
     Quasar.Async.V2
     Quasar.Awaitable
diff --git a/src/Quasar/Async/Fork.hs b/src/Quasar/Async/Fork.hs
new file mode 100644
index 0000000..311f1cc
--- /dev/null
+++ b/src/Quasar/Async/Fork.hs
@@ -0,0 +1,51 @@
+module Quasar.Async.Fork (
+  -- * Forking with an asynchronous exception channel
+  -- ** STM
+  fork,
+  fork_,
+  forkWithUnmask,
+  forkWithUnmask_,
+
+  -- ** ShortIO
+  forkWithUnmaskShortIO,
+  forkWithUnmaskShortIO_,
+) where
+
+import Control.Concurrent (ThreadId)
+import Control.Concurrent.STM
+import Control.Monad.Catch
+import Quasar.Async.STMHelper
+import Quasar.Awaitable
+import Quasar.Exceptions
+import Quasar.Prelude
+import Quasar.Utils.ShortIO
+
+
+-- * Fork in STM (with ExceptionChannel)
+
+fork :: IO () -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId)
+fork fn = forkWithUnmask (\unmask -> unmask fn)
+
+fork_ :: IO () -> TIOWorker -> ExceptionChannel -> STM ()
+fork_ fn worker exChan = void $ fork fn worker exChan
+
+
+forkWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId)
+forkWithUnmask fn worker exChan = startShortIO (forkWithUnmaskShortIO fn exChan) worker exChan
+
+forkWithUnmask_ :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM ()
+forkWithUnmask_ fn worker exChan = void $ forkWithUnmask fn worker exChan
+
+
+-- * Fork in ShortIO (with ExceptionChannel)
+
+forkWithUnmaskShortIO :: ((forall a. IO a -> IO a) -> IO ()) -> ExceptionChannel -> ShortIO ThreadId
+forkWithUnmaskShortIO fn exChan = forkFn
+  where
+    forkFn :: ShortIO ThreadId
+    forkFn = mask_ $ forkIOWithUnmaskShortIO wrappedFn
+    wrappedFn :: (forall a. IO a -> IO a) -> IO ()
+    wrappedFn unmask = fn unmask `catchAll` \ex -> atomically (throwToExceptionChannel exChan ex)
+
+forkWithUnmaskShortIO_ :: ((forall a. IO a -> IO a) -> IO ()) -> ExceptionChannel -> ShortIO ()
+forkWithUnmaskShortIO_ fn exChan = void $ forkWithUnmaskShortIO fn exChan
diff --git a/src/Quasar/Async/STMHelper.hs b/src/Quasar/Async/STMHelper.hs
index 6e38644..3b92b19 100644
--- a/src/Quasar/Async/STMHelper.hs
+++ b/src/Quasar/Async/STMHelper.hs
@@ -1,15 +1,12 @@
 module Quasar.Async.STMHelper (
+  -- * Helper to fork from STM
   TIOWorker,
   newTIOWorker,
   startShortIO,
   startShortIO_,
-  fork,
-  fork_,
-  forkWithUnmask,
-  forkWithUnmask_,
 ) where
 
-import Control.Concurrent (ThreadId, forkIO)
+import Control.Concurrent (forkIO)
 import Control.Concurrent.STM
 import Control.Exception (BlockedIndefinitelyOnSTM)
 import Control.Monad.Catch
@@ -50,22 +47,3 @@ newTIOWorker = do
       (\(_ :: BlockedIndefinitelyOnSTM) -> pure ())
 
   pure $ TIOWorker jobQueue
-
-
-fork :: IO () -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId)
-fork fn = forkWithUnmask (\unmask -> unmask fn)
-
-fork_ :: IO () -> TIOWorker -> ExceptionChannel -> STM ()
-fork_ fn worker exChan = void $ fork fn worker exChan
-
-
-forkWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId)
-forkWithUnmask fn worker exChan = startShortIO forkFn worker exChan
-  where
-    forkFn :: ShortIO ThreadId
-    forkFn = mask_ $ forkIOWithUnmaskShortIO wrappedFn
-    wrappedFn :: (forall a. IO a -> IO a) -> IO ()
-    wrappedFn unmask = fn unmask `catchAll` \ex -> atomically (throwToExceptionChannel exChan ex)
-
-forkWithUnmask_ :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM ()
-forkWithUnmask_ fn worker exChan = void $ forkWithUnmask fn worker exChan
diff --git a/src/Quasar/Async/V2.hs b/src/Quasar/Async/V2.hs
index f1ba3d8..8b66c93 100644
--- a/src/Quasar/Async/V2.hs
+++ b/src/Quasar/Async/V2.hs
@@ -18,6 +18,7 @@ module Quasar.Async.V2 (
 import Control.Concurrent (ThreadId)
 import Control.Concurrent.STM
 import Control.Monad.Catch
+import Quasar.Async.Fork
 import Quasar.Async.STMHelper
 import Quasar.Awaitable
 import Quasar.Exceptions
-- 
GitLab