suppress some warnings
[packages/stm.git] / tests / conc046.hs
1 {-# LANGUAGE PatternSignatures #-}
2 module Main where
3
4 import GHC.Conc
5 import Control.Concurrent
6 import Control.Exception
7
8 inittvars :: STM (TVar String, TVar String)
9 inittvars = do v1 <- newTVar "Hello "
10 v2 <- newTVar "world\n"
11 return (v1, v2)
12
13 stmops :: TVar String -> TVar String -> STM String
14 stmops v1 v2 = do s1 <- readTVar v1
15 s2 <- readTVar v2
16 return (s1 ++ s2)
17
18 stmupdates :: TVar String -> TVar String -> STM ()
19 stmupdates v1 v2 = do writeTVar v1 "About to throw exception"
20 throw (ErrorCall "Exn holding string")
21
22 internalexn :: TVar String -> TVar String -> STM ()
23 internalexn v1 v2 = catchSTM ( do writeTVar v1 "About to throw exception"
24 throw (ErrorCall "Exn holding string" ))
25 (\_ -> writeTVar v1 "Reached handler ")
26
27 internalexn2 :: TVar String -> TVar String -> STM ()
28 internalexn2 v1 v2 = catchSTM ( do writeTVar v1 "Hello " )
29 (\_ -> writeTVar v1 "Reached handler2 ")
30
31 -- Exception handling within / around memory transactions
32 main = do putStr "Before\n"
33 (sv1, sv2) <- atomically ( inittvars )
34
35 putStr "Reading from svars: "
36 x <- atomically ( stmops sv1 sv2 )
37 putStr x
38
39 putStr "Abandoning update with exception\n"
40 Control.Exception.catch (atomically ( stmupdates sv1 sv2 ))
41 (\(e::ErrorCall) -> putStr "Abandoned\n")
42
43 putStr "Reading from svars: "
44 x <- atomically ( stmops sv1 sv2 )
45 putStr x
46
47 putStr "Atomic block with internal exception\n"
48 atomically ( internalexn sv1 sv2 )
49
50 putStr "Reading from svars: "
51 x <- atomically ( stmops sv1 sv2 )
52 putStr x
53
54 putStr "Atomic block with handler but no exception\n"
55 atomically ( internalexn2 sv1 sv2 )
56
57 putStr "Reading from svars: "
58 x <- atomically ( stmops sv1 sv2 )
59 putStr x
60
61 return ()
62
63
64
65
66
67
68
69