Question

I have the following implementation of a concurrent thread manager

newtype Query = Query String

type ThreadWorker = (Query, ThreadStatus)
data ThreadStatus = Running | Finished | Threw IOException

newtype ThreadManager = Manager (MVar (M.Map ThreadId (MVar ThreadWorker)

I want to write manageWorkers :: ThreadManager -> IO () that traverses the Map and looks at the ThreadStatus of the ThreadWorker.

If the ThreadWorker is finished, then it is deleted from the ThreadManager. If an exception has been thrown, then it should be handled (print to stdout is fine for example purposes) and a new thread should be forked to process the query (assume the existance of a function runQuery :: Query -> IO a) and be added to the ThreadManager, else the thread is still running and should be left alone.

my first attempt at an implementation was:

manageWorkers :: ThreadManager -> IO ()
manageWorkers (Manager mgr) =
    modifyMVar mgr $ \m -> do
        m' <- M.traverseWithKey manageWorker m
        return (m', ())
where manageWorker :: ThreadId -> MVar ThreadWorker -> IO (MVar ThreadWorker)
      manageWorker tid wkr = tryTakeMVar wkr >>= \mwkr ->
          case mwkr of
               Just (_, Finished) -> undefined -- need to delete this finished ThreadWorker
               Just (q, Threw e ) -> do
                   putStrLn ("[ERROR] " ++ show e)
                   tid' <- forkIO $ runQuery q
                   undefined -- need to add new ThreadWorker
               Just r -> newMVar r
               _ -> newEmptyMVar

but then I got stuck, it doesnt seem possible to delete or add from/to the ThreadManager while in manageWorker. I’m not sure if it’s possible to do what I want from a traverse-like function.

Is it possible to implement this manageWorkers function using my ThreadManager or is there a better abstraction out there?

EDIT: at ThomasM.DuBuisson’s suggestion to use a fold, I now have the following

manageWorkers (Manager mgr) =
    modifyMVar mgr $ \m ->
    return (M.foldrWithKey manageWorker M.empty m, ())
where manageWorker :: ThreadId -> MVar ThreadWorker -> M.Map ThreadId (MVar ThreadWorker)
                      -> IO (M.Map ThreadId (MVar ThreadWorker))
      manageWorker tid wkr ts = tryTakeMVar wkr >>= \mwkr ->
          case mwkr of
              Just (q, Threw e) -> do
                  putStrLn ("[ERROR] " ++ show e)
                  wkr' <- newEmptyMVar
                  tid' <- forkIO $ runQuery q
                  return $ M.insert tid' wkr' ts
              Just (_, Running) -> return $ M.insert tid wkr
              _ -> return ts

the only problem is that obviously manageWorker‘s signature does not work with M.foldrWithKey. I need a M.foldrWithKeyM :: Monad m => (k -> a -> b -> m b) -> b -> M.Map k a -> m b but such a thing does not exist, and I’m having trouble composing it myself.

Obviously I can use unsafePerformIO to escape the IO monad and satisfy the compiler, but I would only use that as a last resort. Is this a situation in which it makes sense to use unsafePerformIO?

Answer 1

In my opinion, you question is irrelevant to concurrency.
You just want to traverse a map, meanwhile, delete some keys from the map or insert some keys in the map and perform some IO actions.
The problem is traverseWithKey cannot delete keys from the map or insert keys in the map, foldrWithKey cannot perform IO actions.
You need a M.foldrWithKeyM :: Monad m => (k -> a -> b -> m b) -> b -> M.Map k a -> m b
Indeed, such a thing does not exist. But if you look at the documentation of foldrWithKey, which states:

foldrWithKey f z == foldr (uncurry f) z . toAscList. 

We can guess such M.foldrWithKeyM can be composed if we replcae foldr by foldM.

The following is my solution.

manageWorkers :: ThreadManager -> IO ()
manageWorkers (Manager mgr) = 
    modifyMVar mgr $ \m -> do
        m' <- foldM manageWorker m (M.toList m)
        return (m', ())
  where manageWorker :: M.Map ThreadId (MVar ThreadWorker) -> (ThreadId, MVar ThreadWorker) -> IO (M.Map ThreadId (MVar ThreadWorker))
        manageWorker ts (tid, wkr) = tryTakeMVar wkr >>= \mwkr ->
            case mwkr of
                 Just (_, Finished) -> return $ M.delete tid ts -- need to delete this finished ThreadWorker
                 Just (q, Threw e ) -> do
                       putStrLn ("[ERROR] " ++ show e)
                       wkr' <- newEmptyMVar
                       tid' <- forkIO $ runQuery q
                       return $ M.insert tid' wkr' ts -- need to add new ThreadWorker
                 _ -> return ts