Skip to content

Commit 03e303b

Browse files
cootcoot
authored
Merge pull request #102 from input-output-hk/jdral/strict-mvar-test-whnf
Test that values inside `StrictMVar`s are in WHNF
2 parents cb65e93 + a250ac0 commit 03e303b

File tree

6 files changed

+234
-17
lines changed

6 files changed

+234
-17
lines changed

‎.github/workflows/haskell.yml

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -130,8 +130,11 @@ jobs:
130130
- name: si-timers [test]
131131
run: cabal run si-timers:test
132132

133-
- name: strict-mvar [test]
134-
run: cabal run strict-mvar:test
133+
- name: strict-mvar [test] [unchecked]
134+
run: cabal run --flag="-testchecked" strict-mvar:test
135+
136+
- name: strict-mvar [test] [checked]
137+
run: cabal run --flag="+testchecked" strict-mvar:test
135138

136139
stylish-haskell:
137140
runs-on: ubuntu-22.04

‎strict-mvar/strict-mvar.cabal

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,15 +38,23 @@ library
3838
-Wpartial-fields
3939
-Widentities
4040

41+
flag testchecked
42+
description: Run tests for checked Strict MVars.
43+
Default: False
44+
Manual: True
45+
4146
test-suite test
4247
type: exitcode-stdio-1.0
4348
hs-source-dirs: test
4449
main-is: Main.hs
4550

4651
other-modules: Test.Control.Concurrent.Class.MonadMVar.Strict.Checked
52+
Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF
53+
Test.Utils
4754
default-language: Haskell2010
4855
build-depends: base >=4.9 && <4.19,
4956
io-sim,
57+
nothunks,
5058
QuickCheck,
5159
tasty,
5260
tasty-quickcheck,
@@ -60,3 +68,6 @@ test-suite test
6068
-Wpartial-fields
6169
-Widentities
6270
-fno-ignore-asserts
71+
72+
if flag(testchecked)
73+
CPP-Options: -DTEST_CHECKED

‎strict-mvar/test/Main.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,11 @@
11
module Main where
22

33
import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked
4+
import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF as WHNF
45
import Test.Tasty
56

67
main :: IO ()
7-
main = defaultMain Checked.tests
8+
main = defaultMain $ testGroup "strict-mvar" [
9+
Checked.tests
10+
, WHNF.tests
11+
]

‎strict-mvar/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs

Lines changed: 1 addition & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,10 @@
33
module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where
44

55
import Control.Concurrent.Class.MonadMVar.Strict.Checked
6-
import Control.Monad.IOSim
7-
import Test.QuickCheck.Gen.Unsafe (Capture (..), capture)
86
import Test.QuickCheck.Monadic
97
import Test.Tasty
108
import Test.Tasty.QuickCheck
9+
import Test.Utils
1110

1211
tests :: TestTree
1312
tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
@@ -42,15 +41,3 @@ prop_invariantShouldFail :: MonadMVar m => PropertyM m ()
4241
prop_invariantShouldFail = run $ do
4342
v <- newMVarWithInvariant invPositiveInt 0
4443
modifyMVar_ v (\x -> pure $ x - 1)
45-
46-
{-------------------------------------------------------------------------------
47-
Property runners (copied from "Ouroboros.Network.Testing.QuickCheck")
48-
-------------------------------------------------------------------------------}
49-
50-
runSimGen :: (forall s. Gen (IOSim s a)) -> Gen a
51-
runSimGen f = do
52-
Capture eval <- capture
53-
return $ runSimOrThrow (eval f)
54-
55-
monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property
56-
monadicSim m = property (runSimGen (monadic' m))

‎strict-mvar/test/Test/Control/Concurrent/Class/MonadMVar/Strict/WHNF.hs

Lines changed: 189 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,189 @@
1+
{-# LANGUAGE CPP #-}
2+
3+
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
4+
{-# HLINT ignore "Use camelCase" #-}
5+
6+
-- | Test whether functions on 'StrictMVar's correctly force values to WHNF
7+
-- before they are put inside the 'StrictMVar'.
8+
module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF (tests) where
9+
10+
#if TEST_CHECKED
11+
import Control.Concurrent.Class.MonadMVar.Strict.Checked
12+
#else
13+
import Control.Concurrent.Class.MonadMVar.Strict
14+
#endif
15+
import Control.Monad (void)
16+
import Data.Typeable (Typeable)
17+
import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks)
18+
import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run)
19+
import Test.Tasty (TestTree, testGroup)
20+
import Test.Tasty.QuickCheck (Fun, applyFun, counterexample,
21+
testProperty)
22+
import Test.Utils (monadicSim)
23+
24+
{-------------------------------------------------------------------------------
25+
Main test tree
26+
-------------------------------------------------------------------------------}
27+
28+
name :: String
29+
#if TEST_CHECKED
30+
name = "Strict.Checked"
31+
#else
32+
name = "Strict"
33+
#endif
34+
35+
tests :: TestTree
36+
tests = testGroup ("Test.Control.Concurrent.Class.MonadMVar." <> name) [
37+
testGroup "WHNF" [
38+
testGroup "IO" [
39+
testProperty "prop_newMVar" $
40+
monadicIO .: prop_newMVar
41+
, testProperty "prop_newMVarWithInvariant" $
42+
monadicIO .: prop_newMVarWithInvariant
43+
, testProperty "prop_putMVar" $
44+
monadicIO .: prop_putMVar
45+
, testProperty "prop_swapMVar" $
46+
monadicIO .: prop_swapMVar
47+
, testProperty "prop_tryPutMVar" $
48+
monadicIO .: prop_tryPutMVar
49+
, testProperty "prop_modifyMVar_" $
50+
monadicIO .: prop_modifyMVar_
51+
, testProperty "prop_modifyMVar" $
52+
monadicIO .: prop_modifyMVar
53+
, testProperty "prop_modifyMVarMasked_" $
54+
monadicIO .: prop_modifyMVarMasked_
55+
, testProperty "prop_modifyMVarMasked" $
56+
monadicIO .: prop_modifyMVarMasked
57+
]
58+
, testGroup "IOSim" [
59+
testProperty "prop_newMVar" $ \x f ->
60+
monadicSim $ prop_newMVar x f
61+
, testProperty "prop_newMVarWithInvariant" $ \x f ->
62+
monadicSim $ prop_newMVarWithInvariant x f
63+
, testProperty "prop_putMVar" $ \x f ->
64+
monadicSim $ prop_putMVar x f
65+
, testProperty "prop_swapMVar" $ \x f ->
66+
monadicSim $ prop_swapMVar x f
67+
, testProperty "prop_tryPutMVar" $ \x f ->
68+
monadicSim $ prop_tryPutMVar x f
69+
, testProperty "prop_modifyMVar_" $ \x f ->
70+
monadicSim $ prop_modifyMVar_ x f
71+
, testProperty "prop_modifyMVar" $ \x f ->
72+
monadicSim $ prop_modifyMVar x f
73+
, testProperty "prop_modifyMVarMasked_" $ \x f ->
74+
monadicSim $ prop_modifyMVarMasked_ x f
75+
, testProperty "prop_modifyMVarMasked" $ \x f ->
76+
monadicSim $ prop_modifyMVarMasked x f
77+
]
78+
]
79+
]
80+
81+
{-------------------------------------------------------------------------------
82+
Utilities
83+
-------------------------------------------------------------------------------}
84+
85+
infixr 9 .:
86+
87+
(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)
88+
(.:) g f x0 x1 = g (f x0 x1)
89+
90+
isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool
91+
isInWHNF v = do
92+
x <- run $ readMVar v
93+
case unsafeNoThunks (OnlyCheckWhnf x) of
94+
Nothing -> pure True
95+
Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)
96+
>> pure False
97+
98+
{-------------------------------------------------------------------------------
99+
Properties
100+
-------------------------------------------------------------------------------}
101+
102+
prop_newMVar ::
103+
MonadMVar m
104+
=> Int
105+
-> Fun Int Int
106+
-> PropertyM m Bool
107+
prop_newMVar x f = do
108+
v <- run $ newMVar (applyFun f x)
109+
isInWHNF v
110+
111+
prop_newMVarWithInvariant ::
112+
MonadMVar m
113+
=> Int
114+
-> Fun Int Int
115+
-> PropertyM m Bool
116+
prop_newMVarWithInvariant x f = do
117+
v <- run $ newMVarWithInvariant (const Nothing) (applyFun f x)
118+
isInWHNF v
119+
120+
prop_putMVar ::
121+
MonadMVar m
122+
=> Int
123+
-> Fun Int Int
124+
-> PropertyM m Bool
125+
prop_putMVar x f = do
126+
v <- run newEmptyMVar
127+
run $ putMVar v (applyFun f x)
128+
isInWHNF v
129+
130+
prop_swapMVar ::
131+
MonadMVar m
132+
=> Int
133+
-> Fun Int Int
134+
-> PropertyM m Bool
135+
prop_swapMVar x f = do
136+
v <- run $ newMVar x
137+
void $ run $ swapMVar v (applyFun f x)
138+
isInWHNF v
139+
140+
prop_tryPutMVar ::
141+
MonadMVar m
142+
=> Int
143+
-> Fun Int Int
144+
-> PropertyM m Bool
145+
prop_tryPutMVar x f = do
146+
v <- run newEmptyMVar
147+
b <- run $ tryPutMVar v (applyFun f x)
148+
b' <- isInWHNF v
149+
pure (b && b')
150+
151+
prop_modifyMVar_ ::
152+
MonadMVar m
153+
=> Int
154+
-> Fun Int Int
155+
-> PropertyM m Bool
156+
prop_modifyMVar_ x f =do
157+
v <- run $ newMVar x
158+
run $ modifyMVar_ v (pure . applyFun f)
159+
isInWHNF v
160+
161+
prop_modifyMVar ::
162+
MonadMVar m
163+
=> Int
164+
-> Fun Int (Int, Char)
165+
-> PropertyM m Bool
166+
prop_modifyMVar x f =do
167+
v <- run $ newMVar x
168+
void $ run $ modifyMVar v (pure . applyFun f)
169+
isInWHNF v
170+
171+
prop_modifyMVarMasked_ ::
172+
MonadMVar m
173+
=> Int
174+
-> Fun Int Int
175+
-> PropertyM m Bool
176+
prop_modifyMVarMasked_ x f =do
177+
v <- run $ newMVar x
178+
void $ run $ modifyMVarMasked_ v (pure . applyFun f)
179+
isInWHNF v
180+
181+
prop_modifyMVarMasked ::
182+
MonadMVar m
183+
=> Int
184+
-> Fun Int (Int, Char)
185+
-> PropertyM m Bool
186+
prop_modifyMVarMasked x f =do
187+
v <- run $ newMVar x
188+
void $ run $ modifyMVarMasked v (pure . applyFun f)
189+
isInWHNF v

‎strict-mvar/test/Test/Utils.hs

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
{-# LANGUAGE RankNTypes #-}
2+
3+
module Test.Utils
4+
( runSimGen
5+
, monadicSim
6+
) where
7+
8+
import Control.Monad.IOSim (IOSim, runSimOrThrow)
9+
import Test.QuickCheck (Gen, Property, Testable (..))
10+
import Test.QuickCheck.Gen.Unsafe (Capture (..), capture)
11+
import Test.QuickCheck.Monadic (PropertyM, monadic')
12+
13+
{-------------------------------------------------------------------------------
14+
Property runners (copied from "Ouroboros.Network.Testing.QuickCheck")
15+
-------------------------------------------------------------------------------}
16+
17+
runSimGen :: (forall s. Gen (IOSim s a)) -> Gen a
18+
runSimGen f = do
19+
Capture eval <- capture
20+
return $ runSimOrThrow (eval f)
21+
22+
monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property
23+
monadicSim m = property (runSimGen (monadic' m))

0 commit comments

Comments
 (0)