concurrentoutput-0.2.0.1: Test.hs

import System.Terminal.Concurrent
import Control.Exception
import Prelude hiding (catch)
import Control.Concurrent
import Control.Monad

testThread writeC n1 n2 crash = do
	t <- myThreadId
	threadDelay $ n1 * 100000
	writeC("Thread " ++ show t ++ ": ")
	threadDelay $ n1 * 100000
	writeC "still working... "
        when crash $
            error "Thread crashed"
	writeC ""
	threadDelay $ n2 * 100000
	writeC "done\n"
        return True

main = do
	writeC <- getConcurrentOutputter
	forkSequence $ zipWith3 (testThread writeC) [0,0,3,5,2,3] [4,8,5,4,1,2] (False:True:repeat False)

-- Enable for parallel downloads
forkSequence acts = do
    sem <- newQSem 5
    mvars <- forM acts $ \act -> do
        mvar <- newEmptyMVar
        forkIO $ do 
            waitQSem sem
            catch (act >>= putMVar mvar) (\e -> putMVar mvar (throw e))
            signalQSem sem
        return mvar
    mapM takeMVar mvars