From 3951dfeaa7011c160b048b3274e8ffde0672d8cf Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sat, 12 Feb 2022 03:14:34 +0100
Subject: [PATCH] Add safe fork variant that collects the result as an
 awaitable

---
 src/Quasar/Async/Fork.hs | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

diff --git a/src/Quasar/Async/Fork.hs b/src/Quasar/Async/Fork.hs
index 311f1cc..aef8816 100644
--- a/src/Quasar/Async/Fork.hs
+++ b/src/Quasar/Async/Fork.hs
@@ -9,6 +9,8 @@ module Quasar.Async.Fork (
   -- ** ShortIO
   forkWithUnmaskShortIO,
   forkWithUnmaskShortIO_,
+  startIOThreadShortIO,
+  startIOThreadWithUnmaskShortIO,
 ) where
 
 import Control.Concurrent (ThreadId)
@@ -49,3 +51,28 @@ forkWithUnmaskShortIO fn exChan = forkFn
 
 forkWithUnmaskShortIO_ :: ((forall a. IO a -> IO a) -> IO ()) -> ExceptionChannel -> ShortIO ()
 forkWithUnmaskShortIO_ fn exChan = void $ forkWithUnmaskShortIO fn exChan
+
+
+-- * Fork in ShortIO while collecting the result (with ExceptionChannel)
+
+startIOThreadWithUnmaskShortIO :: forall a. ((forall b. IO b -> IO b) -> IO a) -> ExceptionChannel -> ShortIO (Awaitable a)
+startIOThreadWithUnmaskShortIO fn exChan = do
+  resultVar <- newAsyncVarShortIO
+  forkWithUnmaskShortIO_ (runAndPut resultVar) exChan
+  pure $ toAwaitable resultVar
+  where
+    runAndPut :: AsyncVar a -> (forall b. IO b -> IO b) -> IO ()
+    runAndPut resultVar unmask = do
+      -- Called in masked state by `forkWithUnmaskShortIO`
+      result <- try $ fn unmask
+      case result of
+        Left ex ->
+          atomically (throwToExceptionChannel exChan ex)
+            `finally`
+              failAsyncVar_ resultVar (AsyncException ex)
+        Right retVal -> do
+          putAsyncVar_ resultVar retVal
+
+
+startIOThreadShortIO :: forall a. IO a -> ExceptionChannel -> ShortIO (Awaitable a)
+startIOThreadShortIO fn = startIOThreadWithUnmaskShortIO ($ fn)
-- 
GitLab