add sequenceConcurrentlyBounded

and sequenceConcurrentlyBounded_

Cabal/src/Distribution/Simple/Utils.hs

@@ -185,6 +185,8 @@ module Distribution.Simple.Utils
   , unintersperse
   , wrapText
   , wrapLine
+  , sequenceConcurrentlyBounded
+  , sequenceConcurrentlyBounded_
 
     -- * FilePath stuff
   , isAbsoluteOnAnyPlatform
@@ -228,6 +230,7 @@ import Data.Typeable
   )
 
 import qualified Control.Exception as Exception
+import Control.Concurrent
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 import Distribution.Compat.Process (proc)
 import Foreign.C.Error (Errno (..), ePIPE)
@@ -1868,3 +1871,41 @@ findHookedPackageDesc verbosity dir = do
 
 buildInfoExt :: String
 buildInfoExt = ".buildinfo"
+
+sequenceConcurrentlyBounded :: Int -> [IO a] -> IO [a]
+sequenceConcurrentlyBounded n xs = do
+    sem <- newQSem (n - 1)
+    tid <- myThreadId
+    let
+      catchForMe x = Exception.catches x
+        [ Exception.Handler $ \e@(Exception.SomeAsyncException _) -> throwIO e
+        , Exception.Handler $ \e@(SomeException _) -> Exception.throwTo tid e
+        ]
+    Exception.mask $ \restore -> do
+      resultvars <- for xs $ \x -> do
+        var <- newEmptyMVar
+        _tid <- forkIO $ Exception.bracket_ (waitQSem sem) (signalQSem sem) $ catchForMe $ do
+          res <- restore x
+          True <- tryPutMVar var res
+          return ()
+        return var
+      Exception.bracket_ (signalQSem sem) (waitQSem sem) (traverse takeMVar resultvars)
+
+sequenceConcurrentlyBounded_ :: Int -> [IO a] -> IO ()
+sequenceConcurrentlyBounded_ n xs = do
+    sem <- newQSem (n - 1)
+    tid <- myThreadId
+    let
+      catchForMe x = Exception.catches x
+        [ Exception.Handler $ \e@(Exception.SomeAsyncException _) -> throwIO e
+        , Exception.Handler $ \e@(SomeException _) -> Exception.throwTo tid e
+        ]
+    Exception.mask $ \restore -> do
+      resultvars <- for xs $ \x -> do
+        var <- newEmptyMVar
+        _tid <- forkIO $ Exception.bracket_ (waitQSem sem) (signalQSem sem) $ catchForMe $ do
+          _ <- restore x
+          True <- tryPutMVar var ()
+          return ()
+        return var
+      Exception.bracket_ (signalQSem sem) (waitQSem sem) (traverse_ takeMVar resultvars)