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