Testsuite: fixup lots of tests
[ghc.git] / libraries / base / tests / Concurrent / Chan001.hs
1 import Test.QuickCheck
2 import System.IO.Unsafe
3 import Control.Concurrent.Chan
4 import Control.Concurrent
5 import Control.Monad
6
7 data Action = NewChan | ReadChan | WriteChan Int | IsEmptyChan | ReturnInt Int
8 | ReturnBool Bool
9 deriving (Eq,Show)
10
11
12 main = do
13 t <- myThreadId
14 forkIO (threadDelay 1000000 >> killThread t)
15 -- just in case we deadlock
16 testChan
17
18 testChan :: IO ()
19 testChan = do
20 quickCheck prop_NewIs_NewRet
21 quickCheck prop_NewWriteIs_NewRet
22 quickCheck prop_NewWriteRead_NewRet
23
24
25 prop_NewIs_NewRet =
26 [NewChan,IsEmptyChan] =^ [NewChan,ReturnBool True]
27
28 prop_NewWriteIs_NewRet n =
29 [NewChan,WriteChan n,IsEmptyChan] =^ [NewChan,WriteChan n,ReturnBool False]
30
31 prop_NewWriteRead_NewRet n =
32 [NewChan,WriteChan n,ReadChan] =^ [NewChan,ReturnInt n]
33
34
35 perform :: [Action] -> IO ([Bool],[Int])
36 perform [] = return ([],[])
37
38 perform (a:as) =
39 case a of
40 ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform as)
41 ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
42 NewChan -> newChan >>= \chan -> perform' chan as
43 _ -> error $ "Please use NewChan as first action"
44
45
46 perform' :: Chan Int -> [Action] -> IO ([Bool],[Int])
47 perform' _ [] = return ([],[])
48
49 perform' chan (a:as) =
50 case a of
51 ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' chan as)
52 ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' chan as)
53 ReadChan -> liftM2 (\v (b,l) -> (b,v:l)) (readChan chan)
54 (perform' chan as)
55 WriteChan n -> writeChan chan n >> perform' chan as
56 IsEmptyChan -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyChan chan)
57 (perform' chan as)
58 _ -> error $ "If you want to use " ++ show a
59 ++ " please use the =^ operator"
60
61
62 actions :: Gen [Action]
63 actions =
64 liftM (NewChan:) (actions' 0)
65
66
67 actions' :: Int -> Gen [Action]
68 actions' contents =
69 oneof ([return [],
70 liftM (IsEmptyChan:) (actions' contents),
71 liftM2 (:) (liftM WriteChan arbitrary) (actions' (contents+1))]
72 ++
73 if contents==0
74 then []
75 else [liftM (ReadChan:) (actions' (contents-1))])
76
77
78 (=^) :: [Action] -> [Action] -> Property
79 c =^ c' =
80 forAll (actions' (delta 0 c))
81 (\suff -> observe c suff == observe c' suff)
82 where observe x suff = unsafePerformIO (perform (x++suff))
83
84
85 (^=^) :: [Action] -> [Action] -> Property
86 c ^=^ c' =
87 forAll actions
88 (\pref -> forAll (actions' (delta 0 (pref++c)))
89 (\suff -> observe c pref suff ==
90 observe c' pref suff))
91 where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
92
93
94 delta :: Int -> [Action] -> Int
95 delta i [] = i
96
97 delta i (ReturnInt _:as) = delta i as
98
99 delta i (ReturnBool _:as) = delta i as
100
101 delta _ (NewChan:as) = delta 0 as
102
103 delta i (WriteChan _:as) = delta (i+1) as
104
105 delta i (ReadChan:as) = delta (if i==0
106 then error "read on empty Chan"
107 else i-1) as
108
109 delta i (IsEmptyChan:as) = delta i as