implemented WorkGroup.hs

module WorkGroup where

import Control.Monad (replicateM_)

import Control.Concurrent

import Control.Concurrent.QSem

import Control.Concurrent.MVar

-- | A WorkGroup is a manager for creating threads. When you create threads

-- using forkIOwg, you can wait for all them to exit using joinWorkGroup.

-- It's implemented because haskell doesn't have joinThread function.

data WorkGroup = WorkGroup {

      wgNum :: MVar Int

    , wgSem :: QSem

    }

newWorkGroup :: IO WorkGroup

newWorkGroup = do

  num <- newMVar 0

  sem <- newQSem 0

  return $ WorkGroup { wgNum=num, wgSem=sem }

-- | forkIO in workgroup. WorkGroup will keep track of started threads and

-- master thread can wait for all of them via joinWorkGroup wg.

forkIOwg :: WorkGroup -> IO () -> IO ThreadId

forkIOwg wg action = do

  modifyMVar_ (wgNum wg) (\n -> return $ n + 1)

  forkFinally action (\e -> signalQSem $ wgSem wg)

joinWorkGroup :: WorkGroup -> IO ()

joinWorkGroup wg = do

  n <- readMVar (wgNum wg)

  replicateM_ n $ waitQSem $ wgSem wg

                     , stm

  default-language:    Haskell2010

executable try5

  main-is:             try5.hs

  other-modules:       WorkGroup

  ghc-options:         -threaded -rtsopts -with-rtsopts=-N

  build-depends:       base >= 4.6.0.0

                     , random

  default-language:    Haskell2010

source-repository head

  type:     git

  location: https://github.com/sylecn/queue-base-threading

-- atomically block, it can't do anything about printing.

import System.IO

import Control.Monad

import Control.Concurrent

import Control.Concurrent.STM

import Text.Printf

-- use default Chan, use shutdown msg to terminate program.

-- let master thread wait for all created threads to finish.

-- well, do that on try 1 as well.

import Control.Concurrent (threadDelay)

import WorkGroup

-- | delay many seconds, then print a msg

printMsg :: Int -> IO ()

printMsg sec = do

  threadDelay $ sec * 1000000

  putStrLn "hehe"

main :: IO ()

main = do

  wg <- newWorkGroup

  forkIOwg wg $ printMsg 1

  forkIOwg wg $ printMsg 2

  forkIOwg wg $ printMsg 3

  forkIOwg wg $ printMsg 4

  joinWorkGroup wg