-
Notifications
You must be signed in to change notification settings - Fork 86
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Closes #2118.
- Loading branch information
Showing
10 changed files
with
225 additions
and
69 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
201 changes: 144 additions & 57 deletions
201
ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.