diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index 09889e7004..827ed721ff 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -49,6 +49,7 @@ import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (InPairs (..), RequiringBoth (..)) +import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Tails as Tails import Ouroboros.Consensus.Byron.Ledger import qualified Ouroboros.Consensus.Byron.Ledger.Conversions as Byron @@ -307,6 +308,7 @@ instance TPraosCrypto c => CanHardFork (CardanoEras c) where , translateChainDepState = PCons translateChainDepStateByronToShelleyWrapper PNil , translateLedgerView = PCons translateLedgerViewByronToShelleyWrapper PNil } + hardForkChainSel = Tails.mk2 CompareBlockNo {------------------------------------------------------------------------------- Translation from Byron to Shelley diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index 757d154701..fbbd0dbbb4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -13,7 +13,10 @@ import Data.Typeable import Ouroboros.Consensus.Util.SOP import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock +import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel import Ouroboros.Consensus.HardFork.Combinator.Translation +import Ouroboros.Consensus.HardFork.Combinator.Util.Tails (Tails) +import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Tails as Tails {------------------------------------------------------------------------------- CanHardFork @@ -21,6 +24,8 @@ import Ouroboros.Consensus.HardFork.Combinator.Translation class (All SingleEraBlock xs, Typeable xs, IsNonEmpty xs) => CanHardFork xs where hardForkEraTranslation :: EraTranslation xs + hardForkChainSel :: Tails AcrossEraSelection xs instance SingleEraBlock blk => CanHardFork '[blk] where hardForkEraTranslation = trivialEraTranslation + hardForkChainSel = Tails.mk1 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs index df4451b32f..8cf0611036 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs @@ -270,19 +270,21 @@ deriving via LiftNamedMismatch "MismatchEraInfo" SingleEraInfo LedgerEraInfo xs Other instances -------------------------------------------------------------------------------} -deriving via LiftNS GenTx xs instance CanHardFork xs => Eq (OneEraGenTx xs) -deriving via LiftNS WrapApplyTxErr xs instance CanHardFork xs => Eq (OneEraApplyTxErr xs) -deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Eq (OneEraEnvelopeErr xs) -deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Eq (OneEraGenTxId xs) -deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Eq (OneEraLedgerError xs) -deriving via LiftNS WrapLedgerWarning xs instance CanHardFork xs => Eq (OneEraLedgerWarning xs) -deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Eq (OneEraTipInfo xs) -deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Eq (OneEraValidationErr xs) +deriving via LiftNP WrapChainSelConfig xs instance CanHardFork xs => Eq (PerEraChainSelConfig xs) +deriving via LiftNS GenTx xs instance CanHardFork xs => Eq (OneEraGenTx xs) +deriving via LiftNS WrapApplyTxErr xs instance CanHardFork xs => Eq (OneEraApplyTxErr xs) +deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Eq (OneEraEnvelopeErr xs) +deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Eq (OneEraGenTxId xs) +deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Eq (OneEraLedgerError xs) +deriving via LiftNS WrapLedgerWarning xs instance CanHardFork xs => Eq (OneEraLedgerWarning xs) +deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Eq (OneEraTipInfo xs) +deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Eq (OneEraValidationErr xs) deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Ord (OneEraGenTxId xs) deriving via LiftNP WrapChainIndepState xs instance CanHardFork xs => Show (PerEraChainIndepState xs) deriving via LiftNP WrapExtraForgeState xs instance CanHardFork xs => Show (PerEraExtraForgeState xs) +deriving via LiftNP WrapChainSelConfig xs instance CanHardFork xs => Show (PerEraChainSelConfig xs) deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Show (OneEraEnvelopeErr xs) deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Show (OneEraLedgerError xs) deriving via LiftNS WrapLedgerWarning xs instance CanHardFork xs => Show (OneEraLedgerWarning xs) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 89ee94d371..c8b87bad1c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -46,7 +46,6 @@ import Ouroboros.Consensus.HardFork.Combinator.Block import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel - (HardForkSelectView (..)) import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView (HardForkLedgerView, HardForkLedgerView_ (..), Ticked (..)) @@ -59,6 +58,32 @@ import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match +{------------------------------------------------------------------------------- + ChainSelection +-------------------------------------------------------------------------------} + +type HardForkSelectView xs = WithBlockNo OneEraSelectView xs + +mkHardForkSelectView :: + BlockNo + -> NS WrapSelectView xs + -> HardForkSelectView xs +mkHardForkSelectView bno view = WithBlockNo bno (OneEraSelectView view) + +-- | Chain selection across eras +instance CanHardFork xs => ChainSelection (HardForkProtocol xs) where + type ChainSelConfig (HardForkProtocol xs) = PerEraChainSelConfig xs + type SelectView (HardForkProtocol xs) = HardForkSelectView xs + + -- We leave 'preferCandidate' at the default + + compareCandidates _ (PerEraChainSelConfig cfgs) l r = + acrossEraSelection + cfgs + hardForkChainSel + (mapWithBlockNo getOneEraSelectView l) + (mapWithBlockNo getOneEraSelectView r) + {------------------------------------------------------------------------------- ConsensusProtocol -------------------------------------------------------------------------------} @@ -116,8 +141,7 @@ instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where cfgs = getPerEraBlockConfig hardForkBlockConfigPerEra selectView HardForkBlockConfig{..} hdr = - HardForkSelectView (blockNo hdr) - . OneEraSelectView + mkHardForkSelectView (blockNo hdr) . hczipWith proxySingle (WrapSelectView .: selectView) cfgs . getOneEraHeader $ getHardForkHeader hdr diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs index 6c4a2c3a98..a2a7fd6d39 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs @@ -1,79 +1,166 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- Intended for qualified import --- --- > import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel (HardForkSelectView(..)) --- > import qualified Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel as ChainSel +-- | Infrastructure for doing chain selection across eras module Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel ( - HardForkSelectView(..) + AcrossEraSelection(..) + , acrossEraSelection + , WithBlockNo(..) + , mapWithBlockNo ) where -import Data.Functor.Product import Data.SOP.Strict import Ouroboros.Consensus.Block import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers -import Ouroboros.Consensus.Util ((.:)) +import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.HardFork.Combinator.Abstract -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras -import Ouroboros.Consensus.HardFork.Combinator.Basics -import Ouroboros.Consensus.HardFork.Combinator.Util.Match +import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock +import Ouroboros.Consensus.HardFork.Combinator.Util.Tails (Tails (..)) -data HardForkSelectView xs = HardForkSelectView { - hardForkSelectViewBlockNo :: BlockNo - , hardForkSelectViewOneEra :: OneEraSelectView xs - } - deriving (Show) +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} --- | Chain selection across eras --- --- TODO: If the two chains are from different eras, we simply pick the longer --- one. This may not be okay for all hard fork transitions; we might need to --- generalize this later. -instance CanHardFork xs => ChainSelection (HardForkProtocol xs) where - type ChainSelConfig (HardForkProtocol xs) = PerEraChainSelConfig xs - type SelectView (HardForkProtocol xs) = HardForkSelectView xs +data AcrossEraSelection :: * -> * -> * where + -- | Just compare block numbers + -- + -- This is a useful default when two eras run totally different consensus + -- protocols, and we just want to choose the longer chain. + CompareBlockNo :: AcrossEraSelection x y + + -- | Two eras running the same protocol + -- + -- In this case, we can just call @compareCandidates@ even across eras. + -- (The 'ChainSelConfig' must also be the same in both eras: we assert this + -- at the value level.) + -- + -- NOTE: We require that the eras have the same /protocol/, not merely the + -- same 'SelectView', because if we have two eras with different protocols + -- that happen to use the same 'SelectView' but a different way to compare + -- chains, it's not clear how to do cross-era selection. + SelectSameProtocol :: + BlockProtocol x ~ BlockProtocol y + => AcrossEraSelection x y + + -- | Custom chain selection + -- + -- This is the most general form, and allows to override chain selection for + -- the specific combination of two eras with a custom comparison function. + CustomChainSel :: + ( ChainSelConfig (BlockProtocol x) + -> ChainSelConfig (BlockProtocol y) + -> SelectView (BlockProtocol x) + -> SelectView (BlockProtocol y) + -> Ordering + ) + -> AcrossEraSelection x y + +{------------------------------------------------------------------------------- + Compare two eras +-------------------------------------------------------------------------------} - -- We leave 'preferCandidate' at the default +withinEra :: + forall blk. SingleEraBlock blk + => WrapChainSelConfig blk + -> WrapSelectView blk + -> WrapSelectView blk + -> Ordering +withinEra (WrapChainSelConfig cfg) (WrapSelectView l) (WrapSelectView r) = + compareCandidates (Proxy @(BlockProtocol blk)) cfg l r + +acrossEras :: + forall blk blk'. SingleEraBlock blk + => WrapChainSelConfig blk + -> WrapChainSelConfig blk' + -> WithBlockNo WrapSelectView blk + -> WithBlockNo WrapSelectView blk' + -> AcrossEraSelection blk blk' + -> Ordering +acrossEras (WrapChainSelConfig cfgL) + (WrapChainSelConfig cfgR) + (WithBlockNo bnoL (WrapSelectView l)) + (WithBlockNo bnoR (WrapSelectView r)) = \case + CompareBlockNo -> compare bnoL bnoR + CustomChainSel f -> f cfgL cfgR l r + SelectSameProtocol -> assertEqWithMsg (cfgL, cfgR) $ + compareCandidates + (Proxy @(BlockProtocol blk)) + cfgL + l + r + +acrossEraSelection :: + All SingleEraBlock xs + => NP WrapChainSelConfig xs + -> Tails AcrossEraSelection xs + -> WithBlockNo (NS WrapSelectView) xs + -> WithBlockNo (NS WrapSelectView) xs + -> Ordering +acrossEraSelection = \cfgs ffs l r -> + goLeft cfgs ffs (distribBlockNo l, distribBlockNo r) + where + goLeft :: + All SingleEraBlock xs + => NP WrapChainSelConfig xs + -> Tails AcrossEraSelection xs + -> ( NS (WithBlockNo WrapSelectView) xs + , NS (WithBlockNo WrapSelectView) xs + ) + -> Ordering + goLeft _ TNil = \(a, _) -> case a of {} + goLeft (c :* cs) (TCons fs ffs') = \case + (Z a, Z b) -> withinEra c (dropBlockNo a) (dropBlockNo b) + (Z a, S b) -> goRight c a cs fs b + (S a, Z b) -> invert $ goRight c b cs fs a + (S a, S b) -> goLeft cs ffs' (a, b) + + goRight :: + forall x xs. (SingleEraBlock x, All SingleEraBlock xs) + => WrapChainSelConfig x + -> WithBlockNo WrapSelectView x + -> NP WrapChainSelConfig xs + -> NP (AcrossEraSelection x) xs + -> NS (WithBlockNo WrapSelectView) xs + -> Ordering + goRight cfgL a = go + where + go :: forall xs'. All SingleEraBlock xs' + => NP WrapChainSelConfig xs' + -> NP (AcrossEraSelection x) xs' + -> NS (WithBlockNo WrapSelectView) xs' + -> Ordering + go _ Nil b = case b of {} + go (c :* _) (f :* _) (Z b) = acrossEras cfgL c a b f + go (_ :* cs) (_ :* fs) (S b) = go cs fs b + +{------------------------------------------------------------------------------- + WithBlockNo +-------------------------------------------------------------------------------} + +data WithBlockNo (f :: k -> *) (a :: k) = WithBlockNo { + getBlockNo :: BlockNo + , dropBlockNo :: f a + } + deriving (Show) - compareCandidates _ (PerEraChainSelConfig cfgs) = - either (uncurry different) same .: matchView - where - -- If the two views are from the same era, just use 'compareCandidates' - same :: NS (Product WrapSelectView WrapSelectView) xs -> Ordering - same = hcollapse . hczipWith proxySingle compareCandidates' cfgs +mapWithBlockNo :: (f x -> g y) -> WithBlockNo f x -> WithBlockNo g y +mapWithBlockNo f (WithBlockNo bno fx) = WithBlockNo bno (f fx) - -- If the two tips are in different eras, just compare chain length - different :: BlockNo -> BlockNo -> Ordering - different = Prelude.compare +distribBlockNo :: SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs +distribBlockNo (WithBlockNo b ns) = hmap (WithBlockNo b) ns {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -compareCandidates' :: forall blk. SingleEraBlock blk - => WrapChainSelConfig blk - -> Product WrapSelectView WrapSelectView blk - -> K Ordering blk -compareCandidates' (WrapChainSelConfig cfg) - (Pair (WrapSelectView view1) - (WrapSelectView view2)) = K $ - compareCandidates (Proxy @(BlockProtocol blk)) cfg view1 view2 - -matchView :: HardForkSelectView xs - -> HardForkSelectView xs - -> Either (BlockNo, BlockNo) - (NS (Product WrapSelectView WrapSelectView) xs) -matchView cand1 cand2 = - case matchNS (getOneEraSelectView $ hardForkSelectViewOneEra cand1) - (getOneEraSelectView $ hardForkSelectViewOneEra cand2) of - Right matched -> Right matched - Left _mismatch -> Left ( hardForkSelectViewBlockNo cand1 - , hardForkSelectViewBlockNo cand2 - ) +invert :: Ordering -> Ordering +invert LT = GT +invert GT = LT +invert EQ = EQ diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Tails.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Tails.hs index eacaf84410..b77943c046 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Tails.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Tails.hs @@ -12,6 +12,11 @@ -- > import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Tails as Tails module Ouroboros.Consensus.HardFork.Combinator.Util.Tails ( Tails(..) + -- * Convenience constructors + , mk1 + , mk2 + , mk3 + -- * SOP-like operators , hmap , hcmap , hpure @@ -30,6 +35,23 @@ data Tails (f :: k -> k -> *) (xs :: [k]) where TNil :: Tails f '[] TCons :: NP (f x) xs -> Tails f xs -> Tails f (x ': xs) +{------------------------------------------------------------------------------- + Convenience constructors +-------------------------------------------------------------------------------} + +mk1 :: Tails f '[x] +mk1 = TCons Nil TNil + +mk2 :: f x y -> Tails f '[x, y] +mk2 xy = TCons (xy :* Nil) mk1 + +mk3 :: f x y -> f x z -> f y z -> Tails f '[x, y, z] +mk3 xy xz yz = TCons (xy :* xz :* Nil) (mk2 yz) + +{------------------------------------------------------------------------------- + SOP-like operators +-------------------------------------------------------------------------------} + hmap :: SListI xs => (forall x y. f x y -> g x y) -> Tails f xs -> Tails g xs diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index a9058bdc17..11ead314a3 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -41,7 +41,9 @@ data family ConsensusConfig p :: * -- | Chain selection class ( NoUnexpectedThunks (ChainSelConfig p) -- For the benefit of tests - , Show (SelectView p) + , Show (SelectView p) + , Show (ChainSelConfig p) + , Eq (ChainSelConfig p) ) => ChainSelection p where -- | Configuration required for chain selection type family ChainSelConfig p :: * diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs index d1878a66f0..7d4b414e6c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -126,11 +126,13 @@ deriving instance Trivial (ExtraForgeState blk) => Trivial (WrapExtraForgeState -------------------------------------------------------------------------------} deriving instance Eq (ChainDepState (BlockProtocol blk)) => Eq (WrapChainDepState blk) +deriving instance Eq (ChainSelConfig (BlockProtocol blk)) => Eq (WrapChainSelConfig blk) deriving instance Eq (ValidationErr (BlockProtocol blk)) => Eq (WrapValidationErr blk) deriving instance Show (CannotLead (BlockProtocol blk)) => Show (WrapCannotLead blk) deriving instance Show (ChainDepState (BlockProtocol blk)) => Show (WrapChainDepState blk) deriving instance Show (ChainIndepState (BlockProtocol blk)) => Show (WrapChainIndepState blk) +deriving instance Show (ChainSelConfig (BlockProtocol blk)) => Show (WrapChainSelConfig blk) deriving instance Show (LedgerView (BlockProtocol blk)) => Show (WrapLedgerView blk) deriving instance Show (SelectView (BlockProtocol blk)) => Show (WrapSelectView blk) deriving instance Show (ValidationErr (BlockProtocol blk)) => Show (WrapValidationErr blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Assert.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Assert.hs index fa9d5ed71a..76e0a055bc 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Assert.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Assert.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} module Ouroboros.Consensus.Util.Assert ( assertWithMsg + , assertEqWithMsg ) where import GHC.Stack (HasCallStack) @@ -15,3 +16,10 @@ assertWithMsg (Left msg) _ = error msg assertWithMsg _ a = a where _ = keepRedundantConstraint (Proxy @HasCallStack) + +assertEqWithMsg :: (Eq b, Show b, HasCallStack) => (b, b) -> a -> a +assertEqWithMsg (x, y) = assertWithMsg msg + where + msg :: Either String () + msg | x == y = Right () + | otherwise = Left $ show x ++ " /= " ++ show y diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs index b9be835a57..c46e320aa8 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs @@ -62,6 +62,7 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation as HFC import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (RequiringBoth (..)) +import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Tails as Tails import Ouroboros.Consensus.HardFork.History (EraParams (..), noLowerBoundSafeZone) import qualified Ouroboros.Consensus.HardFork.History as History @@ -380,6 +381,7 @@ instance CanHardFork '[BlockA, BlockB] where , translateChainDepState = PCons chainDepState_AtoB PNil , translateLedgerView = PCons ledgerView_AtoB PNil } + hardForkChainSel = Tails.mk2 CompareBlockNo versionN2N :: BlockNodeToNodeVersion TestBlock versionN2N = HardForkNodeToNodeEnabled $