Refactor backing store tests to use quickcheck-lockstep.

IntersectMBO · Dec 2, 2022 · 7f6094a · 7f6094a
1 parent b273157
commit 7f6094a
Show file tree

Hide file tree

Showing 14 changed files with 1,510 additions and 1,046 deletions.
diff --git a/cabal.project b/cabal.project
@@ -143,5 +143,11 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/lmdb-simple
-  tag: 887528264349890550a755c0a2f242c227c8f8fe
-  --sha256: 1gaayzl1dbsrfdarxdnqqp1viixgj5nmw64c45g75xra35nc236r
+  tag: 955df18972b51da31609889028e15f268b14edf2
+  --sha256: 0f8lvw83z9pzx5v49243a64spsmflmd313fsvnc8mv89p9n3knyy
+
+source-repository-package
+  type: git
+  location: https://github.com/well-typed/quickcheck-lockstep
+  tag: c0143cee64ed882aeb63494da51b801b3febcc4d
+  --sha256: 178bgwhs0v4hf0nyrnrc0zr0jghbhhkmv9wb7rwirpnq0219vmdn
diff --git a/ouroboros-consensus-test/ouroboros-consensus-test.cabal b/ouroboros-consensus-test/ouroboros-consensus-test.cabal
@@ -242,6 +242,9 @@ test-suite test-storage
                        Test.Ouroboros.Storage.LedgerDB.DiskPolicy
                        Test.Ouroboros.Storage.LedgerDB.HD
                        Test.Ouroboros.Storage.LedgerDB.HD.BackingStore
+                       Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Registry
+                       Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Lockstep
+                       Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock
                        Test.Ouroboros.Storage.LedgerDB.HD.DiffSeq
                        Test.Ouroboros.Storage.LedgerDB.HD.LMDB
                        Test.Ouroboros.Storage.LedgerDB.InMemory
@@ -256,13 +259,15 @@ test-suite test-storage
 
   build-depends:       base
                      , async
+                     , anti-diff
                      , bifunctors
                      , binary
                      , bytestring
                      , cardano-binary
                      , cardano-crypto-class
                      , cardano-slotting
                      , cborg
+                     , constraints
                      , containers
                      , contra-tracer
                      , directory
@@ -274,6 +279,8 @@ test-suite test-storage
                      , nothunks
                      , pretty-show
                      , QuickCheck
+                     , quickcheck-dynamic
+                     , quickcheck-lockstep >=0.2.0
                      , quickcheck-state-machine >=0.7.0
                      , random
                      , serialise

diff --git a/ouroboros-consensus-test/src/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus-test/src/Test/Util/Orphans/ToExpr.hs
@@ -1,18 +1,14 @@
 {-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveAnyClass       #-}
-{-# LANGUAGE DerivingStrategies   #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE GADTs                #-}
 {-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Test.Util.Orphans.ToExpr () where
 
-import           Data.Foldable (toList)
-import           Data.TreeDiff (Expr (App), ToExpr (..), genericToExpr)
+import           Data.TreeDiff (ToExpr (..))
 
 import           Cardano.Slotting.Slot
 
@@ -24,7 +20,6 @@ import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Protocol.Abstract
-import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.DiffSeq as DS
 
 {-------------------------------------------------------------------------------
   ouroboros-network
@@ -42,57 +37,14 @@ instance (ToExpr slot, ToExpr hash) => ToExpr (Block slot hash)
   ouroboros-consensus
 -------------------------------------------------------------------------------}
 
-deriving anyclass instance ( ToExpr (ChainDepState (BlockProtocol blk))
-                           , ToExpr (TipInfo blk)
-                           , ToExpr (LedgerState blk mk)
-                           ) => ToExpr (ExtLedgerState blk mk)
+instance ( ToExpr (LedgerState blk EmptyMK)
+         , ToExpr (ChainDepState (BlockProtocol blk))
+         , ToExpr (TipInfo blk)
+         ) => ToExpr (ExtLedgerState blk EmptyMK)
 
 instance ( ToExpr (ChainDepState (BlockProtocol blk))
          , ToExpr (TipInfo blk)
          ) => ToExpr (HeaderState blk)
 
 instance ( ToExpr (TipInfo blk)
          ) => ToExpr (AnnTip blk)
-
-{-------------------------------------------------------------------------------
-  ouroboros-consensus: UTxO HD
--------------------------------------------------------------------------------}
-
-instance (ToExpr k, ToExpr v) => ToExpr (ApplyMapKind' mk' k v) where
-  toExpr ApplyEmptyMK =
-    App "ApplyEmptyMK"     []
-  toExpr (ApplyDiffMK diffs) =
-    App "ApplyDiffMK"      [genericToExpr diffs]
-  toExpr (ApplyKeysMK keys) =
-    App "ApplyKeysMK"      [genericToExpr keys]
-  toExpr (ApplySeqDiffMK (DS.UnsafeDiffSeq seqdiff)) =
-    App "ApplySeqDiffMK"   [genericToExpr $ toList seqdiff]
-  toExpr (ApplyTrackingMK vals diffs) =
-    App "ApplyTrackingMK"  [
-        genericToExpr vals
-      , genericToExpr diffs
-      ]
-  toExpr (ApplyValuesMK vals) =
-    App "ApplyValuesMK"    [genericToExpr vals]
-  toExpr ApplyQueryAllMK =
-    App "ApplyQueryAllMK"  []
-  toExpr (ApplyQuerySomeMK keys) =
-    App "ApplyQuerySomeMK" [genericToExpr keys]
-
-deriving anyclass instance ToExpr v => ToExpr (DS.DiffEntry v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Diff k v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Values k v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Keys k v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.RootMeasure k v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.InternalMeasure k v)
-deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Element k v)
-deriving anyclass instance ToExpr DS.Length
-deriving anyclass instance ToExpr DS.SlotNoUB
-deriving anyclass instance ToExpr DS.SlotNoLB
-
-instance ToExpr v => ToExpr (DS.DiffHistory v) where
-  toExpr h = App "DiffHistory" [genericToExpr . toList $ h]
-
-instance ToExpr v => ToExpr (DS.NEDiffHistory v) where
-  toExpr h = App "NEDiffHistory" [genericToExpr . toList $ h]
-