asyncTree1.hs

module Main where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Trans.Writer.Strict
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.Async

main = do
  handle <- asyncTree (multiworkCleanup "working" ["one", "two", "three"])
  getLine
  cancel handle
  getLine

asyncTree action =
  async $ asyncCleanup action

asyncCleanup =
  bracket setup cleanup
  where
    setup = newMVar []
    cleanup var = takeMVar var >>= mapM_ cancel

async' :: MVar [Async a] -> IO a -> IO (Async a)
async' var action = do
  handle <- async action
  modifyMVar_ var (return . (handle :))
  return handle

multiworkCleanup :: String -> [String] -> MVar [Async ()] -> IO ()
multiworkCleanup msg msgs var = do
  let async = async' var
  mapM_ (async . workLoop) msgs
  workLoop msg

workLoop :: String -> IO ()
workLoop msg = do
  print msg
  threadDelay (10^6)
  workLoop msg

asyncTree2.hs

module Main where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Trans.Writer.Strict
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.Async

main = do
  handle <- asyncTree (multimultiworkCleanup "working" [("1-3", ["one", "two", "three"]), ("4-6", ["four", "five", "six"])])
  getLine
  cancel handle
  getLine

asyncTree action =
  async $ asyncCleanup action

asyncCleanup work =
  bracket setup cleanup (work . async')
  where
    setup = newMVar []
    cleanup var = takeMVar var >>= mapM_ cancel

type AsyncFunc a = IO a -> IO (Async a)

async' :: MVar [Async a] -> IO a -> IO (Async a)
async' var action = do
  handle <- async action
  modifyMVar_ var (return . (handle :))
  return handle

multimultiworkCleanup :: String -> [(String, [String])] -> AsyncFunc () -> IO ()
multimultiworkCleanup msg msgs async = do
  mapM_ (async . (\(msg, msgs) -> multiworkCleanup msg msgs async)) msgs
  workLoop msg

multiworkCleanup :: String -> [String] -> AsyncFunc () -> IO ()
multiworkCleanup msg msgs async = do
  mapM_ (async . workLoop) msgs
  workLoop msg

workLoop :: String -> IO ()
workLoop msg = do
  print msg
  threadDelay (10^6)
  workLoop msg

monadicAsyncTree1.hs

module Main where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.Async

type AsyncFunc a = IO a -> IO (Async a)

type AsyncCleanup a b = ReaderT (MVar [Async a]) IO b

main = do
  handle <- asyncTree (multiworkCleanup "working" ["one", "two", "three"])
  getLine
  cancel handle
  getLine

asyncTree action =
  async $ asyncCleanup action

asyncCleanup work =
  bracket setup cleanup (runReaderT work)
  where
    setup = newMVar []
    cleanup var = takeMVar var >>= mapM_ cancel

async' :: MVar [Async a] -> IO a -> IO (Async a)
async' var action = do
  handle <- async action
  modifyMVar_ var (return . (handle :))
  return handle

asyncAsk :: IO a -> AsyncCleanup a (Async a)
asyncAsk action = do
  var <- ask
  liftIO $ async' var action

multiworkCleanup :: String -> [String] -> AsyncCleanup () ()
multiworkCleanup msg msgs = do
  mapM_ (asyncAsk . workLoop) msgs
  liftIO $ workLoop msg

workLoop :: String -> IO ()
workLoop msg = do
  print msg
  threadDelay (10^6)
  workLoop msg

monadicLiftedAsyncTree1.hs

{-# LANGUAGE FlexibleContexts #-}

module Main where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.Async.Lifted
import Control.Monad.Trans.Control

type AsyncCleanup a m b = ReaderT (MVar [Async (StM m a)]) m b

main = do
  handle <- asyncTree (multiworkCleanup "working" ["one", "two", "three"])
  getLine
  cancel handle
  getLine

asyncTree action =
  async $ asyncCleanup action

asyncCleanup work =
  bracket setup cleanup (runReaderT work)
  where
    setup = newMVar []
    cleanup var = takeMVar var >>= mapM_ cancel

buildAsync :: (MonadIO m, MonadBaseControl IO m) => MVar [Async (StM m a)] -> m a -> m (Async (StM m a))
buildAsync var action = do
  handle <- async action
  liftIO $ modifyMVar_ var (return . (handle :))
  return handle

async' :: (MonadIO m, MonadBaseControl IO m) => m a -> AsyncCleanup a m (Async (StM m a))
async' action = do
  var <- ask
  lift $ buildAsync var action

multiworkCleanup :: String -> [String] -> AsyncCleanup () IO ()
multiworkCleanup msg msgs = do
  mapM_ (async' . workLoop) msgs
  liftIO $ workLoop msg

workLoop :: String -> IO ()
workLoop msg = do
  print msg
  threadDelay (10^6)
  workLoop msg

monadicLiftedAsyncTree2WIP.hs

{-# LANGUAGE FlexibleContexts      #-}

module Main where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.Async.Lifted
import Control.Monad.Trans.Control

type AsyncCleanup a m b = ReaderT (MVar [Async (StM m a)]) m b

main = do
  handle <- asyncTree (multiworkCleanup "working" ["one", "two", "three"])
  getLine
  cancel handle
  getLine

asyncTree :: AsyncCleanup a IO b -> IO (Async (StM IO b))
asyncTree action =
  async $ asyncCleanup action

asyncCleanup :: AsyncCleanup a IO b -> IO b
asyncCleanup work =
  bracket setup cleanup (runReaderT work)
  where
    setup = newMVar []
    cleanup var = takeMVar var >>= mapM_ cancel

buildAsync :: (MonadIO m, MonadBaseControl IO m) => MVar [Async (StM m a)] -> m a -> m (Async (StM m a))
buildAsync var action = do
  handle <- async action
  liftIO $ modifyMVar_ var (return . (handle :))
  return handle

async' :: (MonadIO m, MonadBaseControl IO m) => m a -> AsyncCleanup a m (Async (StM m a))
async' action = do
  var <- ask
  lift $ buildAsync var action


multimultiworkCleanup :: String -> [(String, [String])] -> AsyncCleanup () IO ()
multimultiworkCleanup msg msgs = do
  mapM_ (async' . uncurry multiworkCleanup) msgs
  liftIO $ workLoop msg

multiworkCleanup :: String -> [String] -> AsyncCleanup () IO ()
multiworkCleanup msg msgs = do
  mapM_ (async' . workLoop) msgs
  liftIO $ workLoop msg

workLoop :: String -> IO ()
workLoop msg = do
  print msg
  threadDelay (10^6)
  workLoop msg