Add back new working QSem and QSemN implementations (#7417)
[packages/base.git] / tests / qsemn001.hs
1 {-# LANGUAGE CPP #-}
2 import Control.Concurrent
3 import Control.Exception
4 import Control.Monad
5 import Control.Concurrent.STM
6
7 new = newQSemN
8 wait = waitQSemN
9 signal = signalQSemN
10
11 --------
12 -- dummy test-framework
13
14 type Assertion = IO ()
15
16 x @?= y = when (x /= y) $ error (show x ++ " /= " ++ show y)
17
18 testCase :: String -> IO () -> IO ()
19 testCase n io = putStrLn ("test " ++ n) >> io
20
21 defaultMain = sequence
22 ------
23
24 main = defaultMain tests
25
26 tests = [
27 testCase "semn" semn,
28 testCase "semn2" semn2,
29 testCase "semn3" semn3,
30 testCase "semn_kill" semn_kill,
31 testCase "semn_bracket" sem_bracket
32 ]
33
34 semn :: Assertion
35 semn = do
36 c <- newTChanIO
37 q <- new 0
38 t1 <- forkIO $ do wait q 1; atomically $ writeTChan c 'a'
39 threadDelay 10000
40 t2 <- forkIO $ do wait q 2; atomically $ writeTChan c 'b'
41 threadDelay 10000
42 t3 <- forkIO $ do wait q 3; atomically $ writeTChan c 'c'
43 threadDelay 10000
44 signal q 1
45 a <- atomically $ readTChan c
46 signal q 2
47 b <- atomically $ readTChan c
48 signal q 3
49 c <- atomically $ readTChan c
50 [a,b,c] @?= "abc"
51
52 semn2 :: Assertion
53 semn2 = do
54 c <- newTChanIO
55 q <- new 0
56 t1 <- forkIO $ do wait q 1; threadDelay 10000; atomically $ writeTChan c 'a'
57 threadDelay 10000
58 t2 <- forkIO $ do wait q 2; threadDelay 20000; atomically $ writeTChan c 'b'
59 threadDelay 10000
60 t3 <- forkIO $ do wait q 3; threadDelay 30000; atomically $ writeTChan c 'c'
61 threadDelay 10000
62 signal q 6
63 a <- atomically $ readTChan c
64 b <- atomically $ readTChan c
65 c <- atomically $ readTChan c
66 [a,b,c] @?= "abc"
67
68 semn3 :: Assertion
69 semn3 = do
70 c <- newTChanIO
71 q <- new 0
72 t1 <- forkIO $ do wait q 1; threadDelay 10000; atomically $ writeTChan c 'a'
73 threadDelay 10000
74 t2 <- forkIO $ do wait q 2; threadDelay 20000; atomically $ writeTChan c 'b'
75 threadDelay 10000
76 t3 <- forkIO $ do wait q 3; threadDelay 30000; atomically $ writeTChan c 'c'
77 threadDelay 10000
78 signal q 3
79 a <- atomically $ readTChan c
80 b <- atomically $ readTChan c
81 threadDelay 10000
82 [a,b] @?= "ab"
83 d <- atomically $ isEmptyTChan c
84 d @?= True
85 signal q 1
86 threadDelay 10000
87 d <- atomically $ isEmptyTChan c
88 d @?= True
89 signal q 2
90 x <- atomically $ readTChan c
91 x @?= 'c'
92
93 semn_kill :: Assertion
94 semn_kill = do
95 q <- new 0
96 t <- forkIO $ do wait q 1
97 threadDelay 10000
98 killThread t
99 m <- newEmptyMVar
100 t <- forkIO $ do wait q 1; putMVar m ()
101 signal q 1
102 takeMVar m
103
104 sem_bracket :: Assertion
105 sem_bracket = do
106 q <- new 1
107 ts <- forM [1..100000] $ \n -> do
108 forkIO $ do bracket_ (wait q 1) (signal q 1) (return ())
109 mapM_ killThread ts
110 wait q 1