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