{- |
  Like `concurrently`, but use at most N threads.
-}
concurrentN :: Int -> [IO a] -> IO [a]
concurrentN n ios = do
  chan <- newEmptyMVar
  mapM_ (forkIO . const (handler chan)) [1 .. n]
  packages <- mapM package ios
  mapM_ (putMVar chan . Just) packages
  putMVar chan Nothing -- send the kill signal
  results <- mapM (takeMVar . snd) packages
  case sequence results of
    Right vals -> return vals
    Left err -> throw (err :: SomeException)
  where
    package io = do
      response <- newEmptyMVar
      return (io, response)

    handler chan = do
      job <- takeMVar chan
      case job of
        Nothing ->
          -- put back the end marker and terminate
          putMVar chan Nothing
        Just (io, response) -> do
          result <- try io
          putMVar response result
          -- loop until we get `Nothing`
          handler chan


{- |
  Like `concurrently_`, but use at most N threads.
-}
concurrentN :: Int -> [IO a] -> IO [a]
concurrentN n ios = do
  chan <- newEmptyMVar
  mapM_ (forkIO . const (handler chan)) [1 .. n]
  packages <- mapM package ios
  mapM_ (putMVar chan . Just) packages
  putMVar chan Nothing -- send the kill signal
  results <- mapM (takeMVar . snd) packages
  case sequence results of
    Right vals -> return vals
    Left err -> throw (err :: SomeException)
  where
    package io = do
      response <- newEmptyMVar
      return (io, response)

    handler chan = do
      job <- takeMVar chan
      case job of
        Nothing ->
          -- put back the end marker and terminate
          putMVar chan Nothing
        Just (io, response) -> do
          result <- try io
          putMVar response result
          -- loop until we get `Nothing`
          handler chan


{- |
  Like `concurrently_`, but use at most N threads.
-}
concurrentN n ios = do
  chan <- newEmptyMVar
  mapM_ (forkIO . const (handler chan)) [1 .. n]
  packages <- mapM package ios
  mapM_ (putMVar chan . Just) packages
  putMVar chan Nothing -- send the kill signal
  results <- mapM (takeMVar . snd) packages
  case sequence results of
    Right vals -> return vals
    Left err -> throw (err :: SomeException)
  where
    package io = do
      response <- newEmptyMVar
      return (io, response)

    handler chan = do
      job <- takeMVar chan
      case job of
        Nothing ->
          -- put back the end marker and terminate
          putMVar chan Nothing
        Just (io, response) -> do
          result <- try io
          putMVar response result
          -- loop until we get `Nothing`
          handler chan


{- |
  Like `concurrently_`, but use at most N threads.
-}