-- | Keeping track of forked threads.
module Game.LambdaHack.Common.Thread
  ( forkChild, waitForChildren
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import Control.Concurrent.Async
import Control.Concurrent.MVar

-- Swiped from <http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html>
-- Ported to Async to link exceptions, to let CI tests fail.

forkChild :: MVar [Async ()] -> IO () -> IO ()
forkChild :: MVar [Async ()] -> IO () -> IO ()
forkChild MVar [Async ()]
children IO ()
io = do
  Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
io
  Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a
  [Async ()]
childs <- MVar [Async ()] -> IO [Async ()]
forall a. MVar a -> IO a
takeMVar MVar [Async ()]
children
  MVar [Async ()] -> [Async ()] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [Async ()]
children (Async ()
a Async () -> [Async ()] -> [Async ()]
forall a. a -> [a] -> [a]
: [Async ()]
childs)

waitForChildren :: MVar [Async ()] -> IO ()
waitForChildren :: MVar [Async ()] -> IO ()
waitForChildren MVar [Async ()]
children = do
  [Async ()]
cs <- MVar [Async ()] -> IO [Async ()]
forall a. MVar a -> IO a
takeMVar MVar [Async ()]
children
  case [Async ()]
cs of
    [] -> do
      MVar [Async ()] -> [Async ()] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [Async ()]
children []
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Async ()
m : [Async ()]
ms -> do
      MVar [Async ()] -> [Async ()] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [Async ()]
children [Async ()]
ms
      Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
m
      MVar [Async ()] -> IO ()
waitForChildren MVar [Async ()]
children