Skip to content

Commit 0c68554

Browse files
mheinzelmheinzel
authored
Merge pull request #604 from IntersectMBO/mheinzel/improve-generators-shrinkers
Improvements to generators and shrinkers
2 parents bcdb227 + 21c6a0c commit 0c68554

File tree

7 files changed

+113
-51
lines changed

7 files changed

+113
-51
lines changed

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

Lines changed: 42 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -37,14 +37,16 @@ module Database.LSMTree.Extras.Generators (
3737
, isKeyForIndexCompact
3838
, KeyForIndexCompact (..)
3939
, BiasedKeyForIndexCompact (..)
40+
-- * helpers
41+
, shrinkVec
4042
) where
4143

4244
import Control.DeepSeq (NFData)
4345
import Control.Exception (assert)
4446
import Data.Coerce (coerce)
4547
import Data.Containers.ListUtils (nubOrd)
4648
import Data.Function ((&))
47-
import Data.List (sort)
49+
import Data.List (nub, sort)
4850
import qualified Data.Primitive.ByteArray as BA
4951
import qualified Data.Vector.Primitive as VP
5052
import Data.Word
@@ -57,7 +59,8 @@ import Database.LSMTree.Internal.BlobRef (BlobSpan (..))
5759
import Database.LSMTree.Internal.Entry (Entry (..), NumEntries (..))
5860
import qualified Database.LSMTree.Internal.Merge as Merge
5961
import Database.LSMTree.Internal.Page (PageNo (..))
60-
import Database.LSMTree.Internal.RawBytes as RB
62+
import Database.LSMTree.Internal.RawBytes (RawBytes (RawBytes))
63+
import qualified Database.LSMTree.Internal.RawBytes as RB
6164
import Database.LSMTree.Internal.Serialise
6265
import qualified Database.LSMTree.Internal.Serialise.Class as S.Class
6366
import Database.LSMTree.Internal.Unsliced (Unsliced, fromUnslicedKey,
@@ -454,8 +457,33 @@ packRawBytesPinnedOrUnpinned True = \ws ->
454457
return mba
455458

456459
shrinkRawBytes :: RawBytes -> [RawBytes]
457-
shrinkRawBytes (RawBytes pvec) = [ RawBytes (VP.fromList ws)
458-
| ws <- QC.shrink (VP.toList pvec) ]
460+
shrinkRawBytes (RawBytes pvec) =
461+
[ RawBytes pvec'
462+
| pvec' <- shrinkVec shrinkByte pvec
463+
]
464+
where
465+
-- no need to try harder shrinking individual bytes
466+
shrinkByte b = nub (takeWhile (< b) [0, b `div` 2])
467+
468+
-- | Based on QuickCheck's 'shrinkList' (behaves identically, see tests).
469+
shrinkVec :: VP.Prim a => (a -> [a]) -> VP.Vector a -> [VP.Vector a]
470+
shrinkVec shr vec =
471+
concat [ removeBlockOf k | k <- takeWhile (> 0) (iterate (`div` 2) len) ]
472+
++ shrinkOne
473+
where
474+
len = VP.length vec
475+
476+
shrinkOne =
477+
[ vec VP.// [(i, x')]
478+
| i <- [0 .. len-1]
479+
, let x = vec VP.! i
480+
, x' <- shr x
481+
]
482+
483+
removeBlockOf k =
484+
[ VP.take i vec VP.++ VP.drop (i + k) vec
485+
| i <- [0, k .. len - k]
486+
]
459487

460488
genSlice :: RawBytes -> Gen RawBytes
461489
genSlice (RawBytes pvec) = do
@@ -465,10 +493,14 @@ genSlice (RawBytes pvec) = do
465493

466494
shrinkSlice :: RawBytes -> [RawBytes]
467495
shrinkSlice (RawBytes pvec) =
468-
[ RawBytes (VP.slice m n pvec)
469-
| n <- QC.shrink (VP.length pvec)
470-
, m <- QC.shrink (VP.length pvec - n)
496+
[ RawBytes (VP.take len' pvec)
497+
| len' <- QC.shrink len
498+
] ++
499+
[ RawBytes (VP.drop (len - len') pvec)
500+
| len' <- QC.shrink len
471501
]
502+
where
503+
len = VP.length pvec
472504

473505
deriving newtype instance Arbitrary SerialisedKey
474506

@@ -489,6 +521,7 @@ deriving newtype instance Arbitrary SerialisedBlob
489521

490522
newtype LargeRawBytes = LargeRawBytes RawBytes
491523
deriving stock Show
524+
deriving newtype NFData
492525

493526
instance Arbitrary LargeRawBytes where
494527
arbitrary = genRawBytesSized (4096*3) >>= fmap LargeRawBytes . genSlice
@@ -501,6 +534,7 @@ instance Arbitrary LargeRawBytes where
501534
++ [ LargeRawBytes (RawBytes pvec')
502535
| let (RawBytes pvec) = rb
503536
, n <- QC.shrink (VP.length pvec)
537+
, assert (n >= 0) True -- negative values would make pvec' longer
504538
, let pvec' = VP.take n pvec VP.++ VP.replicate (VP.length pvec - n) 0
505539
, assert (VP.length pvec' == VP.length pvec) $
506540
pvec' /= pvec
@@ -533,6 +567,7 @@ deriving newtype instance SerialiseKey KeyForIndexCompact
533567
newtype BiasedKeyForIndexCompact =
534568
BiasedKeyForIndexCompact { getBiasedKeyForIndexCompact :: RawBytes }
535569
deriving stock (Eq, Ord, Show)
570+
deriving newtype NFData
536571

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

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -184,14 +184,15 @@ simplePaths ns = fmap simplePath ns
184184
QuickCheck
185185
-------------------------------------------------------------------------------}
186186

187+
{- HLINT ignore "Hoist not" -}
187188
labelRunData :: SerialisedRunData -> Property -> Property
188189
labelRunData (RunData m) = tabulate "value size" size . label note
189190
where
190191
kops = Map.toList m
191192
size = map (showPowersOf10 . sizeofValue) vals
192193
vals = concatMap (bifoldMap pure mempty . snd) kops
193194
note
194-
| any (uncurry entryWouldFitInPage) kops = "has large k/op"
195+
| any (not . uncurry entryWouldFitInPage) kops = "has large k/op"
195196
| otherwise = "no large k/op"
196197

197198
instance ( Ord k, Arbitrary k, Arbitrary v, Arbitrary b

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

Lines changed: 42 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -19,61 +19,78 @@ import Database.LSMTree.Internal.Entry
1919
import Database.LSMTree.Internal.PageAcc (entryWouldFitInPage,
2020
sizeofEntry)
2121
import Database.LSMTree.Internal.RawBytes (RawBytes (..))
22+
import qualified Database.LSMTree.Internal.RawBytes as RB
2223
import Database.LSMTree.Internal.Serialise
2324

2425
import qualified Test.QuickCheck as QC
2526
import Test.QuickCheck (Property)
2627
import Test.Tasty (TestTree, localOption, testGroup)
27-
import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty)
28+
import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty,
29+
(===))
2830
import Test.Util.Arbitrary
2931

3032
tests :: TestTree
3133
tests = testGroup "Test.Database.LSMTree.Generators" [
3234
testGroup "PageContentFits" $
33-
prop_arbitraryAndShrinkPreserveInvariant pageContentFitsInvariant
35+
prop_arbitraryAndShrinkPreserveInvariant noTags
36+
pageContentFitsInvariant
3437
, testGroup "PageContentOrdered" $
35-
prop_arbitraryAndShrinkPreserveInvariant pageContentOrderedInvariant
38+
prop_arbitraryAndShrinkPreserveInvariant noTags
39+
pageContentOrderedInvariant
3640
, localOption (QuickCheckMaxSize 20) $ -- takes too long!
3741
testGroup "LogicalPageSummaries" $
38-
prop_arbitraryAndShrinkPreserveInvariant (pagesInvariant @Word64)
42+
prop_arbitraryAndShrinkPreserveInvariant noTags $
43+
pagesInvariant @Word64
3944
, testGroup "Chunk size" $
40-
prop_arbitraryAndShrinkPreserveInvariant chunkSizeInvariant
41-
, testGroup "Raw bytes" $
42-
[testProperty "packRawBytesPinnedOrUnpinned"
43-
prop_packRawBytesPinnedOrUnpinned
45+
prop_arbitraryAndShrinkPreserveInvariant noTags
46+
chunkSizeInvariant
47+
, testGroup "RawBytes" $
48+
[ testProperty "packRawBytesPinnedOrUnpinned"
49+
prop_packRawBytesPinnedOrUnpinned
4450
]
45-
++ prop_arbitraryAndShrinkPreserveInvariant (deepseqInvariant @RawBytes)
51+
++ prop_arbitraryAndShrinkPreserveInvariant labelRawBytes
52+
(deepseqInvariant @RawBytes)
53+
, testGroup "LargeRawBytes" $
54+
prop_arbitraryAndShrinkPreserveInvariant
55+
(\(LargeRawBytes rb) -> labelRawBytes rb)
56+
(deepseqInvariant @LargeRawBytes)
4657
, testGroup "KeyForIndexCompact" $
47-
prop_arbitraryAndShrinkPreserveInvariant $
58+
prop_arbitraryAndShrinkPreserveInvariant noTags $
4859
isKeyForIndexCompact . getKeyForIndexCompact
4960
, testGroup "BiasedKeyForIndexCompact" $
50-
prop_arbitraryAndShrinkPreserveInvariant $
61+
prop_arbitraryAndShrinkPreserveInvariant noTags $
5162
isKeyForIndexCompact . getBiasedKeyForIndexCompact
5263
, testGroup "lists of key/op pairs" $
53-
[ testProperty "prop_distributionKOps" $
54-
prop_distributionKOps
64+
prop_arbitraryAndShrinkPreserveInvariant labelTestKOps $
65+
deepseqInvariant
66+
, testGroup "helpers"
67+
[ testProperty "prop_shrinkVec" $ \vec ->
68+
shrinkVec (QC.shrink @Int) vec === map VP.fromList (QC.shrink (VP.toList vec))
5569
]
5670
]
5771

5872
prop_packRawBytesPinnedOrUnpinned :: Bool -> [Word8] -> Bool
5973
prop_packRawBytesPinnedOrUnpinned pinned ws =
6074
packRawBytesPinnedOrUnpinned pinned ws == RawBytes (VP.fromList ws)
6175

76+
labelRawBytes :: RawBytes -> Property -> Property
77+
labelRawBytes rb =
78+
QC.tabulate "size" [showPowersOf 2 (RB.size rb)]
79+
6280
type TestEntry = Entry SerialisedValue BlobSpan
6381
type TestKOp = (BiasedKeyForIndexCompact, TestEntry)
6482

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
83+
labelTestKOps :: [TestKOp] -> Property -> Property
84+
labelTestKOps kops' =
85+
QC.tabulate "key occurrences (>1 is collision)" (map (show . snd) (Map.assocs keyCounts))
86+
. QC.tabulate "key sizes" (map (showPowersOf 4 . sizeofKey) keys)
87+
. QC.tabulate "value sizes" (map (showPowersOf 4 . sizeofValue) values)
88+
. QC.tabulate "k/op sizes" (map (showPowersOf 4 . uncurry sizeofEntry) kops)
89+
. QC.tabulate "k/op is large" (map (show . isLarge) kops)
90+
. QC.checkCoverage
91+
. QC.cover 50 (any isLarge kops) "any k/op is large"
92+
. QC.cover 1 (ratioUniqueKeys < (0.9 :: Double)) ">10% of keys collide"
93+
. QC.cover 5 (any (> 2) keyCounts) "has key with >2 collisions"
7794
where
7895
kops = coerce kops' :: [(SerialisedKey, Entry SerialisedValue BlobSpan)]
7996
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/Merge.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,7 @@ prop_MergeDistributes fs hbio mergeType stepSize (SmallList rds) =
111111
rds' = fmap serialiseRunData rds
112112
kops = foldMap (Map.toList . unRunData) rds'
113113
vals = concatMap (bifoldMap pure mempty . snd) kops
114-
isLarge = uncurry entryWouldFitInPage
114+
isLarge = not . uncurry entryWouldFitInPage
115115

116116
getRunContent run@(DeRef Run.Run {
117117
Run.runFilter,

‎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)