Skip to content

Commit 8fc9b97

Browse files
mheinzelmheinzel
committed
label shrinks in prop_arbitraryAndShrinkPreserveInvariant
Also allows adding your own labels to the invariant.
1 parent 9802630 commit 8fc9b97

File tree

5 files changed

+54
-41
lines changed

5 files changed

+54
-41
lines changed

‎src-extras/Database/LSMTree/Extras/Generators.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -533,6 +533,7 @@ deriving newtype instance SerialiseKey KeyForIndexCompact
533533
newtype BiasedKeyForIndexCompact =
534534
BiasedKeyForIndexCompact { getBiasedKeyForIndexCompact :: RawBytes }
535535
deriving stock (Eq, Ord, Show)
536+
deriving newtype NFData
536537

537538
instance Arbitrary BiasedKeyForIndexCompact where
538539
-- we try to make collisions and close keys more likely (very crudely)

‎test/Test/Database/LSMTree/Generators.hs‎

Lines changed: 27 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -30,29 +30,33 @@ import Test.Util.Arbitrary
3030
tests :: TestTree
3131
tests = testGroup "Test.Database.LSMTree.Generators" [
3232
testGroup "PageContentFits" $
33-
prop_arbitraryAndShrinkPreserveInvariant pageContentFitsInvariant
33+
prop_arbitraryAndShrinkPreserveInvariant noTags
34+
pageContentFitsInvariant
3435
, testGroup "PageContentOrdered" $
35-
prop_arbitraryAndShrinkPreserveInvariant pageContentOrderedInvariant
36+
prop_arbitraryAndShrinkPreserveInvariant noTags
37+
pageContentOrderedInvariant
3638
, localOption (QuickCheckMaxSize 20) $ -- takes too long!
3739
testGroup "LogicalPageSummaries" $
38-
prop_arbitraryAndShrinkPreserveInvariant (pagesInvariant @Word64)
40+
prop_arbitraryAndShrinkPreserveInvariant noTags $
41+
pagesInvariant @Word64
3942
, testGroup "Chunk size" $
40-
prop_arbitraryAndShrinkPreserveInvariant chunkSizeInvariant
43+
prop_arbitraryAndShrinkPreserveInvariant noTags
44+
chunkSizeInvariant
4145
, testGroup "Raw bytes" $
42-
[testProperty "packRawBytesPinnedOrUnpinned"
43-
prop_packRawBytesPinnedOrUnpinned
46+
[ testProperty "packRawBytesPinnedOrUnpinned"
47+
prop_packRawBytesPinnedOrUnpinned
4448
]
45-
++ prop_arbitraryAndShrinkPreserveInvariant (deepseqInvariant @RawBytes)
49+
++ prop_arbitraryAndShrinkPreserveInvariant noTags
50+
(deepseqInvariant @RawBytes)
4651
, testGroup "KeyForIndexCompact" $
47-
prop_arbitraryAndShrinkPreserveInvariant $
52+
prop_arbitraryAndShrinkPreserveInvariant noTags $
4853
isKeyForIndexCompact . getKeyForIndexCompact
4954
, testGroup "BiasedKeyForIndexCompact" $
50-
prop_arbitraryAndShrinkPreserveInvariant $
55+
prop_arbitraryAndShrinkPreserveInvariant noTags $
5156
isKeyForIndexCompact . getBiasedKeyForIndexCompact
5257
, testGroup "lists of key/op pairs" $
53-
[ testProperty "prop_distributionKOps" $
54-
prop_distributionKOps
55-
]
58+
prop_arbitraryAndShrinkPreserveInvariant labelTestKOps $
59+
deepseqInvariant
5660
]
5761

5862
prop_packRawBytesPinnedOrUnpinned :: Bool -> [Word8] -> Bool
@@ -62,18 +66,17 @@ prop_packRawBytesPinnedOrUnpinned pinned ws =
6266
type TestEntry = Entry SerialisedValue BlobSpan
6367
type TestKOp = (BiasedKeyForIndexCompact, TestEntry)
6468

65-
prop_distributionKOps :: [TestKOp] -> Property
66-
prop_distributionKOps kops' =
67-
QC.tabulate "key occurrences (>1 is collision)" (map (show . snd) (Map.assocs keyCounts)) $
68-
QC.tabulate "key sizes" (map (showPowersOf 4 . sizeofKey) keys) $
69-
QC.tabulate "value sizes" (map (showPowersOf 4 . sizeofValue) values) $
70-
QC.tabulate "k/op sizes" (map (showPowersOf 4 . uncurry sizeofEntry) kops) $
71-
QC.tabulate "k/op is large" (map (show . isLarge) kops) $
72-
QC.checkCoverage $
73-
QC.cover 50 (any isLarge kops) "any k/op is large" $
74-
QC.cover 1 (ratioUniqueKeys < (0.9 :: Double)) ">10% of keys collide" $
75-
QC.cover 5 (any (> 2) keyCounts) "has key with >2 collisions" $
76-
True
69+
labelTestKOps :: [TestKOp] -> Property -> Property
70+
labelTestKOps kops' =
71+
QC.tabulate "key occurrences (>1 is collision)" (map (show . snd) (Map.assocs keyCounts))
72+
. QC.tabulate "key sizes" (map (showPowersOf 4 . sizeofKey) keys)
73+
. QC.tabulate "value sizes" (map (showPowersOf 4 . sizeofValue) values)
74+
. QC.tabulate "k/op sizes" (map (showPowersOf 4 . uncurry sizeofEntry) kops)
75+
. QC.tabulate "k/op is large" (map (show . isLarge) kops)
76+
. QC.checkCoverage
77+
. QC.cover 50 (any isLarge kops) "any k/op is large"
78+
. QC.cover 1 (ratioUniqueKeys < (0.9 :: Double)) ">10% of keys collide"
79+
. QC.cover 5 (any (> 2) keyCounts) "has key with >2 collisions"
7780
where
7881
kops = coerce kops' :: [(SerialisedKey, Entry SerialisedValue BlobSpan)]
7982
keys = map fst kops

‎test/Test/Database/LSMTree/Internal/Lookup.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ import System.FS.BlockIO.API
7171
import Test.QuickCheck
7272
import Test.Tasty
7373
import Test.Tasty.QuickCheck
74-
import Test.Util.Arbitrary (deepseqInvariant,
74+
import Test.Util.Arbitrary (deepseqInvariant, noTags,
7575
prop_arbitraryAndShrinkPreserveInvariant,
7676
prop_forAllArbitraryAndShrinkPreserveInvariant)
7777
import Test.Util.FS (withTempIOHasBlockIO)
@@ -90,13 +90,14 @@ tests = testGroup "Test.Database.LSMTree.Internal.Lookup" [
9090
]
9191
, testGroup "With multi-page values" [
9292
testGroup "InMemLookupData" $
93-
prop_arbitraryAndShrinkPreserveInvariant (deepseqInvariant @(InMemLookupData SerialisedKey SerialisedValue BlobSpan))
93+
prop_arbitraryAndShrinkPreserveInvariant noTags $
94+
deepseqInvariant @(InMemLookupData SerialisedKey SerialisedValue BlobSpan)
9495
, localOption (QuickCheckMaxSize 1000) $
9596
testProperty "prop_inMemRunLookupAndConstruction" prop_inMemRunLookupAndConstruction
9697
]
9798
, testGroup "Without multi-page values" [
9899
testGroup "InMemLookupData" $
99-
prop_forAllArbitraryAndShrinkPreserveInvariant
100+
prop_forAllArbitraryAndShrinkPreserveInvariant noTags
100101
genNoMultiPage
101102
shrinkNoMultiPage
102103
(deepseqInvariant @(InMemLookupData SerialisedKey SerialisedValue BlobSpan))

‎test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec" [
4444
, testGroup "Generators and shrinkers are finite" $
4545
testAll $ \(p :: Proxy a) ->
4646
testGroup (show $ typeRep p) $
47-
prop_arbitraryAndShrinkPreserveInvariant @a deepseqInvariant
47+
prop_arbitraryAndShrinkPreserveInvariant @a noTags deepseqInvariant
4848
]
4949

5050
{-------------------------------------------------------------------------------

‎test/Test/Util/Arbitrary.hs‎

Lines changed: 21 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,34 +1,42 @@
1-
{-# LANGUAGE ScopedTypeVariables #-}
2-
{-# LANGUAGE TypeApplications #-}
3-
41
module Test.Util.Arbitrary (
52
prop_arbitraryAndShrinkPreserveInvariant
63
, prop_forAllArbitraryAndShrinkPreserveInvariant
74
, deepseqInvariant
5+
, noTags
86
) where
97

108
import Control.DeepSeq (NFData, deepseq)
9+
import Database.LSMTree.Extras (showPowersOf10)
1110
import Test.QuickCheck
1211
import Test.Tasty (TestTree)
1312
import Test.Tasty.QuickCheck (testProperty)
1413

1514
prop_arbitraryAndShrinkPreserveInvariant ::
16-
forall a. (Arbitrary a, Show a) => (a -> Bool) -> [TestTree]
17-
prop_arbitraryAndShrinkPreserveInvariant =
18-
prop_forAllArbitraryAndShrinkPreserveInvariant arbitrary shrink
15+
forall a prop. (Arbitrary a, Show a, Testable prop)
16+
=> (a -> Property -> Property) -> (a -> prop) -> [TestTree]
17+
prop_arbitraryAndShrinkPreserveInvariant tag =
18+
prop_forAllArbitraryAndShrinkPreserveInvariant tag arbitrary shrink
1919

2020
prop_forAllArbitraryAndShrinkPreserveInvariant ::
21-
forall a. Show a => Gen a -> (a -> [a]) -> (a -> Bool) -> [TestTree]
22-
prop_forAllArbitraryAndShrinkPreserveInvariant gen shr inv =
21+
forall a prop. (Show a, Testable prop)
22+
=> (a -> Property -> Property) -> Gen a -> (a -> [a]) -> (a -> prop) -> [TestTree]
23+
prop_forAllArbitraryAndShrinkPreserveInvariant tag gen shr inv =
2324
[ testProperty "Arbitrary satisfies invariant" $
24-
property $ forAllShrink gen shr inv
25+
forAllShrink gen shr $ \x ->
26+
tag x $ property $ inv x
2527
, testProperty "Shrinking satisfies invariant" $
26-
property $ forAll gen $ \x ->
27-
case shr x of
28-
[] -> label "no shrinks" $ property True
29-
xs -> forAll (growingElements xs) inv
28+
-- We don't use forallShrink here. If this property fails, it means that
29+
-- the shrinker is broken, so we don't want to rely on it.
30+
forAll gen $ \x ->
31+
case shr x of
32+
[] -> label "no shrinks" $ property True
33+
xs -> tabulate "number of shrinks" [showPowersOf10 (length xs)] $
34+
forAll (elements xs) inv -- TODO: check more than one?
3035
]
3136

3237
-- | Trivial invariant, but checks that the value is finite
3338
deepseqInvariant :: NFData a => a -> Bool
3439
deepseqInvariant x = x `deepseq` True
40+
41+
noTags :: a -> Property -> Property
42+
noTags _ = id

0 commit comments

Comments
 (0)