follow Control.Exception changes
[packages/stm.git] / tests / conc048.hs
1 {-# LANGUAGE PatternSignatures #-}
2 module Main where
3
4 import GHC.Conc
5 import Control.Concurrent
6 import Control.Exception
7 import IO
8 import Foreign.StablePtr
9 import System.IO
10
11 -- Create two tvars each holding 0
12 initTVars :: STM (TVar Int, TVar Int)
13 initTVars = do v1 <- newTVar 0
14 v2 <- newTVar 0
15 return (v1, v2)
16
17 -- Increment v1, retry
18 optionOne :: TVar Int -> TVar Int -> STM ()
19 optionOne v1 v2 = do x <- readTVar v1
20 writeTVar v1 (x + 10)
21 retry
22
23 -- Increment v2, don't retry
24 optionTwo :: TVar Int -> TVar Int -> STM ()
25 optionTwo v1 v2 = do x <- readTVar v2
26 writeTVar v2 (x + 10)
27
28 -- Combine options one and two. We should be left with optionTwo because
29 -- optionOne attempts to retry while valid.
30 elseTestA :: TVar Int -> TVar Int -> STM ()
31 elseTestA v1 v2 = (optionOne v1 v2) `orElse` (optionTwo v1 v2)
32
33 -- Combine options one and two. We should be left with optionTwo because
34 -- optionOne attempts to retry while valid.
35 elseTestB :: TVar Int -> TVar Int -> STM ()
36 elseTestB v1 v2 = (optionTwo v1 v2) `orElse` (optionOne v1 v2)
37
38 -- Combine options two and one. We should be left with optionTwo because
39 -- it completes successfully.
40 elseTestC :: TVar Int -> TVar Int -> STM ()
41 elseTestC v1 v2 = (optionTwo v1 v2) `orElse` (optionTwo v1 v2)
42
43 -- Nested use of `orElse`: combine (optionOne and OptionOne) with optionTwo
44 elseTestD :: TVar Int -> TVar Int -> STM ()
45 elseTestD v1 v2 = ((optionOne v1 v2) `orElse` (optionOne v1 v2)) `orElse` (optionTwo v1 v2)
46
47 -- Nested use of `orElse`: combine (optionOne and optionTwo) with optionTwo
48 elseTestE :: TVar Int -> TVar Int -> STM ()
49 elseTestE v1 v2 = ((optionOne v1 v2) `orElse` (optionTwo v1 v2)) `orElse` (optionTwo v1 v2)
50
51 -- Combine options one and one. Retry should propagate.
52 elseTestZ :: TVar Int -> TVar Int -> STM ()
53 elseTestZ v1 v2 = (optionOne v1 v2) `orElse` (optionOne v1 v2)
54
55 -- return (v1, v2)
56 snapshot :: TVar Int -> TVar Int -> STM (Int, Int)
57 snapshot v1 v2 = do s1 <- readTVar v1
58 s2 <- readTVar v2
59 return (s1, s2)
60
61 main :: IO ()
62 main = do newStablePtr stdout
63 iteration 10
64
65 iteration :: Int -> IO ()
66 iteration n =
67 do putStrLn ("Iter " ++ show n)
68 (sv1, sv2) <- atomically ( initTVars )
69
70 putStrLn "T1"
71 atomically ( elseTestA sv1 sv2 )
72 vs <- atomically ( snapshot sv1 sv2 )
73 print vs
74
75 putStrLn "T2"
76 atomically ( elseTestB sv1 sv2 )
77 vs <- atomically ( snapshot sv1 sv2 )
78 print vs
79
80 putStrLn "T3"
81 atomically ( elseTestC sv1 sv2 )
82 vs <- atomically ( snapshot sv1 sv2 )
83 print vs
84
85 putStrLn "T4"
86 atomically ( elseTestD sv1 sv2 )
87 vs <- atomically ( snapshot sv1 sv2 )
88 print vs
89
90 putStrLn "T5"
91 atomically ( elseTestE sv1 sv2 )
92 vs <- atomically ( snapshot sv1 sv2 )
93 print vs
94
95 putStrLn "T6"
96 Control.Exception.catch (atomically ( elseTestZ sv1 sv2 ))
97 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
98 vs <- atomically ( snapshot sv1 sv2 )
99 print vs
100
101 putStrLn "T7"
102 if (n == 0) then return () else iteration (n - 1)
103
104
105