Skip to content

Commit a250ac0

Browse files
jorisdraljorisdral
committed
Resolve PR comments: monomorphisation
1 parent cdb46f0 commit a250ac0

File tree

3 files changed

+64
-89
lines changed

3 files changed

+64
-89
lines changed

‎strict-mvar/strict-mvar.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -70,4 +70,4 @@ test-suite test
7070
-fno-ignore-asserts
7171

7272
if flag(testchecked)
73-
CPP-Options: -DCHECKED
73+
CPP-Options: -DTEST_CHECKED

‎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: 62 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,19 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE RankNTypes #-}
3-
{-# LANGUAGE TypeApplications #-}
1+
{-# LANGUAGE CPP #-}
42

53
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
64
{-# HLINT ignore "Use camelCase" #-}
75

6+
-- | Test whether functions on 'StrictMVar's correctly force values to WHNF
7+
-- before they are put inside the 'StrictMVar'.
88
module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF (tests) where
99

10-
#if CHECKED
10+
#if TEST_CHECKED
1111
import Control.Concurrent.Class.MonadMVar.Strict.Checked
1212
#else
1313
import Control.Concurrent.Class.MonadMVar.Strict
1414
#endif
1515
import Control.Monad (void)
16-
import Data.Typeable (Proxy (..), Typeable)
16+
import Data.Typeable (Typeable)
1717
import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks)
1818
import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run)
1919
import Test.Tasty (TestTree, testGroup)
@@ -26,7 +26,7 @@ import Test.Utils (monadicSim)
2626
-------------------------------------------------------------------------------}
2727

2828
name :: String
29-
#if CHECKED
29+
#if TEST_CHECKED
3030
name = "Strict.Checked"
3131
#else
3232
name = "Strict"
@@ -37,43 +37,43 @@ tests = testGroup ("Test.Control.Concurrent.Class.MonadMVar." <> name) [
3737
testGroup "WHNF" [
3838
testGroup "IO" [
3939
testProperty "prop_newMVar" $
40-
monadicIO .: prop_newMVar (Proxy @Int)
40+
monadicIO .: prop_newMVar
4141
, testProperty "prop_newMVarWithInvariant" $
42-
monadicIO .: prop_newMVarWithInvariant (Proxy @Int)
42+
monadicIO .: prop_newMVarWithInvariant
4343
, testProperty "prop_putMVar" $
44-
monadicIO .: prop_putMVar (Proxy @Int)
44+
monadicIO .: prop_putMVar
4545
, testProperty "prop_swapMVar" $
46-
monadicIO .: prop_swapMVar (Proxy @Int)
46+
monadicIO .: prop_swapMVar
4747
, testProperty "prop_tryPutMVar" $
48-
monadicIO .: prop_tryPutMVar (Proxy @Int)
48+
monadicIO .: prop_tryPutMVar
4949
, testProperty "prop_modifyMVar_" $
50-
monadicIO .: prop_modifyMVar_ (Proxy @Int)
50+
monadicIO .: prop_modifyMVar_
5151
, testProperty "prop_modifyMVar" $
52-
monadicIO .: prop_modifyMVar (Proxy @Int) (Proxy @Char)
52+
monadicIO .: prop_modifyMVar
5353
, testProperty "prop_modifyMVarMasked_" $
54-
monadicIO .: prop_modifyMVarMasked_ (Proxy @Int)
54+
monadicIO .: prop_modifyMVarMasked_
5555
, testProperty "prop_modifyMVarMasked" $
56-
monadicIO .: prop_modifyMVarMasked (Proxy @Int) (Proxy @Char)
56+
monadicIO .: prop_modifyMVarMasked
5757
]
5858
, testGroup "IOSim" [
5959
testProperty "prop_newMVar" $ \x f ->
60-
monadicSim $ prop_newMVar (Proxy @Int) x f
60+
monadicSim $ prop_newMVar x f
6161
, testProperty "prop_newMVarWithInvariant" $ \x f ->
62-
monadicSim $ prop_newMVarWithInvariant (Proxy @Int) x f
62+
monadicSim $ prop_newMVarWithInvariant x f
6363
, testProperty "prop_putMVar" $ \x f ->
64-
monadicSim $ prop_putMVar (Proxy @Int) x f
64+
monadicSim $ prop_putMVar x f
6565
, testProperty "prop_swapMVar" $ \x f ->
66-
monadicSim $ prop_swapMVar (Proxy @Int) x f
66+
monadicSim $ prop_swapMVar x f
6767
, testProperty "prop_tryPutMVar" $ \x f ->
68-
monadicSim $ prop_tryPutMVar (Proxy @Int) x f
68+
monadicSim $ prop_tryPutMVar x f
6969
, testProperty "prop_modifyMVar_" $ \x f ->
70-
monadicSim $ prop_modifyMVar_ (Proxy @Int) x f
70+
monadicSim $ prop_modifyMVar_ x f
7171
, testProperty "prop_modifyMVar" $ \x f ->
72-
monadicSim $ prop_modifyMVar (Proxy @Int) (Proxy @Char) x f
72+
monadicSim $ prop_modifyMVar x f
7373
, testProperty "prop_modifyMVarMasked_" $ \x f ->
74-
monadicSim $ prop_modifyMVarMasked_ (Proxy @Int) x f
74+
monadicSim $ prop_modifyMVarMasked_ x f
7575
, testProperty "prop_modifyMVarMasked" $ \x f ->
76-
monadicSim $ prop_modifyMVarMasked (Proxy @Int) (Proxy @Char) x f
76+
monadicSim $ prop_modifyMVarMasked x f
7777
]
7878
]
7979
]
@@ -90,112 +90,100 @@ infixr 9 .:
9090
isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool
9191
isInWHNF v = do
9292
x <- run $ readMVar v
93-
let tinfoMay = unsafeNoThunks (OnlyCheckWhnf x)
94-
case tinfoMay of
93+
case unsafeNoThunks (OnlyCheckWhnf x) of
9594
Nothing -> pure True
96-
Just tinfo -> monitor (counterexample $ "Thunk found: " ++ show tinfo)
95+
Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)
9796
>> pure False
9897

9998
{-------------------------------------------------------------------------------
10099
Properties
101100
-------------------------------------------------------------------------------}
102101

103102
prop_newMVar ::
104-
(MonadMVar m, Typeable a)
105-
=> proxy a
106-
-> a
107-
-> Fun a a
103+
MonadMVar m
104+
=> Int
105+
-> Fun Int Int
108106
-> PropertyM m Bool
109-
prop_newMVar _ x f = do
107+
prop_newMVar x f = do
110108
v <- run $ newMVar (applyFun f x)
111109
isInWHNF v
112110

113111
prop_newMVarWithInvariant ::
114-
(MonadMVar m, Typeable a)
115-
=> proxy a
116-
-> a
117-
-> Fun a a
112+
MonadMVar m
113+
=> Int
114+
-> Fun Int Int
118115
-> PropertyM m Bool
119-
prop_newMVarWithInvariant _ x f = do
116+
prop_newMVarWithInvariant x f = do
120117
v <- run $ newMVarWithInvariant (const Nothing) (applyFun f x)
121118
isInWHNF v
122119

123120
prop_putMVar ::
124-
(MonadMVar m, Typeable a)
125-
=> proxy a
126-
-> a
127-
-> Fun a a
121+
MonadMVar m
122+
=> Int
123+
-> Fun Int Int
128124
-> PropertyM m Bool
129-
prop_putMVar _ x f = do
125+
prop_putMVar x f = do
130126
v <- run newEmptyMVar
131127
run $ putMVar v (applyFun f x)
132128
isInWHNF v
133129

134130
prop_swapMVar ::
135-
(MonadMVar m, Typeable a)
136-
=> proxy a
137-
-> a
138-
-> Fun a a
131+
MonadMVar m
132+
=> Int
133+
-> Fun Int Int
139134
-> PropertyM m Bool
140-
prop_swapMVar _ x f = do
135+
prop_swapMVar x f = do
141136
v <- run $ newMVar x
142137
void $ run $ swapMVar v (applyFun f x)
143138
isInWHNF v
144139

145140
prop_tryPutMVar ::
146-
(MonadMVar m, Typeable a)
147-
=> proxy a
148-
-> a
149-
-> Fun a a
141+
MonadMVar m
142+
=> Int
143+
-> Fun Int Int
150144
-> PropertyM m Bool
151-
prop_tryPutMVar _ x f = do
145+
prop_tryPutMVar x f = do
152146
v <- run newEmptyMVar
153147
b <- run $ tryPutMVar v (applyFun f x)
154148
b' <- isInWHNF v
155149
pure (b && b')
156150

157151
prop_modifyMVar_ ::
158-
(MonadMVar m, Typeable a)
159-
=> Proxy a
160-
-> a
161-
-> Fun a a
152+
MonadMVar m
153+
=> Int
154+
-> Fun Int Int
162155
-> PropertyM m Bool
163-
prop_modifyMVar_ _ x f =do
156+
prop_modifyMVar_ x f =do
164157
v <- run $ newMVar x
165158
run $ modifyMVar_ v (pure . applyFun f)
166159
isInWHNF v
167160

168161
prop_modifyMVar ::
169-
(MonadMVar m, Typeable a)
170-
=> Proxy a
171-
-> Proxy b
172-
-> a
173-
-> Fun a (a, b)
162+
MonadMVar m
163+
=> Int
164+
-> Fun Int (Int, Char)
174165
-> PropertyM m Bool
175-
prop_modifyMVar _ _ x f =do
166+
prop_modifyMVar x f =do
176167
v <- run $ newMVar x
177168
void $ run $ modifyMVar v (pure . applyFun f)
178169
isInWHNF v
179170

180171
prop_modifyMVarMasked_ ::
181-
(MonadMVar m, Typeable a)
182-
=> Proxy a
183-
-> a
184-
-> Fun a a
172+
MonadMVar m
173+
=> Int
174+
-> Fun Int Int
185175
-> PropertyM m Bool
186-
prop_modifyMVarMasked_ _ x f =do
176+
prop_modifyMVarMasked_ x f =do
187177
v <- run $ newMVar x
188178
void $ run $ modifyMVarMasked_ v (pure . applyFun f)
189179
isInWHNF v
190180

191181
prop_modifyMVarMasked ::
192-
(MonadMVar m, Typeable a)
193-
=> Proxy a
194-
-> Proxy b
195-
-> a
196-
-> Fun a (a, b)
182+
MonadMVar m
183+
=> Int
184+
-> Fun Int (Int, Char)
197185
-> PropertyM m Bool
198-
prop_modifyMVarMasked _ _ x f =do
186+
prop_modifyMVarMasked x f =do
199187
v <- run $ newMVar x
200188
void $ run $ modifyMVarMasked v (pure . applyFun f)
201189
isInWHNF v

0 commit comments

Comments
 (0)