Skip to content

Commit 67cc826

Browse files
jonathanknowlesjonathanknowles
authored
Use unified key type in test suite. (#241)
2 parents 6484e11 + 43c45f3 commit 67cc826

File tree

4 files changed

+75
-31
lines changed

4 files changed

+75
-31
lines changed

‎components/monoidmap-test/Data/MonoidMap/ClassSpec.hs‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,8 @@ import Test.Combinators.NonZero
2626
import Test.Common ()
2727
import Test.Hspec
2828
( Spec, describe )
29+
import Test.Key
30+
( Key1, Key2, Key4, Key8 )
2931
import Test.QuickCheck
3032
( Arbitrary (..) )
3133
import Test.QuickCheck.Classes
@@ -68,12 +70,11 @@ import Test.QuickCheck.Classes.Semigroup.Cancellative
6870
spec :: Spec
6971
spec = do
7072
describe "Class laws" $ do
71-
-- Test against a variety of key types, in ascending order of
72-
-- cardinality:
73-
specLawsFor (Proxy @Bool)
74-
specLawsFor (Proxy @Ordering)
75-
specLawsFor (Proxy @Int)
76-
specLawsFor (Proxy @Integer)
73+
-- Test against a variety of key sizes:
74+
specLawsFor (Proxy @Key1)
75+
specLawsFor (Proxy @Key2)
76+
specLawsFor (Proxy @Key4)
77+
specLawsFor (Proxy @Key8)
7778

7879
specLawsFor
7980
:: forall k. () =>

‎components/monoidmap-test/Test/Common.hs‎

Lines changed: 16 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,8 @@ import Numeric.Natural
6262
( Natural )
6363
import Test.Hspec
6464
( Spec, describe )
65+
import Test.Key
66+
( Key2, Key4 )
6567
import Test.QuickCheck
6668
( Arbitrary (..)
6769
, CoArbitrary (..)
@@ -70,7 +72,6 @@ import Test.QuickCheck
7072
, Testable
7173
, arbitrarySizedIntegral
7274
, checkCoverage
73-
, choose
7475
, coarbitraryIntegral
7576
, coarbitraryShow
7677
, frequency
@@ -139,18 +140,8 @@ instance Function Text where
139140
-- Test keys
140141
--------------------------------------------------------------------------------
141142

142-
newtype Key = Key Int
143-
deriving (Enum, Eq, Integral, Num, Ord, Real, Show)
144-
145-
instance Arbitrary Key where
146-
arbitrary = Key <$> choose (0, 15)
147-
shrink (Key k) = Key <$> shrink k
148-
149-
instance CoArbitrary Key where
150-
coarbitrary = coarbitraryIntegral
151-
152-
instance Function Key where
153-
function = functionIntegral
143+
type SmallKey = Key2
144+
type Key = Key4
154145

155146
--------------------------------------------------------------------------------
156147
-- Test constraints
@@ -198,14 +189,14 @@ testValueTypesAll =
198189
, TestValueType (Proxy @(Text))
199190
, TestValueType (Proxy @[Int])
200191
, TestValueType (Proxy @[Natural])
201-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Int)))
202-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
192+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Int)))
193+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
203194
]
204195

205196
testValueTypesGroup :: [TestValueType Group]
206197
testValueTypesGroup =
207198
[ TestValueType (Proxy @(Sum Int))
208-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Int)))
199+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Int)))
209200
]
210201

211202
testValueTypesMonus :: [TestValueType Monus]
@@ -214,7 +205,7 @@ testValueTypesMonus =
214205
, TestValueType (Proxy @(Set Int))
215206
, TestValueType (Proxy @(Set Natural))
216207
, TestValueType (Proxy @(Sum Natural))
217-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
208+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
218209
]
219210

220211
testValueTypesLeftReductive :: [TestValueType LeftReductive]
@@ -231,7 +222,7 @@ testValueTypesLeftReductive =
231222
, TestValueType (Proxy @(Text))
232223
, TestValueType (Proxy @[Int])
233224
, TestValueType (Proxy @[Natural])
234-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
225+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
235226
]
236227

237228
testValueTypesRightReductive :: [TestValueType RightReductive]
@@ -248,7 +239,7 @@ testValueTypesRightReductive =
248239
, TestValueType (Proxy @(Text))
249240
, TestValueType (Proxy @[Int])
250241
, TestValueType (Proxy @[Natural])
251-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
242+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
252243
]
253244

254245
testValueTypesReductive :: [TestValueType Reductive]
@@ -259,7 +250,7 @@ testValueTypesReductive =
259250
, TestValueType (Proxy @(Set Natural))
260251
, TestValueType (Proxy @(Sum Int))
261252
, TestValueType (Proxy @(Sum Natural))
262-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
253+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
263254
]
264255

265256
testValueTypesLeftGCDMonoid :: [TestValueType LeftGCDMonoid]
@@ -270,7 +261,7 @@ testValueTypesLeftGCDMonoid =
270261
, TestValueType (Proxy @(Set Natural))
271262
, TestValueType (Proxy @(Sum Natural))
272263
, TestValueType (Proxy @(Text))
273-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
264+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
274265
]
275266

276267
testValueTypesRightGCDMonoid :: [TestValueType RightGCDMonoid]
@@ -281,7 +272,7 @@ testValueTypesRightGCDMonoid =
281272
, TestValueType (Proxy @(Set Natural))
282273
, TestValueType (Proxy @(Sum Natural))
283274
, TestValueType (Proxy @(Text))
284-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
275+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
285276
]
286277

287278
testValueTypesOverlappingGCDMonoid :: [TestValueType OverlappingGCDMonoid]
@@ -292,7 +283,7 @@ testValueTypesOverlappingGCDMonoid =
292283
, TestValueType (Proxy @(Set Natural))
293284
, TestValueType (Proxy @(Sum Natural))
294285
, TestValueType (Proxy @(Text))
295-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
286+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
296287
]
297288

298289
testValueTypesGCDMonoid :: [TestValueType GCDMonoid]
@@ -301,7 +292,7 @@ testValueTypesGCDMonoid =
301292
, TestValueType (Proxy @(Set Int))
302293
, TestValueType (Proxy @(Set Natural))
303294
, TestValueType (Proxy @(Sum Natural))
304-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
295+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
305296
]
306297

307298
testValueTypesLCMMonoid :: [TestValueType LCMMonoid]
@@ -310,7 +301,7 @@ testValueTypesLCMMonoid =
310301
, TestValueType (Proxy @(Set Int))
311302
, TestValueType (Proxy @(Set Natural))
312303
, TestValueType (Proxy @(Sum Natural))
313-
, TestValueType (Proxy @(MonoidMap Ordering (Sum Natural)))
304+
, TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural)))
314305
]
315306

316307
--------------------------------------------------------------------------------

‎components/monoidmap-test/Test/Key.hs‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
5+
-- |
6+
-- Copyright: © 2022–2025 Jonathan Knowles
7+
-- License: Apache-2.0
8+
--
9+
-- Quasi-unique keys.
10+
--
11+
module Test.Key
12+
( Key1
13+
, Key2
14+
, Key4
15+
, Key8
16+
)
17+
where
18+
19+
import Prelude
20+
21+
import GHC.Generics
22+
( Generic
23+
)
24+
import GHC.TypeLits
25+
( Nat
26+
)
27+
import Test.QuickCheck
28+
( Arbitrary
29+
, CoArbitrary
30+
, Function
31+
)
32+
import Test.QuickCheck.Quid
33+
( Latin (Latin)
34+
, Quid
35+
, Size (Size)
36+
)
37+
38+
newtype Key (size :: Nat) = Key (Latin Quid)
39+
deriving stock (Eq, Generic, Ord)
40+
deriving newtype (Read, Show)
41+
deriving (Arbitrary) via Size size Quid
42+
deriving (CoArbitrary) via Quid
43+
deriving anyclass (Function)
44+
45+
type Key1 = Key 1
46+
type Key2 = Key 2
47+
type Key4 = Key 4
48+
type Key8 = Key 8

‎monoidmap.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,8 @@ common dependency-quickcheck-groups
4242
build-depends:quickcheck-groups >= 0.0.0.0 && < 0.1
4343
common dependency-quickcheck-monoid-subclasses
4444
build-depends:quickcheck-monoid-subclasses >= 0.3.0.0 && < 0.4
45+
common dependency-quickcheck-quid
46+
build-depends:quickcheck-quid >= 0.0.1.7 && < 0.1
4547
common dependency-tasty-bench
4648
build-depends:tasty-bench >= 0.3.2 && < 0.5
4749
common dependency-tasty-hunit
@@ -165,6 +167,7 @@ test-suite monoidmap-test
165167
, dependency-quickcheck-classes
166168
, dependency-quickcheck-groups
167169
, dependency-quickcheck-monoid-subclasses
170+
, dependency-quickcheck-quid
168171
, dependency-text
169172
, extensions
170173
build-depends:
@@ -203,6 +206,7 @@ test-suite monoidmap-test
203206
Test.Common
204207
Test.QuickCheck.Classes.Hspec
205208
Test.Hspec.Unit
209+
Test.Key
206210
type:
207211
exitcode-stdio-1.0
208212
default-language:

0 commit comments

Comments
 (0)