1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
-- Code from ticket #488
module Test where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Exception
import Prelude hiding (catch)
runTest loop = do
(tc1, tc2, tmv) <- atomically (do
tmv <- newEmptyTMVar
tc1 <- newTChan
tc2 <- newTChan
return (tc1, tc2, tmv)
)
myTId <- myThreadId
forkIO (forked loop (tc1, tc2, tmv, myTId))
atomically (writeTChan tc1 "blah")
atomically (writeTChan tc1 "blah2")
return "done"
forked loop args@(tc1, tc2, tmv, hisTId) = catch ((loop args) >>= setTMV . Just) hndlr `finally` setTMV Nothing
where
setTMV x = atomically (tryPutTMVar tmv x >> return ())
hndlr (AsyncException ThreadKilled) = return ()
hndlr e = throwTo hisTId e
goodLoop args@(tc1, tc2, tmv, hisTId) = do
x <- atomically (readTChan tc1)
x' <- return $ reverse x
atomically (writeTChan tc2 x')
if x == "blah2"
then return ()
else goodLoop args
badLoop args@(tc1, tc2, tmv, hisTId) = do
x <- atomically (readTChan tc1)
x' <- return $ reverse x
atomically (writeTChan tc2 x')
badLoop args
|
