Skip to content

Commit 3924390

Browse files
cootcoot
committed
MonadMVar: tests in IOSim
1 parent 3a3f2f1 commit 3924390

File tree

3 files changed

+329
-0
lines changed

3 files changed

+329
-0
lines changed

‎io-sim/io-sim.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -80,6 +80,7 @@ test-suite test
8080
other-modules: Test.IOSim
8181
Test.STM
8282
Test.Control.Monad.IOSimPOR
83+
Test.Control.Monad.Class.MonadMVar
8384
default-language: Haskell2010
8485
build-depends: base,
8586
array,
@@ -91,6 +92,7 @@ test-suite test
9192
strict-stm,
9293
tasty,
9394
tasty-quickcheck,
95+
tasty-hunit,
9496
time >= 1.9.1
9597

9698
ghc-options: -Wall

‎io-sim/test/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Main (main) where
22

33
import Test.Tasty
44

5+
import qualified Test.Control.Monad.Class.MonadMVar (tests)
56
import qualified Test.IOSim (tests)
67

78
main :: IO ()
@@ -11,4 +12,5 @@ tests :: TestTree
1112
tests =
1213
testGroup "IO Sim"
1314
[ Test.IOSim.tests
15+
, Test.Control.Monad.Class.MonadMVar.tests
1416
]

‎io-sim/test/Test/Control/Monad/Class/MonadMVar.hs

Lines changed: 325 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,325 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TupleSections #-}
5+
6+
module Test.Control.Monad.Class.MonadMVar where
7+
8+
import Control.Monad.Class.MonadAsync
9+
import Control.Monad.Class.MonadFork
10+
import Control.Monad.Class.MonadMVar
11+
import Control.Monad.Class.MonadTime
12+
import Control.Monad.Class.MonadTimer
13+
import Data.Foldable (traverse_)
14+
import Data.Functor (($>))
15+
import Data.Maybe (isNothing)
16+
17+
import Control.Monad.IOSim
18+
19+
import Test.QuickCheck
20+
import Test.Tasty
21+
import Test.Tasty.HUnit
22+
import Test.Tasty.QuickCheck (testProperty)
23+
24+
tests :: TestTree
25+
tests =
26+
testGroup "Control.Monad.Class.MonadMVar"
27+
[ testGroup "putMVar"
28+
[ testProperty "fairness (IOSim)" prop_putMVar_fairness_sim
29+
, testCase "blocks on a full MVar (IOSim)"
30+
unit_putMVar_blocks_on_full_sim
31+
, testCase "blocks on a full MVar (IO)"
32+
unit_putMVar_blocks_on_full_io
33+
]
34+
, testGroup "takeMVar"
35+
[ testProperty "fairness (IOSim)" prop_takeMVar_fairness_sim
36+
, testCase "blocks on an empty MVar (IOSim)"
37+
unit_takeMVar_blocks_on_empty_sim
38+
, testCase "blocks on an empty MVar (IO)"
39+
unit_takeMVar_blocks_on_empty_io
40+
]
41+
, testGroup "tryTakeMVar"
42+
[ testCase "does not block on an empty MVar (IOSim)"
43+
unit_tryTakeMVar_empty
44+
, testCase "does not block on a full MVar (IOSim)"
45+
unit_tryTakeMVar_full
46+
, testCase "return value on an empty MVar (IOSim)"
47+
unit_tryTakeMVar_return_empty_sim
48+
, testCase "return value on an full MVar (IOSim)"
49+
unit_tryTakeMVar_return_full_sim
50+
]
51+
, testGroup "tryPutMVar"
52+
[ testCase "does not block on an empty MVar (IOSim)"
53+
unit_tryPutMVar_empty
54+
, testCase "does not block on a full MVar (IOSim)"
55+
unit_tryPutMVar_full
56+
, testCase "return value on an empty MVar (IOSim)"
57+
unit_tryPutMVar_return_empty_sim
58+
, testCase "return value on an full MVar (IOSim)"
59+
unit_tryPutMVar_return_full_sim
60+
]
61+
, testGroup "isEmptyMVar"
62+
[ testCase "empty MVar is empty" unit_isEmptyMVar_empty_sim
63+
, testCase "full MVar is not empty" unit_isEmptyMVar_full_sim
64+
]
65+
]
66+
67+
68+
--
69+
-- putMVar
70+
--
71+
72+
-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'
73+
-- as it relies on its thread scheduling and determinism.
74+
--
75+
prop_putMVar_fairness
76+
:: forall m.
77+
( MonadAsync m
78+
, MonadDelay m
79+
, MonadMVar m
80+
)
81+
=> Int -- ^ number of threads
82+
-> m Bool
83+
prop_putMVar_fairness n = do
84+
v <- newEmptyMVar
85+
traverse_ (\a -> async $ do threadDelay 0.01
86+
putMVar v a)
87+
[1..n]
88+
threadDelay 0.02
89+
results <- sequence (replicate n (takeMVar v))
90+
return $ results == [1..n]
91+
92+
prop_putMVar_fairness_sim :: Positive (Small Int)
93+
-> Property
94+
prop_putMVar_fairness_sim (Positive (Small n)) =
95+
let trace = runSimTrace (prop_putMVar_fairness n)
96+
in counterexample (ppTrace trace)
97+
$ case traceResult False trace of
98+
Left err -> counterexample (show err) False
99+
Right a -> property a
100+
101+
102+
unit_putMVar_blocks_on_full
103+
:: ( MonadFork m
104+
, MonadDelay m
105+
, MonadMVar m
106+
, MonadMonotonicTime m
107+
)
108+
=> m Bool
109+
unit_putMVar_blocks_on_full = do
110+
start <- getMonotonicTime
111+
let delta = 0.01
112+
v :: MVar m () <- newMVar ()
113+
_ <- forkIO $ threadDelay delta
114+
>> takeMVar v
115+
$> ()
116+
putMVar v ()
117+
end <- getMonotonicTime
118+
return (end `diffTime` start >= delta)
119+
120+
unit_putMVar_blocks_on_full_sim :: Assertion
121+
unit_putMVar_blocks_on_full_sim = assertBool "did not block on an full MVar" $
122+
runSimOrThrow unit_putMVar_blocks_on_full
123+
124+
unit_putMVar_blocks_on_full_io :: Assertion
125+
unit_putMVar_blocks_on_full_io =
126+
unit_putMVar_blocks_on_full >>= assertBool "did not block on an full MVar"
127+
128+
129+
--
130+
-- takeMVar
131+
--
132+
133+
-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'
134+
-- as it relies on its thread scheduling and determinism.
135+
--
136+
prop_takeMVar_fairness
137+
:: forall m.
138+
( MonadAsync m
139+
, MonadDelay m
140+
, MonadMVar m
141+
, Eq (Async m Int)
142+
)
143+
=> Int -- ^ number of threads
144+
-> m Property
145+
prop_takeMVar_fairness n = do
146+
v <- newEmptyMVar
147+
ts <- sequence $ replicate n (async $ takeMVar v)
148+
threadDelay 0.01
149+
traverse_ (putMVar v) [1..n]
150+
results <- waitAll ts
151+
return $ results === [1..n]
152+
153+
prop_takeMVar_fairness_sim :: Positive (Small Int)
154+
-> Property
155+
prop_takeMVar_fairness_sim (Positive (Small n)) =
156+
runSimOrThrow (prop_takeMVar_fairness n)
157+
158+
159+
unit_takeMVar_blocks_on_empty
160+
:: ( MonadFork m
161+
, MonadDelay m
162+
, MonadMVar m
163+
, MonadMonotonicTime m
164+
)
165+
=> m Bool
166+
unit_takeMVar_blocks_on_empty = do
167+
start <- getMonotonicTime
168+
let delta = 0.01
169+
v :: MVar m () <- newEmptyMVar
170+
_ <- forkIO $ threadDelay delta
171+
>> putMVar v ()
172+
takeMVar v
173+
end <- getMonotonicTime
174+
return (end `diffTime` start >= delta)
175+
176+
unit_takeMVar_blocks_on_empty_sim :: Assertion
177+
unit_takeMVar_blocks_on_empty_sim = assertBool "did not block on an empty MVar" $ runSimOrThrow unit_takeMVar_blocks_on_empty
178+
179+
unit_takeMVar_blocks_on_empty_io :: Assertion
180+
unit_takeMVar_blocks_on_empty_io =
181+
unit_takeMVar_blocks_on_empty >>= assertBool "did not block on an empty MVar"
182+
183+
--
184+
-- tryTakeMVar
185+
--
186+
187+
188+
prop_tryTakeMVar
189+
:: ( m ~ IOSim s -- this property is only true in IOSim, since we use time to
190+
-- detect that an operation is non blocking
191+
)
192+
=> Bool -> Bool
193+
prop_tryTakeMVar isEmpty = runSimOrThrow $ do
194+
v <- if isEmpty
195+
then newEmptyMVar
196+
else newMVar ()
197+
start <- getMonotonicTime
198+
_ <- tryTakeMVar v
199+
end <- getMonotonicTime
200+
return $ start == end
201+
202+
unit_tryTakeMVar_empty :: Assertion
203+
unit_tryTakeMVar_empty = assertBool "blocked on an empty MVar" $
204+
prop_tryTakeMVar False
205+
206+
unit_tryTakeMVar_full :: Assertion
207+
unit_tryTakeMVar_full = assertBool "blocked on an empty MVar" $
208+
prop_tryTakeMVar True
209+
210+
211+
prop_tryTakeMVar_return_value
212+
:: MonadMVar m
213+
=> Bool
214+
-> m Bool
215+
prop_tryTakeMVar_return_value isEmpty =
216+
do v :: MVar m ()
217+
<- if isEmpty
218+
then newEmptyMVar
219+
else newMVar ()
220+
a <- tryTakeMVar v
221+
return $ isNothing a == isEmpty
222+
223+
unit_tryTakeMVar_return_empty_sim :: Assertion
224+
unit_tryTakeMVar_return_empty_sim =
225+
assertBool "tryTakeMVar on an empty should return result" $
226+
runSimOrThrow (prop_tryTakeMVar_return_value True)
227+
228+
unit_tryTakeMVar_return_full_sim :: Assertion
229+
unit_tryTakeMVar_return_full_sim =
230+
assertBool "tryTakeMVar on an full should return result" $
231+
runSimOrThrow (prop_tryTakeMVar_return_value False)
232+
233+
--
234+
-- tryPutMVar
235+
--
236+
237+
prop_tryPutMVar
238+
:: ( m ~ IOSim s -- this property is only true in IOSim, since we use time to
239+
-- detect that an operation is non blocking
240+
)
241+
=> Bool -> Bool
242+
prop_tryPutMVar isEmpty = runSimOrThrow $ do
243+
v <- if isEmpty
244+
then newEmptyMVar
245+
else newMVar ()
246+
start <- getMonotonicTime
247+
_ <- tryPutMVar v ()
248+
end <- getMonotonicTime
249+
return $ start == end
250+
251+
unit_tryPutMVar_empty :: Assertion
252+
unit_tryPutMVar_empty = assertBool "blocked on an empty MVar" $
253+
prop_tryTakeMVar False
254+
255+
unit_tryPutMVar_full :: Assertion
256+
unit_tryPutMVar_full = assertBool "blocked on an empty MVar" $
257+
prop_tryTakeMVar True
258+
259+
260+
prop_tryPutMVar_return_value
261+
:: forall m.
262+
MonadMVar m
263+
=> Bool
264+
-> m Bool
265+
prop_tryPutMVar_return_value isEmpty = do
266+
v :: MVar m ()
267+
<- if isEmpty
268+
then newEmptyMVar
269+
else newMVar ()
270+
a <- tryPutMVar v ()
271+
return $ a == isEmpty
272+
273+
unit_tryPutMVar_return_empty_sim :: Assertion
274+
unit_tryPutMVar_return_empty_sim =
275+
assertBool "tryPutMVar on an empty should return result" $
276+
runSimOrThrow (prop_tryPutMVar_return_value True)
277+
278+
unit_tryPutMVar_return_full_sim :: Assertion
279+
unit_tryPutMVar_return_full_sim =
280+
assertBool "tryPutMVar on an full should return result" $
281+
runSimOrThrow (prop_tryPutMVar_return_value False)
282+
283+
--
284+
-- isEmptyMVar
285+
--
286+
287+
prop_isEmptyMVar
288+
:: forall m. MonadMVar m
289+
=> Bool
290+
-> m Bool
291+
prop_isEmptyMVar isEmpty = do
292+
v :: MVar m ()
293+
<- if isEmpty
294+
then newEmptyMVar
295+
else newMVar ()
296+
(isEmpty ==) <$> isEmptyMVar v
297+
298+
unit_isEmptyMVar_empty_sim :: Assertion
299+
unit_isEmptyMVar_empty_sim =
300+
assertBool "empty mvar must be empty" $
301+
runSimOrThrow (prop_isEmptyMVar True)
302+
303+
unit_isEmptyMVar_full_sim :: Assertion
304+
unit_isEmptyMVar_full_sim =
305+
assertBool "full mvar must not be empty" $
306+
runSimOrThrow (prop_isEmptyMVar False)
307+
308+
--
309+
-- Utils
310+
--
311+
312+
waitAll :: forall m.
313+
( MonadAsync m
314+
, Eq (Async m Int)
315+
)
316+
=> [Async m Int] -> m [Int]
317+
waitAll = go []
318+
where
319+
go :: [Int] -> [Async m Int] -> m [Int]
320+
go as ts = do
321+
(t, a) <- waitAny ts
322+
let ts' = filter (/= t) ts
323+
case ts' of
324+
[] -> return (reverse (a : as))
325+
_ -> go (a : as) ts'

0 commit comments

Comments
 (0)