add tests for Arbitrary (Large)RawBytes

Author: mheinzel

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

@@ -489,6 +489,7 @@ deriving newtype instance Arbitrary SerialisedBlob
 
 newtype LargeRawBytes = LargeRawBytes RawBytes
   deriving stock Show
+  deriving newtype NFData
 
 instance Arbitrary LargeRawBytes where
   arbitrary = genRawBytesSized (4096*3) >>= fmap LargeRawBytes . genSlice
@@ -501,6 +502,7 @@ instance Arbitrary LargeRawBytes where
    ++ [ LargeRawBytes (RawBytes pvec')
       | let (RawBytes pvec) = rb
       , n <- QC.shrink (VP.length pvec)
+      , assert (n >= 0) True  -- negative values would make pvec' longer
       , let pvec' = VP.take n pvec VP.++ VP.replicate (VP.length pvec - n) 0
       , assert (VP.length pvec' == VP.length pvec) $
         pvec' /= pvec

test/Test/Database/LSMTree/Generators.hs

@@ -19,6 +19,7 @@ import           Database.LSMTree.Internal.Entry
 import           Database.LSMTree.Internal.PageAcc (entryWouldFitInPage,
                      sizeofEntry)
 import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
+import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.Serialise
 
 import qualified Test.QuickCheck as QC
@@ -42,12 +43,16 @@ tests = testGroup "Test.Database.LSMTree.Generators" [
     , testGroup "Chunk size" $
         prop_arbitraryAndShrinkPreserveInvariant noTags
           chunkSizeInvariant
-    , testGroup "Raw bytes" $
+    , testGroup "RawBytes" $
         [ testProperty "packRawBytesPinnedOrUnpinned"
             prop_packRawBytesPinnedOrUnpinned
         ]
-     ++ prop_arbitraryAndShrinkPreserveInvariant noTags
+     ++ prop_arbitraryAndShrinkPreserveInvariant labelRawBytes
           (deepseqInvariant @RawBytes)
+    , testGroup "LargeRawBytes" $
+        prop_arbitraryAndShrinkPreserveInvariant
+          (\(LargeRawBytes rb) -> labelRawBytes rb)
+          (deepseqInvariant @LargeRawBytes)
     , testGroup "KeyForIndexCompact" $
         prop_arbitraryAndShrinkPreserveInvariant noTags $
           isKeyForIndexCompact . getKeyForIndexCompact
@@ -63,6 +68,10 @@ prop_packRawBytesPinnedOrUnpinned :: Bool -> [Word8] -> Bool
 prop_packRawBytesPinnedOrUnpinned pinned ws =
     packRawBytesPinnedOrUnpinned pinned ws == RawBytes (VP.fromList ws)
 
+labelRawBytes :: RawBytes -> Property -> Property
+labelRawBytes rb =
+    QC.tabulate "size" [showPowersOf 2 (RB.size rb)]
+
 type TestEntry = Entry SerialisedValue BlobSpan
 type TestKOp = (BiasedKeyForIndexCompact, TestEntry)