From a2e7828cd42203660970ac09a05500e58359379d Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Oct 2024 14:29:14 +0100 Subject: [PATCH] HFC: generalize cross era ticking Co-authored-by: Nicolas Frisby --- .../Consensus/Byron/Ledger/Ledger.hs | 4 + .../Consensus/Cardano/CanHardFork.hs | 166 ++++---------- .../Ouroboros/Consensus/Cardano/Node.hs | 5 +- .../Consensus/Shelley/Ledger/Ledger.hs | 1 + .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 118 ++++++---- .../ThreadNet/Infra/ShelleyBasedHardFork.hs | 25 +-- .../Test/Consensus/HardFork/Combinator.hs | 27 ++- .../HardFork/Combinator/Embed/Nary.hs | 11 +- .../Consensus/HardFork/Combinator/Ledger.hs | 150 +++++++++---- .../Consensus/HardFork/Combinator/Protocol.hs | 35 ++- .../Consensus/HardFork/Combinator/State.hs | 77 +------ .../HardFork/Combinator/State/Infra.hs | 57 +++-- .../HardFork/Combinator/State/Types.hs | 36 +++- .../HardFork/Combinator/Translation.hs | 17 +- sop-extras/src/Data/SOP/InPairs.hs | 11 +- sop-extras/src/Data/SOP/Telescope.hs | 202 +++++------------- 16 files changed, 410 insertions(+), 532 deletions(-) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index f455db7d44..be233d844e 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -83,6 +83,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.PBFT +import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy (..), (..:)) {------------------------------------------------------------------------------- @@ -164,6 +165,7 @@ getByronTip state = -- | The ticked Byron ledger state data instance Ticked (LedgerState ByronBlock) = TickedByronLedgerState { tickedByronLedgerState :: !CC.ChainValidationState + , untickedByronLedgerTipBlockNo :: !(WithOrigin BlockNo) , untickedByronLedgerTransition :: !ByronTransition } deriving (Generic, NoThunks) @@ -178,6 +180,8 @@ instance IsLedger (LedgerState ByronBlock) where TickedByronLedgerState { tickedByronLedgerState = CC.applyChainTick cfg (toByronSlotNo slotNo) byronLedgerState + , untickedByronLedgerTipBlockNo = + byronLedgerTipBlockNo , untickedByronLedgerTransition = byronLedgerTransition } diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 8ff742f446..83ea6b6a76 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -25,7 +25,9 @@ module Ouroboros.Consensus.Cardano.CanHardFork ( -- * Re-exports of Shelley code , ShelleyPartialLedgerConfig (..) , crossEraForecastAcrossShelley - , translateChainDepStateAcrossShelley + , forecastAcrossShelley + , tickChainDepStateAcrossShelley + , tickLedgerStateAcrossShelley , translateLedgerStateByronToShelley ) where @@ -53,7 +55,8 @@ import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) import Data.Proxy import Data.SOP.BasicFunctors -import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth) +import Data.SOP.InPairs (RequiringBoth, RequiringBoth' (..), + ignoringBoth) import qualified Data.SOP.Strict as SOP import Data.SOP.Tails (Tails (..)) import qualified Data.SOP.Tails as Tails @@ -68,8 +71,7 @@ import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types -import Ouroboros.Consensus.HardFork.History (Bound (boundSlot), - addSlots) +import Ouroboros.Consensus.HardFork.History (Bound (..), addSlots) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32, @@ -282,23 +284,23 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where type HardForkTxMeasure (CardanoEras c) = ConwayMeasure hardForkEraTranslation = EraTranslation { - translateLedgerState = - PCons translateLedgerStateByronToShelleyWrapper - $ PCons translateLedgerStateShelleyToAllegraWrapper - $ PCons translateLedgerStateAllegraToMaryWrapper - $ PCons translateLedgerStateMaryToAlonzoWrapper - $ PCons translateLedgerStateAlonzoToBabbageWrapper - $ PCons translateLedgerStateBabbageToConwayWrapper + crossEraTickLedgerState = + PCons tickLedgerStateByronToShelley + $ PCons tickLedgerStateAcrossShelley + $ PCons tickLedgerStateAcrossShelley + $ PCons tickLedgerStateAcrossShelley + $ PCons tickLedgerStateAcrossShelley + $ PCons tickLedgerStateAcrossShelley $ PNil - , translateChainDepState = - PCons translateChainDepStateByronToShelleyWrapper - $ PCons translateChainDepStateAcrossShelley - $ PCons translateChainDepStateAcrossShelley - $ PCons translateChainDepStateAcrossShelley - $ PCons translateChainDepStateAcrossShelley - $ PCons translateChainDepStateAcrossShelley + , crossEraTickChainDepState = + PCons tickChainDepStateByronToShelley + $ PCons tickChainDepStateAcrossShelley + $ PCons tickChainDepStateAcrossShelley + $ PCons tickChainDepStateAcrossShelley + $ PCons tickChainDepStateAcrossShelley + $ PCons tickChainDepStateAcrossShelley $ PNil - , crossEraForecast = + , crossEraForecast = PCons crossEraForecastByronToShelleyWrapper $ PCons crossEraForecastAcrossShelley $ PCons crossEraForecastAcrossShelley @@ -324,8 +326,8 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where translateTxAllegraToMaryWrapper translateValidatedTxAllegraToMaryWrapper ) - $ PCons (RequireBoth $ \_cfgMary cfgAlonzo -> - let ctxt = getAlonzoTranslationContext cfgAlonzo + $ PCons (RequireBoth $ \_cfgMary (WrapLedgerConfig cfgAlonzo) -> + let ctxt = shelleyLedgerTranslationContext cfgAlonzo in Pair2 (translateTxMaryToAlonzoWrapper ctxt) @@ -338,8 +340,8 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where (translateTxAlonzoToBabbageWrapper ctxt) (translateValidatedTxAlonzoToBabbageWrapper ctxt) ) - $ PCons (RequireBoth $ \_cfgBabbage cfgConway -> - let ctxt = getConwayTranslationContext cfgConway + $ PCons (RequireBoth $ \_cfgBabbage (WrapLedgerConfig cfgConway) -> + let ctxt = shelleyLedgerTranslationContext cfgConway in Pair2 (translateTxBabbageToConwayWrapper ctxt) @@ -415,20 +417,23 @@ translatePointByronToShelley point bNo = _otherwise -> error "translatePointByronToShelley: invalid Byron state" -translateLedgerStateByronToShelleyWrapper :: +tickLedgerStateByronToShelley :: ( ShelleyCompatible (TPraos c) (ShelleyEra c) , HASH c ~ Blake2b_256 , ADDRHASH c ~ Blake2b_224 ) => RequiringBoth WrapLedgerConfig - (Translate LedgerState) + CrossEraTickLedgerState ByronBlock (ShelleyBlock (TPraos c) (ShelleyEra c)) -translateLedgerStateByronToShelleyWrapper = - RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> Translate $ - translateLedgerStateByronToShelley - (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley)) +tickLedgerStateByronToShelley = + RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> + CrossEraTickLedgerState $ \bound slot -> + applyChainTickLedgerResult cfgShelley slot + . translateLedgerStateByronToShelley + (shelleyLedgerTranslationContext cfgShelley) + bound translateLedgerStateByronToShelley :: ( ShelleyCompatible (TPraos c) (ShelleyEra c) @@ -436,10 +441,10 @@ translateLedgerStateByronToShelley :: , ADDRHASH c ~ Blake2b_224 ) => SL.FromByronTranslationContext c - -> EpochNo -- ^ Start of the new era + -> Bound -- ^ Start of the new era -> LedgerState ByronBlock -> LedgerState (ShelleyBlock (TPraos c) (ShelleyEra c)) -translateLedgerStateByronToShelley ctx epochNo ledgerByron = +translateLedgerStateByronToShelley ctx bound ledgerByron = ShelleyLedgerState { shelleyLedgerTip = translatePointByronToShelley @@ -448,23 +453,24 @@ translateLedgerStateByronToShelley ctx epochNo ledgerByron = , shelleyLedgerState = SL.translateToShelleyLedgerState ctx - epochNo + (boundEpoch bound) (byronLedgerState ledgerByron) , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} } -translateChainDepStateByronToShelleyWrapper :: - RequiringBoth +tickChainDepStateByronToShelley :: + ConsensusProtocol (TPraos c) + => RequiringBoth WrapConsensusConfig - (Translate WrapChainDepState) + CrossEraTickChainDepState ByronBlock (ShelleyBlock (TPraos c) (ShelleyEra c)) -translateChainDepStateByronToShelleyWrapper = +tickChainDepStateByronToShelley = RequireBoth $ \_ (WrapConsensusConfig cfgShelley) -> - Translate $ \_ (WrapChainDepState pbftState) -> - WrapChainDepState $ - translateChainDepStateByronToShelley cfgShelley pbftState + CrossEraTickChainDepState $ \_bound view slot -> + tickChainDepState cfgShelley view slot + . translateChainDepStateByronToShelley cfgShelley translateChainDepStateByronToShelley :: forall bc c. @@ -555,18 +561,6 @@ crossEraForecastByronToShelleyWrapper = Translation from Shelley to Allegra -------------------------------------------------------------------------------} -translateLedgerStateShelleyToAllegraWrapper :: - (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) - => RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (TPraos c) (ShelleyEra c)) - (ShelleyBlock (TPraos c) (AllegraEra c)) -translateLedgerStateShelleyToAllegraWrapper = - ignoringBoth $ - Translate $ \_epochNo -> - unComp . SL.translateEra' SL.NoGenesis . Comp - translateTxShelleyToAllegraWrapper :: (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => InjectTx @@ -587,18 +581,6 @@ translateValidatedTxShelleyToAllegraWrapper = InjectValidatedTx $ Translation from Allegra to Mary -------------------------------------------------------------------------------} -translateLedgerStateAllegraToMaryWrapper :: - (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) - => RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (TPraos c) (AllegraEra c)) - (ShelleyBlock (TPraos c) (MaryEra c)) -translateLedgerStateAllegraToMaryWrapper = - ignoringBoth $ - Translate $ \_epochNo -> - unComp . SL.translateEra' SL.NoGenesis . Comp - translateTxAllegraToMaryWrapper :: (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => InjectTx @@ -619,24 +601,6 @@ translateValidatedTxAllegraToMaryWrapper = InjectValidatedTx $ Translation from Mary to Alonzo -------------------------------------------------------------------------------} -translateLedgerStateMaryToAlonzoWrapper :: - (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) - => RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (TPraos c) (MaryEra c)) - (ShelleyBlock (TPraos c) (AlonzoEra c)) -translateLedgerStateMaryToAlonzoWrapper = - RequireBoth $ \_cfgMary cfgAlonzo -> - Translate $ \_epochNo -> - unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp - -getAlonzoTranslationContext :: - WrapLedgerConfig (ShelleyBlock (TPraos c) (AlonzoEra c)) - -> SL.TranslationContext (AlonzoEra c) -getAlonzoTranslationContext = - shelleyLedgerTranslationContext . unwrapLedgerConfig - translateTxMaryToAlonzoWrapper :: (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => SL.TranslationContext (AlonzoEra c) @@ -660,28 +624,6 @@ translateValidatedTxMaryToAlonzoWrapper ctxt = InjectValidatedTx $ Translation from Alonzo to Babbage -------------------------------------------------------------------------------} -translateLedgerStateAlonzoToBabbageWrapper :: - (Praos.PraosCrypto c, TPraos.PraosCrypto c) - => RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (TPraos c) (AlonzoEra c)) - (ShelleyBlock (Praos c) (BabbageEra c)) -translateLedgerStateAlonzoToBabbageWrapper = - RequireBoth $ \_cfgAlonzo _cfgBabbage -> - Translate $ \_epochNo -> - unComp . SL.translateEra' SL.NoGenesis . Comp . transPraosLS - where - transPraosLS :: - LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c)) -> - LedgerState (ShelleyBlock (Praos c) (AlonzoEra c)) - transPraosLS (ShelleyLedgerState wo nes st) = - ShelleyLedgerState - { shelleyLedgerTip = fmap castShelleyTip wo - , shelleyLedgerState = nes - , shelleyLedgerTransition = st - } - translateTxAlonzoToBabbageWrapper :: (Praos.PraosCrypto c) => SL.TranslationContext (BabbageEra c) @@ -722,24 +664,6 @@ translateValidatedTxAlonzoToBabbageWrapper ctxt = InjectValidatedTx $ Translation from Babbage to Conway -------------------------------------------------------------------------------} -translateLedgerStateBabbageToConwayWrapper :: - (Praos.PraosCrypto c) - => RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (Praos c) (BabbageEra c)) - (ShelleyBlock (Praos c) (ConwayEra c)) -translateLedgerStateBabbageToConwayWrapper = - RequireBoth $ \_cfgBabbage cfgConway -> - Translate $ \_epochNo -> - unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp - -getConwayTranslationContext :: - WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c)) - -> SL.TranslationContext (ConwayEra c) -getConwayTranslationContext = - shelleyLedgerTranslationContext . unwrapLedgerConfig - translateTxBabbageToConwayWrapper :: (Praos.PraosCrypto c) => SL.TranslationContext (ConwayEra c) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index fbbba13750..cfa2601add 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -1021,12 +1021,13 @@ protocolInfoCardano paramsCardano PNil where byronToShelleyTranslation = - Translate $ translateLedgerStateByronToShelley ctx + CrossEra $ \(Current bound _) -> + translateLedgerStateByronToShelley ctx bound where ctx = SL.toFromByronTranslationContext genesisShelley interShelleyTranslation transitionConfig = - Translate $ \_ -> translateShelleyLedgerState ctx + CrossEra $ \_ -> translateShelleyLedgerState ctx where ctx = transitionConfig ^. L.tcTranslationContextL 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 380f97f562..c80850a788 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 @@ -91,6 +91,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract (EnvelopeCheckError, envelopeChecks, mkHeaderView) +import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) 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 bac88e56af..491900a432 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -22,7 +22,8 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC ( , ShelleyPartialLedgerConfig (..) , crossEraForecastAcrossShelley , forecastAcrossShelley - , translateChainDepStateAcrossShelley + , tickChainDepStateAcrossShelley + , tickLedgerStateAcrossShelley , translateShelleyLedgerState ) where @@ -37,7 +38,7 @@ import Control.Monad.Except (runExcept, throwError, withExceptT) import Data.Coerce import qualified Data.Map.Strict as Map import Data.SOP.BasicFunctors -import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth) +import Data.SOP.InPairs (RequiringBoth, RequiringBoth' (..)) import qualified Data.Text as T (pack) import Data.Void (Void) import Data.Word @@ -48,8 +49,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import qualified Ouroboros.Consensus.Forecast as Forecast -import Ouroboros.Consensus.HardFork.Combinator hiding - (translateChainDepState) +import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) @@ -241,25 +241,9 @@ instance ShelleyCompatible proto era => HasPartialLedgerConfig (ShelleyBlock pro } } -translateChainDepStateAcrossShelley :: - forall eraFrom eraTo protoFrom protoTo. - ( TranslateProto protoFrom protoTo - ) - => RequiringBoth - WrapConsensusConfig - (Translate WrapChainDepState) - (ShelleyBlock protoFrom eraFrom) - (ShelleyBlock protoTo eraTo) -translateChainDepStateAcrossShelley = - ignoringBoth $ - Translate $ \_epochNo (WrapChainDepState chainDepState) -> - -- Same protocol, same 'ChainDepState'. Note that we don't have to apply - -- any changes related to an epoch transition, this is already done when - -- ticking the state. - WrapChainDepState $ translateChainDepState (Proxy @(protoFrom, protoTo)) chainDepState - +-- | Wrapper around 'forecastAcrossShelley'. crossEraForecastAcrossShelley :: - forall eraFrom eraTo protoFrom protoTo. + forall protoFrom protoTo eraFrom eraTo. ( TranslateProto protoFrom protoTo , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom) ) @@ -270,7 +254,14 @@ crossEraForecastAcrossShelley :: (ShelleyBlock protoTo eraTo) crossEraForecastAcrossShelley = coerce forecastAcrossShelley --- | Forecast from a Shelley-based era to the next Shelley-based era. +-- | Forecast from a Shelley-based era to the next Shelley-based era. We do so +-- via the "forecast-then-translate" scheme: +-- +-- - First, we forecast for the given slot using the logic of @'ShelleyBlock' +-- protoFrom eraFrom@. +-- +-- - Then, we translate the resulting 'LedgerView' from @protoFrom@ to +-- @protoTo@. forecastAcrossShelley :: forall protoFrom protoTo eraFrom eraTo. ( TranslateProto protoFrom protoTo @@ -311,32 +302,69 @@ forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom (SL.stabilityWindow (shelleyLedgerGlobals cfgFrom)) (SL.stabilityWindow (shelleyLedgerGlobals cfgTo)) +-- | Tick the ledger state from one Shelley-based era @eraFrom@ to the the next +-- era @eraTo@. We do so via the "translate-then-tick" scheme: +-- +-- - First, we translate the ledger state from @eraFrom@ to @eraTo@. +-- +-- - Then, we tick the ledger state to the target slot using the logic of +-- @eraTo@. +-- +-- Note that this function also allows to change the protocol; this is harmless +-- as the ledger state only depends trivially on the protocol via the +-- @HeaderHash@ contained in the tip. +tickLedgerStateAcrossShelley :: + forall protoFrom protoTo eraFrom eraTo. + ( ShelleyBasedEra eraTo + , eraFrom ~ SL.PreviousEra eraTo + , SL.TranslateEra eraTo SL.NewEpochState + , SL.TranslationError eraTo SL.NewEpochState ~ Void + , ProtoCrypto protoFrom ~ ProtoCrypto protoTo + ) + => RequiringBoth + WrapLedgerConfig + CrossEraTickLedgerState + (ShelleyBlock protoFrom eraFrom) + (ShelleyBlock protoTo eraTo) +tickLedgerStateAcrossShelley = + RequireBoth $ \_cfgFrom (WrapLedgerConfig cfgTo) -> + CrossEraTickLedgerState $ \_bound slot -> + applyChainTickLedgerResult cfgTo slot + . translateShelleyLedgerState + (shelleyLedgerTranslationContext cfgTo) + +-- | Tick the chain-dependent state from one Shelley-based era to the the next, +-- potentially changing the protocol. We do so via the "translate-then-tick" +-- scheme: +-- +-- - First, we translate the chain-dependent state from @protoFrom@ to +-- @protoTo@. +-- +-- - Then, we tick the chain-dependent state to the target slot using the logic +-- of @protoTo@. +-- +-- Note that this function also allows to change the ledger era; this is +-- harmless as the chain-dependent state doesn't depend on it at all. +tickChainDepStateAcrossShelley :: + forall protoFrom protoTo eraFrom eraTo. + ( TranslateProto protoFrom protoTo + , ConsensusProtocol protoTo + ) + => RequiringBoth + WrapConsensusConfig + CrossEraTickChainDepState + (ShelleyBlock protoFrom eraFrom) + (ShelleyBlock protoTo eraTo) +tickChainDepStateAcrossShelley = + RequireBoth $ \_cfgFrom (WrapConsensusConfig cfgTo) -> + CrossEraTickChainDepState $ \_bound view slot -> + tickChainDepState cfgTo view slot + . translateChainDepState (Proxy @(protoFrom, protoTo)) + {------------------------------------------------------------------------------- Translation from one Shelley-based era to another Shelley-based era -------------------------------------------------------------------------------} -instance ( ShelleyBasedEra era - , ShelleyBasedEra (SL.PreviousEra era) - , SL.Era (SL.PreviousEra era) - , EraCrypto (SL.PreviousEra era) ~ EraCrypto era - ) => SL.TranslateEra era (ShelleyTip proto) where - translateEra _ (ShelleyTip sno bno (ShelleyHash hash)) = - return $ ShelleyTip sno bno (ShelleyHash hash) - -instance ( ShelleyBasedEra era - , SL.TranslateEra era (ShelleyTip proto) - , SL.TranslateEra era SL.NewEpochState - , SL.TranslationError era SL.NewEpochState ~ Void - ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock proto) where - translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do - tip' <- mapM (SL.translateEra ctxt) tip - state' <- SL.translateEra ctxt state - return $ Comp $ ShelleyLedgerState { - shelleyLedgerTip = tip' - , shelleyLedgerState = state' - , shelleyLedgerTransition = ShelleyTransitionInfo 0 - } - translateShelleyLedgerState :: ( eraFrom ~ SL.PreviousEra eraTo , SL.TranslateEra eraTo SL.NewEpochState diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index d4961835e0..1eedc5e6ac 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -42,12 +42,12 @@ import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Cardano.CanHardFork (ShelleyPartialLedgerConfig (..), crossEraForecastAcrossShelley, - translateChainDepStateAcrossShelley) + tickChainDepStateAcrossShelley, + tickLedgerStateAcrossShelley) import Ouroboros.Consensus.Cardano.Node (TriggerHardFork (..)) import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.Embed.Binary import Ouroboros.Consensus.HardFork.Combinator.Serialisation -import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as HFC import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) import Ouroboros.Consensus.Ledger.SupportsMempool @@ -173,25 +173,10 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 TxMeasure (ShelleyBlock proto2 era2) hardForkEraTranslation = EraTranslation { - translateLedgerState = PCons translateLedgerState PNil - , translateChainDepState = PCons translateChainDepStateAcrossShelley PNil - , crossEraForecast = PCons crossEraForecastAcrossShelley PNil + crossEraTickLedgerState = PCons tickLedgerStateAcrossShelley PNil + , crossEraTickChainDepState = PCons tickChainDepStateAcrossShelley PNil + , crossEraForecast = PCons crossEraForecastAcrossShelley PNil } - where - translateLedgerState :: - InPairs.RequiringBoth - WrapLedgerConfig - (HFC.Translate LedgerState) - (ShelleyBlock proto1 era1) - (ShelleyBlock proto2 era2) - translateLedgerState = - InPairs.RequireBoth - $ \_cfg1 cfg2 -> HFC.Translate - $ \_epochNo -> - unComp - . SL.translateEra' - (shelleyLedgerTranslationContext (unwrapLedgerConfig cfg2)) - . Comp hardForkChainSel = Tails.mk2 CompareSameSelectView diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index c59f9b27ba..33622af310 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -18,7 +18,7 @@ module Test.Consensus.HardFork.Combinator (tests) where import qualified Data.Map.Strict as Map import Data.SOP.Counting -import Data.SOP.InPairs (RequiringBoth (..)) +import Data.SOP.InPairs (RequiringBoth, RequiringBoth' (..)) import qualified Data.SOP.InPairs as InPairs import Data.SOP.OptNP (OptNP (..)) import Data.SOP.Strict @@ -366,9 +366,9 @@ instance CanHardFork '[BlockA, BlockB] where type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32 hardForkEraTranslation = EraTranslation { - translateLedgerState = PCons ledgerState_AtoB PNil - , translateChainDepState = PCons chainDepState_AtoB PNil - , crossEraForecast = PCons forecast_AtoB PNil + crossEraTickLedgerState = PCons ledgerState_AtoB PNil + , crossEraTickChainDepState = PCons chainDepState_AtoB PNil + , crossEraForecast = PCons forecast_AtoB PNil } hardForkChainSel = Tails.mk2 CompareBlockNo hardForkInjectTxs = InPairs.mk2 injectTx_AtoB @@ -411,21 +411,26 @@ instance SerialiseHFC '[BlockA, BlockB] ledgerState_AtoB :: RequiringBoth WrapLedgerConfig - (Translate LedgerState) + CrossEraTickLedgerState BlockA BlockB -ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ LgrA{..} -> LgrB { - lgrB_tip = castPoint lgrA_tip - } +ledgerState_AtoB = + RequireBoth $ \_cfgA (WrapLedgerConfig cfgB) -> + CrossEraTickLedgerState $ \_ slot LgrA{..} -> + applyChainTickLedgerResult cfgB slot LgrB { + lgrB_tip = castPoint lgrA_tip + } chainDepState_AtoB :: RequiringBoth WrapConsensusConfig - (Translate WrapChainDepState) + CrossEraTickChainDepState BlockA BlockB -chainDepState_AtoB = InPairs.ignoringBoth $ Translate $ \_ _ -> - WrapChainDepState () +chainDepState_AtoB = + InPairs.ignoringBoth $ + CrossEraTickChainDepState $ \_ _ _ _ -> + TickedTrivial forecast_AtoB :: RequiringBoth diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs index 666f54c5e4..e5340a0258 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.HardFork.Combinator.Embed.Nary ( Inject (..) @@ -16,6 +18,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Embed.Nary ( , injectNestedCtxt_ , injectQuery -- * Initial 'ExtLedgerState' + , Translate , injectInitialExtLedgerState , mkInitialStateViaTranslation ) where @@ -29,7 +32,7 @@ import Data.SOP.Index import Data.SOP.Strict import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator -import Ouroboros.Consensus.HardFork.Combinator.State (Translate (..)) +import Ouroboros.Consensus.HardFork.Combinator.State import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..)) @@ -186,8 +189,10 @@ injectInitialExtLedgerState = initBounds :: Exactly xs History.Bound initBounds = Exactly $ hpure $ K History.initBound +type Translate f = CrossEra f Proxy f + -- | Translate the given @f x@ until it has the same index as the n-ary sum. The --- translations happen at epoch 0. +-- translations happen at 'History.initBound'. mkInitialStateViaTranslation :: InPairs (Translate f) (x : xs) -> f x @@ -203,4 +208,4 @@ mkInitialStateViaTranslation = go go _ fx Z{} = Z fx go (PCons t ts) fx (S gxs) = S $ go ts fx' gxs where - fx' = translateWith t (EpochNo 0) fx + fx' = crossEra t (Current History.initBound Proxy) fx 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 aaa001f0b8..fb368663e0 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 @@ -37,11 +37,12 @@ import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting (getExactly) import Data.SOP.Index -import Data.SOP.InPairs (InPairs (..)) +import Data.SOP.InPairs (InPairs (..), Requiring (..), + RequiringBoth' (..)) import qualified Data.SOP.InPairs as InPairs import qualified Data.SOP.Match as Match import Data.SOP.Strict -import Data.SOP.Telescope (Telescope (..)) +import Data.SOP.Telescope (Extend (..), Telescope (..)) import qualified Data.SOP.Telescope as Telescope import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -58,6 +59,7 @@ import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Protocol () import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView import qualified Ouroboros.Consensus.HardFork.Combinator.State as State +import qualified Ouroboros.Consensus.HardFork.Combinator.State.Lift as State import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Translation import Ouroboros.Consensus.HardFork.History (Bound (..), EraParams, @@ -68,6 +70,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util ((.:)) import Ouroboros.Consensus.Util.Condense {------------------------------------------------------------------------------- @@ -117,53 +120,110 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs - applyChainTickLedgerResult cfg@HardForkLedgerConfig{..} slot (HardForkLedgerState st) = - sequenceHardForkState - (hcizipWith proxySingle (tickOne ei slot) cfgs extended) <&> \l' -> + applyChainTickLedgerResult cfg slot lst@(HardForkLedgerState st) = + ticked <&> \st' -> TickedHardForkLedgerState { tickedHardForkLedgerStateTransition = - -- We are bundling a 'TransitionInfo' with a /ticked/ ledger state, - -- but /derive/ that 'TransitionInfo' from the /unticked/ (albeit - -- extended) state. That requires justification. Three cases: - -- - -- o 'TransitionUnknown'. If the transition is unknown, then it - -- cannot become known due to ticking. In this case, we record - -- the tip of the ledger, which ticking also does not modify - -- (this is an explicit postcondition of 'applyChainTick'). - -- o 'TransitionKnown'. If the transition to the next epoch is - -- already known, then ticking does not change that information. - -- It can't be the case that the 'SlotNo' we're ticking to is - -- /in/ that next era, because if was, then 'extendToSlot' would - -- have extended the telescope further. - -- (This does mean however that it is important to use the - -- /extended/ ledger state, not the original, to determine the - -- 'TransitionInfo'.) - -- o 'TransitionImpossible'. This has two subcases: either we are - -- in the final era, in which case ticking certainly won't be able - -- to change that, or we're forecasting, which is simply not - -- applicable here. - State.mostRecentTransitionInfo cfg extended - , tickedHardForkLedgerStatePerEra = l' + -- TODO justify + case State.match (State.tip st) st' of + -- TODO Previously, this might have been 'TransitionKnown' if the + -- next era uses 'TriggerHardForkAtEpoch'. It /seems/ + -- inconsequential that we know a bit less here. + Left _ -> TransitionUnknown (ledgerTipSlot lst) + Right _ -> State.mostRecentTransitionInfo cfg st + , tickedHardForkLedgerStatePerEra = st' } where - cfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra - ei = State.epochInfoLedger cfg st - - extended :: HardForkState LedgerState xs - extended = State.extendToSlot cfg slot st - -tickOne :: SingleEraBlock blk - => EpochInfo (Except PastHorizonException) - -> SlotNo - -> Index xs blk - -> WrapPartialLedgerConfig blk - -> LedgerState blk - -> ( LedgerResult (LedgerState (HardForkBlock xs)) - :.: (Ticked :.: LedgerState) - ) blk -tickOne ei slot index pcfg st = Comp $ fmap Comp $ - embedLedgerResult (injectLedgerEvent index) - $ applyChainTickLedgerResult (completeLedgerConfig' ei pcfg) slot st + ticked :: HardForkLedgerResult xs (HardForkState (Ticked :.: LedgerState) xs) + ticked = tick cfg slot st + +type HardForkLedgerResult xs = LedgerResult (LedgerState (HardForkBlock xs)) + +tick :: + forall xs. CanHardFork xs + => HardForkLedgerConfig xs + -> SlotNo + -> HardForkState LedgerState xs + -> HardForkLedgerResult xs (HardForkState (Ticked :.: LedgerState) xs) +tick ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) = + sequenceHardForkState + . HardForkState + . unI + . Telescope.extend + (hczipWith + proxySingle + (fn .: whenExtend) + pcfgs + (getExactly (History.getShape hardForkLedgerConfigShape))) + ( InPairs.requiringBoth indices + $ InPairs.hmap (\f -> RequireBoth $ \_ ix + -> Require $ \(K t) + -> Extend $ \cur + -> I $ tickCross f ix t cur) + $ InPairs.requiringBoth cfgs + $ crossEraTickLedgerState hardForkEraTranslation + ) + (hcimap proxySingle ((fn . State.lift) .: tickOne) cfgs) + $ st + where + pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra + cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs + ei = State.epochInfoLedger ledgerCfg ledgerSt + + -- Return the end of this era if we should transition to the next + whenExtend :: SingleEraBlock blk + => WrapPartialLedgerConfig blk + -> K History.EraParams blk + -> Current LedgerState blk + -> (Maybe :.: K History.Bound) blk + whenExtend pcfg (K eraParams) cur = Comp $ K <$> do + transition <- singleEraTransition' + pcfg + eraParams + (currentStart cur) + (currentState cur) + let endBound = History.mkUpperBound + eraParams + (currentStart cur) + transition + guard (slot >= History.boundSlot endBound) + return endBound + + tickCross :: + CrossEraTickLedgerState blk blk' + -> Index xs blk' + -> History.Bound + -> Current LedgerState blk + -> ( K Past blk + , Current (HardForkLedgerResult xs :.: Ticked :.: LedgerState) blk' + ) + tickCross f index currentEnd cur = ( + K Past { + pastStart = currentStart cur + , pastEnd = currentEnd + } + , Current { + currentStart = currentEnd + , currentState = + Comp $ fmap Comp + $ embedLedgerResult (injectLedgerEvent index) + $ crossEraTickLedgerStateWith f + currentEnd + slot + (currentState cur) + } + ) + + tickOne :: + SingleEraBlock blk + => Index xs blk + -> WrapLedgerConfig blk + -> LedgerState blk + -> (HardForkLedgerResult xs :.: (Ticked :.: LedgerState)) blk + tickOne index (WrapLedgerConfig cfg) = + Comp . fmap Comp + . embedLedgerResult (injectLedgerEvent index) + . applyChainTickLedgerResult cfg slot {------------------------------------------------------------------------------- ApplyBlock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index bdbcb9960d..472e49be15 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -50,10 +50,11 @@ import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView (HardForkLedgerView, HardForkLedgerView_ (..)) -import Ouroboros.Consensus.HardFork.Combinator.State (HardForkState, - Translate (..)) +import Ouroboros.Consensus.HardFork.Combinator.State (CrossEra (..), + CrossEraTickChainDepState (..), Current (..), + HardForkState) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State -import Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation +import qualified Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((.:)) @@ -181,7 +182,7 @@ tick cfg@HardForkConsensusConfig{..} tickedHardForkChainDepStateEpochInfo = ei , tickedHardForkChainDepStatePerEra = State.align - (translateConsensus ei cfg) + (crossEraTickChainDepState ei cfg slot) (hcmap proxySingle (fn_2 . tickOne) cfgs) ledgerView chainDepState @@ -367,13 +368,25 @@ chainDepStateInfo :: forall blk. SingleEraBlock blk => (Ticked :.: WrapChainDepState) blk -> SingleEraInfo blk chainDepStateInfo _ = singleEraInfo (Proxy @blk) -translateConsensus :: forall xs. CanHardFork xs - => EpochInfo (Except PastHorizonException) - -> ConsensusConfig (HardForkProtocol xs) - -> InPairs (Translate WrapChainDepState) xs -translateConsensus ei HardForkConsensusConfig{..} = - InPairs.requiringBoth cfgs $ - HFTranslation.translateChainDepState hardForkEraTranslation +type CrossEraTickChainDepState' = + CrossEra + WrapChainDepState + WrapLedgerView + (Ticked :.: WrapChainDepState) + +crossEraTickChainDepState :: + forall xs. CanHardFork xs + => EpochInfo (Except PastHorizonException) + -> ConsensusConfig (HardForkProtocol xs) + -> SlotNo + -> InPairs CrossEraTickChainDepState' xs +crossEraTickChainDepState ei HardForkConsensusConfig{..} slot = + InPairs.hmap (\(CrossEraTickChainDepState f) -> + CrossEra $ \(Current start view) cds -> + Comp $ WrapTickedChainDepState $ + f start (unwrapLedgerView view) slot (unwrapChainDepState cds)) + $ InPairs.requiringBoth cfgs + $ HFTranslation.crossEraTickChainDepState hardForkEraTranslation where pcfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra cfgs = hcmap proxySingle (completeConsensusConfig'' ei) pcfgs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs index a4fc808490..3f2ffe47d0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Intended for qualified import @@ -24,20 +23,16 @@ module Ouroboros.Consensus.HardFork.Combinator.State ( , epochInfoPrecomputedTransitionInfo , mostRecentTransitionInfo , reconstructSummaryLedger - -- * Ledger specific functionality - , extendToSlot ) where -import Control.Monad (guard) import Data.Functor.Product import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting (getExactly) -import Data.SOP.InPairs (InPairs, Requiring (..)) import qualified Data.SOP.InPairs as InPairs import Data.SOP.Strict -import Data.SOP.Telescope (Extend (..), ScanNext (..), Telescope) +import Data.SOP.Telescope (ScanNext (..), Telescope) import qualified Data.SOP.Telescope as Telescope import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -47,10 +42,8 @@ import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.State.Infra as X import Ouroboros.Consensus.HardFork.Combinator.State.Instances as X () import Ouroboros.Consensus.HardFork.Combinator.State.Types as X -import Ouroboros.Consensus.HardFork.Combinator.Translation import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract hiding (getTip) -import Ouroboros.Consensus.Util ((.:)) import Prelude hiding (sequence) {------------------------------------------------------------------------------- @@ -163,71 +156,3 @@ epochInfoPrecomputedTransitionInfo :: epochInfoPrecomputedTransitionInfo shape transition st = History.summaryToEpochInfo $ reconstructSummary shape transition st - -{------------------------------------------------------------------------------- - Extending --------------------------------------------------------------------------------} - --- | Extend the telescope until the specified slot is within the era at the tip -extendToSlot :: forall xs. CanHardFork xs - => HardForkLedgerConfig xs - -> SlotNo - -> HardForkState LedgerState xs -> HardForkState LedgerState xs -extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) = - HardForkState . unI - . Telescope.extend - ( InPairs.hmap (\f -> Require $ \(K t) - -> Extend $ \cur - -> I $ howExtend f t cur) - $ translate - ) - (hczipWith - proxySingle - (fn .: whenExtend) - pcfgs - (getExactly (History.getShape hardForkLedgerConfigShape))) - $ st - where - pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra - cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs - ei = epochInfoLedger ledgerCfg ledgerSt - - -- Return the end of this era if we should transition to the next - whenExtend :: SingleEraBlock blk - => WrapPartialLedgerConfig blk - -> K History.EraParams blk - -> Current LedgerState blk - -> (Maybe :.: K History.Bound) blk - whenExtend pcfg (K eraParams) cur = Comp $ K <$> do - transition <- singleEraTransition' - pcfg - eraParams - (currentStart cur) - (currentState cur) - let endBound = History.mkUpperBound - eraParams - (currentStart cur) - transition - guard (slot >= History.boundSlot endBound) - return endBound - - howExtend :: Translate LedgerState blk blk' - -> History.Bound - -> Current LedgerState blk - -> (K Past blk, Current LedgerState blk') - howExtend f currentEnd cur = ( - K Past { - pastStart = currentStart cur - , pastEnd = currentEnd - } - , Current { - currentStart = currentEnd - , currentState = translateWith f - (History.boundEpoch currentEnd) - (currentState cur) - } - ) - - translate :: InPairs (Translate LedgerState) xs - translate = InPairs.requiringBoth cfgs $ - translateLedgerState hardForkEraTranslation diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs index b9a7d09d22..0acd6ba704 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs @@ -19,7 +19,7 @@ module Ouroboros.Consensus.HardFork.Combinator.State.Infra ( -- * Situated , Situated (..) , situate - -- * Aligning + -- * Extend and align , align -- * EpochInfo/Summary , reconstructSummary @@ -29,7 +29,7 @@ import Data.Functor.Product import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting -import Data.SOP.InPairs (InPairs, Requiring (..)) +import Data.SOP.InPairs (InPairs, RequiringBoth' (..)) import qualified Data.SOP.InPairs as InPairs import Data.SOP.Match (Mismatch) import qualified Data.SOP.Match as Match @@ -38,12 +38,12 @@ import Data.SOP.Strict import Data.SOP.Telescope (Extend (..), Telescope (..)) import qualified Data.SOP.Telescope as Telescope import Ouroboros.Consensus.Block -import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock import Ouroboros.Consensus.HardFork.Combinator.State.Lift import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (..), EraEnd (..), EraParams (..), EraSummary (..), SafeZone (..)) import qualified Ouroboros.Consensus.HardFork.History as History +import Ouroboros.Consensus.Util.CallStack import Prelude hiding (sequence) {------------------------------------------------------------------------------- @@ -114,19 +114,28 @@ situate ns = go ns . getHardForkState Aligning -------------------------------------------------------------------------------} -align :: forall xs f f' f''. All SingleEraBlock xs - => InPairs (Translate f) xs - -> NP (f' -.-> f -.-> f'') xs - -> HardForkState f' xs -- ^ State we are aligning with - -> HardForkState f xs -- ^ State we are aligning - -> HardForkState f'' xs -align fs updTip (HardForkState alignWith) (HardForkState toAlign) = +-- TODO docs +align :: + forall f f' f'' xs. (SListI xs, HasCallStack) + => InPairs (CrossEra f f' f'') xs + -- ^ How to cross the era boundary. + -> NP (f' -.-> f -.-> f'') xs + -- ^ What to do if the states are already in the same era. + -> HardForkState f' xs + -- ^ State we are aligning with. + -> HardForkState f xs + -- ^ State we are aligning. Must be exactly one era ahead if not already + -- aligned. + -> HardForkState f'' xs + -- ^ In the same era as the state we are aligning with, and therefore + -- either in the same era or one era ahead as the to-be-aligned state. +align cross updTip (HardForkState alignWith) (HardForkState toAlign) = HardForkState . unI $ - Telescope.alignExtend - (InPairs.hmap (\f -> Require $ - \past -> Extend $ - \cur -> I $ - newCurrent f past cur) fs) + Telescope.align + (InPairs.hmap (\(CrossEra f) -> RequireBoth $ + \past newEra -> Extend $ + \(Current _ cur) -> I $ + (past, newEra { currentState = f newEra cur })) cross) (hmap (fn_2 . liftUpdTip) updTip) alignWith toAlign @@ -135,24 +144,6 @@ align fs updTip (HardForkState alignWith) (HardForkState toAlign) = -> Current f' blk -> Current f blk -> Current f'' blk liftUpdTip f = lift . apFn . apFn f . currentState - newCurrent :: Translate f blk blk' - -> K Past blk - -> Current f blk - -> (K Past blk, Current f blk') - newCurrent f (K past) curF = ( - K Past { pastStart = currentStart curF - , pastEnd = curEnd - } - , Current { currentStart = curEnd - , currentState = translateWith f - (boundEpoch curEnd) - (currentState curF) - } - ) - where - curEnd :: Bound - curEnd = pastEnd past - {------------------------------------------------------------------------------- Summary/EpochInfo -------------------------------------------------------------------------------} 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 8821d1af08..ef46039173 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 @@ -11,9 +11,11 @@ module Ouroboros.Consensus.HardFork.Combinator.State.Types ( , Past (..) , sequenceHardForkState -- * Supporting types + , CrossEra (..) , CrossEraForecaster (..) + , CrossEraTickChainDepState (..) + , CrossEraTickLedgerState (..) , TransitionInfo (..) - , Translate (..) ) where import Control.Monad.Except @@ -27,6 +29,9 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.History (Bound) +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Ticked import Prelude {------------------------------------------------------------------------------- @@ -108,11 +113,30 @@ sequenceHardForkState (HardForkState tel) = Supporting types -------------------------------------------------------------------------------} --- | Translate @f x@ to @f y@ across an era transition --- --- Typically @f@ will be 'LedgerState' or 'WrapChainDepState'. -newtype Translate f x y = Translate { - translateWith :: EpochNo -> f x -> f y +newtype CrossEra f f' f'' x y = CrossEra { + crossEra :: + Current f' y -- State that already is in the new era + -> f x -- State in the old era + -> f'' y -- State to compute for the new era + } + +-- TODO docs +newtype CrossEraTickLedgerState x y = CrossEraTickLedgerState { + crossEraTickLedgerStateWith :: + Bound -- 'Bound' of the transition (start of the new era) + -> SlotNo -- 'SlotNo' we are ticking to + -> LedgerState x + -> LedgerResult (LedgerState y) (TickedLedgerState y) + } + +-- TODO docs +newtype CrossEraTickChainDepState x y = CrossEraTickChainDepState { + crossEraTickChainDepStateWith :: + Bound -- 'Bound' of the transition (start of the new era) + -> LedgerView (BlockProtocol y) + -> SlotNo -- 'SlotNo' we are ticking to + -> ChainDepState (BlockProtocol x) + -> Ticked (ChainDepState (BlockProtocol y)) } -- | Forecast a @view y@ from a @state x@ across an era transition. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs index 1528b9a578..3b74d150b1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs @@ -7,7 +7,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Translation ( , trivialEraTranslation ) where -import Data.SOP.InPairs (InPairs (..), RequiringBoth (..)) +import Data.SOP.InPairs (InPairs (..), RequiringBoth) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Abstract @@ -17,16 +17,19 @@ import Ouroboros.Consensus.TypeFamilyWrappers -------------------------------------------------------------------------------} data EraTranslation xs = EraTranslation { - translateLedgerState :: InPairs (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs - , translateChainDepState :: InPairs (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState)) xs - , crossEraForecast :: InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs + crossEraTickLedgerState :: + InPairs (RequiringBoth WrapLedgerConfig CrossEraTickLedgerState) xs + , crossEraTickChainDepState :: + InPairs (RequiringBoth WrapConsensusConfig CrossEraTickChainDepState) xs + , crossEraForecast :: + InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs } deriving NoThunks via OnlyCheckWhnfNamed "EraTranslation" (EraTranslation xs) trivialEraTranslation :: EraTranslation '[blk] trivialEraTranslation = EraTranslation { - translateLedgerState = PNil - , crossEraForecast = PNil - , translateChainDepState = PNil + crossEraTickLedgerState = PNil + , crossEraTickChainDepState = PNil + , crossEraForecast = PNil } diff --git a/sop-extras/src/Data/SOP/InPairs.hs b/sop-extras/src/Data/SOP/InPairs.hs index f00eff6f19..04c7c49c0a 100644 --- a/sop-extras/src/Data/SOP/InPairs.hs +++ b/sop-extras/src/Data/SOP/InPairs.hs @@ -28,7 +28,8 @@ module Data.SOP.InPairs ( , hpure -- * Requiring , Requiring (..) - , RequiringBoth (..) + , RequiringBoth + , RequiringBoth' (..) , ignoring , ignoringBoth , requiring @@ -117,14 +118,16 @@ newtype Requiring h f x y = Require { provide :: h x -> f x y } -newtype RequiringBoth h f x y = RequireBoth { - provideBoth :: h x -> h y -> f x y +newtype RequiringBoth' h h' f x y = RequireBoth { + provideBoth :: h x -> h' y -> f x y } +type RequiringBoth h = RequiringBoth' h h + ignoring :: f x y -> Requiring h f x y ignoring fxy = Require $ const fxy -ignoringBoth :: f x y -> RequiringBoth h f x y +ignoringBoth :: f x y -> RequiringBoth' h h' f x y ignoringBoth fxy = RequireBoth $ \_ _ -> fxy requiring :: SListI xs => NP h xs -> InPairs (Requiring h f) xs -> InPairs f xs diff --git a/sop-extras/src/Data/SOP/Telescope.hs b/sop-extras/src/Data/SOP/Telescope.hs index 74695de94a..9e49ca65f0 100644 --- a/sop-extras/src/Data/SOP/Telescope.hs +++ b/sop-extras/src/Data/SOP/Telescope.hs @@ -35,17 +35,10 @@ module Data.SOP.Telescope ( , bihczipWith , bihmap , bihzipWith - -- * Extension, retraction, alignment + -- * Extension and alignment , Extend (..) - , Retract (..) , align , extend - , retract - -- ** Simplified API - , alignExtend - , alignExtendNS - , extendIf - , retractIf -- * Additional API , ScanNext (..) , SimpleTelescope (..) @@ -59,11 +52,9 @@ import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting -import Data.SOP.InPairs (InPairs (..), Requiring (..)) -import qualified Data.SOP.InPairs as InPairs +import Data.SOP.InPairs (InPairs (..), Requiring (..), + RequiringBoth' (..)) import Data.SOP.Strict -import Data.SOP.Tails (Tails (..)) -import qualified Data.SOP.Tails as Tails import GHC.Stack import NoThunks.Class (NoThunks (..), allNoThunks) import Prelude hiding (scanl, sequence, zipWith) @@ -299,151 +290,66 @@ fromTZ :: Telescope g f '[x] -> f x fromTZ (TZ fx) = fx {------------------------------------------------------------------------------- - Extension and retraction + Extension and alignment -------------------------------------------------------------------------------} -newtype Extend m g f x y = Extend { extendWith :: f x -> m (g x, f y) } +newtype Extend m g f f' x y = Extend { extendWith :: f x -> m (g x, f' y) } --- | Extend the telescope +-- | Extend the telescope by at most one segment. -- -- We will not attempt to extend the telescope past its final segment. -extend :: forall m h g f xs. Monad m - => InPairs (Requiring h (Extend m g f)) xs -- ^ How to extend - -> NP (f -.-> Maybe :.: h) xs -- ^ Where to extend /from/ - -> Telescope g f xs -> m (Telescope g f xs) +extend :: + forall m g h f f' xs. Monad m + => NP (f -.-> Maybe :.: h) xs -- ^ Whether to extend + -> InPairs (Requiring h (Extend m g f f')) xs -- ^ How to extend + -> NP (f -.-> f') xs -- ^ How not to extend + -> Telescope g f xs -> m (Telescope g f' xs) extend = go where - go :: InPairs (Requiring h (Extend m g f)) xs' - -> NP (f -.-> Maybe :.: h) xs' - -> Telescope g f xs' -> m (Telescope g f xs') - go PNil _ (TZ fx) = - return (TZ fx) - go (PCons e es) (p :* ps) (TZ fx) = - case unComp $ apFn p fx of - Nothing -> - return (TZ fx) - Just hx -> do - (gx, fy) <- extendWith (provide e hx) fx - TS gx <$> go es ps (TZ fy) - go (PCons _ es) (_ :* ps) (TS gx fx) = - TS gx <$> go es ps fx - -newtype Retract m g f x y = Retract { retractWith :: g x -> f y -> m (f x) } - --- | Retract a telescope -retract :: forall m h g f xs. Monad m - => Tails (Requiring h (Retract m g f)) xs -- ^ How to retract - -> NP (g -.-> Maybe :.: h) xs -- ^ Where to retract /to/ - -> Telescope g f xs -> m (Telescope g f xs) -retract = - \tails np -> - npToSListI np $ go tails np - where - go :: SListI xs' - => Tails (Requiring h (Retract m g f)) xs' - -> NP (g -.-> Maybe :.: h) xs' - -> Telescope g f xs' -> m (Telescope g f xs') - go _ _ (TZ fx) = return $ TZ fx - go (TCons r rs) (p :* ps) (TS gx t) = - case unComp (apFn p gx) of - Just hx -> - fmap (TZ . hcollapse) $ hsequence' $ - hzipWith (retractAux hx gx) r (tip t) - Nothing -> - TS gx <$> go rs ps t - --- | Internal auxiliary to 'retract' and 'alignWith' -retractAux :: Functor m - => h x -- Proof that we need to retract - -> g x -- Era we are retracting to - -> Requiring h (Retract m g f) x z - -> f z -- Current tip (what we are retracting from) - -> (m :.: K (f x)) z -retractAux hx gx r fz = Comp $ K <$> retractWith (provide r hx) gx fz - --- | Align a telescope with another, then apply a function to the tips --- --- Aligning is a combination of extension and retraction, extending or --- retracting the telescope as required to match up with the other telescope. -align :: forall m g' g f' f f'' xs. Monad m - => InPairs (Requiring g' (Extend m g f)) xs -- ^ How to extend - -> Tails (Requiring f' (Retract m g f)) xs -- ^ How to retract - -> NP (f' -.-> f -.-> f'') xs -- ^ Function to apply at the tip - -> Telescope g' f' xs -- ^ Telescope we are aligning with - -> Telescope g f xs -> m (Telescope g f'' xs) -align = \es rs atTip -> - npToSListI atTip $ go es rs atTip - where - go :: SListI xs' - => InPairs (Requiring g' (Extend m g f)) xs' - -> Tails (Requiring f' (Retract m g f)) xs' - -> NP (f' -.-> f -.-> f'') xs' - -> Telescope g' f' xs' -> Telescope g f xs' -> m (Telescope g f'' xs') - go _ _ (f :* _) (TZ f'x) (TZ fx) = - return $ TZ (f `apFn` f'x `apFn` fx) - go (PCons _ es) (TCons _ rs) (_ :* fs) (TS _ f'x) (TS gx fx) = - TS gx <$> go es rs fs f'x fx - go _ (TCons r _) (f :* _) (TZ f'x) (TS gx fx) = - fmap (TZ . (\fx' -> f `apFn` f'x `apFn` fx') . hcollapse) $ hsequence' $ - hzipWith (retractAux f'x gx) r (tip fx) - go (PCons e es) (TCons _ rs) (_ :* fs) (TS g'x t'x) (TZ fx) = do - (gx, fy) <- extendWith (provide e g'x) fx - TS gx <$> go es rs fs t'x (TZ fy) - -{------------------------------------------------------------------------------- - Derived API --------------------------------------------------------------------------------} - --- | Version of 'extend' where the evidence is a simple 'Bool' -extendIf :: Monad m - => InPairs (Extend m g f) xs -- ^ How to extend - -> NP (f -.-> K Bool) xs -- ^ Where to extend /from/ - -> Telescope g f xs -> m (Telescope g f xs) -extendIf es ps = npToSListI ps $ - extend - (InPairs.hmap (Require . const) es) - (hmap (\f -> fn $ fromBool . apFn f) ps) - --- | Version of 'retract' where the evidence is a simple 'Bool' -retractIf :: Monad m - => Tails (Retract m g f) xs -- ^ How to retract - -> NP (g -.-> K Bool) xs -- ^ Where to retract /to/ - -> Telescope g f xs -> m (Telescope g f xs) -retractIf rs ps = npToSListI ps $ - retract - (Tails.hmap (Require . const) rs) - (hmap (\f -> fn $ fromBool . apFn f) ps) - --- | Version of 'align' that never retracts, only extends + go :: + NP (f -.-> Maybe :.: h) xs' + -> InPairs (Requiring h (Extend m g f f')) xs' + -> NP (f -.-> f') xs' + -> Telescope g f xs' -> m (Telescope g f' xs') + go _ PNil (ne :* _) (TZ fx) = + pure (TZ (apFn ne fx)) + go (c :* _) (PCons e _) (ne :* _) (TZ fx) = + case unComp $ apFn c fx of + Nothing -> pure $ TZ $ apFn ne fx + Just hx -> do + (gx, f'y) <- extendWith (provide e hx) fx + pure $ TS gx $ TZ f'y + go (_ :* cs) (PCons _ es) (_ :* nes) (TS gx fys) = + TS gx <$> go cs es nes fys + +-- | Align the telescope with another by at most one segment. -- --- PRE: The telescope we are aligning with cannot be behind us. -alignExtend :: (Monad m, HasCallStack) - => InPairs (Requiring g' (Extend m g f)) xs -- ^ How to extend - -> NP (f' -.-> f -.-> f'') xs -- ^ Function to apply at the tip - -> Telescope g' f' xs -- ^ Telescope we are aligning with - -> Telescope g f xs -> m (Telescope g f'' xs) -alignExtend es atTip = npToSListI atTip $ - align es (Tails.hpure $ Require $ \_ -> error precondition) atTip +-- PRE: The telescope we are aligning with is in the same segment or one segment +-- ahead. +align :: + forall m g g' f f' f'' xs. (Monad m, HasCallStack) + => InPairs (RequiringBoth' g' f' (Extend m g f f'')) xs -- ^ How to extend + -> NP (f' -.-> f -.-> f'') xs -- ^ Function to apply at the tip + -> Telescope g' f' xs -- ^ Telescope we are aligning with + -> Telescope g f xs -> m (Telescope g f'' xs) +align = go where - precondition :: String - precondition = "alignExtend: precondition violated" - --- | Version of 'alignExtend' that extends with an NS instead -alignExtendNS :: (Monad m, HasCallStack) - => InPairs (Extend m g f) xs -- ^ How to extend - -> NP (f' -.-> f -.-> f'') xs -- ^ Function to apply at the tip - -> NS f' xs -- ^ NS we are aligning with - -> Telescope g f xs -> m (Telescope g f'' xs) -alignExtendNS es atTip ns = npToSListI atTip $ - alignExtend - (InPairs.hmap (Require . const) es) - atTip - (fromTip ns) - --- | Internal auxiliary to 'extendIf' and 'retractIf' -fromBool :: K Bool x -> (Maybe :.: K ()) x -fromBool (K True) = Comp $ Just $ K () -fromBool (K False) = Comp Nothing + go :: + InPairs (RequiringBoth' g' f' (Extend m g f f'')) xs' + -> NP (f' -.-> f -.-> f'') xs' + -> Telescope g' f' xs' + -> Telescope g f xs' -> m (Telescope g f'' xs') + go _ (atTip :* _) (TZ f'x) (TZ fx) = + pure $ TZ (atTip `apFn` f'x `apFn` fx) + go (PCons e _) _ (TS g'x (TZ f'x)) (TZ fx) = do + (gx, f''y) <- extendWith (provideBoth e g'x f'x) fx + pure $ TS gx $ TZ f''y + go (PCons _ es) (_ :* atTips) (TS _ f'ys) (TS gx fys) = + TS gx <$> go es atTips f'ys fys + go _ _ TZ{} TS{} = + error "precondition: behind" + go _ _ (TS _ TS{}) TZ{} = + error "precondition: more than one ahead" {------------------------------------------------------------------------------- Additional API