64da381ebeb488bd0ef785c41c4f8eb2ec1f8806
[packages/stm.git] / tests / conc060.hs
1 {-# LANGUAGE PatternSignatures #-}
2 module Main where
3
4 import GHC.Conc
5 import Control.Exception
6
7 -- Create trivial invariants using a single TVar
8 main = do
9 putStr "\nStarting\n"
10 x <- atomically ( newTVar 42 )
11
12 putStr "\nAdding trivially true invariant (no TVar access)\n"
13 atomically ( alwaysSucceeds ( return 1 ) )
14
15 putStr "\nAdding trivially true invariant (no TVar access)\n"
16 atomically ( always ( return True ) )
17
18 putStr "\nAdding a trivially true invariant (TVar access)\n"
19 atomically ( alwaysSucceeds ( readTVar x ) )
20
21 putStr "\nAdding an invraiant that's false when attemted to be added\n"
22 Control.Exception.catch (atomically ( do writeTVar x 100
23 alwaysSucceeds ( do v <- readTVar x
24 if (v == 100) then throw (ErrorCall "URK") else return () )
25 writeTVar x 0 ) )
26 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
27
28 putStr "\nWriting to a TVar watched by a trivially true invariant\n"
29 atomically ( writeTVar x 17 )
30
31 putStr "\nAdding a second trivially true invariant (same TVar access)\n"
32 atomically ( alwaysSucceeds ( readTVar x ) )
33
34 putStr "\nWriting to a TVar watched by both trivially true invariants\n"
35 atomically ( writeTVar x 18 )
36
37 putStr "\nAdding a trivially false invariant (no TVar access)\n"
38 Control.Exception.catch (atomically ( alwaysSucceeds ( throw (ErrorCall "Exn raised in invariant") ) ) )
39 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
40
41 putStr "\nAdding a trivially false invariant (no TVar access)\n"
42 Control.Exception.catch (atomically ( always ( throw (ErrorCall "Exn raised in invariant") ) ) )
43 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
44
45 putStr "\nAdding a trivially false invariant (no TVar access)\n"
46 Control.Exception.catch (atomically ( always ( return False ) ) )
47 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
48
49 putStr "\nAdding a trivially false invariant (with TVar access)\n"
50 Control.Exception.catch (atomically (
51 alwaysSucceeds ( do t <- readTVar x
52 throw (ErrorCall "Exn raised in invariant") ) ) )
53 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
54
55 putStr "\nAdding a third invariant true if TVar != 42\n"
56 atomically ( alwaysSucceeds ( do t <- readTVar x
57 if (t == 42) then throw (ErrorCall "Exn raised in invariant") else return () ) )
58
59 putStr "\nViolating third invariant by setting TVar to 42\n"
60 Control.Exception.catch (atomically ( writeTVar x 42 ) )
61 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
62
63 putStr "\nChecking final TVar contents\n"
64 t <- atomically ( readTVar x )
65 putStr ("Final value = " ++ (show t) ++ "\n")
66
67 putStr "\nDone\n"
68