blob: fcb2d5c2e4d5792f75f35b0ebd6ea18432bce71d (
plain)
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
44
45
46
47
48
49
|
module Main where
import Control.Concurrent
import qualified Control.Exception as E
trapHandler :: MVar Int -> MVar () -> IO ()
trapHandler inVar caughtVar =
(do E.block $ do
trapMsg <- takeMVar inVar
putStrLn ("Handler got: " ++ show trapMsg)
trapHandler inVar caughtVar
)
`E.catch`
(trapExc inVar caughtVar)
trapExc :: MVar Int -> MVar () -> E.SomeException -> IO ()
-- If we have been killed then we are done
trapExc inVar caughtVar e
| Just E.ThreadKilled <- E.fromException e = return ()
-- Otherwise...
trapExc inVar caughtVar e =
do putStrLn ("Exception: " ++ show e)
putMVar caughtVar ()
trapHandler inVar caughtVar
main :: IO ()
main = do
inVar <- newEmptyMVar
caughtVar <- newEmptyMVar
tid <- forkIO (trapHandler inVar caughtVar)
yield
putMVar inVar 1
threadDelay 1000
throwTo tid (E.ErrorCall "1st")
takeMVar caughtVar
putMVar inVar 2
threadDelay 1000
throwTo tid (E.ErrorCall "2nd")
-- the second time around, exceptions will be blocked, because
-- the trapHandler is effectively "still in the handler" from the
-- first exception. I'm not sure if this is by design or by
-- accident. Anyway, the trapHandler will at some point block
-- in takeMVar, and thereby become interruptible, at which point
-- it will receive the second exception.
takeMVar caughtVar
-- Running the GHCi way complains that tid is blocked indefinitely if
-- it still exists, so kill it.
killThread tid
putStrLn "All done"
|
