Split out ImmutableEraParams

ouroboros-consensus-cardano/changelog.d/20241218_095046_nick.frisby_annotate_headers_with_time.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Update now that `ImmutableEraParams` was split out
+

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs

@@ -50,9 +50,11 @@ type ByronBlockHFC = HardForkBlock '[ByronBlock]
   NoHardForks instance
 -------------------------------------------------------------------------------}
 
-instance NoHardForks ByronBlock where
-  getEraParams cfg =
+instance ImmutableEraParams ByronBlock where
+  immutableEraParams cfg =
       byronEraParamsNeverHardForks (byronGenesisConfig (configBlock cfg))
+
+instance NoHardForks ByronBlock where
   toPartialLedgerConfig _ cfg = ByronPartialLedgerConfig {
         byronLedgerConfig    = cfg
       , byronTriggerHardFork = TriggerHardForkNotDuringThisExecution

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

@@ -76,13 +76,17 @@ type ShelleyBlockHFC proto era = HardForkBlock '[ShelleyBlock proto era]
 
 instance ( ShelleyCompatible proto era
          , LedgerSupportsProtocol (ShelleyBlock proto era)
-         , TxLimits (ShelleyBlock proto era)
-         , Crypto (ProtoCrypto proto)
-         ) => NoHardForks (ShelleyBlock proto era) where
-  getEraParams =
+         ) => ImmutableEraParams (ShelleyBlock proto era) where
+  immutableEraParams =
         shelleyEraParamsNeverHardForks
       . shelleyLedgerGenesis
       . configLedger
+
+instance ( ShelleyCompatible proto era
+         , LedgerSupportsProtocol (ShelleyBlock proto era)
+         , TxLimits (ShelleyBlock proto era)
+         , Crypto (ProtoCrypto proto)
+         ) => NoHardForks (ShelleyBlock proto era) where
   toPartialLedgerConfig _ cfg = ShelleyPartialLedgerConfig {
         shelleyLedgerConfig    = cfg
       , shelleyTriggerHardFork = TriggerHardForkNotDuringThisExecution

ouroboros-consensus/changelog.d/20241218_095010_nick.frisby_annotate_headers_with_time.md

@@ -0,0 +1,19 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+### Breaking
+
+- Split out `ImmutableEraParams` so that the test blocks don't have to
+  instantiate the `SingleEraBlock` omnibus.
+
+- Remove the `NoThunks Bimap` orphan instance (it's now upstream in the `resource-registry` library).

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs

@@ -154,7 +154,7 @@ type instance BlockProtocol (Header blk) = BlockProtocol blk
 
 type instance HeaderHash (Header blk) = HeaderHash blk
 
-instance HasHeader blk => StandardHash (Header blk)
+instance StandardHash blk => StandardHash (Header blk)
 
 -- | Get the 'HeaderFields' of a block, without requiring 'HasHeader blk'
 --

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -87,17 +86,15 @@ blockRealPoint blk = RealPoint s h
     HeaderFields { headerFieldSlot = s, headerFieldHash = h } = getHeaderFields blk
 
 headerRealPoint ::
-    ( HasHeader (Header blk)
-#if __GLASGOW_HASKELL__ >= 904
--- GHC 9.4+ considers these constraints insufficient.
-    , HasHeader blk
-#endif
-    )
+       forall blk. HasHeader (Header blk)
     => Header blk
     -> RealPoint blk
 headerRealPoint hdr = RealPoint s h
   where
-    HeaderFields { headerFieldSlot = s, headerFieldHash = h } = getHeaderFields hdr
+    HeaderFields { headerFieldSlot = s, headerFieldHash = h } = hf
+
+    hf :: HeaderFields (Header blk)
+    hf = getHeaderFields hdr
 
 realPointToPoint :: RealPoint blk -> Point blk
 realPointToPoint (RealPoint s h) = BlockPoint s h

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs

@@ -1,6 +1,7 @@
 module Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks (
-    NoHardForks (..)
-  , noHardForksEpochInfo
+    ImmutableEraParams (..)
+  , NoHardForks (..)
+  , immutableEpochInfo
   ) where
 
 import           Cardano.Slotting.EpochInfo
@@ -15,28 +16,39 @@ import           Ouroboros.Consensus.Ledger.Abstract
   Blocks that don't /have/ any transitions
 -------------------------------------------------------------------------------}
 
-class SingleEraBlock blk => NoHardForks blk where
+-- | A block type for which the 'EraParams' will /never/ change
+--
+-- Technically, some application of
+-- 'Ouroboros.Consensus.HardFork.Combinator.Basics.HardForkBlock' could have an
+-- instance for this. But that would only be appropriate if two conditions were
+-- met.
+--
+-- * all the eras in that block have the same 'EraParams'
+--
+-- * all eras that will /ever/ be added to that block in the future will also
+--   have those same 'EraParams'
+class ImmutableEraParams blk where
   -- | Extract 'EraParams' from the top-level config
   --
   -- The HFC itself does not care about this, as it must be given the full shape
   -- across /all/ eras.
-  getEraParams :: TopLevelConfig blk -> EraParams
-
+  immutableEraParams :: TopLevelConfig blk -> EraParams
 
+class (SingleEraBlock blk, ImmutableEraParams blk) => NoHardForks blk where
   -- | Construct partial ledger config from full ledger config
   --
   -- See also 'toPartialConsensusConfig'
   toPartialLedgerConfig :: proxy blk
                         -> LedgerConfig blk -> PartialLedgerConfig blk
 
-noHardForksEpochInfo :: (Monad m, NoHardForks blk)
-                     => TopLevelConfig blk
-                     -> EpochInfo m
-noHardForksEpochInfo cfg =
+immutableEpochInfo :: (Monad m, ImmutableEraParams blk)
+                   => TopLevelConfig blk
+                   -> EpochInfo m
+immutableEpochInfo cfg =
       hoistEpochInfo (pure . runIdentity)
     $ fixedEpochInfo
         (History.eraEpochSize  params)
         (History.eraSlotLength params)
   where
     params :: EraParams
-    params = getEraParams cfg
+    params = immutableEraParams cfg

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs

@@ -267,7 +267,7 @@ instance Isomorphic TopLevelConfig where
         emptyCheckpointsMap
     where
       ei :: EpochInfo (Except PastHorizonException)
-      ei = noHardForksEpochInfo $ project tlc
+      ei = immutableEpochInfo $ project tlc
 
       auxLedger :: LedgerConfig (HardForkBlock '[blk]) -> LedgerConfig blk
       auxLedger =
@@ -297,7 +297,7 @@ instance Isomorphic TopLevelConfig where
         (inject       $ configStorage   tlc)
         emptyCheckpointsMap
     where
-      eraParams = getEraParams tlc
+      eraParams = immutableEraParams tlc
 
       auxLedger :: LedgerConfig blk -> LedgerConfig (HardForkBlock '[blk])
       auxLedger cfg = HardForkLedgerConfig {
@@ -423,15 +423,15 @@ instance Functor m => Isomorphic (BlockForging m) where
                                    (inject cfg)
                                    sno
                                    (injTickedChainDepSt
-                                     (noHardForksEpochInfo cfg)
+                                     (immutableEpochInfo cfg)
                                      tickedChainDepSt)
       , checkCanForge    = \cfg sno tickedChainDepSt isLeader forgeStateInfo ->
                                first (project' (Proxy @(WrapCannotForge blk))) $
                                  checkCanForge
                                    (inject cfg)
                                    sno
                                    (injTickedChainDepSt
-                                     (noHardForksEpochInfo cfg)
+                                     (immutableEpochInfo cfg)
                                      tickedChainDepSt)
                                    (inject' (Proxy @(WrapIsLeader blk)) isLeader)
                                    (inject' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs

@@ -56,6 +56,7 @@ import           Codec.Serialise (Serialise (..))
 import qualified Control.Exception as Exn
 import           Control.Monad (unless)
 import           Control.Monad.Except (throwError)
+import           Control.ResourceRegistry ()
 import           Data.Bifunctor (first)
 import           Data.Bimap (Bimap)
 import qualified Data.Bimap as Bimap

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs

@@ -19,17 +19,14 @@ import           Cardano.Ledger.Genesis (NoGenesis (..))
 import           Codec.CBOR.Decoding (Decoder)
 import           Codec.Serialise (Serialise (..))
 import           Control.Tracer (Tracer)
-import           Data.Bimap (Bimap)
-import qualified Data.Bimap as Bimap
 import           Data.IntPSQ (IntPSQ)
 import qualified Data.IntPSQ as PSQ
 import           Data.MultiSet (MultiSet)
 import qualified Data.MultiSet as MultiSet
 import           Data.SOP.BasicFunctors
 import           GHC.TypeLits (KnownNat)
 import           NoThunks.Class (InspectHeap (..), InspectHeapNamed (..),
-                     NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks,
-                     noThunksInKeysAndValues)
+                     NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks)
 import           Ouroboros.Network.Util.ShowProxy
 import           System.FS.API (SomeHasFS)
 import           System.FS.API.Types (FsPath, Handle)
@@ -53,10 +50,6 @@ instance NoThunks (NoGenesis era) where
   showTypeOf _ = "NoGenesis"
   wNoThunks _ NoGenesis = return Nothing
 
-instance (NoThunks k, NoThunks v)
-      => NoThunks (Bimap k v) where
-  wNoThunks ctxt = noThunksInKeysAndValues ctxt . Bimap.toList
-
 instance ( NoThunks p
          , NoThunks v
          , Ord p

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs

@@ -305,7 +305,7 @@ newtype instance Header (TestBlockWith ptype) =
 
 instance Typeable ptype => ShowProxy (Header (TestBlockWith ptype)) where
 
-instance (Typeable ptype, Eq ptype) => HasHeader (Header (TestBlockWith ptype)) where
+instance (Typeable ptype) => HasHeader (Header (TestBlockWith ptype)) where
   getHeaderFields (TestHeader TestBlockWith{..}) = HeaderFields {
         headerFieldHash    = tbHash
       , headerFieldSlot    = tbSlot