CAD-4652 Add property tests for DbChangelog combinators (#3824)

* Put transformed Gen constructors in Test.Util.QuickCheck * Add tests for DbChangelog
IntersectMBO · Dec 2, 2022 · 7e14ff1 · 7e14ff1
1 parent eaa1a27
commit 7e14ff1
Show file tree

Hide file tree

Showing 7 changed files with 479 additions and 26 deletions.
diff --git a/ouroboros-consensus-test/ouroboros-consensus-test.cabal b/ouroboros-consensus-test/ouroboros-consensus-test.cabal
@@ -241,6 +241,7 @@ test-suite test-storage
                        Test.Ouroboros.Storage.ImmutableDB.Primary
                        Test.Ouroboros.Storage.ImmutableDB.StateMachine
                        Test.Ouroboros.Storage.LedgerDB
+                       Test.Ouroboros.Storage.LedgerDB.DbChangelog
                        Test.Ouroboros.Storage.LedgerDB.DiskPolicy
                        Test.Ouroboros.Storage.LedgerDB.HD
                        Test.Ouroboros.Storage.LedgerDB.HD.LMDB

diff --git a/ouroboros-consensus-test/src/Test/Util/ChainUpdates.hs b/ouroboros-consensus-test/src/Test/Util/ChainUpdates.hs
@@ -15,6 +15,7 @@ module Test.Util.ChainUpdates (
 import           Control.Monad.State.Strict
 
 import           Test.QuickCheck
+import           Test.Util.QuickCheck (frequency')
 
 import           Ouroboros.Network.Mock.Chain (Chain (Genesis))
 import qualified Ouroboros.Network.Mock.Chain as Chain
@@ -163,17 +164,6 @@ genChainUpdateState updateBehavior securityParam n =
       genAddBlock Invalid
       genSwitchFork (pure 1)
 
--- | Variant of 'frequency' that allows for transformers of 'Gen'
-frequency' :: (MonadTrans t, Monad (t Gen)) => [(Int, t Gen a)] -> t Gen a
-frequency' [] = error "frequency' used with empty list"
-frequency' xs0 = lift (choose (1, tot)) >>= (`pick` xs0)
-  where
-    tot = sum (map fst xs0)
-
-    pick n ((k,x):xs)
-      | n <= k    = x
-      | otherwise = pick (n-k) xs
-    pick _ _  = error "pick used with empty list"
 
 -- | Test that applying the generated updates gives us the same chain
 -- as @cusCurrentChain@.

diff --git a/ouroboros-consensus-test/src/Test/Util/QuickCheck.hs b/ouroboros-consensus-test/src/Test/Util/QuickCheck.hs
@@ -12,10 +12,12 @@ module Test.Util.QuickCheck (
   , checkShrinker
     -- * Comparison functions
   , expectRight
+  , frequency'
   , ge
   , gt
   , le
   , lt
+  , oneof'
   , strictlyIncreasing
     -- * Comparing maps
   , isSubmapOfBy
@@ -194,3 +196,24 @@ shrinkNP g f np = npToSListI np $ cshrinkNP (Proxy @Top) g f np
 
 collects :: Show a => [a] -> Property -> Property
 collects = repeatedly collect
+
+
+{-------------------------------------------------------------------------------
+  Generator variants that allow for transformers
+-------------------------------------------------------------------------------}
+
+-- | Variant of 'frequency' that allows for transformers of 'Gen'
+frequency' :: (MonadTrans t, Monad (t Gen)) => [(Int, t Gen a)] -> t Gen a
+frequency' [] = error "frequency' used with empty list"
+frequency' xs0 = lift (choose (1, tot)) >>= (`pick` xs0)
+  where
+    tot = sum (map fst xs0)
+
+    pick n ((k,x):xs)
+      | n <= k    = x
+      | otherwise = pick (n-k) xs
+    pick _ _  = error "pick used with empty list"
+
+oneof' :: (MonadTrans t, Monad (t Gen)) => [t Gen a] -> t Gen a
+oneof' [] = error "QuickCheck.oneof used with empty list"
+oneof' gs = lift (chooseInt (0,length gs - 1)) >>= (gs !!)
diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB.hs
@@ -2,6 +2,7 @@ module Test.Ouroboros.Storage.LedgerDB (tests) where
 
 import           Test.Tasty
 
+import qualified Test.Ouroboros.Storage.LedgerDB.DbChangelog as DbChangelog
 import qualified Test.Ouroboros.Storage.LedgerDB.DiskPolicy as DiskPolicy
 import qualified Test.Ouroboros.Storage.LedgerDB.HD as HD
 import qualified Test.Ouroboros.Storage.LedgerDB.InMemory as InMemory
@@ -13,4 +14,5 @@ tests = testGroup "LedgerDB" [
     , InMemory.tests
     , OnDisk.tests
     , DiskPolicy.tests
+    , DbChangelog.tests
     ]