content: -- file: ch24/NiceFork.hs
  import Control.Concurrent
  import Control.Exception (Exception, try)
  import qualified Data.Map as M
  
  data ThreadStatus = Running
                    | Finished         -- terminated normally
                    | Threw Exception  -- killed by uncaught exception
                      deriving (Eq, Show)
  
  -- | Create a new thread manager.
  newManager :: IO ThreadManager
  
  -- | Create a new managed thread.
  forkManaged :: ThreadManager -> IO () -> IO ThreadId
  
  -- | Immediately return the status of a managed thread.
  getStatus :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
  
  -- | Block until a specific managed thread terminates.
  waitFor :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
  
  -- | Block until all managed threads terminate.
  waitAll :: ThreadManager -> IO ()
  
  -- file: ch24/NiceFork.hs
  module NiceFork
      (
        ThreadManager
      , newManager
      , forkManaged
      , getStatus
      , waitFor
      , waitAll
      ) where
  
  -- file: ch24/NiceFork.hs
  newtype ThreadManager =
      Mgr (MVar (M.Map ThreadId (MVar ThreadStatus)))
      deriving (Eq)
  
  newManager = Mgr `fmap` newMVar M.empty
  
  -- file: ch24/NiceFork.hs
  forkManaged (Mgr mgr) body =
      modifyMVar mgr $ \m -> do
        state <- newEmptyMVar
        tid <- forkIO $ do
          result <- try body
          putMVar state (either Threw (const Finished) result)
        return (M.insert tid state m, tid)
  
  -- file: ch24/NiceFork.hs
  getStatus (Mgr mgr) tid =
    modifyMVar mgr $ \m ->
      case M.lookup tid m of
        Nothing -> return (m, Nothing)
        Just st -> tryTakeMVar st >>= \mst -> case mst of
                     Nothing -> return (m, Just Running)
                     Just sth -> return (M.delete tid m, Just sth)
  
  -- file: ch24/NiceFork.hs
  waitFor (Mgr mgr) tid = do
    maybeDone <- modifyMVar mgr $ \m ->
      return $ case M.updateLookupWithKey (\_ _ -> Nothing) tid m of
        (Nothing, _) -> (m, Nothing)
        (done, m') -> (m', done)
    case maybeDone of
      Nothing -> return Nothing
      Just st -> Just `fmap` takeMVar st
  
  -- file: ch24/NiceFork.hs
  waitAll (Mgr mgr) = modifyMVar mgr elems >>= mapM_ takeMVar
      where elems m = return (M.empty, M.elems m)
  
  -- file: ch24/NiceFork.hs
  waitFor2 (Mgr mgr) tid =
    join . modifyMVar mgr $ \m ->
      return $ case M.updateLookupWithKey (\_ _ -> Nothing) tid m of
        (Nothing, _) -> (m, return Nothing)
        (Just st, m') -> (m', Just `fmap` takeMVar st)
  