diff --git a/flake.lock b/flake.lock
index 935bef76ea..ae03ac1ec2 100644
--- a/flake.lock
+++ b/flake.lock
@@ -237,11 +237,11 @@
     "hackageNix": {
       "flake": false,
       "locked": {
-        "lastModified": 1729643285,
-        "narHash": "sha256-2ukEfnphbVMpa6qJQ/h0O12e6wS9j+/w2mwE1YZQskI=",
+        "lastModified": 1733272207,
+        "narHash": "sha256-4gCU1d7x8dK3+5dmGVPZLf+DlLgIWDw2IWA8pKXn/yw=",
         "owner": "input-output-hk",
         "repo": "hackage.nix",
-        "rev": "e07df92046b89b0359d426c02848d96196ad60ec",
+        "rev": "1e119d9d07d2cced932cb00dbb389753783ef660",
         "type": "github"
       },
       "original": {
diff --git a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs
index 66d1ec176a..b93543492c 100644
--- a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs
+++ b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE LambdaCase    #-}
+{-# LANGUAGE LambdaCase #-}
 
 module DBAnalyser.Parsers (
     BlockType (..)
@@ -82,7 +82,7 @@ parseValidationPolicy =
         _                          -> Nothing
 
 parseAnalysis :: Parser AnalysisName
-parseAnalysis = asum [
+parseAnalysis = Foldable.asum [
       flag' ShowSlotBlockNo $ mconcat [
           long "show-slot-block-no"
         , help "Show slot and block number and hash of all blocks"
@@ -150,7 +150,7 @@ checkNoThunksParser = CheckNoThunksEvery <$> option auto
   <> help "Check the ledger state for thunks every n blocks" )
 
 parseLimit :: Parser Limit
-parseLimit = asum [
+parseLimit = Foldable.asum [
     Limit <$> option auto (mconcat [
         long "num-blocks-to-process"
       , help "Maximum number of blocks we want to process"
@@ -244,7 +244,7 @@ parseShelleyArgs = ShelleyBlockArgs
           , help "Path to config file"
           , metavar "PATH"
           ])
-    <*> asum [ Nonce  <$> parseNonce
+    <*> Foldable.asum [ Nonce  <$> parseNonce
              , pure NeutralNonce]
   where
     parseNonce = strOption (mconcat [
diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs
index 1e31f9c40e..f346ba8d5f 100644
--- a/ouroboros-consensus-cardano/app/snapshot-converter.hs
+++ b/ouroboros-consensus-cardano/app/snapshot-converter.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -159,20 +158,20 @@ load ::
     => Config
     -> CodecConfig blk
     -> IO (ExtLedgerState blk ValuesMK)
-load Config{from = Legacy, inpath = pathToFS -> (fs, inpath)} ccfg = do
-    checkSnapshot Legacy inpath fs
+load Config{from = Legacy, inpath = pathToFS -> (fs, path)} ccfg = do
+    checkSnapshot Legacy path fs
     eSt <- fmap unstowLedgerTables
-        <$> runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode inpath)
+        <$> runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode path)
     case eSt of
       Left err -> throwIO $ SnapshotError err
       Right st -> pure st
-load Config{from = Mem, inpath = pathToFS -> (fs@(SomeHasFS hasFS), inpath)} ccfg = do
-    checkSnapshot Mem inpath fs
-    eExtLedgerSt <- runExceptT $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (inpath </> mkFsPath ["state"])
+load Config{from = Mem, inpath = pathToFS -> (fs@(SomeHasFS hasFS), path)} ccfg = do
+    checkSnapshot Mem path fs
+    eExtLedgerSt <- runExceptT $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (path </> mkFsPath ["state"])
     case eExtLedgerSt of
       Left err -> throwIO $ SnapshotError err
       Right extLedgerSt -> do
-        values <- withFile hasFS (inpath </> mkFsPath ["tables", "tvar"]) ReadMode $ \h -> do
+        values <- withFile hasFS (path </> mkFsPath ["tables", "tvar"]) ReadMode $ \h -> do
             bs <- hGetAll hasFS h
             case CBOR.deserialiseFromBytes valuesMKDecoder bs of
                 Left err -> throwIO $ TablesCantDeserializeError err
@@ -181,14 +180,14 @@ load Config{from = Mem, inpath = pathToFS -> (fs@(SomeHasFS hasFS), inpath)} ccf
                             then pure x
                             else throwIO TablesTrailingBytes
         pure (extLedgerSt `withLedgerTables` values)
-load Config{from = LMDB, inpath = pathToFS -> (fs, inpath)} ccfg = do
-    checkSnapshot LMDB inpath fs
-    eExtLedgerSt <- runExceptT $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (inpath </> mkFsPath ["state"])
+load Config{from = LMDB, inpath = pathToFS -> (fs, path)} ccfg = do
+    checkSnapshot LMDB path fs
+    eExtLedgerSt <- runExceptT $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (path </> mkFsPath ["state"])
     case eExtLedgerSt of
       Left err -> throwIO $ SnapshotError err
       Right extLedgerSt -> do
         values <- do
-            dbEnv <- LMDB.openEnvironment (fsToFilePath (MountPoint ".") (inpath </> mkFsPath ["tables"])) defaultLMDBLimits
+            dbEnv <- LMDB.openEnvironment (fsToFilePath (MountPoint ".") (path </> mkFsPath ["tables"])) defaultLMDBLimits
             Disk.LMDBMK _ dbBackingTables <- LMDB.readWriteTransaction dbEnv (Disk.getDb (K2 "utxo"))
             catch (LMDB.readOnlyTransaction dbEnv $
                       LMDB.Cursor.runCursorAsTransaction'
@@ -209,26 +208,26 @@ store ::
     -> CodecConfig blk
     -> ExtLedgerState blk ValuesMK
     -> IO ()
-store Config{to = Legacy, outpath = pathToFS -> (fs, outpath)} ccfg state =
-    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) outpath (stowLedgerTables state)
-store Config{to = Mem, outpath = pathToFS -> (fs@(SomeHasFS hasFS), outpath)} ccfg state = do
+store Config{to = Legacy, outpath = pathToFS -> (fs, path)} ccfg state =
+    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) path (stowLedgerTables state)
+store Config{to = Mem, outpath = pathToFS -> (fs@(SomeHasFS hasFS), path)} ccfg state = do
     -- write state
-    createDirectoryIfMissing hasFS True outpath
-    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) (outpath </> mkFsPath ["state"]) (forgetLedgerTables state)
+    createDirectoryIfMissing hasFS True path
+    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) (path </> mkFsPath ["state"]) (forgetLedgerTables state)
     -- write tables
-    createDirectoryIfMissing hasFS True $ outpath </> mkFsPath ["tables"]
-    withFile hasFS (outpath </> mkFsPath ["tables", "tvar"]) (WriteMode MustBeNew) $ \hf ->
+    createDirectoryIfMissing hasFS True $ path </> mkFsPath ["tables"]
+    withFile hasFS (path </> mkFsPath ["tables", "tvar"]) (WriteMode MustBeNew) $ \hf ->
         void $
             hPutAll hasFS hf $
                 CBOR.toLazyByteString $
                     valuesMKEncoder (projectLedgerTables state)
-store Config{to = LMDB, outpath = pathToFS -> (fs@(SomeHasFS hasFS), outpath)} ccfg state = do
+store Config{to = LMDB, outpath = pathToFS -> (fs@(SomeHasFS hasFS), path)} ccfg state = do
     -- write state
-    createDirectoryIfMissing hasFS True outpath
-    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) (outpath </> mkFsPath ["state"]) (forgetLedgerTables state)
+    createDirectoryIfMissing hasFS True path
+    writeExtLedgerState fs (encodeDiskExtLedgerState ccfg) (path </> mkFsPath ["state"]) (forgetLedgerTables state)
     -- write tables
-    createDirectoryIfMissing hasFS True $ outpath </> mkFsPath ["tables"]
-    dbEnv <- LMDB.openEnvironment (fsToFilePath (MountPoint ".") $ outpath </> mkFsPath ["tables"]) defaultLMDBLimits
+    createDirectoryIfMissing hasFS True $ path </> mkFsPath ["tables"]
+    dbEnv <- LMDB.openEnvironment (fsToFilePath (MountPoint ".") $ path </> mkFsPath ["tables"]) defaultLMDBLimits
     dbState <- LMDB.readWriteTransaction dbEnv $ LMDB.getDatabase (Just "_dbstate")
     dbBackingTables <-
         LMDB.readWriteTransaction dbEnv $
diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
index 5f194e8497..a97e896c31 100644
--- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
+++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
@@ -163,6 +163,7 @@ library
     ouroboros-consensus-protocol ^>=0.9,
     ouroboros-network-api ^>=0.11,
     serialise ^>=0.2,
+    singletons ^>=3.0,
     small-steps,
     sop-core ^>=0.5,
     sop-extras ^>=0.2,
diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs
index b8d8842093..fe3439acd0 100644
--- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs
+++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs
@@ -19,6 +19,13 @@
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
+#if __GLASGOW_HASKELL__ <= 906
+{-# OPTIONS_GHC -Wno-incomplete-patterns
+                -Wno-incomplete-uni-patterns
+                -Wno-incomplete-record-updates
+                -Wno-overlapping-patterns #-}
+#endif
+
 module Ouroboros.Consensus.Cardano.Ledger (
     CardanoTxOut (..)
   , eliminateCardanoTxOut
diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs
index 0a921ef1f3..7b9b4bb4a5 100644
--- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs
+++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs
@@ -27,7 +27,7 @@
 module Ouroboros.Consensus.Cardano.QueryHF () where
 
 import           Data.Functor.Product
-import           Data.Proxy
+import           Data.Singletons
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
 import           Data.SOP.Index
@@ -54,10 +54,12 @@ newtype FlipBlockQuery footprint result x =
   FlipBlockQuery (BlockQuery x footprint result)
 
 answerCardanoQueryHF ::
-  ( xs ~ CardanoEras c
-  , CardanoHardForkConstraints c
-  , All (Compose NoThunks WrapTxOut) xs
-  )
+     forall x xs c footprint result m.
+     ( xs ~ CardanoEras c
+     , CardanoHardForkConstraints c
+     , All (Compose NoThunks WrapTxOut) xs
+     , SingI footprint
+     )
   => (   forall blk.
          IsShelleyBlock blk
       => Index xs blk
@@ -72,15 +74,18 @@ answerCardanoQueryHF ::
   -> ReadOnlyForker' m (HardForkBlock xs)
   -> m result
 answerCardanoQueryHF f idx cfg q dlv =
-  hcollapse $
-   hap
-   (   (Fn $ \(Pair _ (FlipBlockQuery q')) -> case q' of {})
-    :* hcmap
-         (Proxy @(IsShelleyBlock))
-         (\idx' -> Fn $ \(Pair cfg' (FlipBlockQuery q')) -> K $ f (IS idx') cfg' q' dlv)
-         indices
-   )
-   (injectNS idx (Pair cfg (FlipBlockQuery q)))
+  case sing :: Sing footprint of
+    SQFNoTables ->
+      error "answerCardanoQueryHF: unreachable, this was called with a QFNoTables query"
+    _ -> hcollapse $
+       hap
+       (   (Fn $ \(Pair _ (FlipBlockQuery q')) -> case q' of {})
+        :* hcmap
+             (Proxy @(IsShelleyBlock))
+             (\idx' -> Fn $ \(Pair cfg' (FlipBlockQuery q')) -> K $ f (IS idx') cfg' q' dlv)
+             indices
+       )
+       (injectNS idx (Pair cfg (FlipBlockQuery q)))
 
 shelleyCardanoFilter ::
      forall proto era c result.
@@ -111,11 +116,18 @@ instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras
 
   queryLedgerGetTraversingFilter idx q = case idx of
     -- Byron
-    IZ                             -> case q of {}
+    IZ                                    -> byronCardanoFilter q
     -- Shelley based
-    IS IZ                          -> shelleyCardanoFilter q
-    IS (IS IZ)                     -> shelleyCardanoFilter q
-    IS (IS (IS IZ))                -> shelleyCardanoFilter q
-    IS (IS (IS (IS IZ)))           -> shelleyCardanoFilter q
-    IS (IS (IS (IS (IS IZ))))      -> shelleyCardanoFilter q
-    IS (IS (IS (IS (IS (IS IZ))))) -> shelleyCardanoFilter q
+    IS IZ                                 -> shelleyCardanoFilter q
+    IS (IS IZ)                            -> shelleyCardanoFilter q
+    IS (IS (IS IZ))                       -> shelleyCardanoFilter q
+    IS (IS (IS (IS IZ)))                  -> shelleyCardanoFilter q
+    IS (IS (IS (IS (IS IZ))))             -> shelleyCardanoFilter q
+    IS (IS (IS (IS (IS (IS IZ)))))        -> shelleyCardanoFilter q
+    IS (IS (IS (IS (IS (IS (IS idx')))))) -> case idx' of {}
+
+byronCardanoFilter ::
+     BlockQuery ByronBlock QFTraverseTables result
+  -> TxOut (LedgerState (HardForkBlock (CardanoEras c)))
+  -> Bool
+byronCardanoFilter = \case {}
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
index 60bf842f74..9810cea5b9 100644
--- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
+++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -18,6 +19,12 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+#if __GLASGOW_HASKELL__ <= 906
+{-# OPTIONS_GHC -Wno-incomplete-patterns
+                -Wno-incomplete-uni-patterns
+                -Wno-incomplete-record-updates
+                -Wno-overlapping-patterns #-}
+#endif
 
 module Ouroboros.Consensus.Shelley.Ledger.Ledger (
     LedgerState (..)
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs
index eb6ce1563e..118d10b206 100644
--- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs
+++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -19,6 +20,12 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+#if __GLASGOW_HASKELL__ <= 906
+{-# OPTIONS_GHC -Wno-incomplete-patterns
+                -Wno-incomplete-uni-patterns
+                -Wno-incomplete-record-updates
+                -Wno-overlapping-patterns #-}
+#endif
 
 module Ouroboros.Consensus.Shelley.Ledger.Query (
     BlockQuery (..)
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs
index 93f4ed5809..17b085b6c8 100644
--- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs
+++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs
@@ -6,7 +6,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs
index 59a7a9d46d..b10a4cf9ae 100644
--- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs
+++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs
index 53ea1bf044..7d35dfd91a 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs
@@ -400,7 +400,7 @@ storeLedgerStateAt slotNo ledgerAppMode env = do
           when (blockSlot blk >= slotNo) $ storeLedgerState newLedger
           when (blockSlot blk > slotNo) $ issueWarning blk
           when ((unBlockNo $ blockNo blk) `mod` 1000 == 0) $ reportProgress blk
-          LedgerDB.reapplyThenPushNOW internal blk
+          LedgerDB.push internal newLedger
           LedgerDB.tryFlush initLedgerDB
           return (continue blk, ())
         Left err -> do
@@ -490,7 +490,7 @@ checkNoThunksEvery
         -- should catch any additional thunks in the values tables.
         IOLike.evaluate (ledgerState newLedger') >>= checkNoThunks bn
 
-      LedgerDB.reapplyThenPushNOW internal blk
+      LedgerDB.push internal newLedger
       LedgerDB.tryFlush ldb
 
 
@@ -515,18 +515,17 @@ traceLedgerProcessing ::
   Analysis blk StartFromLedgerState
 traceLedgerProcessing
   (AnalysisEnv {db, registry, startFrom, cfg, limit}) = do
-    void $ processAll db registry GetBlock startFrom limit () (process initLedger internal)
+    void $ processAll db registry GetBlock startFrom limit () (process initLedger)
     pure Nothing
   where
     FromLedgerState initLedger internal = startFrom
 
     process
       :: LedgerDB.LedgerDB' IO blk
-      -> LedgerDB.TestInternals' IO blk
       -> ()
       -> blk
       -> IO ()
-    process ledgerDB intLedgerDB _ blk = do
+    process ledgerDB _ blk = do
       frk <- LedgerDB.getForkerAtTarget ledgerDB registry VolatileTip >>= \case
         Left {} -> error "Unreachable, volatile tip MUST be in the LedgerDB"
         Right f -> pure f
@@ -544,7 +543,7 @@ traceLedgerProcessing
               HasAnalysis.WithLedgerState blk (ledgerState oldLedger) (ledgerState newLedger'))
       mapM_ Debug.traceMarkerIO traces
 
-      LedgerDB.reapplyThenPushNOW intLedgerDB blk
+      LedgerDB.push internal newLedger
       LedgerDB.tryFlush ledgerDB
 
 {-------------------------------------------------------------------------------
@@ -626,10 +625,10 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom,
         -- 'time' takes care of forcing the evaluation of its argument's result.
         (ldgrView, tForecast) <- time $ forecast            slot prevLedgerState
         (tkHdrSt,  tHdrTick)  <- time $ tickTheHeaderState  slot prevLedgerState ldgrView
-        (!_,   tHdrApp)       <- time $ applyTheHeader                           ldgrView tkHdrSt
+        (!newHeader,   tHdrApp)       <- time $ applyTheHeader                           ldgrView tkHdrSt
         (tkLdgrSt, tBlkTick)  <- time $ tickTheLedgerState  slot prevLedgerState
         let !tkLdgrSt' = applyDiffs (prevLedgerState `withLedgerTables` tables) tkLdgrSt
-        (!_,  tBlkApp)        <- time $ applyTheBlock                                     tkLdgrSt'
+        (!newLedger,  tBlkApp)        <- time $ applyTheBlock                                     tkLdgrSt'
 
         currentRtsStats <- GC.getRTSStats
         let
@@ -661,7 +660,7 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom,
 
         F.writeDataPoint outFileHandle outFormat slotDataPoint
 
-        LedgerDB.reapplyThenPushNOW intLedgerDB blk
+        LedgerDB.push intLedgerDB $ ExtLedgerState newLedger newHeader
         LedgerDB.tryFlush ledgerDB
       where
         rp = blockRealPoint blk
@@ -772,7 +771,7 @@ getBlockApplicationMetrics (NumberOfBlocks nrBlocks) mOutFile env = do
 
           IO.hFlush outFileHandle
 
-      LedgerDB.reapplyThenPushNOW intLedgerDB blk
+      LedgerDB.push intLedgerDB nextLedgerSt
       LedgerDB.tryFlush ledgerDB
 
       pure ()
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
index 0f09d01380..5f666ac9d6 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
@@ -106,13 +106,11 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
             V1InMem -> LedgerDB.LedgerDbFlavorArgsV1
                ( LedgerDB.V1.V1Args
                    LedgerDB.V1.DisableFlushing
-                   LedgerDB.V1.DisableQuerySize
                    LedgerDB.V1.InMemoryBackingStoreArgs
                )
             V1LMDB  -> LedgerDB.LedgerDbFlavorArgsV1
                ( LedgerDB.V1.V1Args
                    LedgerDB.V1.DisableFlushing
-                   LedgerDB.V1.DisableQuerySize
                    ( LedgerDB.V1.LMDBBackingStoreArgs
                        "lmdb"
                        defaultLMDBLimits
@@ -133,9 +131,23 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
               shfs
               flavargs $
             ChainDB.defaultArgs
-          chainDbArgs = maybeValidateAll $ ChainDB.updateTracer chainDBTracer args'
+          -- Set @k=1@ to reduce the memory usage of the LedgerDB. We only ever
+          -- go forward so we don't need to account for rollbacks.
+          args'' =
+            args' {
+              ChainDB.cdbLgrDbArgs =
+                (\x -> x {
+                    LedgerDB.lgrConfig =
+                      LedgerDB.LedgerDbCfg
+                        (SecurityParam 1)
+                        (LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig x)
+                    }
+                )
+                (ChainDB.cdbLgrDbArgs args')
+              }
+          chainDbArgs = maybeValidateAll $ ChainDB.updateTracer chainDBTracer args''
           immutableDbArgs = ChainDB.cdbImmDbArgs chainDbArgs
-          ldbArgs = ChainDB.cdbLgrDbArgs args'
+          ldbArgs = ChainDB.cdbLgrDbArgs args''
 
       withImmutableDB immutableDbArgs $ \(immutableDB, internal) -> do
         SomeAnalysis (Proxy :: Proxy startFrom) ana <- pure $ runAnalysis analysis
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
index 30abf0f45d..70ccf26e20 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
@@ -127,7 +127,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir
         let
             epochSize   = sgEpochLength confShelleyGenesis
             chunkInfo   = Node.nodeImmutableDbChunkInfo (configStorage pInfoConfig)
-            bss = LedgerDB.V1.V1Args LedgerDB.V1.DisableFlushing LedgerDB.V1.DisableQuerySize $ InMemoryBackingStoreArgs
+            bss = LedgerDB.V1.V1Args LedgerDB.V1.DisableFlushing InMemoryBackingStoreArgs
             flavargs = LedgerDB.LedgerDbFlavorArgsV1 bss
             dbArgs      =
              ChainDB.completeChainDbArgs
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs
index 95b2169865..08eb3c0cfa 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE BlockArguments            #-}
-{-# LANGUAGE DerivingStrategies        #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE NamedFieldPuns            #-}
-{-# LANGUAGE RankNTypes                #-}
-{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Consensus.Genesis.Setup (
     module Test.Consensus.Genesis.Setup.GenChains
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index f742724311..866aaff993 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -234,10 +234,11 @@ library
     Ouroboros.Consensus.Storage.ImmutableDB.Stream
     Ouroboros.Consensus.Storage.LedgerDB
     Ouroboros.Consensus.Storage.LedgerDB.API
-    Ouroboros.Consensus.Storage.LedgerDB.Forker
     Ouroboros.Consensus.Storage.LedgerDB.Args
-    Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
+    Ouroboros.Consensus.Storage.LedgerDB.Forker
     Ouroboros.Consensus.Storage.LedgerDB.Snapshots
+    Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
+    Ouroboros.Consensus.Storage.LedgerDB.V1
     Ouroboros.Consensus.Storage.LedgerDB.V1.Args
     Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
     Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
@@ -246,15 +247,14 @@ library
     Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge
     Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status
     Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
-    Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq
-    Ouroboros.Consensus.Storage.LedgerDB.V1
+    Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
     Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots
+    Ouroboros.Consensus.Storage.LedgerDB.V2
     Ouroboros.Consensus.Storage.LedgerDB.V2.Args
     Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
-    Ouroboros.Consensus.Storage.LedgerDB.V2
     Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
@@ -696,8 +696,7 @@ test-suite storage-test
     Test.Ouroboros.Storage.LedgerDB.V1.BackingStore
     Test.Ouroboros.Storage.LedgerDB.V1.BackingStore.Lockstep
     Test.Ouroboros.Storage.LedgerDB.V1.BackingStore.Mock
-    Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.QuickCheck
-    Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.Unit
+    Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog
     Test.Ouroboros.Storage.LedgerDB.V1.LMDB
     Test.Ouroboros.Storage.Orphans
     Test.Ouroboros.Storage.TestBlock
@@ -708,7 +707,6 @@ test-suite storage-test
 
   build-depends:
     QuickCheck,
-    async,
     base,
     bifunctors,
     binary,
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs
index 9965fd1c1d..a4723e708d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs
@@ -141,31 +141,6 @@ matchPolyTxsTele is ns = go
            -> Telescope g (Product f ([] :.: tx)) xs
     insert = hmap (\(Pair tx (Pair f (Comp txs))) -> Pair f (Comp (tx:txs)))
 
--- -- | Match a list of transactions with an 'NS', attempting to inject where
--- -- possible
--- matchPolyTxsNS ::
---      forall tx f xs. SListI xs
---   => InPairs (InjectPolyTx tx) xs
---   -> NS f xs
---   -> [NS tx xs]
---   -> ( [(NS tx xs, Mismatch tx f xs)]
---      , NS (Product f ([] :.: tx)) xs
---      )
--- matchPolyTxsNS is ns = go
---   where
---     go :: [NS tx xs]
---        -> ([(NS tx xs, Mismatch tx f xs)], NS (Product f ([] :.: tx)) xs)
---     go []       = ([], hmap (`Pair` Comp []) ns)
---     go (tx:txs) =
---       let (mismatched, matched) = go txs
---       in case matchPolyTxNS is tx matched of
---            Left  err      -> ((tx, hmap pairFst err) : mismatched, matched)
---            Right matched' -> (mismatched, insert matched')
-
---     insert :: NS (Product tx (Product f ([] :.: tx))) xs
---            -> NS (Product f ([] :.: tx)) xs
---     insert = hmap $ \(Pair tx (Pair f (Comp txs))) -> Pair f (Comp (tx:txs))
-
 {-------------------------------------------------------------------------------
   Monomorphic aliases
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs
index 5659d448a8..c42dc8475b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs
@@ -34,7 +34,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger (
   , AnnForecast (..)
   , mkHardForkForecast
     -- * Ledger tables
-  , distribLedgerTables
+  , ejectLedgerTables
   , injectLedgerTables
     -- ** HardForkTxIn
   , HasCanonicalTxIn (..)
@@ -889,7 +889,7 @@ instance ( CanHardFork xs
       withLedgerTablesOne i l =
           Flip
         $ withLedgerTables (unFlip l)
-        $ distribLedgerTables i tables
+        $ ejectLedgerTables i tables
 
 instance ( CanHardFork xs
          , HasCanonicalTxIn xs
@@ -940,7 +940,7 @@ instance ( CanHardFork xs
           FlipTickedLedgerState
         $ withLedgerTables (getFlipTickedLedgerState l)
         $ castLedgerTables
-        $ distribLedgerTables i (castLedgerTables tables)
+        $ ejectLedgerTables i (castLedgerTables tables)
 
 instance All (Compose CanStowLedgerTables LedgerState) xs
       => CanStowLedgerTables (LedgerState (HardForkBlock xs)) where
@@ -979,18 +979,9 @@ injectLedgerTables ::
   -> LedgerTables (LedgerState                x  ) mk
   -> LedgerTables (LedgerState (HardForkBlock xs)) mk
 injectLedgerTables idx =
-    LedgerTables
-  . mapKeysMK injTxIn
-  . mapMK injTxOut
-  . getLedgerTables
-  where
-    injTxIn :: TxIn (LedgerState x) -> TxIn (LedgerState (HardForkBlock xs))
-    injTxIn = injectCanonicalTxIn idx
-
-    injTxOut :: TxOut (LedgerState x) -> TxOut (LedgerState (HardForkBlock xs))
-    injTxOut = injectHardForkTxOut idx
+    bimapLedgerTables (injectCanonicalTxIn idx) (injectHardForkTxOut idx)
 
-distribLedgerTables ::
+ejectLedgerTables ::
      forall xs x mk. (
           CanMapKeysMK mk
         , Ord (TxIn (LedgerState x))
@@ -1001,11 +992,8 @@ distribLedgerTables ::
   => Index xs x
   -> LedgerTables (LedgerState (HardForkBlock xs)) mk
   -> LedgerTables (LedgerState                x  ) mk
-distribLedgerTables idx =
-    LedgerTables
-  . mapKeysMK (ejectCanonicalTxIn idx)
-  . mapMK (ejectHardForkTxOut idx)
-  . getLedgerTables
+ejectLedgerTables idx =
+    bimapLedgerTables (ejectCanonicalTxIn idx) (ejectHardForkTxOut idx)
 
 {-------------------------------------------------------------------------------
   HardForkTxIn
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs
index f956c64d54..9df40ec7c7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs
@@ -5,10 +5,12 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -25,7 +27,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Mempool (
   , hardForkApplyTxErrToEither
   ) where
 
-import           Control.Arrow ((+++))
+import           Control.Arrow (first, (+++))
 import           Control.Monad.Except
 import           Data.Functor.Product
 import           Data.Kind (Type)
@@ -108,10 +110,10 @@ type instance ApplyTxErr (HardForkBlock xs) = HardForkApplyTxErr xs
 --
 -- This is also isomorphic to
 -- @'Ouroboros.Consensus.Ledger.SupportsMempool.ReapplyTxsResult' (HardForkBlock xs)@
-type DecomposedReapplyTxsResult xs =
+type DecomposedReapplyTxsResult extra xs =
   (,,)
     [Invalidated (HardForkBlock xs)]
-    [Validated (GenTx (HardForkBlock xs))]
+    [(Validated (GenTx (HardForkBlock xs)), extra)]
   :.:
     FlipTickedLedgerState TrackingMK
 
@@ -131,6 +133,12 @@ instance ( CanHardFork xs
           (WrapValidatedGenTx vtx)
           tls
 
+  reapplyTxs :: forall extra.
+       LedgerConfig (HardForkBlock xs)
+    -> SlotNo -- ^ Slot number of the block containing the tx
+    -> [(Validated (GenTx (HardForkBlock xs)), extra)]
+    -> TickedLedgerState (HardForkBlock xs) ValuesMK
+    -> ReapplyTxsResult extra (HardForkBlock xs)
   reapplyTxs
     HardForkLedgerConfig{..}
     slot
@@ -155,9 +163,15 @@ instance ( CanHardFork xs
       (mismatched, matched) =
         matchPolyTxsTele
           -- How to translate txs to later eras
-          (InPairs.hmap snd2 (InPairs.requiringBoth cfgs hardForkInjectTxs))
+          (InPairs.hmap
+             (\(Pair2 _ (InjectPolyTx w)) -> InjectPolyTx (\(Comp (ex, tx)) -> Comp . (ex,) <$> w tx))
+             (InPairs.requiringBoth cfgs hardForkInjectTxs)
+          )
           (State.getHardForkState hardForkState)
-          (map (getOneEraValidatedGenTx . getHardForkValidatedGenTx) vtxs)
+          (map
+             (\(tx, extra) -> hmap (Comp . (extra,)) . getOneEraValidatedGenTx . getHardForkValidatedGenTx $ tx)
+             vtxs
+          )
 
       mismatched' :: [Invalidated (HardForkBlock xs)]
       mismatched' =
@@ -167,24 +181,25 @@ instance ( CanHardFork xs
                                     $ snd x)
                  . HardForkValidatedGenTx
                  . OneEraValidatedGenTx
+                 . hmap (snd . unComp)
                  . fst
                  $ x)
             mismatched
 
       modeApplyCurrent :: forall blk.
-           SingleEraBlock                      blk
-        => Index xs                            blk
-        -> WrapLedgerConfig                    blk
+           SingleEraBlock                              blk
+        => Index xs                                    blk
+        -> WrapLedgerConfig                            blk
         -> Product
              (FlipTickedLedgerState ValuesMK)
-             ([] :.: WrapValidatedGenTx)       blk
-        -> DecomposedReapplyTxsResult xs       blk
+             ([] :.: (,) extra :.: WrapValidatedGenTx) blk
+        -> DecomposedReapplyTxsResult extra xs         blk
       modeApplyCurrent index cfg (Pair (FlipTickedLedgerState st) txs) =
         let ReapplyTxsResult err val st' =
-              reapplyTxs (unwrapLedgerConfig cfg) slot [ unwrapValidatedGenTx t | t <- unComp txs ] st
+              reapplyTxs (unwrapLedgerConfig cfg) slot [ (unwrapValidatedGenTx tx, tk) | (Comp (tk,tx)) <- unComp txs ] st
         in Comp
            ( [ injectValidatedGenTx index (getInvalidated x) `Invalidated` injectApplyTxErr index (getReason x) | x <- err ]
-           , map (HardForkValidatedGenTx . OneEraValidatedGenTx . injectNS index . WrapValidatedGenTx) val
+           , map (first (HardForkValidatedGenTx . OneEraValidatedGenTx . injectNS index . WrapValidatedGenTx)) val
            , FlipTickedLedgerState st'
            )
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs
index 8ce1c05e63..bf282ba872 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs
@@ -192,12 +192,13 @@ newtype TranslateTxOut x y = TranslateTxOut (TxOut (LedgerState x) -> TxOut (Led
 -- translated to newer eras. This function fills that hole and allows us to
 -- promote tables from one era into tables from the next era.
 --
--- TODO(jdral): this is not optimal. If either 'translateTxInWith' or
--- 'translateTxOutWith' is a no-op ('id'), mapping over the diff with those
--- functions is also equivalent to a no-op. However, we are still traversing the
--- map in both cases. If necessary for performance reasons, this code could be
--- optimised to skip the 'Map.mapKeys' step and/or 'Map.map' step if
--- 'translateTxInWith' and/or 'translateTxOutWith' are no-ops.
+-- NOTE: If either 'translateTxInWith' or 'translateTxOutWith' is a no-op ('id'),
+-- mapping over the diff with those functions is also equivalent to a
+-- no-op. However, we are still traversing the map in both cases.
+--
+-- NOTE: This function is only used on ticking, to prepend differences from
+-- previous eras, so it will be called only when crossing era boundaries,
+-- therefore the translation won't be equivalent to 'id'.
 translateLedgerTablesWith ::
      Ord (TxIn (LedgerState y))
   => TranslateLedgerTables x y
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs
index a3e8e62d56..1e9af84a5c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs
@@ -141,12 +141,11 @@ class ( UpdateLedger blk
   -- in the same order as they were given, as we will use those later on to
   -- filter a list of 'TxTicket's.
   reapplyTxs ::
-       HasCallStack
-    => LedgerConfig blk
+       LedgerConfig blk
     -> SlotNo -- ^ Slot number of the block containing the tx
-    -> [Validated (GenTx blk)]
+    -> [(Validated (GenTx blk), extra)]
     -> TickedLedgerState blk ValuesMK
-    -> ReapplyTxsResult blk
+    -> ReapplyTxsResult extra blk
   reapplyTxs cfg slot txs st =
       (\(err, val, st') ->
          ReapplyTxsResult
@@ -154,10 +153,10 @@ class ( UpdateLedger blk
            (reverse val)
            st'
       )
-    $ Foldable.foldl' (\(accE, accV, st') tx ->
+    $ Foldable.foldl' (\(accE, accV, st') (tx, extra) ->
                  case runExcept (reapplyTx cfg slot tx $ trackingToValues st') of
                    Left err   -> (Invalidated tx err : accE, accV, st')
-                   Right st'' -> (accE, tx : accV, prependTrackingDiffs st' st'')
+                   Right st'' -> (accE, (tx, extra) : accV, prependTrackingDiffs st' st'')
              ) ([], [], attachEmptyDiffs st) txs
 
   -- | Discard the evidence that transaction has been previously validated
@@ -169,13 +168,13 @@ class ( UpdateLedger blk
   -- transaction size.
   getTransactionKeySets :: GenTx blk -> LedgerTables (LedgerState blk) KeysMK
 
-data ReapplyTxsResult blk =
+data ReapplyTxsResult extra blk =
   ReapplyTxsResult {
       -- | txs that are now invalid. Order doesn't matter
       invalidatedTxs :: ![Invalidated blk]
       -- | txs that are valid again, order must be the same as the order in
       -- which txs were received
-    , validatedTxs   :: ![Validated (GenTx blk)]
+    , validatedTxs   :: ![(Validated (GenTx blk), extra)]
       -- | Resulting ledger state
     , resultingState :: !(TickedLedgerState blk TrackingMK)
     }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Diff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Diff.hs
index a0c8984b3c..acc24cc516 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Diff.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Diff.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
 
 module Ouroboros.Consensus.Ledger.Tables.Diff (
     -- * Types
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs
index 243682d09a..c2116891f3 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
@@ -17,6 +18,7 @@ module Ouroboros.Consensus.Ledger.Tables.MapKind (
   , NoThunksMK
   , ShowMK
   , ZeroableMK (..)
+  , bimapLedgerTables
     -- * Concrete MapKinds
   , CodecMK (..)
   , DiffMK (..)
@@ -74,6 +76,27 @@ type NoThunksMK :: MapKind -> Constraint
 class (forall k v. (NoThunks k, NoThunks v) => NoThunks (mk k v))
    => NoThunksMK mk
 
+-- | Map both keys and values in ledger tables.
+--
+-- For keys, it has the same caveats as 'Data.Map.Strict.mapKeys' or
+-- `Data.Set.map', namely that only injective functions are suitable to be used
+-- here.
+bimapLedgerTables ::
+     forall x y mk. (
+          CanMapKeysMK mk
+        , CanMapMK mk
+        , Ord (TxIn y)
+        )
+  => (TxIn x -> TxIn y)
+  -> (TxOut x -> TxOut y)
+  -> LedgerTables x mk
+  -> LedgerTables y mk
+bimapLedgerTables f g =
+    LedgerTables
+  . mapKeysMK f
+  . mapMK g
+  . getLedgerTables
+
 {-------------------------------------------------------------------------------
   EmptyMK
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs
index 720c678689..2a7aa805fc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs
@@ -320,29 +320,20 @@ revalidateTxsFor
   -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))]
   -> RevalidateTxsResult blk
 revalidateTxsFor capacityOverride cfg slot st values lastTicketNo txTickets =
-  let theTxs = map txTicketTx txTickets
+  let theTxs = map wrap txTickets
+      wrap = (\(TxTicket tx tk tz) -> (tx, (tk, tz)))
+      unwrap = (\(tx, (tk, tz)) -> TxTicket tx tk tz)
       ReapplyTxsResult err val st' =
         reapplyTxs cfg slot theTxs
         $ applyDiffForKeysOnTables
               values
-              (Foldable.foldMap' (getTransactionKeySets . txForgetValidated) theTxs)
+              (Foldable.foldMap' (getTransactionKeySets . txForgetValidated . fst) theTxs)
               st
 
-      -- TODO: This is ugly, but I couldn't find a way to sneak the 'TxTicket' into
-      -- 'reapplyTxs'.
-      filterTxTickets _ [] = []
-      filterTxTickets (t1 : t1s) t2ss@(t2 : t2s)
-        | txId (txForgetValidated $ txTicketTx t1) == txId (txForgetValidated t2)
-        = t1 : filterTxTickets t1s t2s
-        | otherwise
-        = filterTxTickets t1s t2ss
-      filterTxTickets [] _ =
-        error "There are less transactions given to the revalidate function than transactions revalidated! This is unacceptable (and impossible)!"
-
   in RevalidateTxsResult
       (IS {
-         isTxs          = TxSeq.fromList $ filterTxTickets txTickets val
-       , isTxIds        = Set.fromList $ map (txId . txForgetValidated) val
+         isTxs          = TxSeq.fromList $ map unwrap val
+       , isTxIds        = Set.fromList $ map (txId . txForgetValidated . fst) val
        , isLedgerState  = trackingToDiffs st'
        , isTip          = castPoint $ getTip st
        , isSlotNo       = slot
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs
index da10f42018..3425af09d8 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 -- | Queries to the mempool
-module Ouroboros.Consensus.Mempool.Query (
-    implGetSnapshotFor
-  ) where
+module Ouroboros.Consensus.Mempool.Query (implGetSnapshotFor) where
 
 import qualified Data.Foldable as Foldable
 import           Ouroboros.Consensus.Block.Abstract
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
index ee42b2ed53..52ba4b08cc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
@@ -148,7 +148,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.API (
   ) where
 
 import           Codec.Serialise
-import           Control.Monad (forM, when)
+import qualified Control.Monad as Monad
 import           Control.Monad.Class.MonadTime.SI
 import           Control.Monad.Except
 import           Control.ResourceRegistry
@@ -287,6 +287,7 @@ data WhereToTakeSnapshot = TakeAtImmutableTip | TakeAtVolatileTip deriving Eq
 data TestInternals m l blk = TestInternals {
     wipeLedgerDB       :: m ()
   , takeSnapshotNOW    :: WhereToTakeSnapshot -> Maybe String -> m ()
+  , push               :: ExtLedgerState blk DiffMK -> m ()
   , reapplyThenPushNOW :: blk -> m ()
   , truncateSnapshots  :: m ()
   , closeLedgerDB      :: m ()
@@ -397,7 +398,7 @@ readLedgerTablesAtFor ldb p ks =
     bracketWithPrivateRegistry
       (\rr -> fmap readOnlyForker <$> getForkerAtTarget ldb rr (SpecificPoint p))
       (mapM_ roforkerClose)
-      $ \foEith -> forM foEith (`roforkerReadTables` ks)
+      $ \foEith -> Monad.forM foEith (`roforkerReadTables` ks)
 
 {-------------------------------------------------------------------------------
   Snapshots
@@ -544,7 +545,7 @@ initialize replayTracer
       eInitDb <- initFromSnapshot s
       case eInitDb of
         Left err -> do
-          when (diskSnapshotIsTemporary s || err == InitFailureGenesis) $
+          Monad.when (diskSnapshotIsTemporary s || err == InitFailureGenesis) $
             deleteSnapshot hasFS s
           traceWith snapTracer . InvalidSnapshot s $ err
           tryNewestFirst (acc . InitFailure s err) ss
@@ -563,7 +564,7 @@ initialize replayTracer
           case eDB of
             Left err -> do
               traceWith snapTracer . InvalidSnapshot s $ err
-              when (diskSnapshotIsTemporary s) $ deleteSnapshot hasFS s
+              Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot hasFS s
               closeDb initDb
               tryNewestFirst (acc . InitFailure s err) ss
             Right (db, replayed) -> do
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
index 06785aec9f..44d455fdc7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
@@ -1,8 +1,12 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
@@ -15,12 +19,17 @@
 module Ouroboros.Consensus.Storage.LedgerDB.Args (
     LedgerDbArgs (..)
   , LedgerDbFlavorArgs (..)
+  , QueryBatchSize (..)
   , defaultArgs
+  , defaultQueryBatchSize
   ) where
 
 import           Control.ResourceRegistry
 import           Control.Tracer
 import           Data.Kind
+import           Data.Word
+import           GHC.Generics (Generic)
+import           NoThunks.Class
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Storage.LedgerDB.API
@@ -49,6 +58,7 @@ data LedgerDbArgs f m blk = LedgerDbArgs {
     , lgrTracer             :: Tracer m (TraceEvent blk)
     , lgrFlavorArgs         :: LedgerDbFlavorArgs f m
     , lgrRegistry           :: HKD f (ResourceRegistry m)
+    , lgrQueryBatchSize     :: QueryBatchSize
       -- | If provided, the ledgerdb will start using said snapshot and fallback
       -- to genesis. It will ignore any other existing snapshots. Useful for
       -- db-analyser.
@@ -64,6 +74,7 @@ defaultArgs = LedgerDbArgs {
     , lgrGenesis            = NoDefault
     , lgrHasFS              = NoDefault
     , lgrConfig             = NoDefault
+    , lgrQueryBatchSize     = DefaultQueryBatchSize
     , lgrTracer             = nullTracer
       -- This value is the closest thing to a pre-UTxO-HD node, and as such it
       -- will be the default for end-users.
@@ -75,3 +86,37 @@ defaultArgs = LedgerDbArgs {
 data LedgerDbFlavorArgs f m =
     LedgerDbFlavorArgsV1 (V1.LedgerDbFlavorArgs f m)
   | LedgerDbFlavorArgsV2 (V2.LedgerDbFlavorArgs f m)
+
+
+{-------------------------------------------------------------------------------
+  QueryBatchSize
+-------------------------------------------------------------------------------}
+
+-- | The /maximum/ number of keys to read in a backing store range query.
+--
+-- When performing a ledger state query that involves on-disk parts of the
+-- ledger state, we might have to read ranges of key-value pair data (e.g.,
+-- UTxO) from disk using backing store range queries. Instead of reading all
+-- data in one go, we read it in batches. 'QueryBatchSize' determines the size
+-- of these batches.
+--
+-- INVARIANT: Should be at least 1.
+--
+-- It is fine if the result of a range read contains less than this number of
+-- keys, but it should never return more.
+data QueryBatchSize =
+    -- | A default value, which is determined by a specific
+    -- 'QueryBatchSize'. See 'defaultQueryBatchSize' as an example.
+    DefaultQueryBatchSize
+    -- | A requested value: the number of keys to read from disk in each batch.
+  | RequestedQueryBatchSize Word64
+  deriving (Show, Eq, Generic)
+  deriving anyclass NoThunks
+
+defaultQueryBatchSize :: QueryBatchSize -> Word64
+defaultQueryBatchSize requestedQueryBatchSize = case requestedQueryBatchSize of
+    RequestedQueryBatchSize value -> value
+    -- Experiments showed that 100_000 is a reasonable value, which yields
+    -- acceptable performance. We might want to tweak this further, but for now
+    -- this default seems good enough.
+    DefaultQueryBatchSize         -> 100_000
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs
index aebb684d9b..2e078ae5e3 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
index 8b0218a6a9..5fa3c24d0d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -74,9 +73,6 @@ mkInitDb ::
   , IOLike m
   , LedgerDbSerialiseConstraints blk
   , HasHardForkHistory blk
-#if __GLASGOW_HASKELL__ < 906
-  , HasAnnTip blk
-#endif
   )
   => Complete LedgerDbArgs m blk
   -> Complete V1.LedgerDbFlavorArgs m
@@ -129,7 +125,7 @@ mkInitDb args bss getBlock =
                , ldbCfg             = lgrConfig
                , ldbHasFS           = lgrHasFS'
                , ldbShouldFlush     = shouldFlush flushFreq
-               , ldbQueryBatchSize  = queryBatchSizeArg
+               , ldbQueryBatchSize  = lgrQueryBatchSize
                , ldbResolveBlock    = getBlock
                }
       h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
@@ -145,11 +141,12 @@ mkInitDb args bss getBlock =
       , lgrConfig
       , lgrGenesis
       , lgrRegistry
+      , lgrQueryBatchSize
       } = args
 
     lgrHasFS' = SnapshotsFS lgrHasFS
 
-    V1Args flushFreq queryBatchSizeArg baArgs = bss
+    V1Args flushFreq baArgs = bss
 
 implMkLedgerDb ::
      forall m l blk.
@@ -160,9 +157,6 @@ implMkLedgerDb ::
      , LedgerSupportsProtocol blk
      , ApplyBlock l blk
      , l ~ ExtLedgerState blk
-#if __GLASGOW_HASKELL__ < 906
-     , HasAnnTip blk
-#endif
      , HasHardForkHistory blk
      )
   => LedgerDBHandle m l blk
@@ -322,7 +316,8 @@ mkInternals ::
   -> TestInternals' m blk
 mkInternals h = TestInternals {
       takeSnapshotNOW = getEnv2 h implIntTakeSnapshot
-    , reapplyThenPushNOW = getEnv1 h implIntReapplyThenPushBlock
+    , push = getEnv1 h implIntPush
+    , reapplyThenPushNOW = getEnv1 h implIntReapplyThenPush
     , wipeLedgerDB = getEnv h $ void . destroySnapshots . snapshotsFs . ldbHasFS
     , closeLedgerDB = getEnv h $ bsClose . ldbBackingStore
     , truncateSnapshots = getEnv h $ void . implIntTruncateSnapshots . ldbHasFS
@@ -365,13 +360,24 @@ implIntTakeSnapshot env whereTo suffix = do
       (ldbBackingStore env)
       suffix
 
-implIntReapplyThenPushBlock ::
+implIntPush ::
+     ( IOLike m
+     , ApplyBlock l blk
+     , l ~ ExtLedgerState blk
+     )
+  => LedgerDBEnv m l blk -> l DiffMK -> m ()
+implIntPush env st = do
+  chlog <- readTVarIO $ ldbChangelog env
+  let chlog' = prune (ledgerDbCfgSecParam $ ldbCfg env) $ extend st chlog
+  atomically $ writeTVar (ldbChangelog env) chlog'
+
+implIntReapplyThenPush ::
      ( IOLike m
      , ApplyBlock l blk
      , l ~ ExtLedgerState blk
      )
   => LedgerDBEnv m l blk -> blk -> m ()
-implIntReapplyThenPushBlock env blk = do
+implIntReapplyThenPush env blk = do
   chlog <- readTVarIO $ ldbChangelog env
   chlog' <- reapplyThenPush (ldbCfg env)  blk (readKeySets (ldbBackingStore env)) chlog
   atomically $ writeTVar (ldbChangelog env) chlog'
@@ -718,12 +724,11 @@ newForker h ldbEnv (vh, dblog) = do
     , foeChangelog               = dblogVar
     , foeSwitchVar               = ldbChangelog ldbEnv
     , foeSecurityParam           = ledgerDbCfgSecParam $ ldbCfg ldbEnv
-    , foeQueryBatchSize          = ldbQueryBatchSize ldbEnv
     , foeTracer                  = LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
     }
   atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
   traceWith (foeTracer forkerEnv) ForkerOpen
-  pure $ mkForker h forkerKey
+  pure $ mkForker h (ldbQueryBatchSize ldbEnv) forkerKey
 
 mkForker ::
      ( IOLike m
@@ -732,12 +737,13 @@ mkForker ::
      , GetTip l
      )
   => LedgerDBHandle m l blk
+  -> QueryBatchSize
   -> ForkerKey
   -> Forker m l blk
-mkForker h forkerKey = Forker {
+mkForker h qbs forkerKey = Forker {
       forkerClose                  = implForkerClose h forkerKey
     , forkerReadTables             = getForkerEnv1   h forkerKey implForkerReadTables
-    , forkerRangeReadTables        = getForkerEnv1   h forkerKey implForkerRangeReadTables
+    , forkerRangeReadTables        = getForkerEnv1   h forkerKey (implForkerRangeReadTables qbs)
     , forkerGetLedgerState         = getForkerEnvSTM h forkerKey implForkerGetLedgerState
     , forkerReadStatistics         = getForkerEnv    h forkerKey implForkerReadStatistics
     , forkerPush                   = getForkerEnv1   h forkerKey implForkerPush
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs
index e99cf9bece..c000c95895 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs
@@ -1,11 +1,9 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -15,9 +13,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Args (
     BackingStoreArgs (..)
   , FlushFrequency (..)
   , LedgerDbFlavorArgs (..)
-  , QueryBatchSize (..)
   , defaultLedgerDbFlavorArgs
-  , queryBatchSize
   , shouldFlush
   ) where
 
@@ -26,44 +22,9 @@ import           Control.Monad.Primitive
 import qualified Data.SOP.Dict as Dict
 import           Data.Word
 import           GHC.Generics
-import           NoThunks.Class
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
 import           Ouroboros.Consensus.Util.Args
 
-{-------------------------------------------------------------------------------
-  Arguments
--------------------------------------------------------------------------------}
-
--- | The /maximum/ number of keys to read in a backing store range query.
---
--- When performing a ledger state query that involves on-disk parts of the
--- ledger state, we might have to read ranges of key-value pair data (e.g.,
--- UTxO) from disk using backing store range queries. Instead of reading all
--- data in one go, we read it in batches. 'QueryBatchSize' determines the size
--- of these batches.
---
--- INVARIANT: Should be at least 1.
---
--- It is fine if the result of a range read contains less than this number of
--- keys, but it should never return more.
-data QueryBatchSize =
-    -- | A default value, which is determined by a specific
-    -- 'SnapshotPolicy'. See 'defaultSnapshotPolicy' as an example.
-    DefaultQueryBatchSize
-    -- | A requested value: the number of keys to read from disk in each batch.
-  | RequestedQueryBatchSize Word64
-
-    -- | To disable queries, to be used in tests
-  | DisableQuerySize
-  deriving (Show, Eq, Generic)
-  deriving anyclass NoThunks
-
-queryBatchSize :: QueryBatchSize -> Word64
-queryBatchSize requestedQueryBatchSize = case requestedQueryBatchSize of
-    RequestedQueryBatchSize value -> value
-    DefaultQueryBatchSize         -> 100_000
-    DisableQuerySize              -> 0
-
 -- | The number of blocks in the immutable part of the chain that we have to see
 -- before we flush the ledger tables to disk. See 'onDiskShouldFlush'.
 data FlushFrequency =
@@ -85,7 +46,6 @@ shouldFlush requestedFlushFrequency = case requestedFlushFrequency of
 
 data LedgerDbFlavorArgs f m = V1Args {
       v1FlushFrequency :: FlushFrequency
-    , v1QueryBatchSize :: QueryBatchSize
     , v1BackendArgs    :: BackingStoreArgs f m
   }
 
@@ -97,7 +57,7 @@ class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
 instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
 
 defaultLedgerDbFlavorArgs :: Incomplete LedgerDbFlavorArgs  m
-defaultLedgerDbFlavorArgs = V1Args DefaultFlushFrequency DefaultQueryBatchSize defaultBackingStoreArgs
+defaultLedgerDbFlavorArgs = V1Args DefaultFlushFrequency defaultBackingStoreArgs
 
 defaultBackingStoreArgs :: Incomplete BackingStoreArgs m
 defaultBackingStoreArgs = InMemoryBackingStoreArgs
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs
index 5f83478108..882ad2b1d4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 -- | See "Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API" for the
 -- documentation. This module just puts together the implementations for the
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
index 1af4844db4..779d0a5c1f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
@@ -29,8 +29,8 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
+import           Ouroboros.Consensus.Storage.LedgerDB.Args
 import           Ouroboros.Consensus.Storage.LedgerDB.Forker as Forker
-import           Ouroboros.Consensus.Storage.LedgerDB.V1.Args
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API as BackingStore
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
@@ -57,7 +57,6 @@ data ForkerEnv m l blk = ForkerEnv {
     -- | Config
   , foeSecurityParam           :: !SecurityParam
      -- | Config
-  , foeQueryBatchSize          :: !QueryBatchSize
   , foeTracer                  :: !(Tracer m TraceForkerEvent)
   }
   deriving Generic
@@ -100,10 +99,11 @@ implForkerReadTables env ks = do
 
 implForkerRangeReadTables ::
      (MonadSTM m, HasLedgerTables l)
-  => ForkerEnv m l blk
+  => QueryBatchSize
+  -> ForkerEnv m l blk
   -> RangeQueryPrevious l
   -> m (LedgerTables l ValuesMK)
-implForkerRangeReadTables env rq0 = do
+implForkerRangeReadTables qbs env rq0 = do
     traceWith (foeTracer env) ForkerRangeReadTablesStart
     ldb <- readTVarIO $ foeChangelog env
     let -- Get the differences without the keys that are greater or equal
@@ -132,7 +132,7 @@ implForkerRangeReadTables env rq0 = do
   where
     lvh = foeBackingStoreValueHandle env
 
-    rq = BackingStore.RangeQuery rq1 (fromIntegral $ queryBatchSize $ foeQueryBatchSize env)
+    rq = BackingStore.RangeQuery rq1 (fromIntegral $ defaultQueryBatchSize qbs)
 
     rq1 = case rq0 of
       NoPreviousQuery        -> Nothing
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
index 8411235085..678e190457 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
@@ -67,9 +67,6 @@ mkInitDb :: forall m blk.
             , IOLike m
             , LedgerDbSerialiseConstraints blk
             , HasHardForkHistory blk
-#if __GLASGOW_HASKELL__ < 906
-            , HasAnnTip blk
-#endif
             )
          => Complete LedgerDbArgs m blk
          -> Complete V2.LedgerDbFlavorArgs m
@@ -105,7 +102,7 @@ mkInitDb args flavArgs getBlock =
                , ldbCfg             = lgrConfig
                , ldbHasFS           = lgrHasFS
                , ldbResolveBlock    = getBlock
-               , ldbQueryBatchSize  = Nothing
+               , ldbQueryBatchSize  = lgrQueryBatchSize
                , ldbOpenHandlesLock = lock
                }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
@@ -118,6 +115,7 @@ mkInitDb args flavArgs getBlock =
      , lgrHasFS
      , lgrSnapshotPolicyArgs
      , lgrTracer
+     , lgrQueryBatchSize
      , lgrRegistry
      } = args
 
@@ -190,6 +188,12 @@ mkInternals bss h = TestInternals {
                 (ldbHasFS env)
                 suff
                 st
+    , push = \st -> withRegistry $ \reg -> do
+          eFrk <- newForkerAtTarget h reg VolatileTip
+          case eFrk of
+            Left {} -> error "Unreachable, Volatile tip MUST be in LedgerDB"
+            Right frk ->
+              forkerPush frk st >> atomically (forkerCommit frk) >> forkerClose frk
     , reapplyThenPushNOW = \blk -> getEnv h $ \env -> withRegistry $ \reg -> do
           eFrk <- newForkerAtTarget h reg VolatileTip
           case eFrk of
@@ -404,7 +408,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv {
   , ldbCfg             :: !(LedgerDbCfg l)
   , ldbHasFS           :: !(SomeHasFS m)
   , ldbResolveBlock    :: !(ResolveBlock m blk)
-  , ldbQueryBatchSize  :: !(Maybe Int)
+  , ldbQueryBatchSize  :: !QueryBatchSize
   , ldbOpenHandlesLock :: !(RAWLock m LDBLock)
   } deriving (Generic)
 
@@ -643,14 +647,13 @@ newForker h ldbEnv rr st = do
         foeLedgerSeq          = lseqVar
       , foeSwitchVar          = ldbSeq ldbEnv
       , foeSecurityParam      = ledgerDbCfgSecParam $ ldbCfg ldbEnv
-      , foeQueryBatchSize     = ldbQueryBatchSize ldbEnv
       , foeTracer             = tr
       , foeResourcesToRelease = toRelease
       }
     atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
     pure $ Forker {
         forkerReadTables             = getForkerEnv1   h forkerKey implForkerReadTables
-      , forkerRangeReadTables        = getForkerEnv1   h forkerKey implForkerRangeReadTables
+      , forkerRangeReadTables        = getForkerEnv1   h forkerKey (implForkerRangeReadTables (ldbQueryBatchSize ldbEnv))
       , forkerGetLedgerState         = getForkerEnvSTM h forkerKey implForkerGetLedgerState
       , forkerReadStatistics         = getForkerEnv    h forkerKey implForkerReadStatistics
       , forkerPush                   = getForkerEnv1   h forkerKey implForkerPush
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
index 2af9d9ba22..d1c1e32bd1 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -30,6 +28,7 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Ledger.Tables.Utils
+import           Ouroboros.Consensus.Storage.LedgerDB.Args
 import           Ouroboros.Consensus.Storage.LedgerDB.Forker
 import           Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
 import           Ouroboros.Consensus.Util.CallStack
@@ -49,8 +48,6 @@ data ForkerEnv m l blk = ForkerEnv {
   , foeSwitchVar          :: !(StrictTVar m (LedgerSeq m l))
     -- | Config
   , foeSecurityParam      :: !SecurityParam
-    -- | The batch size
-  , foeQueryBatchSize     :: !(Maybe Int)
     -- | Config
   , foeTracer             :: !(Tracer m TraceForkerEvent)
     -- | Release the resources
@@ -79,13 +76,14 @@ implForkerReadTables env ks = do
 
 implForkerRangeReadTables ::
      (MonadSTM m, GetTip l, HasLedgerTables l)
-  => ForkerEnv m l blk
+  => QueryBatchSize
+  -> ForkerEnv m l blk
   -> RangeQueryPrevious l
   -> m (LedgerTables l ValuesMK)
-implForkerRangeReadTables env rq0 = do
+implForkerRangeReadTables qbs env rq0 = do
     traceWith (foeTracer env) ForkerRangeReadTablesStart
     ldb <- readTVarIO $ foeLedgerSeq env
-    let n = maybe 100_000 id $ foeQueryBatchSize env
+    let n = fromIntegral $ defaultQueryBatchSize qbs
     case rq0 of
       NoPreviousQuery -> readRange (tables $ currentHandle ldb) (Nothing, n)
       PreviousQueryWasFinal -> pure $ LedgerTables emptyMK
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs
index 50f0bfb856..a589e31e60 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs
@@ -4,8 +4,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Ouroboros.Consensus.Util.IOLike (
     IOLike (..)
@@ -180,6 +178,6 @@ instance NoThunks a => NoThunks (Strict.StrictMVar IO a) where
 
 instance NoThunks a => NoThunks (StrictSTM.StrictTMVar IO a) where
   showTypeOf _ = "StrictTMVar IO"
-  wNoThunks ctxt tmvar  = do
-      a <- inspectTMVar (Proxy :: Proxy IO) $ toLazyTMVar tmvar
+  wNoThunks ctxt t  = do
+      a <- inspectTMVar (Proxy :: Proxy IO) $ toLazyTMVar t
       noThunks ctxt a
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
index 4179293e7c..57f5fa2e48 100644
--- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
+++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
@@ -126,6 +126,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs {
         , lgrRegistry           = mcdbRegistry
         , lgrConfig             = configLedgerDb mcdbTopLevelConfig
         , lgrFlavorArgs         = LedgerDbFlavorArgsV2 (V2Args InMemoryHandleArgs)
+        , lgrQueryBatchSize     = DefaultQueryBatchSize
         , lgrStartSnapshot      = Nothing
         }
     , cdbsArgs = ChainDbSpecificArgs {
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Ledger/Tables/DiffSeq.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Ledger/Tables/DiffSeq.hs
index 0d499e9aa1..d211fc08f7 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Ledger/Tables/DiffSeq.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Ledger/Tables/DiffSeq.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs
index 4cb332b426..df7ec43268 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs
@@ -1,6 +1,6 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
index fd4780ba8f..a4720da315 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
@@ -219,8 +219,9 @@ initLedgerDB s c = do
         , lgrHasFS              = SomeHasFS $ simHasFS fs
         , lgrGenesis            = return testInitExtLedger
         , lgrTracer             = nullTracer
-        , lgrFlavorArgs         = LedgerDbFlavorArgsV1 $ V1Args DefaultFlushFrequency DefaultQueryBatchSize InMemoryBackingStoreArgs
+        , lgrFlavorArgs         = LedgerDbFlavorArgsV1 $ V1Args DefaultFlushFrequency InMemoryBackingStoreArgs
         , lgrConfig             = LedgerDB.configLedgerDb $ testCfg s
+        , lgrQueryBatchSize     = DefaultQueryBatchSize
         , lgrRegistry           = reg
         , lgrStartSnapshot      = Nothing
         }
diff --git a/ouroboros-consensus/test/storage-test/Main.hs b/ouroboros-consensus/test/storage-test/Main.hs
index e06d57b050..6b3986e1b6 100644
--- a/ouroboros-consensus/test/storage-test/Main.hs
+++ b/ouroboros-consensus/test/storage-test/Main.hs
@@ -1,19 +1,11 @@
-{-# LANGUAGE NumericUnderscores #-}
 module Main (main) where
 
-import           Control.Concurrent (threadDelay)
-import           Control.Concurrent.Async (race_)
-import           Control.Monad (forever)
-import           System.IO (hFlush, stdout)
 import qualified Test.Ouroboros.Storage
 import           Test.Tasty
 import           Test.Util.TestEnv
 
 main :: IO ()
-main = runTests `race_` heartbeat
-  where
-    runTests  = defaultMainWithTestEnv defaultTestEnvConfig tests
-    heartbeat = forever $ threadDelay (30 * 1_000_000)  >> putChar '.' >> hFlush stdout
+main = defaultMainWithTestEnv defaultTestEnvConfig tests
 
 tests :: TestTree
 tests = testGroup "ouroboros-storage" [
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index 8b3fbddd62..d4f93b9d7a 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -181,8 +181,6 @@ data Cmd blk it flr
     -- smaller than the block's slot number (such that the block is from the
     -- future) and larger or equal to the current slot, and add the block.
   | GetCurrentChain
-  -- TODO(js_ldb): reenable
-  --  GetLedgerDB
   | GetTipBlock
   | GetTipHeader
   | GetTipPoint
@@ -402,7 +400,6 @@ run env@ChainDBEnv { varDB, .. } cmd =
       AddBlock blk             -> Point               <$> advanceAndAdd st (blockSlot blk) blk
       AddFutureBlock blk s     -> Point               <$> advanceAndAdd st s               blk
       GetCurrentChain          -> Chain               <$> atomically getCurrentChain
-      -- GetLedgerDB              -> LedgerDB . flush    <$> atomically getDbChangelog -- TODO(jdral_ldb)
       GetTipBlock              -> MbBlock             <$> getTipBlock
       GetTipHeader             -> MbHeader            <$> getTipHeader
       GetTipPoint              -> Point               <$> atomically getTipPoint
@@ -462,33 +459,6 @@ run env@ChainDBEnv { varDB, .. } cmd =
     giveWithEq a =
       fmap (`WithEq` a) $ atomically $ stateTVar varNextId $ \i -> (i, succ i)
 
--- | When the model is asked for the ledger DB, it reconstructs it by applying
--- the blocks in the current chain, starting from the initial ledger state.
--- Before the introduction of UTxO HD, this approach resulted in a ledger DB
--- equivalent to the one maintained by the SUT. However, after UTxO HD, this is
--- no longer the case since the ledger DB can be altered as the result of taking
--- snapshots or opening the ledger DB (for instance when we process the
--- 'WipeVolatileDB' command). Taking snapshots or opening the ledger DB cause
--- the ledger DB to be flushed, which modifies its sequence of volatile and
--- immutable states.
---
--- The model does not have information about when the flushes occur and it
--- cannot infer that information in a reliable way since this depends on the low
--- level details of operations such as opening the ledger DB. Therefore, we
--- assume that the 'GetLedgerDB' command should return a flushed ledger DB, and
--- we use this function to implement such command both in the SUT and in the
--- model.
---
--- When we compare the SUT and model's ledger DBs, by flushing we are not
--- comparing the immutable parts of the SUT and model's ledger DBs. However,
--- this was already the case in before the introduction of UTxO HD: if the
--- current chain contained more than K blocks, then the ledger states before the
--- immutable tip were not compared by the 'GetLedgerDB' command.
--- flush ::
---      (LedgerSupportsProtocol blk)
---   => DbChangelog.DbChangelog' blk -> DbChangelog.DbChangelog' blk
--- flush = snd . DbChangelog.splitForFlushing
-
 persistBlks :: IOLike m => ShouldGarbageCollect -> ChainDB.Internal m blk -> m ()
 persistBlks collectGarbage ChainDB.Internal{..} = do
     mSlotNo <- intCopyToImmutableDB
@@ -673,7 +643,6 @@ runPure cfg = \case
     AddBlock blk             -> ok  Point               $ update  (advanceAndAdd (blockSlot blk) blk)
     AddFutureBlock blk s     -> ok  Point               $ update  (advanceAndAdd s               blk)
     GetCurrentChain          -> ok  Chain               $ query   (Model.volatileChain k getHeader)
---    GetLedgerDB              -> ok  LedgerDB            $ query   (flush . Model.getDbChangelog cfg)
     GetTipBlock              -> ok  MbBlock             $ query    Model.tipBlock
     GetTipHeader             -> ok  MbHeader            $ query   (fmap getHeader . Model.tipBlock)
     GetTipPoint              -> ok  Point               $ query    Model.tipPoint
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs
index 5337e77694..e6af8cc45c 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs
@@ -10,18 +10,18 @@ import qualified Test.Ouroboros.Storage.LedgerDB.Serialisation as Serialisation
 import qualified Test.Ouroboros.Storage.LedgerDB.SnapshotPolicy as SnapshotPolicy
 import qualified Test.Ouroboros.Storage.LedgerDB.StateMachine as StateMachine
 import qualified Test.Ouroboros.Storage.LedgerDB.V1.BackingStore as BackingStore
-import qualified Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.QuickCheck as DbChangelog.QuickCheck
-import qualified Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.Unit as DbChangelog.Unit
+import qualified Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog as DbChangelog
 import           Test.Tasty (TestTree, testGroup)
 
 tests :: TestTree
 tests = testGroup "LedgerDB" [
       testGroup "V1" [
           BackingStore.tests
-        , DbChangelog.Unit.tests
-        , DbChangelog.QuickCheck.tests
+        , DbChangelog.tests
     ]
+      -- Independent of the LedgerDB implementation
     , SnapshotPolicy.tests
     , Serialisation.tests
+      -- Tests both V1 and V2
     , StateMachine.tests
     ]
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
index 1b632c2e6f..4341c16ecd 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
@@ -37,7 +37,7 @@
 -- corresponding ledger state modelling the whole block chain since genesis.
 module Test.Ouroboros.Storage.LedgerDB.StateMachine (tests) where
 
-import           Control.Monad (when)
+import qualified Control.Monad as Monad
 import           Control.Monad.Except
 import           Control.Monad.State hiding (state)
 import           Control.ResourceRegistry
@@ -124,7 +124,7 @@ initialEnvironment fsOps getLmdbDir mkTestArguments cdb = do
   (lmdbDir, cleanupLMDB) <- getLmdbDir
   pure $ Environment
     undefined
-    (TestInternals undefined undefined undefined undefined (pure ()))
+    (TestInternals undefined undefined undefined undefined undefined (pure ()))
     cdb
     (flip mkTestArguments lmdbDir)
     sfs
@@ -147,7 +147,7 @@ realFilePath = liftIO $ do
   tmpdir <- (FilePath.</> "test_lmdb") <$> Dir.getTemporaryDirectory
   pure (tmpdir, do
            exists <- Dir.doesDirectoryExist tmpdir
-           when exists $ Dir.removeDirectoryRecursive tmpdir)
+           Monad.when exists $ Dir.removeDirectoryRecursive tmpdir)
 
 simulatedFS :: IO (SomeHasFS IO, IO ())
 simulatedFS = do
@@ -166,7 +166,7 @@ inMemV1TestArguments ::
   -> TestArguments IO
 inMemV1TestArguments secParam _ =
   TestArguments {
-      argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing DisableQuerySize InMemoryBackingStoreArgs
+      argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing InMemoryBackingStoreArgs
     , argLedgerDbCfg = extLedgerDbConfig secParam
     }
 
@@ -186,7 +186,7 @@ lmdbTestArguments ::
   -> TestArguments IO
 lmdbTestArguments secParam fp =
   TestArguments {
-      argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing DisableQuerySize $ LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict
+      argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing $ LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict
     , argLedgerDbCfg = extLedgerDbConfig secParam
     }
 
@@ -427,6 +427,7 @@ openLedgerDB flavArgs env cfg fs = do
                nullTracer
                flavArgs
                rr
+               DefaultQueryBatchSize
                Nothing
   (ldb, _, od) <- case flavArgs of
     LedgerDbFlavorArgsV1 bss ->
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs
index af54746e9d..2b14f773e2 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE Rank2Types #-}
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs
new file mode 100644
index 0000000000..986afbb777
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs
@@ -0,0 +1,652 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | Db changelog ledger DB tests.
+--
+-- The in-memory component of the ledger DB is a bit tricky: it stores only a
+-- few snapshots of the ledger state, in order to reduce memory footprint, but
+-- must nonetheless be able to construct any ledger state (within @k@ blocks
+-- from the chain tip) efficiently. The properties we are verify here are
+-- various invariants of this data type, things such as
+--
+-- * Rolling back and then reapplying the same blocks is an identity operation
+--   (provided the rollback is not too far)
+-- * The shape of the datatype (where we store snapshots and how many we store)
+--   always matches the policy set by the user, and is invariant under any of
+--   the operations (add a block, switch to a fork, etc.)
+-- * The maximum rollback supported is always @k@ (unless we are near genesis)
+-- * etc.
+--
+module Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog (tests) where
+
+import           Cardano.Slotting.Slot (WithOrigin (..))
+import           Control.Monad hiding (ap)
+import           Control.Monad.Trans.Class (lift)
+import           Control.Monad.Trans.State.Strict hiding (state)
+import           Data.Foldable
+import qualified Data.Map.Diff.Strict.Internal as Diff
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe (catMaybes, fromJust, isJust, isNothing)
+import           Data.Set (Set)
+import qualified Data.Set as Set
+import           Data.Word
+import           GHC.Generics (Generic)
+import           NoThunks.Class (NoThunks)
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.BlockchainTime
+import           Ouroboros.Consensus.Config
+import qualified Ouroboros.Consensus.HardFork.History as HardFork
+import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Storage.LedgerDB.API
+import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog hiding
+                     (tip)
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
+import           Ouroboros.Consensus.Util
+import qualified Ouroboros.Network.AnchoredSeq as AS
+import           Ouroboros.Network.Block (Point (..))
+import qualified Ouroboros.Network.Point as Point
+import           Test.QuickCheck hiding (elements)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck hiding (elements)
+import           Test.Util.Orphans.Arbitrary ()
+import           Test.Util.QuickCheck
+import qualified Test.Util.TestBlock as TestBlock
+import           Text.Show.Pretty (ppShow)
+
+samples :: Int
+samples = 1000
+
+tests :: TestTree
+tests = testGroup "DbChangelog" [
+      testGroup "Genesis" [
+          testProperty "current"                prop_genesisCurrent
+        ]
+    , testGroup "Push" [
+          testProperty "expectedLedger"         prop_pushExpectedLedger
+        , testProperty "pastLedger"             prop_pastLedger
+        ]
+    , testGroup "Rollback" [
+          testProperty "maxRollbackGenesisZero" prop_maxRollbackGenesisZero
+        , testProperty "ledgerDbMaxRollback"    prop_snapshotsMaxRollback
+        , testProperty "switchSameChain"        prop_switchSameChain
+        , testProperty "switchExpectedLedger"   prop_switchExpectedLedger
+        , testProperty "pastAfterSwitch"        prop_pastAfterSwitch
+        ]
+    , testProperty "flushing" $ withMaxSuccess samples $ conjoin
+        [ counterexample "flushing keeps immutable tip"
+          prop_flushingSplitsTheChangelog
+        ]
+    , testProperty "rolling back" $ withMaxSuccess samples $ conjoin
+        [ counterexample "rollback after extension is noop"
+          prop_rollbackAfterExtendIsNoop
+        , counterexample "prefixing back to anchor is rolling back volatile states"
+          prop_rollbackToAnchorIsRollingBackVolatileStates
+        , counterexample "prefix back to volatile tip is a noop"
+          prop_rollBackToVolatileTipIsNoop
+        ]
+    , testProperty "extending adds head to volatile states"
+        $ withMaxSuccess samples prop_extendingAdvancesTipOfVolatileStates
+    , testProperty "pruning leaves at most maxRollback volatile states"
+        $ withMaxSuccess samples prop_pruningLeavesAtMostMaxRollbacksVolatileStates
+    ]
+
+{-------------------------------------------------------------------------------
+  Genesis
+-------------------------------------------------------------------------------}
+
+prop_genesisCurrent :: Property
+prop_genesisCurrent =
+    current genSnaps === convertMapKind TestBlock.testInitLedger
+  where
+    genSnaps = empty (convertMapKind TestBlock.testInitLedger)
+
+{-------------------------------------------------------------------------------
+  Constructing snapshots
+-------------------------------------------------------------------------------}
+
+prop_pushExpectedLedger :: ChainSetup -> Property
+prop_pushExpectedLedger setup@ChainSetup{..} =
+    classify (chainSetupSaturated setup) "saturated" $
+      conjoin [
+          l === convertMapKind (refoldLedger cfg (expectedChain o) (convertMapKind TestBlock.testInitLedger))
+        | (o, l) <- snapshots csPushed
+        ]
+  where
+    expectedChain :: Word64 -> [TestBlock.TestBlock]
+    expectedChain o = take (fromIntegral (csNumBlocks - o)) csChain
+
+    cfg :: LedgerConfig TestBlock.TestBlock
+    cfg = ledgerDbCfg (csBlockConfig setup)
+
+prop_pastLedger :: ChainSetup -> Property
+prop_pastLedger setup@ChainSetup{..} =
+    classify (chainSetupSaturated setup) "saturated"    $
+    classify withinReach                 "within reach" $
+          getPastLedgerAt tip csPushed
+      === if withinReach
+            then Just (current afterPrefix)
+            else Nothing
+  where
+    prefix :: [TestBlock.TestBlock]
+    prefix = take (fromIntegral csPrefixLen) csChain
+
+    tip :: Point TestBlock.TestBlock
+    tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
+
+    afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
+    afterPrefix = reapplyThenPushMany' (csBlockConfig setup) prefix csGenSnaps
+
+    -- See 'prop_snapshotsMaxRollback'
+    withinReach :: Bool
+    withinReach = (csNumBlocks - csPrefixLen) <= maxRollback csPushed
+
+{-------------------------------------------------------------------------------
+  Rollback
+-------------------------------------------------------------------------------}
+
+prop_maxRollbackGenesisZero :: Property
+prop_maxRollbackGenesisZero =
+        maxRollback (empty (convertMapKind TestBlock.testInitLedger))
+    === 0
+
+prop_snapshotsMaxRollback :: ChainSetup -> Property
+prop_snapshotsMaxRollback setup@ChainSetup{..} =
+    classify (chainSetupSaturated setup) "saturated" $
+      conjoin [
+          if chainSetupSaturated setup
+            then (maxRollback csPushed) `ge` k
+            else (maxRollback csPushed) `ge` (min k csNumBlocks)
+        , (maxRollback csPushed) `le` k
+        ]
+  where
+    SecurityParam k = csSecParam
+
+prop_switchSameChain :: SwitchSetup -> Property
+prop_switchSameChain setup@SwitchSetup{..} =
+    classify (switchSetupSaturated setup) "saturated" $
+          switch' (csBlockConfig ssChainSetup) ssNumRollback blockInfo csPushed
+      === Just csPushed
+  where
+    ChainSetup{csPushed} = ssChainSetup
+    blockInfo            = ssRemoved
+
+prop_switchExpectedLedger :: SwitchSetup -> Property
+prop_switchExpectedLedger setup@SwitchSetup{..} =
+    classify (switchSetupSaturated setup) "saturated" $
+      conjoin [
+          l === convertMapKind (refoldLedger cfg (expectedChain o) (convertMapKind TestBlock.testInitLedger))
+        | (o, l) <- snapshots ssSwitched
+        ]
+  where
+    expectedChain :: Word64 -> [TestBlock.TestBlock]
+    expectedChain o = take (fromIntegral (ssNumBlocks - o)) ssChain
+
+    cfg :: LedgerConfig TestBlock.TestBlock
+    cfg = ledgerDbCfg (csBlockConfig ssChainSetup)
+
+-- | Check 'prop_pastLedger' still holds after switching to a fork
+prop_pastAfterSwitch :: SwitchSetup -> Property
+prop_pastAfterSwitch setup@SwitchSetup{..} =
+    classify (switchSetupSaturated setup) "saturated"    $
+    classify withinReach                  "within reach" $
+          getPastLedgerAt tip ssSwitched
+      === if withinReach
+            then Just (current afterPrefix)
+            else Nothing
+  where
+    prefix :: [TestBlock.TestBlock]
+    prefix = take (fromIntegral ssPrefixLen) ssChain
+
+    tip :: Point TestBlock.TestBlock
+    tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
+
+    afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
+    afterPrefix = reapplyThenPushMany' (csBlockConfig ssChainSetup) prefix (csGenSnaps ssChainSetup)
+
+    -- See 'prop_snapshotsMaxRollback'
+    withinReach :: Bool
+    withinReach = (ssNumBlocks - ssPrefixLen) <= maxRollback ssSwitched
+
+{-------------------------------------------------------------------------------
+  Test setup
+-------------------------------------------------------------------------------}
+
+data ChainSetup = ChainSetup {
+      -- | Security parameter
+      csSecParam  :: SecurityParam
+
+      -- | Number of blocks applied
+    , csNumBlocks :: Word64
+
+      -- | Some prefix of the chain
+      --
+      -- Although we choose this to be less than or equal to 'csNumBlocks',
+      -- we don't guarantee this during shrinking. If 'csPrefixLen' is larger
+      -- than 'csNumBlocks', the prefix should simply be considered to be the
+      -- entire chain.
+    , csPrefixLen :: Word64
+
+      -- | Derived: genesis snapshots
+    , csGenSnaps  :: DbChangelog (LedgerState TestBlock.TestBlock)
+
+      -- | Derived: the actual blocks that got applied (old to new)
+    , csChain     :: [TestBlock.TestBlock]
+
+      -- | Derived: the snapshots after all blocks were applied
+    , csPushed    :: DbChangelog (LedgerState TestBlock.TestBlock)
+    }
+  deriving (Show)
+
+csBlockConfig :: ChainSetup -> LedgerDbCfg (LedgerState TestBlock.TestBlock)
+csBlockConfig = csBlockConfig' . csSecParam
+
+csBlockConfig' :: SecurityParam -> LedgerDbCfg (LedgerState TestBlock.TestBlock)
+csBlockConfig' secParam = LedgerDbCfg {
+      ledgerDbCfgSecParam = secParam
+    , ledgerDbCfg         =
+          TestBlock.testBlockLedgerConfigFrom
+        $ HardFork.defaultEraParams secParam slotLength
+    }
+  where
+    slotLength = slotLengthFromSec 20
+
+chainSetupSaturated :: ChainSetup -> Bool
+chainSetupSaturated ChainSetup{..} = isSaturated csSecParam csPushed
+
+data SwitchSetup = SwitchSetup {
+      -- | Chain setup
+      ssChainSetup  :: ChainSetup
+
+      -- | Number of blocks to roll back
+    , ssNumRollback :: Word64
+
+      -- | Number of new blocks (to be applied after the rollback)
+    , ssNumNew      :: Word64
+
+      -- | Prefix of the new chain
+      --
+      -- See also 'csPrefixLen'
+    , ssPrefixLen   :: Word64
+
+      -- | Derived: number of blocks in the new chain
+    , ssNumBlocks   :: Word64
+
+      -- | Derived: the blocks that were removed
+    , ssRemoved     :: [TestBlock.TestBlock]
+
+      -- | Derived: the new blocks themselves
+    , ssNewBlocks   :: [TestBlock.TestBlock]
+
+      -- | Derived: the full chain after switching to this fork
+    , ssChain       :: [TestBlock.TestBlock]
+
+      -- | Derived; the snapshots after the switch was performed
+    , ssSwitched    :: DbChangelog (LedgerState TestBlock.TestBlock)
+    }
+  deriving (Show)
+
+switchSetupSaturated :: SwitchSetup -> Bool
+switchSetupSaturated = chainSetupSaturated . ssChainSetup
+
+mkTestSetup :: SecurityParam -> Word64 -> Word64 -> ChainSetup
+mkTestSetup csSecParam csNumBlocks csPrefixLen =
+    ChainSetup {..}
+  where
+    csGenSnaps = empty (convertMapKind TestBlock.testInitLedger)
+    csChain    = take (fromIntegral csNumBlocks) $
+                   iterate TestBlock.successorBlock (TestBlock.firstBlock 0)
+    csPushed   = reapplyThenPushMany' (csBlockConfig' csSecParam) csChain csGenSnaps
+
+mkRollbackSetup :: ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
+mkRollbackSetup ssChainSetup ssNumRollback ssNumNew ssPrefixLen =
+    SwitchSetup {..}
+  where
+    ChainSetup{..} = ssChainSetup
+
+    ssNumBlocks = csNumBlocks - ssNumRollback + ssNumNew
+    ssRemoved   = takeLast ssNumRollback csChain
+    ssNewBlocks = let afterRollback      = dropLast ssNumRollback csChain
+                      firstAfterRollback =
+                        case lastMaybe afterRollback of
+                          Nothing -> TestBlock.firstBlock 1
+                          Just b  -> TestBlock.modifyFork (+ 1) $ TestBlock.successorBlock b
+                  in take (fromIntegral ssNumNew) $
+                        iterate TestBlock.successorBlock firstAfterRollback
+    ssChain     = concat [
+                         take (fromIntegral (csNumBlocks - ssNumRollback)) csChain
+                       , ssNewBlocks
+                       ]
+    ssSwitched  = fromJust $ switch' (csBlockConfig ssChainSetup) ssNumRollback ssNewBlocks csPushed
+
+instance Arbitrary ChainSetup where
+  arbitrary = do
+      secParam <- arbitrary
+      let k = maxRollbacks secParam
+      numBlocks <- choose (0, k * 2)
+      prefixLen <- choose (0, numBlocks)
+      return $ mkTestSetup secParam numBlocks prefixLen
+
+  shrink ChainSetup{..} = concat [
+        -- Shrink the policy
+        [ mkTestSetup csSecParam' csNumBlocks csPrefixLen
+        | csSecParam' <- shrink csSecParam
+        ]
+
+        -- Reduce number of blocks
+      , [ mkTestSetup csSecParam csNumBlocks' csPrefixLen
+        | csNumBlocks' <- shrink csNumBlocks
+        ]
+      ]
+
+instance Arbitrary SwitchSetup where
+  arbitrary = do
+      chainSetup  <- arbitrary
+      numRollback <- choose (0, maxRollback (csPushed chainSetup))
+      numNew      <- choose (numRollback, 2 * numRollback)
+      prefixLen   <- choose (0, csNumBlocks chainSetup - numRollback + numNew)
+      return $ mkRollbackSetup chainSetup numRollback numNew prefixLen
+
+  shrink SwitchSetup{..} = concat [
+        -- If we shrink the chain setup, we might restrict max rollback
+        [ mkRollbackSetup ssChainSetup' ssNumRollback ssNumNew ssPrefixLen
+        | ssChainSetup' <- shrink ssChainSetup
+        , ssNumRollback <= maxRollback (csPushed ssChainSetup')
+        ]
+        -- Number of new blocks must be at least the rollback
+      , [ mkRollbackSetup ssChainSetup ssNumRollback ssNumNew' ssPrefixLen
+        | ssNumNew' <- shrink ssNumNew
+        , ssNumNew' >= ssNumRollback
+        ]
+        -- But rolling back less is always possible
+      , [ mkRollbackSetup ssChainSetup ssNumRollback' ssNumNew ssPrefixLen
+        | ssNumRollback' <- shrink ssNumRollback
+        ]
+      ]
+
+{-------------------------------------------------------------------------------
+  Test setup
+-------------------------------------------------------------------------------}
+
+data TestLedger (mk :: MapKind) = TestLedger {
+  tlUtxos :: mk Key Int,
+  tlTip   :: Point TestLedger
+}
+
+nextState :: DbChangelog TestLedger -> TestLedger DiffMK
+nextState dblog = TestLedger {
+              tlTip = pointAtSlot $ nextSlot (getTipSlot old)
+            , tlUtxos = DiffMK mempty
+            }
+  where
+    old = DbChangelog.current dblog
+    nextSlot = At . withOrigin 1 (+1)
+
+
+deriving instance Show (mk Key Int) => Show (TestLedger mk)
+
+instance GetTip TestLedger where
+  getTip = castPoint . tlTip
+
+data H = H deriving (Eq, Ord, Show, Generic)
+deriving anyclass instance NoThunks H
+type instance HeaderHash TestLedger = H
+
+instance StandardHash TestLedger
+
+deriving instance Eq (TestLedger EmptyMK)
+
+type instance TxIn  TestLedger = Key
+type instance TxOut TestLedger = Int
+
+instance HasLedgerTables TestLedger where
+  projectLedgerTables                     = LedgerTables . tlUtxos
+  withLedgerTables st    (LedgerTables x) = st { tlUtxos = x }
+
+data DbChangelogTestSetup = DbChangelogTestSetup {
+  -- The operations are applied on the right, i.e., the newest operation is at the head of the list.
+    operations          :: [Operation TestLedger]
+  , dbChangelogStartsAt :: WithOrigin SlotNo
+  }
+
+data Operation l = Extend (l DiffMK) | Prune SecurityParam
+deriving instance Show (l DiffMK) => Show (Operation l)
+
+data DbChangelogTestSetupWithRollbacks = DbChangelogTestSetupWithRollbacks
+  { testSetup :: DbChangelogTestSetup
+  , rollbacks :: Int
+  } deriving (Show)
+
+instance Show DbChangelogTestSetup where
+  show = ppShow . operations
+
+instance Arbitrary DbChangelogTestSetup where
+  arbitrary = sized $ \n -> do
+    slotNo <- oneof [pure Origin, At . SlotNo <$> chooseEnum (1, 1000)]
+    ops <- genOperations slotNo n
+    pure $ DbChangelogTestSetup
+      { operations = ops
+      , dbChangelogStartsAt = slotNo
+      }
+
+  -- Shrinking finds the shortest prefix of the list of operations that result
+  -- in a failed property, by simply testing prefixes in increasing order.
+  shrink setup = reverse $ takeWhileJust $ drop 1 (iterate reduce (Just setup))
+    where
+      reduce (Just (DbChangelogTestSetup (_:ops) dblog)) = Just $ DbChangelogTestSetup ops dblog
+      reduce _ = Nothing
+      takeWhileJust = catMaybes . takeWhile isJust
+
+instance Arbitrary DbChangelogTestSetupWithRollbacks where
+  arbitrary = do
+    setup <- arbitrary
+    let dblog = resultingDbChangelog setup
+    rolls <- chooseInt (0, AS.length (DbChangelog.changelogStates dblog))
+    pure $ DbChangelogTestSetupWithRollbacks
+      { testSetup = setup
+      , rollbacks = rolls
+      }
+
+  shrink setupWithRollback = toWithRollbacks <$> setups
+    where
+      setups = shrink (testSetup setupWithRollback)
+      shrinkRollback :: DbChangelogTestSetup -> Int -> Int
+      shrinkRollback setup rollbacks =
+        AS.length (DbChangelog.changelogStates $ resultingDbChangelog setup) `min` rollbacks
+      toWithRollbacks setup = DbChangelogTestSetupWithRollbacks {
+           testSetup = setup
+         , rollbacks = shrinkRollback setup (rollbacks setupWithRollback)
+         }
+
+resultingDbChangelog :: DbChangelogTestSetup -> DbChangelog TestLedger
+resultingDbChangelog setup = applyOperations (operations setup) originalDbChangelog
+  where
+    originalDbChangelog = DbChangelog.empty $ TestLedger EmptyMK theAnchor
+    theAnchor = pointAtSlot (dbChangelogStartsAt setup)
+
+applyOperations :: (HasLedgerTables l, GetTip l)
+  => [Operation l] -> DbChangelog l -> DbChangelog l
+applyOperations ops dblog = foldr' apply' dblog ops
+  where apply' (Extend newState) dblog' = DbChangelog.extend newState dblog'
+        apply' (Prune sp) dblog'        = DbChangelog.prune sp dblog'
+
+{-------------------------------------------------------------------------------
+  Properties
+-------------------------------------------------------------------------------}
+
+-- | Changelog states and diffs appear in one either the changelog to flush or the changelog to
+-- keep, moreover, the to flush changelog has no volatile states, and the to keep changelog has no
+-- immutable states.
+prop_flushingSplitsTheChangelog :: DbChangelogTestSetup -> Property
+prop_flushingSplitsTheChangelog setup = isNothing toFlush .||.
+    (    toKeepTip            === At toFlushTip
+    .&&. DS.fromAntiDiff (DS.cumulativeDiff diffs) === toFlushDiffs <> DS.fromAntiDiff (DS.cumulativeDiff toKeepDiffs)
+    )
+  where
+    dblog                                 = resultingDbChangelog setup
+    (toFlush, toKeep)                     = DbChangelog.splitForFlushing dblog
+    toFlushTip                            = maybe undefined DbChangelog.toFlushSlot toFlush
+    toKeepTip                             = DbChangelog.immutableTipSlot toKeep
+    LedgerTables (SeqDiffMK toKeepDiffs)  = DbChangelog.changelogDiffs toKeep
+    LedgerTables (DiffMK toFlushDiffs)    = maybe undefined DbChangelog.toFlushDiffs toFlush
+    LedgerTables (SeqDiffMK diffs)        = DbChangelog.changelogDiffs dblog
+
+-- | Extending the changelog adds the correct head to the volatile states.
+prop_extendingAdvancesTipOfVolatileStates :: DbChangelogTestSetup -> Property
+prop_extendingAdvancesTipOfVolatileStates setup =
+  property $ tlTip state == tlTip new
+  where
+    dblog  = resultingDbChangelog setup
+    state  = nextState dblog
+    dblog' = DbChangelog.extend state dblog
+    new    = AS.headAnchor (DbChangelog.changelogStates dblog')
+
+-- | Rolling back n extensions is the same as doing nothing.
+prop_rollbackAfterExtendIsNoop :: DbChangelogTestSetup -> Positive Int -> Property
+prop_rollbackAfterExtendIsNoop setup (Positive n) =
+    property (dblog == fromJust (DbChangelog.rollbackN (fromIntegral n) $ nExtensions n dblog))
+  where
+    dblog = resultingDbChangelog setup
+
+-- | The number of volatile states left after pruning is at most the maximum number of rollbacks.
+prop_pruningLeavesAtMostMaxRollbacksVolatileStates ::
+  DbChangelogTestSetup -> SecurityParam -> Property
+prop_pruningLeavesAtMostMaxRollbacksVolatileStates setup sp@(SecurityParam k) =
+  property $ AS.length (DbChangelog.changelogStates dblog') <= fromIntegral k
+  where
+    dblog = resultingDbChangelog setup
+    dblog' = DbChangelog.prune sp dblog
+
+-- | The rollbackToAnchor function rolls back all volatile states.
+prop_rollbackToAnchorIsRollingBackVolatileStates :: DbChangelogTestSetup -> Property
+prop_rollbackToAnchorIsRollingBackVolatileStates setup =
+  property $ rolledBack == toAnchor
+  where
+    dblog = resultingDbChangelog setup
+    n = AS.length (DbChangelog.changelogStates dblog)
+    rolledBack = fromJust $ DbChangelog.rollbackN (fromIntegral n) dblog
+    toAnchor = DbChangelog.rollbackToAnchor dblog
+
+-- | Rolling back to the last state is the same as doing nothing.
+prop_rollBackToVolatileTipIsNoop ::
+  Positive Int -> DbChangelogTestSetup -> Property
+prop_rollBackToVolatileTipIsNoop (Positive n) setup = property $ Just dblog == dblog'
+  where
+    dblog = resultingDbChangelog setup
+    pt = getTip $ DbChangelog.current dblog
+    dblog' = DbChangelog.rollbackToPoint pt $ nExtensions n dblog
+
+nExtensions :: Int -> DbChangelog TestLedger -> DbChangelog TestLedger
+nExtensions n dblog = iterate ext dblog !! n
+  where ext dblog' = DbChangelog.extend (nextState dblog') dblog'
+
+{-------------------------------------------------------------------------------
+  Generators
+-------------------------------------------------------------------------------}
+
+pointAtSlot :: WithOrigin SlotNo -> Point TestLedger
+pointAtSlot = Point.withOrigin GenesisPoint (\slotNo -> Point $ At $ Point.Block slotNo H)
+
+type Key = String
+
+data GenOperationsState = GenOperationsState {
+    -- | The current slot number on the sequence of generated operations
+    gosSlotNo            :: !(WithOrigin SlotNo)
+    -- | Accumulation of operations
+  , gosOps               :: ![Operation TestLedger]
+    -- | UTxOs in the UTxO set
+  , gosActiveUtxos       :: !(Map Key Int)
+    -- | UTxOs for which an insertion has been generated
+    --
+    -- Just after generation, they will be moved to 'gosActiveUtxos'
+  , gosPendingInsertions :: !(Map Key Int)
+    -- | UTxOs for which a delete has been generated
+  , gosConsumedUtxos     :: !(Set Key)
+  } deriving (Show)
+
+applyPending :: GenOperationsState -> GenOperationsState
+applyPending gosState = gosState
+  { gosActiveUtxos = Map.union (gosActiveUtxos gosState) (gosPendingInsertions gosState)
+  , gosPendingInsertions = Map.empty
+  }
+
+genOperations :: WithOrigin SlotNo -> Int -> Gen [Operation TestLedger]
+genOperations slotNo nOps = gosOps <$> execStateT (replicateM_ nOps genOperation) initState
+  where
+    initState = GenOperationsState {
+        gosSlotNo = slotNo
+      , gosActiveUtxos = Map.empty
+      , gosPendingInsertions = Map.empty
+      , gosConsumedUtxos = Set.empty
+      , gosOps = []
+      }
+
+    genOperation :: StateT GenOperationsState Gen ()
+    genOperation = do
+      op <- frequency' [ (1, genPrune), (10, genExtend) ]
+      modify' $ \st -> st { gosOps = op:gosOps st }
+
+    genPrune :: StateT GenOperationsState Gen (Operation TestLedger)
+    genPrune = Prune . SecurityParam <$> lift (chooseEnum (0, 10))
+
+    genExtend :: StateT GenOperationsState Gen (Operation TestLedger)
+    genExtend = do
+      nextSlotNo <- advanceSlotNo =<< lift (chooseEnum (1, 5))
+      d <- genUtxoDiff
+      pure $ Extend $ TestLedger (DiffMK $ DS.fromAntiDiff d) (castPoint $ pointAtSlot nextSlotNo)
+
+    advanceSlotNo :: SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo)
+    advanceSlotNo by = do
+      nextSlotNo <- gets (At . Point.withOrigin by (+ by) . gosSlotNo)
+      modify' $ \st -> st { gosSlotNo = nextSlotNo }
+      pure nextSlotNo
+
+    genUtxoDiff :: StateT GenOperationsState Gen (Diff.Diff Key Int)
+    genUtxoDiff = do
+      nEntries <- lift $ chooseInt (1, 10)
+      entries <- replicateM nEntries genUtxoDiffEntry
+      modify' applyPending
+      pure $ Diff.fromList entries
+
+    genUtxoDiffEntry :: StateT GenOperationsState Gen (Key, Diff.Delta Int)
+    genUtxoDiffEntry = do
+      activeUtxos <- gets gosActiveUtxos
+      consumedUtxos <- gets gosConsumedUtxos
+      oneof' $ catMaybes [
+        genDelEntry activeUtxos,
+        genInsertEntry consumedUtxos]
+
+    genDelEntry :: Map Key Int -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
+    genDelEntry activeUtxos =
+      if Map.null activeUtxos then Nothing
+      else Just $ do
+        (k, _) <- lift $ elements (Map.toList activeUtxos)
+        modify' $ \st -> st
+          { gosActiveUtxos = Map.delete k (gosActiveUtxos st)
+          }
+        pure (k, Diff.Delete)
+
+    genInsertEntry :: Set Key -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
+    genInsertEntry consumedUtxos = Just $ do
+      k <- lift $ genKey `suchThat` (`Set.notMember` consumedUtxos)
+      v <- lift arbitrary
+      modify' $ \st -> st
+        { gosPendingInsertions = Map.insert k v (gosPendingInsertions st)
+        , gosConsumedUtxos = Set.insert k (gosConsumedUtxos st)
+        }
+      pure (k, Diff.Insert v)
+
+genKey :: Gen Key
+genKey = replicateM 2 $ elements ['A'..'Z']
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/QuickCheck.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/QuickCheck.hs
deleted file mode 100644
index bf1218a03f..0000000000
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/QuickCheck.hs
+++ /dev/null
@@ -1,336 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- | In-memory ledger DB tests.
---
--- The in-memory component of the ledger DB is a bit tricky: it stores only a
--- few snapshots of the ledger state, in order to reduce memory footprint, but
--- must nonetheless be able to construct any ledger state (within @k@ blocks
--- from the chain tip) efficiently. The properties we are verify here are
--- various invariants of this data type, things such as
---
--- * Rolling back and then reapplying the same blocks is an identity operation
---   (provided the rollback is not too far)
--- * The shape of the datatype (where we store snapshots and how many we store)
---   always matches the policy set by the user, and is invariant under any of
---   the operations (add a block, switch to a fork, etc.)
--- * The maximum rollback supported is always @k@ (unless we are near genesis)
--- * etc.
---
-module Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.QuickCheck (tests) where
-
-import           Data.Maybe (fromJust)
-import           Data.Word
-import           Ouroboros.Consensus.Block
-import           Ouroboros.Consensus.BlockchainTime
-import           Ouroboros.Consensus.Config
-import qualified Ouroboros.Consensus.HardFork.History as HardFork
-import           Ouroboros.Consensus.Ledger.Abstract
-import           Ouroboros.Consensus.Storage.LedgerDB.API
-import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog hiding
-                     (tip)
-import           Ouroboros.Consensus.Util
-import           Test.QuickCheck
-import           Test.Tasty
-import           Test.Tasty.QuickCheck
-import           Test.Util.Orphans.Arbitrary ()
-import           Test.Util.QuickCheck
-import           Test.Util.TestBlock
-
-tests :: TestTree
-tests = testGroup "InMemory" [
-      testGroup "Genesis" [
-          testProperty "current"                prop_genesisCurrent
-        ]
-    , testGroup "Push" [
-          testProperty "expectedLedger"         prop_pushExpectedLedger
-        , testProperty "pastLedger"             prop_pastLedger
-        ]
-    , testGroup "Rollback" [
-          testProperty "maxRollbackGenesisZero" prop_maxRollbackGenesisZero
-        , testProperty "ledgerDbMaxRollback"    prop_snapshotsMaxRollback
-        , testProperty "switchSameChain"        prop_switchSameChain
-        , testProperty "switchExpectedLedger"   prop_switchExpectedLedger
-        , testProperty "pastAfterSwitch"        prop_pastAfterSwitch
-        ]
-    ]
-
-{-------------------------------------------------------------------------------
-  Genesis
--------------------------------------------------------------------------------}
-
-prop_genesisCurrent :: Property
-prop_genesisCurrent =
-    current genSnaps === convertMapKind testInitLedger
-  where
-    genSnaps = empty (convertMapKind testInitLedger)
-
-{-------------------------------------------------------------------------------
-  Constructing snapshots
--------------------------------------------------------------------------------}
-
-prop_pushExpectedLedger :: ChainSetup -> Property
-prop_pushExpectedLedger setup@ChainSetup{..} =
-    classify (chainSetupSaturated setup) "saturated" $
-      conjoin [
-          l === convertMapKind (refoldLedger cfg (expectedChain o) (convertMapKind testInitLedger))
-        | (o, l) <- snapshots csPushed
-        ]
-  where
-    expectedChain :: Word64 -> [TestBlock]
-    expectedChain o = take (fromIntegral (csNumBlocks - o)) csChain
-
-    cfg :: LedgerConfig TestBlock
-    cfg = ledgerDbCfg (csBlockConfig setup)
-
-prop_pastLedger :: ChainSetup -> Property
-prop_pastLedger setup@ChainSetup{..} =
-    classify (chainSetupSaturated setup) "saturated"    $
-    classify withinReach                 "within reach" $
-          getPastLedgerAt tip csPushed
-      === if withinReach
-            then Just (current afterPrefix)
-            else Nothing
-  where
-    prefix :: [TestBlock]
-    prefix = take (fromIntegral csPrefixLen) csChain
-
-    tip :: Point TestBlock
-    tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
-
-    afterPrefix :: DbChangelog (LedgerState TestBlock)
-    afterPrefix = reapplyThenPushMany' (csBlockConfig setup) prefix csGenSnaps
-
-    -- See 'prop_snapshotsMaxRollback'
-    withinReach :: Bool
-    withinReach = (csNumBlocks - csPrefixLen) <= maxRollback csPushed
-
-{-------------------------------------------------------------------------------
-  Rollback
--------------------------------------------------------------------------------}
-
-prop_maxRollbackGenesisZero :: Property
-prop_maxRollbackGenesisZero =
-        maxRollback (empty (convertMapKind testInitLedger))
-    === 0
-
-prop_snapshotsMaxRollback :: ChainSetup -> Property
-prop_snapshotsMaxRollback setup@ChainSetup{..} =
-    classify (chainSetupSaturated setup) "saturated" $
-      conjoin [
-          if chainSetupSaturated setup
-            then (maxRollback csPushed) `ge` k
-            else (maxRollback csPushed) `ge` (min k csNumBlocks)
-        , (maxRollback csPushed) `le` k
-        ]
-  where
-    SecurityParam k = csSecParam
-
-prop_switchSameChain :: SwitchSetup -> Property
-prop_switchSameChain setup@SwitchSetup{..} =
-    classify (switchSetupSaturated setup) "saturated" $
-          switch' (csBlockConfig ssChainSetup) ssNumRollback blockInfo csPushed
-      === Just csPushed
-  where
-    ChainSetup{csPushed} = ssChainSetup
-    blockInfo            = ssRemoved
-
-prop_switchExpectedLedger :: SwitchSetup -> Property
-prop_switchExpectedLedger setup@SwitchSetup{..} =
-    classify (switchSetupSaturated setup) "saturated" $
-      conjoin [
-          l === convertMapKind (refoldLedger cfg (expectedChain o) (convertMapKind testInitLedger))
-        | (o, l) <- snapshots ssSwitched
-        ]
-  where
-    expectedChain :: Word64 -> [TestBlock]
-    expectedChain o = take (fromIntegral (ssNumBlocks - o)) ssChain
-
-    cfg :: LedgerConfig TestBlock
-    cfg = ledgerDbCfg (csBlockConfig ssChainSetup)
-
--- | Check 'prop_pastLedger' still holds after switching to a fork
-prop_pastAfterSwitch :: SwitchSetup -> Property
-prop_pastAfterSwitch setup@SwitchSetup{..} =
-    classify (switchSetupSaturated setup) "saturated"    $
-    classify withinReach                  "within reach" $
-          getPastLedgerAt tip ssSwitched
-      === if withinReach
-            then Just (current afterPrefix)
-            else Nothing
-  where
-    prefix :: [TestBlock]
-    prefix = take (fromIntegral ssPrefixLen) ssChain
-
-    tip :: Point TestBlock
-    tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
-
-    afterPrefix :: DbChangelog (LedgerState TestBlock)
-    afterPrefix = reapplyThenPushMany' (csBlockConfig ssChainSetup) prefix (csGenSnaps ssChainSetup)
-
-    -- See 'prop_snapshotsMaxRollback'
-    withinReach :: Bool
-    withinReach = (ssNumBlocks - ssPrefixLen) <= maxRollback ssSwitched
-
-{-------------------------------------------------------------------------------
-  Test setup
--------------------------------------------------------------------------------}
-
-data ChainSetup = ChainSetup {
-      -- | Security parameter
-      csSecParam  :: SecurityParam
-
-      -- | Number of blocks applied
-    , csNumBlocks :: Word64
-
-      -- | Some prefix of the chain
-      --
-      -- Although we choose this to be less than or equal to 'csNumBlocks',
-      -- we don't guarantee this during shrinking. If 'csPrefixLen' is larger
-      -- than 'csNumBlocks', the prefix should simply be considered to be the
-      -- entire chain.
-    , csPrefixLen :: Word64
-
-      -- | Derived: genesis snapshots
-    , csGenSnaps  :: DbChangelog (LedgerState TestBlock)
-
-      -- | Derived: the actual blocks that got applied (old to new)
-    , csChain     :: [TestBlock]
-
-      -- | Derived: the snapshots after all blocks were applied
-    , csPushed    :: DbChangelog (LedgerState TestBlock)
-    }
-  deriving (Show)
-
-csBlockConfig :: ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
-csBlockConfig = csBlockConfig' . csSecParam
-
-csBlockConfig' :: SecurityParam -> LedgerDbCfg (LedgerState TestBlock)
-csBlockConfig' secParam = LedgerDbCfg {
-      ledgerDbCfgSecParam = secParam
-    , ledgerDbCfg         =
-          testBlockLedgerConfigFrom
-        $ HardFork.defaultEraParams secParam slotLength
-    }
-  where
-    slotLength = slotLengthFromSec 20
-
-chainSetupSaturated :: ChainSetup -> Bool
-chainSetupSaturated ChainSetup{..} = isSaturated csSecParam csPushed
-
-data SwitchSetup = SwitchSetup {
-      -- | Chain setup
-      ssChainSetup  :: ChainSetup
-
-      -- | Number of blocks to roll back
-    , ssNumRollback :: Word64
-
-      -- | Number of new blocks (to be applied after the rollback)
-    , ssNumNew      :: Word64
-
-      -- | Prefix of the new chain
-      --
-      -- See also 'csPrefixLen'
-    , ssPrefixLen   :: Word64
-
-      -- | Derived: number of blocks in the new chain
-    , ssNumBlocks   :: Word64
-
-      -- | Derived: the blocks that were removed
-    , ssRemoved     :: [TestBlock]
-
-      -- | Derived: the new blocks themselves
-    , ssNewBlocks   :: [TestBlock]
-
-      -- | Derived: the full chain after switching to this fork
-    , ssChain       :: [TestBlock]
-
-      -- | Derived; the snapshots after the switch was performed
-    , ssSwitched    :: DbChangelog (LedgerState TestBlock)
-    }
-  deriving (Show)
-
-switchSetupSaturated :: SwitchSetup -> Bool
-switchSetupSaturated = chainSetupSaturated . ssChainSetup
-
-mkTestSetup :: SecurityParam -> Word64 -> Word64 -> ChainSetup
-mkTestSetup csSecParam csNumBlocks csPrefixLen =
-    ChainSetup {..}
-  where
-    csGenSnaps = empty (convertMapKind testInitLedger)
-    csChain    = take (fromIntegral csNumBlocks) $
-                   iterate successorBlock (firstBlock 0)
-    csPushed   = reapplyThenPushMany' (csBlockConfig' csSecParam) csChain csGenSnaps
-
-mkRollbackSetup :: ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
-mkRollbackSetup ssChainSetup ssNumRollback ssNumNew ssPrefixLen =
-    SwitchSetup {..}
-  where
-    ChainSetup{..} = ssChainSetup
-
-    ssNumBlocks = csNumBlocks - ssNumRollback + ssNumNew
-    ssRemoved   = takeLast ssNumRollback csChain
-    ssNewBlocks = let afterRollback      = dropLast ssNumRollback csChain
-                      firstAfterRollback =
-                        case lastMaybe afterRollback of
-                          Nothing -> firstBlock 1
-                          Just b  -> modifyFork (+ 1) $ successorBlock b
-                  in take (fromIntegral ssNumNew) $
-                        iterate successorBlock firstAfterRollback
-    ssChain     = concat [
-                         take (fromIntegral (csNumBlocks - ssNumRollback)) csChain
-                       , ssNewBlocks
-                       ]
-    ssSwitched  = fromJust $ switch' (csBlockConfig ssChainSetup) ssNumRollback ssNewBlocks csPushed
-
-instance Arbitrary ChainSetup where
-  arbitrary = do
-      secParam <- arbitrary
-      let k = maxRollbacks secParam
-      numBlocks <- choose (0, k * 2)
-      prefixLen <- choose (0, numBlocks)
-      return $ mkTestSetup secParam numBlocks prefixLen
-
-  shrink ChainSetup{..} = concat [
-        -- Shrink the policy
-        [ mkTestSetup csSecParam' csNumBlocks csPrefixLen
-        | csSecParam' <- shrink csSecParam
-        ]
-
-        -- Reduce number of blocks
-      , [ mkTestSetup csSecParam csNumBlocks' csPrefixLen
-        | csNumBlocks' <- shrink csNumBlocks
-        ]
-      ]
-
-instance Arbitrary SwitchSetup where
-  arbitrary = do
-      chainSetup  <- arbitrary
-      numRollback <- choose (0, maxRollback (csPushed chainSetup))
-      numNew      <- choose (numRollback, 2 * numRollback)
-      prefixLen   <- choose (0, csNumBlocks chainSetup - numRollback + numNew)
-      return $ mkRollbackSetup chainSetup numRollback numNew prefixLen
-
-  shrink SwitchSetup{..} = concat [
-        -- If we shrink the chain setup, we might restrict max rollback
-        [ mkRollbackSetup ssChainSetup' ssNumRollback ssNumNew ssPrefixLen
-        | ssChainSetup' <- shrink ssChainSetup
-        , ssNumRollback <= maxRollback (csPushed ssChainSetup')
-        ]
-        -- Number of new blocks must be at least the rollback
-      , [ mkRollbackSetup ssChainSetup ssNumRollback ssNumNew' ssPrefixLen
-        | ssNumNew' <- shrink ssNumNew
-        , ssNumNew' >= ssNumRollback
-        ]
-        -- But rolling back less is always possible
-      , [ mkRollbackSetup ssChainSetup ssNumRollback' ssNumNew ssPrefixLen
-        | ssNumRollback' <- shrink ssNumRollback
-        ]
-      ]
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/Unit.hs
deleted file mode 100644
index 643c3d66e2..0000000000
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog/Unit.hs
+++ /dev/null
@@ -1,337 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog.Unit (tests) where
-
-import           Cardano.Slotting.Slot (WithOrigin (..), withOrigin)
-import           Control.Monad hiding (ap)
-import           Control.Monad.Trans.Class (lift)
-import           Control.Monad.Trans.State.Strict hiding (state)
-import           Data.Foldable
-import qualified Data.Map.Diff.Strict.Internal as Diff
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, fromJust, isJust, isNothing)
-import           Data.Set (Set)
-import qualified Data.Set as Set
-import           GHC.Generics (Generic)
-import           NoThunks.Class (NoThunks)
-import           Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
-import           Ouroboros.Consensus.Ledger.Basics
-import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
-                     (DbChangelog (..))
-import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
-import           Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
-import qualified Ouroboros.Network.AnchoredSeq as AS
-import           Ouroboros.Network.Block (HeaderHash, Point (..), SlotNo (..),
-                     StandardHash, castPoint, pattern GenesisPoint)
-import qualified Ouroboros.Network.Point as Point
-import           Test.QuickCheck
-import           Test.Tasty (TestTree, testGroup)
-import           Test.Tasty.QuickCheck (testProperty)
-import           Test.Util.Orphans.Arbitrary ()
-import           Test.Util.QuickCheck (frequency', oneof')
-import           Text.Show.Pretty (ppShow)
-
-samples :: Int
-samples = 1000
-
-tests :: TestTree
-tests = testGroup "DbChangelog"
-      [ testProperty "flushing" $ withMaxSuccess samples $ conjoin
-        [ counterexample "flushing keeps immutable tip"
-          prop_flushingSplitsTheChangelog
-        ]
-      , testProperty "rolling back" $ withMaxSuccess samples $ conjoin
-        [ counterexample "rollback after extension is noop"
-          prop_rollbackAfterExtendIsNoop
-        , counterexample "prefixing back to anchor is rolling back volatile states"
-          prop_prefixBackToAnchorIsRollingBackVolatileStates
-        , counterexample "prefix back to volatile tip is a noop"
-          prop_rollBackToVolatileTipIsNoop
-        ]
-      , testProperty "extending adds head to volatile states"
-        $ withMaxSuccess samples prop_extendingAdvancesTipOfVolatileStates
-      , testProperty "pruning leaves at most maxRollback volatile states"
-        $ withMaxSuccess samples prop_pruningLeavesAtMostMaxRollbacksVolatileStates
-      ]
-
-
-
-{-------------------------------------------------------------------------------
-  Test setup
--------------------------------------------------------------------------------}
-
-data TestLedger (mk :: MapKind) = TestLedger {
-  tlUtxos :: mk Key Int,
-  tlTip   :: Point TestLedger
-}
-
-nextState :: DbChangelog TestLedger -> TestLedger DiffMK
-nextState dblog = TestLedger {
-              tlTip = pointAtSlot $ nextSlot (getTipSlot old)
-            , tlUtxos = DiffMK mempty
-            }
-  where
-    old = DbChangelog.current dblog
-    nextSlot = At . withOrigin 1 (+1)
-
-
-deriving instance Show (mk Key Int) => Show (TestLedger mk)
-
-instance GetTip TestLedger where
-  getTip = castPoint . tlTip
-
-data H = H deriving (Eq, Ord, Show, Generic)
-deriving anyclass instance NoThunks H
-type instance HeaderHash TestLedger = H
-
-instance StandardHash TestLedger
-
-deriving instance Eq (TestLedger EmptyMK)
-
-type instance TxIn  TestLedger = Key
-type instance TxOut TestLedger = Int
-
-instance HasLedgerTables TestLedger where
-  projectLedgerTables                     = LedgerTables . tlUtxos
-  withLedgerTables st    (LedgerTables x) = st { tlUtxos = x }
-
-data DbChangelogTestSetup = DbChangelogTestSetup {
-  -- The operations are applied on the right, i.e., the newest operation is at the head of the list.
-    operations          :: [Operation TestLedger]
-  , dbChangelogStartsAt :: WithOrigin SlotNo
-  }
-
-data Operation l = Extend (l DiffMK) | Prune SecurityParam
-deriving instance Show (l DiffMK) => Show (Operation l)
-
-data DbChangelogTestSetupWithRollbacks = DbChangelogTestSetupWithRollbacks
-  { testSetup :: DbChangelogTestSetup
-  , rollbacks :: Int
-  } deriving (Show)
-
-instance Show DbChangelogTestSetup where
-  show = ppShow . operations
-
-instance Arbitrary DbChangelogTestSetup where
-  arbitrary = sized $ \n -> do
-    slotNo <- oneof [pure Origin, At . SlotNo <$> chooseEnum (1, 1000)]
-    ops <- genOperations slotNo n
-    pure $ DbChangelogTestSetup
-      { operations = ops
-      , dbChangelogStartsAt = slotNo
-      }
-
-  -- TODO: Shrinking might not be optimal. Shrinking finds the shortest prefix of the list of
-  -- operations that result in a failed property, by simply testing prefixes in increasing order.
-  shrink setup = reverse $ takeWhileJust $ drop 1 (iterate reduce (Just setup))
-    where
-      reduce (Just (DbChangelogTestSetup (_:ops) dblog)) = Just $ DbChangelogTestSetup ops dblog
-      reduce _ = Nothing
-      takeWhileJust = catMaybes . takeWhile isJust
-
-instance Arbitrary DbChangelogTestSetupWithRollbacks where
-  arbitrary = do
-    setup <- arbitrary
-    let dblog = resultingDbChangelog setup
-    rolls <- chooseInt (0, AS.length (DbChangelog.changelogStates dblog))
-    pure $ DbChangelogTestSetupWithRollbacks
-      { testSetup = setup
-      , rollbacks = rolls
-      }
-
-  shrink setupWithRollback = toWithRollbacks <$> setups
-    where
-      setups = shrink (testSetup setupWithRollback)
-      shrinkRollback :: DbChangelogTestSetup -> Int -> Int
-      shrinkRollback setup rollback =
-        AS.length (DbChangelog.changelogStates $ resultingDbChangelog setup) `min` rollback
-      toWithRollbacks setup = DbChangelogTestSetupWithRollbacks {
-           testSetup = setup
-         , rollbacks = shrinkRollback setup (rollbacks setupWithRollback)
-         }
-
-resultingDbChangelog :: DbChangelogTestSetup -> DbChangelog TestLedger
-resultingDbChangelog setup = applyOperations (operations setup) originalDbChangelog
-  where
-    originalDbChangelog = DbChangelog.empty $ TestLedger EmptyMK anchor
-    anchor = pointAtSlot (dbChangelogStartsAt setup)
-
-applyOperations :: (HasLedgerTables l, GetTip l)
-  => [Operation l] -> DbChangelog l -> DbChangelog l
-applyOperations ops dblog = foldr' apply' dblog ops
-  where apply' (Extend newState) dblog' = DbChangelog.extend newState dblog'
-        apply' (Prune sp) dblog'        = DbChangelog.prune sp dblog'
-
-{-------------------------------------------------------------------------------
-  Properties
--------------------------------------------------------------------------------}
-
--- | Changelog states and diffs appear in one either the changelog to flush or the changelog to
--- keep, moreover, the to flush changelog has no volatile states, and the to keep changelog has no
--- immutable states.
-prop_flushingSplitsTheChangelog :: DbChangelogTestSetup -> Property
-prop_flushingSplitsTheChangelog setup = isNothing toFlush .||.
-    (    toKeepTip            === At toFlushTip
-    .&&. DS.fromAntiDiff (cumulativeDiff diffs) === toFlushDiffs <> DS.fromAntiDiff (cumulativeDiff toKeepDiffs)
-    )
-  where
-    dblog                                 = resultingDbChangelog setup
-    (toFlush, toKeep)                     = DbChangelog.splitForFlushing dblog
-    toFlushTip                            = maybe undefined DbChangelog.toFlushSlot toFlush
-    toKeepTip                             = DbChangelog.immutableTipSlot toKeep
-    LedgerTables (SeqDiffMK toKeepDiffs)  = DbChangelog.changelogDiffs toKeep
-    LedgerTables (DiffMK toFlushDiffs)    = maybe undefined DbChangelog.toFlushDiffs toFlush
-    LedgerTables (SeqDiffMK diffs)        = DbChangelog.changelogDiffs dblog
-
--- | Extending the changelog adds the correct head to the volatile states.
-prop_extendingAdvancesTipOfVolatileStates :: DbChangelogTestSetup -> Property
-prop_extendingAdvancesTipOfVolatileStates setup =
-  property $ tlTip state == tlTip new
-  where
-    dblog  = resultingDbChangelog setup
-    state  = nextState dblog
-    dblog' = DbChangelog.extend state dblog
-    new    = AS.headAnchor (DbChangelog.changelogStates dblog')
-
--- | Rolling back n extensions is the same as doing nothing.
-prop_rollbackAfterExtendIsNoop :: DbChangelogTestSetup -> Positive Int -> Property
-prop_rollbackAfterExtendIsNoop setup (Positive n) =
-    property (dblog == fromJust (DbChangelog.rollbackN (fromIntegral n) $ nExtensions n dblog))
-  where
-    dblog = resultingDbChangelog setup
-
--- | The number of volatile states left after pruning is at most the maximum number of rollbacks.
-prop_pruningLeavesAtMostMaxRollbacksVolatileStates ::
-  DbChangelogTestSetup -> SecurityParam -> Property
-prop_pruningLeavesAtMostMaxRollbacksVolatileStates setup sp@(SecurityParam k) =
-  property $ AS.length (DbChangelog.changelogStates dblog') <= fromIntegral k
-  where
-    dblog = resultingDbChangelog setup
-    dblog' = DbChangelog.prune sp dblog
-
--- | The prefixBackToAnchor function rolls back all volatile states.
-prop_prefixBackToAnchorIsRollingBackVolatileStates :: DbChangelogTestSetup -> Property
-prop_prefixBackToAnchorIsRollingBackVolatileStates setup =
-  property $ rolledBack == toAnchor
-  where
-    dblog = resultingDbChangelog setup
-    n = AS.length (DbChangelog.changelogStates dblog)
-    rolledBack = fromJust $ DbChangelog.rollbackN (fromIntegral n) dblog
-    toAnchor = DbChangelog.rollbackToAnchor dblog
-
--- | Rolling back to the last state is the same as doing nothing.
-prop_rollBackToVolatileTipIsNoop ::
-  Positive Int -> DbChangelogTestSetup -> Property
-prop_rollBackToVolatileTipIsNoop (Positive n) setup = property $ Just dblog == dblog'
-  where
-    dblog = resultingDbChangelog setup
-    pt = getTip $ DbChangelog.current dblog
-    dblog' = DbChangelog.rollbackToPoint pt $ nExtensions n dblog
-
-nExtensions :: Int -> DbChangelog TestLedger -> DbChangelog TestLedger
-nExtensions n dblog = iterate ext dblog !! n
-  where ext dblog' = DbChangelog.extend (nextState dblog') dblog'
-
-{-------------------------------------------------------------------------------
-  Generators
--------------------------------------------------------------------------------}
-
-pointAtSlot :: WithOrigin SlotNo -> Point TestLedger
-pointAtSlot = Point.withOrigin GenesisPoint (\slotNo -> Point $ At $ Point.Block slotNo H)
-
-type Key = String
-
-data GenOperationsState = GenOperationsState {
-    gosSlotNo            :: !(WithOrigin SlotNo)
-  , gosOps               :: ![Operation TestLedger]
-  , gosActiveUtxos       :: !(Map Key Int)
-  , gosPendingInsertions :: !(Map Key Int)
-  , gosConsumedUtxos     :: !(Set Key)
-  } deriving (Show)
-
-applyPending :: GenOperationsState -> GenOperationsState
-applyPending gosState = gosState
-  { gosActiveUtxos = Map.union (gosActiveUtxos gosState) (gosPendingInsertions gosState)
-  , gosPendingInsertions = Map.empty
-  }
-
-genOperations :: WithOrigin SlotNo -> Int -> Gen [Operation TestLedger]
-genOperations slotNo nOps = gosOps <$> execStateT (replicateM_ nOps genOperation) initState
-  where
-    initState = GenOperationsState {
-        gosSlotNo = slotNo
-      , gosActiveUtxos = Map.empty
-      , gosPendingInsertions = Map.empty
-      , gosConsumedUtxos = Set.empty
-      , gosOps = []
-      }
-
-    genOperation :: StateT GenOperationsState Gen ()
-    genOperation = do
-      op <- frequency' [ (1, genPrune), (10, genExtend) ]
-      modify' $ \st -> st { gosOps = op:gosOps st }
-
-    genPrune :: StateT GenOperationsState Gen (Operation TestLedger)
-    genPrune = Prune . SecurityParam <$> lift (chooseEnum (0, 10))
-
-    genExtend :: StateT GenOperationsState Gen (Operation TestLedger)
-    genExtend = do
-      nextSlotNo <- advanceSlotNo =<< lift (chooseEnum (1, 5))
-      d <- genUtxoDiff
-      pure $ Extend $ TestLedger (DiffMK $ DS.fromAntiDiff d) (castPoint $ pointAtSlot nextSlotNo)
-
-    advanceSlotNo :: SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo)
-    advanceSlotNo by = do
-      nextSlotNo <- gets (At . Point.withOrigin by (+ by) . gosSlotNo)
-      modify' $ \st -> st { gosSlotNo = nextSlotNo }
-      pure nextSlotNo
-
-    genUtxoDiff :: StateT GenOperationsState Gen (Diff.Diff Key Int)
-    genUtxoDiff = do
-      nEntries <- lift $ chooseInt (1, 10)
-      entries <- replicateM nEntries genUtxoDiffEntry
-      modify' applyPending
-      pure $ Diff.fromList entries
-
-    genUtxoDiffEntry :: StateT GenOperationsState Gen (Key, Diff.Delta Int)
-    genUtxoDiffEntry = do
-      activeUtxos <- gets gosActiveUtxos
-      consumedUtxos <- gets gosConsumedUtxos
-      oneof' $ catMaybes [
-        genDelEntry activeUtxos,
-        genInsertEntry consumedUtxos]
-
-    genDelEntry :: Map Key Int -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
-    genDelEntry activeUtxos =
-      if Map.null activeUtxos then Nothing
-      else Just $ do
-        (k, _) <- lift $ elements (Map.toList activeUtxos)
-        modify' $ \st -> st
-          { gosActiveUtxos = Map.delete k (gosActiveUtxos st)
-          }
-        pure (k, Diff.Delete)
-
-    genInsertEntry :: Set Key -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
-    genInsertEntry consumedUtxos = Just $ do
-      k <- lift $ genKey `suchThat` (`Set.notMember` consumedUtxos)
-      v <- lift arbitrary
-      modify' $ \st -> st
-        { gosPendingInsertions = Map.insert k v (gosPendingInsertions st)
-        , gosConsumedUtxos = Set.insert k (gosConsumedUtxos st)
-        }
-      pure (k, Diff.Insert v)
-
-genKey :: Gen Key
-genKey = replicateM 2 $ elements ['A'..'Z']
diff --git a/scripts/ci/run-cabal-gild.sh b/scripts/ci/run-cabal-gild.sh
index cb352ed8c9..546757fb20 100755
--- a/scripts/ci/run-cabal-gild.sh
+++ b/scripts/ci/run-cabal-gild.sh
@@ -24,4 +24,4 @@ $fdcmd --full-path "$path" -e cabal -x cabal-gild -i {} -o {}
 case "$(uname -s)" in
     MINGW*) git ls-files --eol | grep "w/crlf" | awk '{print $4}' | xargs dos2unix;;
     *) ;;
-esac
+esac || true
diff --git a/scripts/ci/run-stylish.sh b/scripts/ci/run-stylish.sh
index 58e1fae420..b03028cc86 100755
--- a/scripts/ci/run-stylish.sh
+++ b/scripts/ci/run-stylish.sh
@@ -3,6 +3,7 @@
 set -e
 
 echo "The custom options for formatting this repo are:"
+stylish-haskell --version
 stylish-haskell --defaults | diff - ./.stylish-haskell.yaml | grep -E "^>.*[[:alnum:]]" | grep -v "#"
 printf "\nFormatting haskell files...\n"
 
@@ -26,30 +27,9 @@ esac
 
 $fdcmd --full-path "$path" \
        --extension hs \
-       --exclude Setup.hs \
-       --exclude ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs \
-       --exclude ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs \
-       --exclude ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Init.hs \
-       --exclude ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Init.hs \
-       --exclude ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs \
-       --exclude ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs \
-       --exclude ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs \
        --exec-batch stylish-haskell -c .stylish-haskell.yaml -i
 
-# We don't want these pragmas to be removed accidentally
-f () {
-    grep "#if __GLASGOW_HASKELL__.*
-import" $1 >/dev/null 2>&1
-}
-f ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs
-f ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs
-f ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Init.hs
-f ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Init.hs
-f ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs
-f ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs
-f ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs
-
 case "$(uname -s)" in
     MINGW*) git ls-files --eol | grep "w/crlf" | awk '{print $4}' | xargs dos2unix;;
     *) ;;
-esac
+esac || true