{-# LANGUAGE Safe #-}
module Control.Concurrent.PooledIO.Independent (
   run,
   runLimited,
   runUnlimited,
   runException,
   ) where

import Control.Concurrent.PooledIO.Monad
          (withNumCapabilities, chooseNumCapabilities,
           forkFinally, forkTry, takeMVarTry, runTry)
import qualified Control.Concurrent.Split.MVar as MVar
import Control.Exception (evaluate)

import Control.Monad (replicateM_)


{- |
Execute all actions parallelly
but run at most @numCapabilities@ threads at once.
Stop when all actions are finished.
If a thread throws an exception this terminates only the throwing thread.
-}
run :: [IO ()] -> IO ()
run :: [IO ()] -> IO ()
run = forall a b. (Int -> a -> IO b) -> a -> IO b
withNumCapabilities Int -> [IO ()] -> IO ()
runLimited

runLimited :: Int -> [IO ()] -> IO ()
runLimited :: Int -> [IO ()] -> IO ()
runLimited Int
numCaps [IO ()]
acts = do
   let ([IO ()]
start, [IO ()]
queue) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
numCaps [IO ()]
acts
   Int
n <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [IO ()]
start
   (In ()
mvarIn, Out ()
mvarOut) <- forall a. IO (In a, Out a)
MVar.newEmpty
   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (In () -> IO () -> IO ()
forkFinally In ()
mvarIn) [IO ()]
start
   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\IO ()
act -> forall a. Out a -> IO a
MVar.take Out ()
mvarOut forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> In () -> IO () -> IO ()
forkFinally In ()
mvarIn IO ()
act) [IO ()]
queue
   forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n forall a b. (a -> b) -> a -> b
$ forall a. Out a -> IO a
MVar.take Out ()
mvarOut

{- |
Execute all actions parallelly without a bound an the number of threads.
Stop when all actions are finished.
-}
runUnlimited :: [IO ()] -> IO ()
runUnlimited :: [IO ()] -> IO ()
runUnlimited [IO ()]
acts =
   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Out a -> IO a
MVar.take forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IO () -> IO (Out ())
fork [IO ()]
acts

fork :: IO () -> IO (MVar.Out ())
fork :: IO () -> IO (Out ())
fork IO ()
act = do
   (In ()
mvarIn, Out ()
mvarOut) <- forall a. IO (In a, Out a)
MVar.newEmpty
   In () -> IO () -> IO ()
forkFinally In ()
mvarIn IO ()
act
   forall (m :: * -> *) a. Monad m => a -> m a
return Out ()
mvarOut


{- |
If a thread ends with an exception,
then terminate all threads and forward that exception.
@runException Nothing@ chooses to use all capabilities,
whereas @runException (Just n)@ chooses @n@ capabilities.
-}
runException :: Maybe Int -> [IO ()] -> IO ()
runException :: Maybe Int -> [IO ()] -> IO ()
runException Maybe Int
maybeNumCaps [IO ()]
acts = do
   Int
numCaps <- Maybe Int -> IO Int
chooseNumCapabilities Maybe Int
maybeNumCaps
   Int -> [IO ()] -> IO ()
runOneBreaksAll Int
numCaps [IO ()]
acts

runOneBreaksAll :: Int -> [IO ()] -> IO ()
runOneBreaksAll :: Int -> [IO ()] -> IO ()
runOneBreaksAll Int
numCaps [IO ()]
acts = do
   let ([IO ()]
start, [IO ()]
queue) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
numCaps [IO ()]
acts
   Int
n <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [IO ()]
start
   (In (ThreadId, Either SomeException ())
mvarIn, Out (ThreadId, Either SomeException ())
mvarOut) <- forall a. IO (In a, Out a)
MVar.newEmpty
   forall a. StateT (Set ThreadId) IO a -> IO a
runTry forall a b. (a -> b) -> a -> b
$ do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a.
NFData a =>
In (ThreadId, Either SomeException a)
-> IO a -> StateT (Set ThreadId) IO ()
forkTry In (ThreadId, Either SomeException ())
mvarIn) [IO ()]
start
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\IO ()
act -> forall a.
Out (ThreadId, Either SomeException a)
-> StateT (Set ThreadId) IO a
takeMVarTry Out (ThreadId, Either SomeException ())
mvarOut forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a.
NFData a =>
In (ThreadId, Either SomeException a)
-> IO a -> StateT (Set ThreadId) IO ()
forkTry In (ThreadId, Either SomeException ())
mvarIn IO ()
act) [IO ()]
queue
      forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n forall a b. (a -> b) -> a -> b
$ forall a.
Out (ThreadId, Either SomeException a)
-> StateT (Set ThreadId) IO a
takeMVarTry Out (ThreadId, Either SomeException ())
mvarOut