Count active threads in order to terminate gracefully, minimal version

threadcount_naive.hs

module Main where

import GHC.Conc (atomically)

import System.Exit (exitSuccess)

import Control.Concurrent.STM.TVar (TVar, readTVarIO, newTVarIO, modifyTVar')
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (bracket_)
import Control.Monad (void, when, forever)

import Data.Int

fork :: TVar Int64 -> IO () -> IO ()
fork sem = void . forkIO . bracket_
  (atomically $ modifyTVar' sem (+1))
  (atomically $ modifyTVar' sem (subtract 1))

wait :: TVar Int64 -> IO ()
wait sem = forever $ do
  threadDelay 1000
  value <- readTVarIO sem
  when (value == 0) $ exitSuccess

action :: IO ()
action = do
  putStrLn "Enter"
  threadDelay 10000
  putStrLn "Exit"

main :: IO ()
main = do
  sem <- newTVarIO 0
  fork sem action
  fork sem action
  wait sem