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