From 566d1e5ff5972f25a77a2b061b4ab0ee7c20ce6a Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 12 Dec 2024 08:20:50 -0800 Subject: [PATCH] WIP rename and document HasEraParams --- .../Combinator/Abstract/NoHardForks.hs | 30 ++++++++++++------- .../HardFork/Combinator/Embed/Unary.hs | 8 ++--- .../Test/Util/HeaderValidation.hs | 10 +++---- .../Test/Util/TestBlock.hs | 6 ++-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 5 ++-- .../Test/Ouroboros/Storage/TestBlock.hs | 6 ++-- 6 files changed, 38 insertions(+), 27 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs index 05c64363c0..9c2116ff63 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs @@ -1,7 +1,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks ( - HasEraParams (..) + ImmutableEraParams (..) , NoHardForks (..) - , getEpochInfo + , immutableEpochInfo ) where import Cardano.Slotting.EpochInfo @@ -16,30 +16,40 @@ import Ouroboros.Consensus.Ledger.Abstract Blocks that don't /have/ any transitions -------------------------------------------------------------------------------} -class HasEraParams 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, HasEraParams blk) => NoHardForks blk where +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 -getEpochInfo :: - (Monad m, HasEraParams blk) +immutableEpochInfo :: + (Monad m, ImmutableEraParams blk) => TopLevelConfig blk -> EpochInfo m -getEpochInfo cfg = +immutableEpochInfo cfg = hoistEpochInfo (pure . runIdentity) $ fixedEpochInfo (History.eraEpochSize params) (History.eraSlotLength params) where params :: EraParams - params = getEraParams cfg + params = immutableEraParams cfg diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index ccdb6b991c..6c3437c9e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/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 = getEpochInfo $ 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,7 +423,7 @@ instance Functor m => Isomorphic (BlockForging m) where (inject cfg) sno (injTickedChainDepSt - (getEpochInfo cfg) + (immutableEpochInfo cfg) tickedChainDepSt) , checkCanForge = \cfg sno tickedChainDepSt isLeader forgeStateInfo -> first (project' (Proxy @(WrapCannotForge blk))) $ @@ -431,7 +431,7 @@ instance Functor m => Isomorphic (BlockForging m) where (inject cfg) sno (injTickedChainDepSt - (getEpochInfo cfg) + (immutableEpochInfo cfg) tickedChainDepSt) (inject' (Proxy @(WrapIsLeader blk)) isLeader) (inject' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs index ebf57e30ac..841df67fef 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs @@ -14,8 +14,8 @@ import Data.Functor.Identity (runIdentity) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block (Header, blockSlot) import Ouroboros.Consensus.Config (TopLevelConfig) -import Ouroboros.Consensus.HardFork.Combinator.Abstract (HasEraParams, - getEpochInfo) +import Ouroboros.Consensus.HardFork.Combinator.Abstract + (ImmutableEraParams, immutableEpochInfo) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -32,14 +32,14 @@ dropTimeFromFragment = AF.mapAnchoredFragment hwtHeader attachSlotTimeToFragment :: ( AF.HasHeader (Header blk) , Typeable blk - , HasEraParams blk) + , ImmutableEraParams blk) => TopLevelConfig blk -> AnchoredFragment (Header blk) -> AnchoredFragment (HeaderWithTime blk) attachSlotTimeToFragment cfg = AF.mapAnchoredFragment (attachSlotTime cfg) attachSlotTime :: - (AF.HasHeader (Header blk), HasEraParams blk) + (AF.HasHeader (Header blk), ImmutableEraParams blk) => TopLevelConfig blk -> Header blk -> HeaderWithTime blk @@ -49,4 +49,4 @@ attachSlotTime cfg hdr = HeaderWithTime { runIdentity $ epochInfoSlotToRelativeTime ei (blockSlot hdr) } where - ei = getEpochInfo cfg + ei = immutableEpochInfo cfg diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index f045b30c82..b99e641c84 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -115,7 +115,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract - (HasEraParams (getEraParams)) + (ImmutableEraParams (immutableEraParams)) import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract @@ -636,8 +636,8 @@ singleNodeTestConfigWith codecConfig storageConfig k genesisWindow = TopLevelCon _eraParams :: HardFork.EraParams _eraParams = (HardFork.defaultEraParams k slotLength) {HardFork.eraGenesisWin = genesisWindow} -instance HasEraParams (TestBlockWith ptype) where - getEraParams = tblcHardForkParams . topLevelConfigLedger +instance ImmutableEraParams (TestBlockWith ptype) where + immutableEraParams = tblcHardForkParams . topLevelConfigLedger {------------------------------------------------------------------------------- Test blocks without payload 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 e89ed2684d..41b98cd9c5 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 @@ -108,7 +108,8 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture import Ouroboros.Consensus.HardFork.Abstract -import Ouroboros.Consensus.HardFork.Combinator.Abstract (HasEraParams) +import Ouroboros.Consensus.HardFork.Combinator.Abstract + (ImmutableEraParams) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -332,7 +333,7 @@ type TestConstraints blk = , ConvertRawHash blk , HasHardForkHistory blk , SerialiseDiskConstraints blk - , HasEraParams blk + , ImmutableEraParams blk ) deriving instance (TestConstraints blk, Eq it, Eq flr) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index 935671c2f4..fe4584ed1f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs @@ -89,7 +89,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract - (HasEraParams (getEraParams)) + (ImmutableEraParams (immutableEraParams)) import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) @@ -696,8 +696,8 @@ mkTestConfig k ChunkSize { chunkCanContainEBB, numRegularBlocks } = , eraGenesisWin = GenesisWindow (maxRollbacks k * 2) } -instance HasEraParams TestBlock where - getEraParams = topLevelConfigLedger +instance ImmutableEraParams TestBlock where + immutableEraParams = topLevelConfigLedger {------------------------------------------------------------------------------- NestedCtxt