Skip to content

Commit be5e0d6

Browse files
cootcoot
committed
MonadMVar: tests in IOSim
1 parent bfb31fe commit be5e0d6

File tree

3 files changed

+337
-0
lines changed

3 files changed

+337
-0
lines changed

‎io-sim/io-sim.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -81,6 +81,7 @@ test-suite test
8181
other-modules: Test.IOSim
8282
Test.STM
8383
Test.Control.Monad.IOSimPOR
84+
Test.Control.Monad.Class.MonadMVar
8485
default-language: Haskell2010
8586
build-depends: base,
8687
array,
@@ -92,6 +93,7 @@ test-suite test
9293
strict-stm,
9394
tasty,
9495
tasty-quickcheck,
96+
tasty-hunit,
9597
time >= 1.9.1
9698

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

0 commit comments

Comments
 (0)