Skip to content

Commit cdb46f0

Browse files
jorisdraljorisdral
committed
Test that values are in WHNF in Strict MVars
1 parent dccf0a7 commit cdb46f0

File tree

5 files changed

+245
-3
lines changed

5 files changed

+245
-3
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: -DCHECKED

‎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/WHNF.hs

Lines changed: 201 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,201 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
5+
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
6+
{-# HLINT ignore "Use camelCase" #-}
7+
8+
module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF (tests) where
9+
10+
#if 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 (Proxy (..), 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 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 (Proxy @Int)
41+
, testProperty "prop_newMVarWithInvariant" $
42+
monadicIO .: prop_newMVarWithInvariant (Proxy @Int)
43+
, testProperty "prop_putMVar" $
44+
monadicIO .: prop_putMVar (Proxy @Int)
45+
, testProperty "prop_swapMVar" $
46+
monadicIO .: prop_swapMVar (Proxy @Int)
47+
, testProperty "prop_tryPutMVar" $
48+
monadicIO .: prop_tryPutMVar (Proxy @Int)
49+
, testProperty "prop_modifyMVar_" $
50+
monadicIO .: prop_modifyMVar_ (Proxy @Int)
51+
, testProperty "prop_modifyMVar" $
52+
monadicIO .: prop_modifyMVar (Proxy @Int) (Proxy @Char)
53+
, testProperty "prop_modifyMVarMasked_" $
54+
monadicIO .: prop_modifyMVarMasked_ (Proxy @Int)
55+
, testProperty "prop_modifyMVarMasked" $
56+
monadicIO .: prop_modifyMVarMasked (Proxy @Int) (Proxy @Char)
57+
]
58+
, testGroup "IOSim" [
59+
testProperty "prop_newMVar" $ \x f ->
60+
monadicSim $ prop_newMVar (Proxy @Int) x f
61+
, testProperty "prop_newMVarWithInvariant" $ \x f ->
62+
monadicSim $ prop_newMVarWithInvariant (Proxy @Int) x f
63+
, testProperty "prop_putMVar" $ \x f ->
64+
monadicSim $ prop_putMVar (Proxy @Int) x f
65+
, testProperty "prop_swapMVar" $ \x f ->
66+
monadicSim $ prop_swapMVar (Proxy @Int) x f
67+
, testProperty "prop_tryPutMVar" $ \x f ->
68+
monadicSim $ prop_tryPutMVar (Proxy @Int) x f
69+
, testProperty "prop_modifyMVar_" $ \x f ->
70+
monadicSim $ prop_modifyMVar_ (Proxy @Int) x f
71+
, testProperty "prop_modifyMVar" $ \x f ->
72+
monadicSim $ prop_modifyMVar (Proxy @Int) (Proxy @Char) x f
73+
, testProperty "prop_modifyMVarMasked_" $ \x f ->
74+
monadicSim $ prop_modifyMVarMasked_ (Proxy @Int) x f
75+
, testProperty "prop_modifyMVarMasked" $ \x f ->
76+
monadicSim $ prop_modifyMVarMasked (Proxy @Int) (Proxy @Char) 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+
let tinfoMay = unsafeNoThunks (OnlyCheckWhnf x)
94+
case tinfoMay of
95+
Nothing -> pure True
96+
Just tinfo -> monitor (counterexample $ "Thunk found: " ++ show tinfo)
97+
>> pure False
98+
99+
{-------------------------------------------------------------------------------
100+
Properties
101+
-------------------------------------------------------------------------------}
102+
103+
prop_newMVar ::
104+
(MonadMVar m, Typeable a)
105+
=> proxy a
106+
-> a
107+
-> Fun a a
108+
-> PropertyM m Bool
109+
prop_newMVar _ x f = do
110+
v <- run $ newMVar (applyFun f x)
111+
isInWHNF v
112+
113+
prop_newMVarWithInvariant ::
114+
(MonadMVar m, Typeable a)
115+
=> proxy a
116+
-> a
117+
-> Fun a a
118+
-> PropertyM m Bool
119+
prop_newMVarWithInvariant _ x f = do
120+
v <- run $ newMVarWithInvariant (const Nothing) (applyFun f x)
121+
isInWHNF v
122+
123+
prop_putMVar ::
124+
(MonadMVar m, Typeable a)
125+
=> proxy a
126+
-> a
127+
-> Fun a a
128+
-> PropertyM m Bool
129+
prop_putMVar _ x f = do
130+
v <- run newEmptyMVar
131+
run $ putMVar v (applyFun f x)
132+
isInWHNF v
133+
134+
prop_swapMVar ::
135+
(MonadMVar m, Typeable a)
136+
=> proxy a
137+
-> a
138+
-> Fun a a
139+
-> PropertyM m Bool
140+
prop_swapMVar _ x f = do
141+
v <- run $ newMVar x
142+
void $ run $ swapMVar v (applyFun f x)
143+
isInWHNF v
144+
145+
prop_tryPutMVar ::
146+
(MonadMVar m, Typeable a)
147+
=> proxy a
148+
-> a
149+
-> Fun a a
150+
-> PropertyM m Bool
151+
prop_tryPutMVar _ x f = do
152+
v <- run newEmptyMVar
153+
b <- run $ tryPutMVar v (applyFun f x)
154+
b' <- isInWHNF v
155+
pure (b && b')
156+
157+
prop_modifyMVar_ ::
158+
(MonadMVar m, Typeable a)
159+
=> Proxy a
160+
-> a
161+
-> Fun a a
162+
-> PropertyM m Bool
163+
prop_modifyMVar_ _ x f =do
164+
v <- run $ newMVar x
165+
run $ modifyMVar_ v (pure . applyFun f)
166+
isInWHNF v
167+
168+
prop_modifyMVar ::
169+
(MonadMVar m, Typeable a)
170+
=> Proxy a
171+
-> Proxy b
172+
-> a
173+
-> Fun a (a, b)
174+
-> PropertyM m Bool
175+
prop_modifyMVar _ _ x f =do
176+
v <- run $ newMVar x
177+
void $ run $ modifyMVar v (pure . applyFun f)
178+
isInWHNF v
179+
180+
prop_modifyMVarMasked_ ::
181+
(MonadMVar m, Typeable a)
182+
=> Proxy a
183+
-> a
184+
-> Fun a a
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
190+
191+
prop_modifyMVarMasked ::
192+
(MonadMVar m, Typeable a)
193+
=> Proxy a
194+
-> Proxy b
195+
-> a
196+
-> Fun a (a, b)
197+
-> PropertyM m Bool
198+
prop_modifyMVarMasked _ _ x f =do
199+
v <- run $ newMVar x
200+
void $ run $ modifyMVarMasked v (pure . applyFun f)
201+
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)