Merge pull request #497 from IntersectMBO/jdral/test-codec-generators-shrinkers

Test generators and shrinkers for snapshot metadata

Author: dcoutts

lsm-tree.cabal

@@ -384,6 +384,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.StateMachine.Op
     Test.Database.LSMTree.UnitTests
     Test.System.Posix.Fcntl.NoCache
+    Test.Util.Arbitrary
     Test.Util.FS
     Test.Util.Orphans
     Test.Util.PrettyProxy

src/Database/LSMTree/Internal/Merge.hs

@@ -15,6 +15,7 @@ module Database.LSMTree.Internal.Merge (
   , steps
   ) where
 
+import           Control.DeepSeq (NFData (..))
 import           Control.Exception (assert)
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadST (MonadST)
@@ -74,6 +75,10 @@ data MergeState =
 data Level = MidLevel | LastLevel
   deriving stock (Eq, Show)
 
+instance NFData Level where
+  rnf MidLevel  = ()
+  rnf LastLevel = ()
+
 type Mappend = SerialisedValue -> SerialisedValue -> SerialisedValue
 
 {-# SPECIALISE new ::

src/Database/LSMTree/Internal/MergeSchedule.hs

@@ -45,6 +45,7 @@ module Database.LSMTree.Internal.MergeSchedule (
   ) where
 
 import           Control.Concurrent.Class.MonadMVar.Strict
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (void, when, (<$!>))
 import           Control.Monad.Class.MonadST (MonadST)
 import           Control.Monad.Class.MonadSTM (MonadSTM (..))
@@ -399,6 +400,10 @@ duplicateMergingRunRuns reg (DeRef mr) =
 data MergePolicyForLevel = LevelTiering | LevelLevelling
   deriving stock (Show, Eq)
 
+instance NFData MergePolicyForLevel where
+  rnf LevelTiering   = ()
+  rnf LevelLevelling = ()
+
 mergePolicyForLevel :: MergePolicy -> LevelNo -> Levels m h -> MergePolicyForLevel
 mergePolicyForLevel MergePolicyLazyLevelling (LevelNo n) nextLevels
   | n == 1
@@ -409,6 +414,7 @@ mergePolicyForLevel MergePolicyLazyLevelling (LevelNo n) nextLevels
 
 newtype NumRuns = NumRuns { unNumRuns :: Int }
   deriving stock (Show, Eq)
+  deriving newtype NFData
 
 newtype UnspentCreditsVar s = UnspentCreditsVar { getUnspentCreditsVar :: PrimVar s Int }
 
@@ -430,6 +436,10 @@ newtype SpentCreditsVar s = SpentCreditsVar { getSpentCreditsVar :: PrimVar s In
 data MergeKnownCompleted = MergeKnownCompleted | MergeMaybeCompleted
   deriving stock (Show, Eq, Read)
 
+instance NFData MergeKnownCompleted where
+  rnf MergeKnownCompleted = ()
+  rnf MergeMaybeCompleted = ()
+
 {-# SPECIALISE duplicateLevels :: TempRegistry IO -> Levels IO h -> IO (Levels IO h) #-}
 duplicateLevels ::
      (PrimMonad m, MonadMVar m, MonadMask m)

src/Database/LSMTree/Internal/Snapshot.hs

@@ -24,6 +24,7 @@ module Database.LSMTree.Internal.Snapshot (
 
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM (MonadSTM)
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadST (MonadST)
 import           Control.Monad.Class.MonadThrow (MonadMask)
@@ -66,11 +67,17 @@ import           System.FS.BlockIO.API (HasBlockIO)
 -- is opened at the correct key\/value\/blob type.
 newtype SnapshotLabel = SnapshotLabel Text
   deriving stock (Show, Eq)
+  deriving newtype NFData
 
 -- TODO: revisit if we need three table types.
 data SnapshotTableType = SnapNormalTable | SnapMonoidalTable | SnapFullTable
   deriving stock (Show, Eq)
 
+instance NFData SnapshotTableType where
+  rnf SnapNormalTable   = ()
+  rnf SnapMonoidalTable = ()
+  rnf SnapFullTable     = ()
+
 data SnapshotMetaData = SnapshotMetaData {
     -- | See 'SnapshotLabel'.
     --
@@ -94,40 +101,58 @@ data SnapshotMetaData = SnapshotMetaData {
   }
   deriving stock (Show, Eq)
 
+instance NFData SnapshotMetaData where
+  rnf (SnapshotMetaData a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+
 {-------------------------------------------------------------------------------
   Levels snapshot format
 -------------------------------------------------------------------------------}
 
 newtype SnapLevels r = SnapLevels { getSnapLevels :: V.Vector (SnapLevel r) }
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
+  deriving newtype NFData
 
 data SnapLevel r = SnapLevel {
     snapIncoming     :: !(SnapIncomingRun r)
   , snapResidentRuns :: !(V.Vector r)
   }
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
 
+instance NFData r => NFData (SnapLevel r) where
+  rnf (SnapLevel a b) = rnf a `seq` rnf b
+
 data SnapIncomingRun r =
     SnapMergingRun !MergePolicyForLevel !NumRuns !NumEntries !UnspentCredits !MergeKnownCompleted !(SnapMergingRunState r)
   | SnapSingleRun !r
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
 
+instance NFData r => NFData (SnapIncomingRun r) where
+  rnf (SnapMergingRun a b c d e f) =
+      rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f
+  rnf (SnapSingleRun a) = rnf a
+
 -- | The total number of unspent credits. This total is used in combination with
 -- 'SpentCredits' on snapshot load to restore merging work that was lost when
 -- the snapshot was created.
 newtype UnspentCredits = UnspentCredits { getUnspentCredits :: Int }
   deriving stock (Show, Eq, Read)
+  deriving newtype NFData
 
 data SnapMergingRunState r =
     SnapCompletedMerge !r
   | SnapOngoingMerge !(V.Vector r) !SpentCredits !Merge.Level
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
 
+instance NFData r => NFData (SnapMergingRunState r) where
+  rnf (SnapCompletedMerge a)   = rnf a
+  rnf (SnapOngoingMerge a b c) = rnf a `seq` rnf b `seq` rnf c
+
 -- | The total number of spent credits. This total is used in combination with
 -- 'UnspentCedits' on snapshot load to restore merging work that was lost when
 -- the snapshot was created.
 newtype SpentCredits = SpentCredits { getSpentCredits :: Int }
   deriving stock (Show, Eq, Read)
+  deriving newtype NFData
 
 {-------------------------------------------------------------------------------
   Conversion to levels snapshot format

test/Test/Database/LSMTree/Generators.hs

@@ -3,12 +3,8 @@
 
 module Test.Database.LSMTree.Generators (
     tests
-  , prop_arbitraryAndShrinkPreserveInvariant
-  , prop_forAllArbitraryAndShrinkPreserveInvariant
-  , deepseqInvariant
   ) where
 
-import           Control.DeepSeq (NFData, deepseq)
 import           Data.Bifoldable (bifoldMap)
 import           Data.Coerce (coerce)
 import qualified Data.Map.Strict as Map
@@ -26,9 +22,10 @@ import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
 import           Database.LSMTree.Internal.Serialise
 
 import qualified Test.QuickCheck as QC
-import           Test.QuickCheck (Arbitrary (..), Gen, Property, Testable (..))
+import           Test.QuickCheck (Property)
 import           Test.Tasty (TestTree, localOption, testGroup)
 import           Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty)
+import           Test.Util.Arbitrary
 
 tests :: TestTree
 tests = testGroup "Test.Database.LSMTree.Generators" [
@@ -54,27 +51,6 @@ tests = testGroup "Test.Database.LSMTree.Generators" [
         ]
     ]
 
-prop_arbitraryAndShrinkPreserveInvariant ::
-    forall a. (Arbitrary a, Show a) => (a -> Bool) -> [TestTree]
-prop_arbitraryAndShrinkPreserveInvariant =
-    prop_forAllArbitraryAndShrinkPreserveInvariant arbitrary shrink
-
-prop_forAllArbitraryAndShrinkPreserveInvariant ::
-    forall a. Show a => Gen a -> (a -> [a]) -> (a -> Bool) -> [TestTree]
-prop_forAllArbitraryAndShrinkPreserveInvariant gen shr inv =
-    [ testProperty "Arbitrary satisfies invariant" $
-            property $ QC.forAllShrink gen shr inv
-    , testProperty "Shrinking satisfies invariant" $
-            property $ QC.forAll gen $ \x ->
-                         case shr x of
-                           [] -> QC.label "no shrinks" $ property True
-                           xs -> QC.forAll (QC.growingElements xs) inv
-    ]
-
--- | Trivial invariant, but checks that the value is finite
-deepseqInvariant :: NFData a => a -> Bool
-deepseqInvariant x = x `deepseq` True
-
 prop_packRawBytesPinnedOrUnpinned :: Bool -> [Word8] -> Bool
 prop_packRawBytesPinnedOrUnpinned pinned ws =
     packRawBytesPinnedOrUnpinned pinned ws == RawBytes (VP.fromList ws)

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

@@ -66,12 +66,12 @@ import qualified System.FS.API as FS
 import           System.FS.API (Handle (..), mkFsPath)
 import qualified System.FS.BlockIO.API as FS
 import           System.FS.BlockIO.API
-import           Test.Database.LSMTree.Generators (deepseqInvariant,
-                     prop_arbitraryAndShrinkPreserveInvariant,
-                     prop_forAllArbitraryAndShrinkPreserveInvariant)
 import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
+import           Test.Util.Arbitrary (deepseqInvariant,
+                     prop_arbitraryAndShrinkPreserveInvariant,
+                     prop_forAllArbitraryAndShrinkPreserveInvariant)
 import           Test.Util.FS (withTempIOHasBlockIO)
 
 tests :: TestTree

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

@@ -7,10 +7,12 @@ import           Codec.CBOR.Encoding
 import           Codec.CBOR.FlatTerm
 import           Codec.CBOR.Read
 import           Codec.CBOR.Write
+import           Control.DeepSeq (NFData)
 import qualified Data.ByteString.Lazy as BSL
 import           Data.Proxy
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import           Data.Typeable
 import qualified Data.Vector as V
 import           Database.LSMTree.Internal.Config
 import           Database.LSMTree.Internal.Entry
@@ -21,6 +23,7 @@ import           Database.LSMTree.Internal.Snapshot
 import           Database.LSMTree.Internal.Snapshot.Codec
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
+import           Test.Util.Arbitrary
 
 -- TODO: we should add golden tests for the CBOR encoders. This should prevent
 -- accidental breakage in the format.
@@ -34,45 +37,20 @@ tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec" [
           testProperty "roundtripCBOR" $ roundtripCBOR (Proxy @(Versioned SnapshotMetaData))
         , testProperty "roundtripFlatTerm" $ roundtripFlatTerm (Proxy @(Versioned SnapshotMetaData))
         ]
-    , testGroup "roundtripCBOR'" (propAll roundtripCBOR')
-    , testGroup "roundtripFlatTerm'" (propAll roundtripFlatTerm')
+     , testGroup "roundtripCBOR'" $
+        propAll roundtripCBOR'
+    , testGroup "roundtripFlatTerm'" $
+        propAll roundtripFlatTerm'
+      -- Test generators and shrinkers
+    , testGroup "Generators and shrinkers are finite" $
+        testAll $ \(p :: Proxy a) ->
+          testGroup (show $ typeRep p) $
+            prop_arbitraryAndShrinkPreserveInvariant @a deepseqInvariant
     ]
 
--- | Run a property on all types in the snapshot metadata hierarchy.
-propAll ::
-     (     forall a. (Encode a, DecodeVersioned a, Eq a, Show a)
-        => Proxy a -> a -> Property
-     )
-  -> [TestTree]
-propAll prop = [
-      -- SnapshotMetaData
-      testProperty "SnapshotMetaData" $ prop (Proxy @SnapshotMetaData)
-    , testProperty "SnapshotLabel" $ prop (Proxy @SnapshotLabel)
-    , testProperty "SnapshotTableType" $ prop (Proxy @SnapshotTableType)
-      -- TableConfig
-    , testProperty "TableConfig" $ prop (Proxy @TableConfig)
-    , testProperty "MergePolicy" $ prop (Proxy @MergePolicy)
-    , testProperty "SizeRatio" $ prop (Proxy @SizeRatio)
-    , testProperty "WriteBufferAlloc" $ prop (Proxy @WriteBufferAlloc)
-    , testProperty "NumEntries" $ prop (Proxy @NumEntries)
-    , testProperty "BloomFilterAlloc" $ prop (Proxy @BloomFilterAlloc)
-    , testProperty "FencePointerIndex" $ prop (Proxy @FencePointerIndex)
-    , testProperty "DiskCachePolicy" $ prop (Proxy @DiskCachePolicy)
-    , testProperty "MergeSchedule" $ prop (Proxy @MergeSchedule)
-      -- SnapLevels
-    , testProperty "SnapLevels" $ prop (Proxy @(SnapLevels RunNumber))
-    , testProperty "SnapLevel" $ prop (Proxy @(SnapLevel RunNumber))
-    , testProperty "Vector RunNumber" $ prop (Proxy @(V.Vector RunNumber))
-    , testProperty "RunNumber" $ prop (Proxy @RunNumber)
-    , testProperty "SnapIncomingRun" $ prop (Proxy @(SnapIncomingRun RunNumber))
-    , testProperty "NumRuns" $ prop (Proxy @NumRuns)
-    , testProperty "MergePolicyForLevel" $ prop (Proxy @MergePolicyForLevel)
-    , testProperty "UnspentCredits" $ prop (Proxy @UnspentCredits)
-    , testProperty "MergeKnownCompleted" $ prop (Proxy @MergeKnownCompleted)
-    , testProperty "SnapMergingRunState" $ prop (Proxy @(SnapMergingRunState RunNumber))
-    , testProperty "SpentCredits" $ prop (Proxy @SpentCredits)
-    , testProperty "Merge.Level" $ prop (Proxy @Merge.Level)
-    ]
+{-------------------------------------------------------------------------------
+  Properties
+-------------------------------------------------------------------------------}
 
 -- | @decode . encode = id@
 explicitRoundtripCBOR ::
@@ -148,6 +126,58 @@ roundtripFlatTerm' ::
   -> Property
 roundtripFlatTerm' _ = explicitRoundtripFlatTerm encode (decodeVersioned currentSnapshotVersion)
 
+{-------------------------------------------------------------------------------
+  Test and property runners
+-------------------------------------------------------------------------------}
+
+type Constraints a = (
+      Eq a, Show a, Typeable a, Arbitrary a
+    , Encode a, DecodeVersioned a, NFData a
+    )
+
+-- | Run a property on all types in the snapshot metadata hierarchy.
+propAll ::
+     (forall a. Constraints a => Proxy a -> a -> Property)
+  -> [TestTree]
+propAll prop = testAll mkTest
+  where
+    mkTest :: forall a. Constraints a => Proxy a -> TestTree
+    mkTest pa = testProperty (show $ typeRep pa) (prop pa)
+
+-- | Run a test on all types in the snapshot metadata hierarchy.
+testAll ::
+     (forall a. Constraints a => Proxy a -> TestTree)
+  -> [TestTree]
+testAll test = [
+      -- SnapshotMetaData
+      test (Proxy @SnapshotMetaData)
+    , test (Proxy @SnapshotLabel)
+    , test (Proxy @SnapshotTableType)
+      -- TableConfig
+    , test (Proxy @TableConfig)
+    , test (Proxy @MergePolicy)
+    , test (Proxy @SizeRatio)
+    , test (Proxy @WriteBufferAlloc)
+    , test (Proxy @NumEntries)
+    , test (Proxy @BloomFilterAlloc)
+    , test (Proxy @FencePointerIndex)
+    , test (Proxy @DiskCachePolicy)
+    , test (Proxy @MergeSchedule)
+      -- SnapLevels
+    , test (Proxy @(SnapLevels RunNumber))
+    , test (Proxy @(SnapLevel RunNumber))
+    , test (Proxy @(V.Vector RunNumber))
+    , test (Proxy @RunNumber)
+    , test (Proxy @(SnapIncomingRun RunNumber))
+    , test (Proxy @NumRuns)
+    , test (Proxy @MergePolicyForLevel)
+    , test (Proxy @UnspentCredits)
+    , test (Proxy @MergeKnownCompleted)
+    , test (Proxy @(SnapMergingRunState RunNumber))
+    , test (Proxy @SpentCredits)
+    , test (Proxy @Merge.Level)
+    ]
+
 {-------------------------------------------------------------------------------
   Arbitrary: versioning
 -------------------------------------------------------------------------------}

test/Test/Util/Arbitrary.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Test.Util.Arbitrary (
+    prop_arbitraryAndShrinkPreserveInvariant
+  , prop_forAllArbitraryAndShrinkPreserveInvariant
+  , deepseqInvariant
+  ) where
+
+import           Control.DeepSeq (NFData, deepseq)
+import           Test.QuickCheck
+import           Test.Tasty (TestTree)
+import           Test.Tasty.QuickCheck (testProperty)
+
+prop_arbitraryAndShrinkPreserveInvariant ::
+    forall a. (Arbitrary a, Show a) => (a -> Bool) -> [TestTree]
+prop_arbitraryAndShrinkPreserveInvariant =
+    prop_forAllArbitraryAndShrinkPreserveInvariant arbitrary shrink
+
+prop_forAllArbitraryAndShrinkPreserveInvariant ::
+    forall a. Show a => Gen a -> (a -> [a]) -> (a -> Bool) -> [TestTree]
+prop_forAllArbitraryAndShrinkPreserveInvariant gen shr inv =
+    [ testProperty "Arbitrary satisfies invariant" $
+            property $ forAllShrink gen shr inv
+    , testProperty "Shrinking satisfies invariant" $
+            property $ forAll gen $ \x ->
+                         case shr x of
+                           [] -> label "no shrinks" $ property True
+                           xs -> forAll (growingElements xs) inv
+    ]
+
+-- | Trivial invariant, but checks that the value is finite
+deepseqInvariant :: NFData a => a -> Bool
+deepseqInvariant x = x `deepseq` True