lifted-concurrent/test/TestThreads.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

import Control.Monad
import Control.Exception (throwIO)

import Control.Concurrent.ThreadUtil
import DebugUtil

main = do
    mvars <- sequence $ replicate 200 $ newEmptyMVar
    threads <- forM mvars $ forkIO . join . takeMVar
    let (normalquits,mvars1) = splitAt 20 mvars
    mapM_ (`putMVar` return ()) normalquits
    let (exceptionquits,mvars2) = splitAt 20 mvars1
    mapM_ (`putMVar` throwIO (userError "oops")) exceptionquits
    let (throwtoexceptions,threads1) = splitAt 20 $ drop 40 threads
    mapM_ (`throwTo` userError "throwTo-oops") throwtoexceptions
    let (killed,threads2) = splitAt 20 threads1
    mapM_ killThread killed
    threadDelay 1000000
    report <- threadReport True
    sequence_ $ zipWith (\n s -> putStrLn $ unwords [show n,s]) [1..] $ lines report
    return ()