Asynchronous jobs up to N simultaniously

async.hs

{-# LANGUAGE ViewPatterns #-}
module Main where

import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Async
import Data.List (delete)
import System.Environment (getArgs)


main :: IO ()
main = do
  j:js:_ <- map read <$> getArgs
  run j $ map (job_wrapper . job) [1..js]


run :: Int -> [IO a] -> IO ()
run n (splitAt n -> (ys, zs)) = mapM async ys >>= go zs
 where
  go :: [IO a] -> [Async a] -> IO ()
  go [] [] = return ()
  go [] as = do
    (a, _) <- waitAny as
    go [] (delete a as)
  go (x:xs) as = do
    (a, _) <- waitAny as
    b <- async x
    go xs (b : delete a as)


job_wrapper :: IO () -> IO ()
job_wrapper a = do
  print "Start job concurrently"
  a
  print "Stop job"


job :: Int -> IO ()
job n = print n >> threadDelay (n * 200000)

% ./async 14 14                                                 
"Start job concurrently"
1
"Start job concurrently"
2
"Start job concurrently"
3
"Start job concurrently"
4
"Start job concurrently"
5
"Start job concurrently"
6
"Start job concurrently"
7
"Start job concurrently"
8
"Start job concurrently"
9
"Start job concurrently"
10
"Start job concurrently"
11
"Start job concurrently"
12
"Start job concurrently"
13
"Start job concurrently"
14
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"
"Stop job"

% ./async 3 14 
"Start job concurrently"
1
"Start job concurrently"
2
"Start job concurrently"
3
"Stop job"
"Start job concurrently"
4
"Stop job"
"Start job concurrently"
5
"Stop job"
"Start job concurrently"
6
"Stop job"
"Start job concurrently"
7
"Stop job"
"Start job concurrently"
8
"Stop job"
"Start job concurrently"
9
"Stop job"
"Start job concurrently"
10
"Stop job"
"Start job concurrently"
11
"Stop job"
"Start job concurrently"
12
"Stop job"
"Start job concurrently"
13
"Stop job"
"Start job concurrently"
14
"Stop job"
"Stop job"
"Stop job"