Fix rebase

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -450,7 +450,6 @@ test-suite cardano-test
     cardano-ledger-alonzo-test,
     cardano-ledger-api,
     cardano-ledger-babbage-test,
-    cardano-ledger-binary,
     cardano-ledger-binary:testlib,
     cardano-ledger-byron,
     cardano-ledger-conway:testlib,

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs

@@ -332,7 +332,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where
     => BlockQuery (ShelleyBlock proto era) QFNoTables (CG.RatifyState era)
 
   GetFuturePParams
-    :: BlockQuery (ShelleyBlock proto era) (Maybe (LC.PParams era))
+    :: BlockQuery (ShelleyBlock proto era) QFNoTables (Maybe (LC.PParams era))
 
   -- | Obtain a snapshot of big ledger peers. CLI can serialize these,
   -- and if made available to the node by topology configuration,

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs

@@ -15,6 +15,7 @@ import           Control.Monad (when)
 import           Control.Monad.Except (runExcept)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import           Control.ResourceRegistry
 import           Control.Tracer as Trace (nullTracer)
 import           Data.Either (isRight)
 import           Data.Maybe (isJust)
@@ -45,7 +46,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunis
 import           Ouroboros.Consensus.Storage.LedgerDB.API
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util.IOLike (atomically)
-import           Ouroboros.Consensus.Util.ResourceRegistry
 import           Ouroboros.Network.AnchoredFragment as AF (Anchor (..),
                      AnchoredFragment, AnchoredSeq (..), headPoint)
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type

ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs

@@ -17,7 +17,6 @@ import qualified Cardano.Chain.Block as Byron
 import qualified Cardano.Chain.UTxO as Byron
 import           Cardano.Ledger.Alonzo ()
 import           Cardano.Ledger.BaseTypes (Network (Testnet), TxIx (..))
-import           Cardano.Ledger.Binary.Version
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as Crypto
 import qualified Cardano.Ledger.Genesis as Genesis
@@ -35,7 +34,6 @@ import           Cardano.Slotting.EpochInfo (fixedEpochInfo)
 import           Cardano.Slotting.Slot (EpochNo (..))
 import qualified Data.ListMap as ListMap
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromMaybe)
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Functors
 import           Data.SOP.InPairs (RequiringBoth (..), provideBoth)
@@ -56,8 +54,6 @@ import           Ouroboros.Consensus.Ledger.Tables.Diff (Diff)
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
 import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Protocol.Praos
-import           Ouroboros.Consensus.Protocol.Praos.Common
-                     (MaxMajorProtVer (..))
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.HFEras ()
@@ -380,7 +376,6 @@ fixedShelleyLedgerConfig translationContext = mkShelleyLedgerConfig
     shelleyGenesis
     translationContext
     (fixedEpochInfo (sgEpochLength shelleyGenesis) (slotLengthFromSec 2))
-    (MaxMajorProtVer (fromMaybe (error "this will never trigger") $ mkVersion (10 :: Int)))
   where
     shelleyGenesis = ShelleyGenesis {
         sgSystemStart       = dawnOfTime

ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs

@@ -30,6 +30,7 @@ import           Data.Maybe (maybeToList)
 import           Data.Proxy (Proxy (..))
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.SOP.Functors
 import           Data.Word (Word64)
 import           Lens.Micro
 import           Ouroboros.Consensus.Block.Forging (BlockForging)
@@ -530,9 +531,9 @@ setByronProtVer =
     modifyExtLedger f elgr = elgr { ledgerState = f (ledgerState elgr ) }
 
     modifyHFLedgerState ::
-         (LedgerState x -> LedgerState x)
-      -> LedgerState (HardForkBlock (x : xs))
-      -> LedgerState (HardForkBlock (x : xs))
+         (LedgerState x mk -> LedgerState x mk)
+      -> LedgerState (HardForkBlock (x : xs)) mk
+      -> LedgerState (HardForkBlock (x : xs)) mk
     modifyHFLedgerState f (HardForkLedgerState (HardForkState (TZ st))) =
-        HardForkLedgerState (HardForkState (TZ st {currentState = f (currentState st)}))
+        HardForkLedgerState (HardForkState (TZ st {currentState = Flip $ f (unFlip $ currentState st)}))
     modifyHFLedgerState _ st = st

ouroboros-consensus/ouroboros-consensus.cabal

@@ -602,7 +602,6 @@ test-suite consensus-test
     fingertree-rm,
     fs-api ^>=0.3,
     fs-sim,
-    generics-sop,
     hashable,
     io-classes,
     io-sim,
@@ -632,7 +631,6 @@ test-suite consensus-test
     time,
     transformers,
     transformers-base,
-    tree-diff,
     typed-protocols ^>=0.3,
     typed-protocols-examples,
     typed-protocols-stateful,

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Diff.hs

@@ -210,7 +210,7 @@ toAntiDiff :: Diff k v -> Anti.Diff k v
 toAntiDiff (Diff d) = Anti.Diff (Map.map f d)
   where
     f (Insert v) = Anti.singletonInsert v
-    f Delete     = Anti.singletonDelete undefined
+    f Delete     = Anti.singletonDelete
 
 {-------------------------------------------------------------------------------
   Traversals and folds

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs

@@ -473,10 +473,3 @@ deriving instance ( Show (GenTx blk)
                   , Show (ApplyTxErr blk)
                   , StandardHash blk
                   ) => Show (TraceEventMempool blk)
-
-deriving instance ( NoThunks (GenTx blk)
-                  , NoThunks (Validated (GenTx blk))
-                  , NoThunks (GenTxId blk)
-                  , NoThunks (ApplyTxErr blk)
-                  , StandardHash blk
-                  ) => NoThunks (TraceEventMempool blk)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs

@@ -440,8 +440,8 @@ implSyncWithLedger mpEnv = do
             -- If the point is gone, resync
             pure (Resync, is)
   case res of
-    OK v -> pure v
-    Resync -> implSyncWithLedger mpEnv
+    OK v    -> pure v
+    Resync  -> implSyncWithLedger mpEnv
     Retry _ -> error "Impossible!"
   where
     MempoolEnv { mpEnvStateVar         = istate

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs

@@ -38,7 +38,8 @@ import           Control.Monad (void, when)
 import           Control.Monad.Base (MonadBase)
 import           Control.Monad.Trans.Class (lift)
 import           Control.ResourceRegistry (WithTempRegistry, allocate,
-                     runInnerWithTempRegistry, runWithTempRegistry)
+                     runInnerWithTempRegistry, runWithTempRegistry,
+                     withRegistry)
 import           Control.Tracer
 import           Data.Functor ((<&>))
 import           Data.Functor.Contravariant ((>$<))

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs

@@ -25,6 +25,7 @@ import           Control.Monad (forM, forM_, unless, void, when)
 import           Control.Monad.Except ()
 import           Control.Monad.Trans.Class (lift)
 import           Control.Monad.Trans.State.Strict
+import           Control.ResourceRegistry (ResourceRegistry, withRegistry)
 import           Control.Tracer (Tracer, nullTracer, traceWith)
 import           Data.Foldable (for_)
 import           Data.Function (on)
@@ -81,8 +82,6 @@ import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.AnchoredFragment
 import           Ouroboros.Consensus.Util.Enclose (encloseWith)
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry,
-                     withRegistry)
 import           Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 import           Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment,
                      AnchoredSeq (..))

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs

@@ -29,6 +29,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query (
   , getAnyKnownBlockComponent
   ) where
 
+import           Control.ResourceRegistry (ResourceRegistry)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import           Ouroboros.Consensus.Block
@@ -49,7 +50,6 @@ import           Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import           Ouroboros.Consensus.Util (eitherToMaybe)
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 import           Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Stream.hs

@@ -12,13 +12,13 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Stream (
   ) where
 
 import           Control.Monad.Except
+import           Control.ResourceRegistry
 import           GHC.Stack
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Storage.Common
 import           Ouroboros.Consensus.Storage.ImmutableDB hiding (streamAll)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry
 
 {-------------------------------------------------------------------------------
   Abstraction over the streaming API provided by the Chain DB

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs

@@ -157,6 +157,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.API (
 
 import           Control.Monad (forM)
 import           Control.Monad.Class.MonadTime.SI
+import           Control.ResourceRegistry
 import           Data.Kind
 import           Data.Set (Set)
 import           Data.Word
@@ -170,7 +171,6 @@ import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
 import           Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots
 import           Ouroboros.Consensus.Util.CallStack
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type
 
 {-------------------------------------------------------------------------------

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Impl/Args.hs

@@ -19,6 +19,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Impl.Args (
   , defaultArgs
   ) where
 
+import           Control.ResourceRegistry
 import           Control.Tracer
 import           Data.Kind
 import           Ouroboros.Consensus.Ledger.Abstract
@@ -29,7 +30,6 @@ import           Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import           Ouroboros.Consensus.Util.Args
-import           Ouroboros.Consensus.Util.ResourceRegistry
 import           System.FS.API
 
 {-------------------------------------------------------------------------------

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Impl/Validate.hs

@@ -29,6 +29,7 @@ import           Control.Monad.Except (ExceptT (..), MonadError (..), runExcept,
                      runExceptT)
 import           Control.Monad.Reader (ReaderT (..))
 import           Control.Monad.Trans (MonadTrans (..))
+import           Control.ResourceRegistry
 import           Data.Kind
 import           Data.Set (Set)
 import qualified Data.Set as Set
@@ -43,7 +44,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCac
 import           Ouroboros.Consensus.Storage.LedgerDB.API hiding (validate)
 import           Ouroboros.Consensus.Util.CallStack
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry
 
 {-------------------------------------------------------------------------------
   Validation

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs

@@ -463,7 +463,7 @@ newLMDBBackingStore dbTracer limits liveFS@(API.LiveLMDBFS liveFS') snapFS@(API.
              IOLike.atomically $ IOLike.writeTVar dbOpenHandles mempty
              liftIO $ LMDB.closeEnvironment dbEnv
              Trace.traceWith dbTracer API.BSClosed
-             pure (Closed, ())
+             pure ((), Closed)
             where
               traceAlreadyClosed = Trace.traceWith dbTracer API.BSAlreadyClosed
 
@@ -541,7 +541,7 @@ mkLMDBBackingStoreValueHandle db = do
         runCleanup cleanup
         IOLike.atomically $ IOLike.modifyTVar' dbOpenHandles (Map.delete vhId)
         Trace.traceWith tracer API.BSVHClosed
-        pure (Closed, ())
+        pure ((), Closed)
       where
         traceAlreadyClosed    = Trace.traceWith dbTracer API.BSAlreadyClosed
         traceTVHAlreadyClosed = Trace.traceWith tracer API.BSVHAlreadyClosed

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Status.hs

@@ -18,12 +18,12 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status (
   ) where
 
 import           Control.Exception (Exception)
+import           Control.RAWLock (RAWLock)
+import qualified Control.RAWLock as RAW
 import           Data.Functor ((<&>))
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Util.IOLike (IOLike, MonadThrow (throwIO))
-import           Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock)
-import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAW
 
 {-------------------------------------------------------------------------------
   Status
@@ -58,7 +58,7 @@ withWriteAccess ::
      (IOLike m, Exception e)
   => StatusLock m
   -> e                -- ^ The exception to throw
-  -> m (Status, a)    -- ^ Action to perform, possibly updating the 'Status'
+  -> m (a, Status)    -- ^ Action to perform, possibly updating the 'Status'
   -> m a
 withWriteAccess lock exc k =
   RAW.withWriteAccess (getStatusLock lock) $ \case
@@ -70,12 +70,12 @@ withWriteAccess' ::
      IOLike m
   => StatusLock m
   -> m a
-  -> m (Status, a)
+  -> m (a, Status)
   -> m a
 withWriteAccess' lock def k =
     RAW.withWriteAccess (getStatusLock lock) $ \case
       Open   -> k
-      Closed -> def <&> (Closed,)
+      Closed -> def <&> (,Closed)
 
 -- | A variant of 'RAW.withReadAccess' that throws an exception if @'Status' ==
 -- 'Closed'@.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Common.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 #if __GLASGOW_HASKELL__ <= 906
 {-# LANGUAGE GADTs #-}
@@ -104,7 +105,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv {
     -- - when taking a snapshot of the ledger db, we need to prevent others
     --   from altering the backing store at the same time, thus we acquire a
     --   Write lock.
-  , ldbLock           :: !(LedgerDBLock m)
+  , ldbLock           :: !(AllowThunk (LedgerDBLock m))
     -- | INVARIANT: this set contains only points that are in the
     -- VolatileDB.
     --

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs

@@ -18,12 +18,14 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Forker (
   , acquireAtWellKnownPoint
   ) where
 
+import           Control.ResourceRegistry
 import           Control.Tracer
 import           Data.Functor.Contravariant ((>$<))
 import qualified Data.Map.Strict as Map
 import           Data.Semigroup
 import qualified Data.Set as Set
 import           Data.Word
+import           NoThunks.Class
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
@@ -42,7 +44,6 @@ import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type
 
 {-------------------------------------------------------------------------------
@@ -59,8 +60,8 @@ newForkerAtWellKnownPoint ::
   -> ResourceRegistry m
   -> Target (Point blk)
   -> m (Forker m l blk)
-newForkerAtWellKnownPoint h rr pt = getEnv h $ \ldbEnv -> do
-    withReadLock (ldbLock ldbEnv) (acquireAtWellKnownPoint ldbEnv rr pt) >>= newForker h ldbEnv
+newForkerAtWellKnownPoint h rr pt = getEnv h $ \ldbEnv@LedgerDBEnv{ldbLock = AllowThunk lock} -> do
+    withReadLock lock (acquireAtWellKnownPoint ldbEnv rr pt) >>= newForker h ldbEnv
 
 newForkerAtPoint ::
      ( HeaderHash l ~ HeaderHash blk
@@ -74,8 +75,8 @@ newForkerAtPoint ::
   -> ResourceRegistry m
   -> Point blk
   -> m (Either GetForkerError (Forker m l blk))
-newForkerAtPoint h rr pt = getEnv h $ \ldbEnv -> do
-    withReadLock (ldbLock ldbEnv) (acquireAtPoint ldbEnv rr pt) >>= traverse (newForker h ldbEnv)
+newForkerAtPoint h rr pt = getEnv h $ \ldbEnv@LedgerDBEnv{ldbLock = AllowThunk lock} -> do
+    withReadLock lock (acquireAtPoint ldbEnv rr pt) >>= traverse (newForker h ldbEnv)
 
 newForkerAtFromTip ::
      ( IOLike m
@@ -87,8 +88,8 @@ newForkerAtFromTip ::
   -> ResourceRegistry m
   -> Word64
   -> m (Either ExceededRollback (Forker m l blk))
-newForkerAtFromTip h rr n = getEnv h $ \ldbEnv -> do
-    withReadLock (ldbLock ldbEnv) (acquireAtFromTip ldbEnv rr n) >>= traverse (newForker h ldbEnv)
+newForkerAtFromTip h rr n = getEnv h $ \ldbEnv@LedgerDBEnv{ldbLock = AllowThunk lock} -> do
+    withReadLock lock (acquireAtFromTip ldbEnv rr n) >>= traverse (newForker h ldbEnv)
 
 -- | Close all open block and header 'Follower's.
 closeAllForkers ::