0bab8e20ed0a82d73506f340685b90624da807fe
[packages/stm.git] / tests / conc061.hs
1 module Main where
2
3 import GHC.Conc
4 import Control.Concurrent
5 import Control.Exception
6
7 main = do putStr "Starting\n";
8 t <- atomically (newTVar 42)
9
10 v <- atomically (readTVar t)
11 putStr ("TVar contains " ++ (show v) ++ "\n")
12
13 -- ......................................................................
14 -- Check that we roll back when an exception leaves an atomic block
15
16 putStr ("Raising uncaught exn in atomic block\n");
17 Control.Exception.catch (atomically (
18 do writeTVar t 17
19 throwDyn "Exn raised in a tx" ) )
20 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
21
22 v <- atomically (readTVar t)
23 putStr ("TVar contains " ++ (show v) ++ "\n")
24
25 -- ......................................................................
26 -- Check that we commit a catchSTM nested tx
27
28 putStr ("Trying a catchSTM without raising an exception\n");
29 Control.Exception.catch (atomically (
30 catchSTM ( do writeTVar t 17 )
31 ( \e -> throw e ) ) )
32 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
33
34 v <- atomically (readTVar t)
35 putStr ("TVar contains " ++ (show v) ++ "\n")
36
37 -- ......................................................................
38 -- Check that we roll back when an exception is caught and rethrown in
39 -- an atomic block
40
41 putStr ("Raising caught and rethrown exn in atomic block\n");
42 Control.Exception.catch (atomically (
43 catchSTM ( do writeTVar t 42
44 throwDyn "Exn raised in a tx" )
45 ( \e -> throw e ) ) )
46 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
47
48 v <- atomically (readTVar t)
49 putStr ("TVar contains " ++ (show v) ++ "\n")
50
51 -- ......................................................................
52 -- Check that we roll back just the "catchSTM" block when an exception is
53 -- raised in it (but caught later in the same atomic block)
54
55 putStr ("Raising caught and rethrown exn in atomic block\n");
56 v <- atomically (
57 do writeTVar t 0
58 catchSTM ( do writeTVar t 1
59 throwDyn "Exn raised in a tx" )
60 ( \_ -> return () )
61 readTVar t )
62 putStr ("TVar contained " ++ (show v) ++ " at end of atomic block\n")
63
64 v <- atomically (readTVar t)
65 putStr ("TVar contains " ++ (show v) ++ "\n")
66
67 -- ......................................................................
68 -- Check that 'retry' can propagate through a catchSTM
69
70 putStr ("Testing retry inside catchSTM\n");
71 Control.Exception.catch (atomically (
72 ( catchSTM ( retry )
73 ( \e -> throw e ) )
74 `orElse` ( return () ) ) )
75 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
76
77 v <- atomically (readTVar t)
78 putStr ("TVar contains " ++ (show v) ++ "\n")
79