Merge pull request #645 from IntersectMBO/jdral/issue-580

Fix key generation for the compact index tests

Author: jorisdral

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

@@ -37,7 +37,6 @@ module Database.LSMTree.Extras.Generators (
   , isKeyForIndexCompact
   , KeyForIndexCompact (..)
   , BiasedKey (..)
-  , BiasedKeyForIndexCompact (..)
     -- * helpers
   , shrinkVec
   ) where
@@ -184,24 +183,24 @@ instance Arbitrary2 Entry where
 --
 -- Also useful for failing tests that have keys as inputs, because the printed
 -- 'WithSerialised' values will show both keys and their serialised form.
-data WithSerialised k = TestKey k SerialisedKey
+data WithSerialised k = WithSerialised k SerialisedKey
   deriving stock Show
 
 instance Eq k => Eq (WithSerialised k) where
-  TestKey k1 _ == TestKey k2 _ = k1 == k2
+  WithSerialised k1 _ == WithSerialised k2 _ = k1 == k2
 
 instance Ord k => Ord (WithSerialised k) where
-  TestKey k1 _ `compare` TestKey k2 _ = k1 `compare` k2
+  WithSerialised k1 _ `compare` WithSerialised k2 _ = k1 `compare` k2
 
 instance (Arbitrary k, SerialiseKey k) => Arbitrary (WithSerialised k) where
   arbitrary = do
     x <- arbitrary
-    pure $ TestKey x (serialiseKey x)
-  shrink (TestKey k _) = [TestKey k' (serialiseKey k') | k' <- shrink k]
+    pure $ WithSerialised x (serialiseKey x)
+  shrink (WithSerialised k _) = [WithSerialised k' (serialiseKey k') | k' <- shrink k]
 
 instance SerialiseKey k => SerialiseKey (WithSerialised k) where
-  serialiseKey (TestKey _ (SerialisedKey bytes)) = bytes
-  deserialiseKey bytes = TestKey (S.Class.deserialiseKey bytes) (SerialisedKey bytes)
+  serialiseKey (WithSerialised _ (SerialisedKey bytes)) = bytes
+  deserialiseKey bytes = WithSerialised (S.Class.deserialiseKey bytes) (SerialisedKey bytes)
 
 {-------------------------------------------------------------------------------
   Other number newtypes
@@ -256,9 +255,14 @@ toAppend (MultiPageOneKey k n)   = AppendMultiPage k n
 shrinkLogicalPageSummary :: Arbitrary k => LogicalPageSummary k -> [LogicalPageSummary k]
 shrinkLogicalPageSummary = \case
     OnePageOneKey k       -> OnePageOneKey <$> shrink k
-    OnePageManyKeys k1 k2 -> OnePageManyKeys <$> shrink k1 <*> shrink k2
-    MultiPageOneKey k n   -> [MultiPageOneKey k' n | k' <- shrink k]
-                          <> [MultiPageOneKey k n' | n' <- shrink n]
+    OnePageManyKeys k1 k2 -> [
+        OnePageManyKeys k1' k2'
+      | (k1', k2') <- shrink (k1, k2)
+      ]
+    MultiPageOneKey k n   -> [
+        MultiPageOneKey k' n'
+      | (k', n') <- shrink (k, n)
+      ]
 
 {-------------------------------------------------------------------------------
   Sequences of (logical\/true) pages
@@ -592,22 +596,6 @@ instance Arbitrary BiasedKey where
 
 deriving newtype instance SerialiseKey BiasedKey
 
-newtype BiasedKeyForIndexCompact =
-    BiasedKeyForIndexCompact { getBiasedKeyForIndexCompact :: RawBytes }
-  deriving stock (Eq, Ord, Show)
-  deriving newtype NFData
-
-instance Arbitrary BiasedKeyForIndexCompact where
-  arbitrary = arbitraryBiasedKey BiasedKeyForIndexCompact genKeyForIndexCompact
-
-  shrink (BiasedKeyForIndexCompact rb) =
-      [ BiasedKeyForIndexCompact rb'
-      | rb' <- shrink rb
-      , isKeyForIndexCompact rb'
-      ]
-
-deriving newtype instance SerialiseKey BiasedKeyForIndexCompact
-
 {-------------------------------------------------------------------------------
   Unsliced
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Internal/Index/Compact.hs

@@ -420,7 +420,7 @@ search k IndexCompact{..} =
                 bitIndexFromToRev (BoundInclusive 0) (BoundInclusive i) (Bit False) icClashes
               -- The TB map is consulted to find the closest key smaller than k.
               !i2 = maybe (PageNo 0) snd $
-                Map.lookupLE (unsafeNoAssertMakeUnslicedKey k) icTieBreaker
+                Map.lookupLE (makeUnslicedKey k) icTieBreaker
               -- If i2 < i1, then it means the clashing pages were all just part
               -- of the same larger-than-page value. Entries are only included
               -- in the TB map if the clash was a *proper* clash.

src/Database/LSMTree/Internal/Unsliced.hs

@@ -12,7 +12,6 @@ module Database.LSMTree.Internal.Unsliced (
   , makeUnslicedKey
   , unsafeMakeUnslicedKey
   , fromUnslicedKey
-  , unsafeNoAssertMakeUnslicedKey
   ) where
 
 import           Control.DeepSeq (NFData)
@@ -44,9 +43,6 @@ makeUnsliced bytes
 unsafeMakeUnsliced :: RawBytes -> Unsliced RawBytes
 unsafeMakeUnsliced bytes = assert (precondition bytes) (Unsliced (getByteArray bytes))
 
-unsafeNoAssertMakeUnsliced :: RawBytes -> Unsliced RawBytes
-unsafeNoAssertMakeUnsliced bytes = Unsliced (getByteArray bytes)
-
 fromUnsliced :: Unsliced RawBytes -> RawBytes
 fromUnsliced (Unsliced ba) = RawBytes (mkPrimVector 0 (sizeofByteArray ba) ba)
 
@@ -66,9 +62,6 @@ makeUnslicedKey (SerialisedKey rb) = from (makeUnsliced rb)
 unsafeMakeUnslicedKey :: SerialisedKey -> Unsliced SerialisedKey
 unsafeMakeUnslicedKey (SerialisedKey rb) = from (unsafeMakeUnsliced rb)
 
-unsafeNoAssertMakeUnslicedKey :: SerialisedKey -> Unsliced SerialisedKey
-unsafeNoAssertMakeUnslicedKey (SerialisedKey rb) = from (unsafeNoAssertMakeUnsliced rb)
-
 fromUnslicedKey :: Unsliced SerialisedKey -> SerialisedKey
 fromUnslicedKey x = SerialisedKey (fromUnsliced (to x))
 

test/Test/Database/LSMTree/Generators.hs

@@ -66,19 +66,10 @@ tests = testGroup "Test.Database.LSMTree.Generators" [
     , testGroup "KeyForIndexCompact" $
         prop_arbitraryAndShrinkPreserveInvariant noTags $
           isKeyForIndexCompact . getKeyForIndexCompact
-    , testGroup "BiasedKeyForIndexCompact" $
-        prop_arbitraryAndShrinkPreserveInvariant noTags $
-          isKeyForIndexCompact . getBiasedKeyForIndexCompact
-    , testGroup "lists of key/op pairs" $
-        [ testGroup "BiasedKey" $
-            prop_arbitraryAndShrinkPreserveInvariant
-              (labelTestKOps @BiasedKey)
-              deepseqInvariant
-        , testGroup "BiasedKeyForIndexCompact" $
-            prop_arbitraryAndShrinkPreserveInvariant
-              (labelTestKOps @BiasedKeyForIndexCompact)
-              deepseqInvariant
-        ]
+    , testGroup "BiasedKey" $
+          prop_arbitraryAndShrinkPreserveInvariant
+            (labelTestKOps @BiasedKey)
+            deepseqInvariant
     , testGroup "helpers"
         [ testProperty "prop_shrinkVec" $ \vec ->
             shrinkVec (QC.shrink @Int) vec === map VP.fromList (QC.shrink (VP.toList vec))

test/Test/Database/LSMTree/Internal/Index/Compact.hs

@@ -27,7 +27,9 @@ import qualified Data.Vector.Unboxed as VU
 import qualified Data.Vector.Unboxed.Base as VU
 import           Data.Word
 import           Database.LSMTree.Extras
-import           Database.LSMTree.Extras.Generators as Gen
+import           Database.LSMTree.Extras.Generators (ChunkSize (..),
+                     LogicalPageSummaries, LogicalPageSummary (..), Pages (..),
+                     genRawBytes, isKeyForIndexCompact, labelPages, toAppends)
 import           Database.LSMTree.Extras.Index (Append (..), appendToCompact)
 import           Database.LSMTree.Internal.BitMath
 import           Database.LSMTree.Internal.Chunk as Chunk (toByteString)
@@ -36,6 +38,8 @@ import           Database.LSMTree.Internal.Index.Compact
 import           Database.LSMTree.Internal.Index.CompactAcc
 import           Database.LSMTree.Internal.Page (PageNo (PageNo), PageSpan,
                      multiPage, singlePage)
+import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
+import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.Serialise
 import           Numeric (showHex)
 import           Prelude hiding (max, min, pi)
@@ -51,14 +55,16 @@ import           Text.Printf (printf)
 
 tests :: TestTree
 tests = testGroup "Test.Database.LSMTree.Internal.Index.Compact" [
-    testProperty "prop_distribution @BiasedKeyForIndexCompact" $
-      prop_distribution @BiasedKeyForIndexCompact
+    testGroup "TestKey" $
+      prop_arbitraryAndShrinkPreserveInvariant @TestKey noTags isTestKey
+  , testProperty "prop_distribution @TestKey" $
+      prop_distribution @TestKey
   , testProperty "prop_searchMinMaxKeysAfterConstruction" $
-      prop_searchMinMaxKeysAfterConstruction @BiasedKeyForIndexCompact 100
+      prop_searchMinMaxKeysAfterConstruction @TestKey 100
   , testProperty "prop_differentChunkSizesSameResults" $
-      prop_differentChunkSizesSameResults @BiasedKeyForIndexCompact
+      prop_differentChunkSizesSameResults @TestKey
   , testProperty "prop_singlesEquivMulti" $
-      prop_singlesEquivMulti @BiasedKeyForIndexCompact
+      prop_singlesEquivMulti @TestKey
   , testGroup "(De)serialisation" [
         testGroup "Chunks generator" $
           prop_arbitraryAndShrinkPreserveInvariant noTags chunksInvariant
@@ -119,14 +125,65 @@ tests = testGroup "Test.Database.LSMTree.Internal.Index.Compact" [
       , testProperty "prop_roundtrip_chunks" $
           prop_roundtrip_chunks
       , testProperty "prop_roundtrip" $
-          prop_roundtrip @BiasedKeyForIndexCompact
+          prop_roundtrip @TestKey
       , testProperty "prop_total_deserialisation" $ withMaxSuccess 10000
           prop_total_deserialisation
       , testProperty "prop_total_deserialisation_whitebox" $ withMaxSuccess 10000
           prop_total_deserialisation_whitebox
       ]
   ]
 
+{-------------------------------------------------------------------------------
+  Test key
+-------------------------------------------------------------------------------}
+
+-- | Key type for compact index tests
+--
+-- Tests outside this module don't have to worry about generating clashing keys.
+-- We can assume that the compact index handles clashes correctly, because we
+-- test this extensively in this module already.
+newtype TestKey = TestKey RawBytes
+  deriving stock (Show, Eq, Ord)
+  deriving newtype SerialiseKey
+
+-- | Generate keys with a non-neglible probability of clashes. This generates
+-- sliced keys too.
+--
+-- Note: recall that keys /clash/ only if their primary bits (first 8 bytes)
+-- match. It does not matter whether the other bytes do not match.
+instance Arbitrary TestKey where
+  arbitrary = do
+      -- Generate primary bits from a relatively small distribution. This
+      -- ensures that we get clashes between keys with a non-negligible
+      -- probability.
+      primBits <- do
+        lastPrefixByte <- QC.getSmall <$> arbitrary
+        pure $ RB.pack ([0,0,0,0,0,0,0] <> [lastPrefixByte])
+      -- The rest of the bits after the primary bits can be anything
+      restBits <- genRawBytes
+      -- The compact index should store keys without retaining unused memory.
+      -- Therefore, we generate slices of keys too.
+      prefix <- elements [RB.pack [], RB.pack [0]]
+      suffix <- elements [RB.pack [], RB.pack [0]]
+      -- Combine the bytes and make sure to take out only the slice we need.
+      let bytes = prefix <> primBits <> restBits <> suffix
+          n = RB.size primBits + RB.size restBits
+          bytes' = RB.take n $ RB.drop (RB.size prefix) bytes
+      pure $ TestKey bytes'
+
+  -- Shrink keys extensively: most failures will occur in small counterexamples,
+  -- so we don't have to limit the number of shrinks as much.
+  shrink (TestKey bytes) = [
+        TestKey bytes'
+      | let RawBytes vec = bytes
+      , vec' <- VP.fromList <$> shrink (VP.toList vec)
+      , let bytes' = RawBytes vec'
+      , isKeyForIndexCompact bytes'
+      ]
+
+isTestKey :: TestKey -> Bool
+isTestKey (TestKey bytes) = isKeyForIndexCompact bytes
+
 {-------------------------------------------------------------------------------
   Properties
 -------------------------------------------------------------------------------}
@@ -319,11 +376,15 @@ fromListSingles maxcsize apps = runST $ do
 
 labelIndex :: IndexCompact -> (Property -> Property)
 labelIndex ic =
-      QC.tabulate "# Clashes" [showPowersOf10 nclashes]
-    . QC.tabulate "# Contiguous clash runs" [showPowersOf10 (length nscontig)]
-    . QC.tabulate "Length of contiguous clash runs" (fmap (showPowersOf10 . snd) nscontig)
+      checkCoverage
+    . QC.tabulate "# Clashes" [showPowersOf 2 nclashes]
+    . QC.cover 60 (nclashes > 0) "Has clashes"
+    . QC.tabulate "# Contiguous clash runs" [showPowersOf 2 (length nscontig)]
+    . QC.cover 30 (not (null nscontig)) "Has contiguous clash runs"
+    . QC.tabulate "Length of contiguous clash runs" (fmap (showPowersOf 2 . snd) nscontig)
     . QC.tabulate "Contiguous clashes contain multi-page values" (fmap (show . fst) nscontig)
-    . QC.classify (multiPageValuesClash ic) "Has clashing multi-page values"
+    . QC.cover 3 (any fst nscontig) "Has contiguous clashes that contain multi-page values"
+    . QC.cover 0.1 (multiPageValuesClash ic) "Has clashing multi-page values"
   where nclashes       = countClashes ic
         nscontig       = countContiguousClashes ic