{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Infrastructure for doing chain selection across eras module Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel ( AcrossEraSelection (..) , WithBlockNo (..) , acrossEraSelection , mapWithBlockNo ) where import Data.Kind (Type) import Data.SOP.Strict import Ouroboros.Consensus.Block import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock import Ouroboros.Consensus.HardFork.Combinator.Util.Tails (Tails (..)) {------------------------------------------------------------------------------- Configuration -------------------------------------------------------------------------------} data AcrossEraSelection :: Type -> Type -> Type 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 @compareChains@ 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 :: ( SelectView (BlockProtocol x) -> SelectView (BlockProtocol y) -> Ordering ) -> AcrossEraSelection x y {------------------------------------------------------------------------------- Compare two eras -------------------------------------------------------------------------------} acrossEras :: forall blk blk'. SingleEraBlock blk => WithBlockNo WrapSelectView blk -> WithBlockNo WrapSelectView blk' -> AcrossEraSelection blk blk' -> Ordering acrossEras :: WithBlockNo WrapSelectView blk -> WithBlockNo WrapSelectView blk' -> AcrossEraSelection blk blk' -> Ordering acrossEras (WithBlockNo BlockNo bnoL (WrapSelectView SelectView (BlockProtocol blk) l)) (WithBlockNo BlockNo bnoR (WrapSelectView SelectView (BlockProtocol blk') r)) = \case AcrossEraSelection blk blk' CompareBlockNo -> BlockNo -> BlockNo -> Ordering forall a. Ord a => a -> a -> Ordering compare BlockNo bnoL BlockNo bnoR CustomChainSel SelectView (BlockProtocol blk) -> SelectView (BlockProtocol blk') -> Ordering f -> SelectView (BlockProtocol blk) -> SelectView (BlockProtocol blk') -> Ordering f SelectView (BlockProtocol blk) l SelectView (BlockProtocol blk') r AcrossEraSelection blk blk' SelectSameProtocol -> SelectView (BlockProtocol blk) -> SelectView (BlockProtocol blk) -> Ordering forall a. Ord a => a -> a -> Ordering compare SelectView (BlockProtocol blk) l SelectView (BlockProtocol blk) SelectView (BlockProtocol blk') r acrossEraSelection :: All SingleEraBlock xs => Tails AcrossEraSelection xs -> WithBlockNo (NS WrapSelectView) xs -> WithBlockNo (NS WrapSelectView) xs -> Ordering acrossEraSelection :: Tails AcrossEraSelection xs -> WithBlockNo (NS WrapSelectView) xs -> WithBlockNo (NS WrapSelectView) xs -> Ordering acrossEraSelection = \Tails AcrossEraSelection xs ffs WithBlockNo (NS WrapSelectView) xs l WithBlockNo (NS WrapSelectView) xs r -> Tails AcrossEraSelection xs -> (NS (WithBlockNo WrapSelectView) xs, NS (WithBlockNo WrapSelectView) xs) -> Ordering forall (xs :: [*]). All SingleEraBlock xs => Tails AcrossEraSelection xs -> (NS (WithBlockNo WrapSelectView) xs, NS (WithBlockNo WrapSelectView) xs) -> Ordering goLeft Tails AcrossEraSelection xs ffs (WithBlockNo (NS WrapSelectView) xs -> NS (WithBlockNo WrapSelectView) xs forall k (xs :: [k]) (f :: k -> *). SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs distribBlockNo WithBlockNo (NS WrapSelectView) xs l, WithBlockNo (NS WrapSelectView) xs -> NS (WithBlockNo WrapSelectView) xs forall k (xs :: [k]) (f :: k -> *). SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs distribBlockNo WithBlockNo (NS WrapSelectView) xs r) where goLeft :: All SingleEraBlock xs => Tails AcrossEraSelection xs -> ( NS (WithBlockNo WrapSelectView) xs , NS (WithBlockNo WrapSelectView) xs ) -> Ordering goLeft :: Tails AcrossEraSelection xs -> (NS (WithBlockNo WrapSelectView) xs, NS (WithBlockNo WrapSelectView) xs) -> Ordering goLeft Tails AcrossEraSelection xs TNil = \(NS (WithBlockNo WrapSelectView) xs a, NS (WithBlockNo WrapSelectView) xs _) -> case NS (WithBlockNo WrapSelectView) xs a of {} goLeft (TCons NP (AcrossEraSelection x) xs fs Tails AcrossEraSelection xs ffs') = \case (Z WithBlockNo WrapSelectView x a, Z WithBlockNo WrapSelectView x b) -> WrapSelectView x -> WrapSelectView x -> Ordering forall a. Ord a => a -> a -> Ordering compare (WithBlockNo WrapSelectView x -> WrapSelectView x forall k (f :: k -> *) (a :: k). WithBlockNo f a -> f a dropBlockNo WithBlockNo WrapSelectView x a) (WithBlockNo WrapSelectView x -> WrapSelectView x forall k (f :: k -> *) (a :: k). WithBlockNo f a -> f a dropBlockNo WithBlockNo WrapSelectView x b) (Z WithBlockNo WrapSelectView x a, S NS (WithBlockNo WrapSelectView) xs b) -> WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering forall x (xs :: [*]). (SingleEraBlock x, All SingleEraBlock xs) => WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering goRight WithBlockNo WrapSelectView x a NP (AcrossEraSelection x) xs NP (AcrossEraSelection x) xs fs NS (WithBlockNo WrapSelectView) xs NS (WithBlockNo WrapSelectView) xs b (S NS (WithBlockNo WrapSelectView) xs a, Z WithBlockNo WrapSelectView x b) -> Ordering -> Ordering invert (Ordering -> Ordering) -> Ordering -> Ordering forall a b. (a -> b) -> a -> b $ WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering forall x (xs :: [*]). (SingleEraBlock x, All SingleEraBlock xs) => WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering goRight WithBlockNo WrapSelectView x b NP (AcrossEraSelection x) xs NP (AcrossEraSelection x) xs fs NS (WithBlockNo WrapSelectView) xs NS (WithBlockNo WrapSelectView) xs a (S NS (WithBlockNo WrapSelectView) xs a, S NS (WithBlockNo WrapSelectView) xs b) -> Tails AcrossEraSelection xs -> (NS (WithBlockNo WrapSelectView) xs, NS (WithBlockNo WrapSelectView) xs) -> Ordering forall (xs :: [*]). All SingleEraBlock xs => Tails AcrossEraSelection xs -> (NS (WithBlockNo WrapSelectView) xs, NS (WithBlockNo WrapSelectView) xs) -> Ordering goLeft Tails AcrossEraSelection xs ffs' (NS (WithBlockNo WrapSelectView) xs NS (WithBlockNo WrapSelectView) xs a, NS (WithBlockNo WrapSelectView) xs NS (WithBlockNo WrapSelectView) xs b) goRight :: forall x xs. (SingleEraBlock x, All SingleEraBlock xs) => WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering goRight :: WithBlockNo WrapSelectView x -> NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering goRight WithBlockNo WrapSelectView x a = NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering forall (xs' :: [*]). All SingleEraBlock xs' => NP (AcrossEraSelection x) xs' -> NS (WithBlockNo WrapSelectView) xs' -> Ordering go where go :: forall xs'. All SingleEraBlock xs' => NP (AcrossEraSelection x) xs' -> NS (WithBlockNo WrapSelectView) xs' -> Ordering go :: NP (AcrossEraSelection x) xs' -> NS (WithBlockNo WrapSelectView) xs' -> Ordering go NP (AcrossEraSelection x) xs' Nil NS (WithBlockNo WrapSelectView) xs' b = case NS (WithBlockNo WrapSelectView) xs' b of {} go (AcrossEraSelection x x f :* NP (AcrossEraSelection x) xs _) (Z WithBlockNo WrapSelectView x b) = WithBlockNo WrapSelectView x -> WithBlockNo WrapSelectView x -> AcrossEraSelection x x -> Ordering forall blk blk'. SingleEraBlock blk => WithBlockNo WrapSelectView blk -> WithBlockNo WrapSelectView blk' -> AcrossEraSelection blk blk' -> Ordering acrossEras WithBlockNo WrapSelectView x a WithBlockNo WrapSelectView x b AcrossEraSelection x x AcrossEraSelection x x f go (AcrossEraSelection x x _ :* NP (AcrossEraSelection x) xs fs) (S NS (WithBlockNo WrapSelectView) xs b) = NP (AcrossEraSelection x) xs -> NS (WithBlockNo WrapSelectView) xs -> Ordering forall (xs' :: [*]). All SingleEraBlock xs' => NP (AcrossEraSelection x) xs' -> NS (WithBlockNo WrapSelectView) xs' -> Ordering go NP (AcrossEraSelection x) xs fs NS (WithBlockNo WrapSelectView) xs NS (WithBlockNo WrapSelectView) xs b {------------------------------------------------------------------------------- WithBlockNo -------------------------------------------------------------------------------} data WithBlockNo (f :: k -> Type) (a :: k) = WithBlockNo { WithBlockNo f a -> BlockNo getBlockNo :: BlockNo , WithBlockNo f a -> f a dropBlockNo :: f a } deriving (Int -> WithBlockNo f a -> ShowS [WithBlockNo f a] -> ShowS WithBlockNo f a -> String (Int -> WithBlockNo f a -> ShowS) -> (WithBlockNo f a -> String) -> ([WithBlockNo f a] -> ShowS) -> Show (WithBlockNo f a) forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a forall k (f :: k -> *) (a :: k). Show (f a) => Int -> WithBlockNo f a -> ShowS forall k (f :: k -> *) (a :: k). Show (f a) => [WithBlockNo f a] -> ShowS forall k (f :: k -> *) (a :: k). Show (f a) => WithBlockNo f a -> String showList :: [WithBlockNo f a] -> ShowS $cshowList :: forall k (f :: k -> *) (a :: k). Show (f a) => [WithBlockNo f a] -> ShowS show :: WithBlockNo f a -> String $cshow :: forall k (f :: k -> *) (a :: k). Show (f a) => WithBlockNo f a -> String showsPrec :: Int -> WithBlockNo f a -> ShowS $cshowsPrec :: forall k (f :: k -> *) (a :: k). Show (f a) => Int -> WithBlockNo f a -> ShowS Show, WithBlockNo f a -> WithBlockNo f a -> Bool (WithBlockNo f a -> WithBlockNo f a -> Bool) -> (WithBlockNo f a -> WithBlockNo f a -> Bool) -> Eq (WithBlockNo f a) forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a forall k (f :: k -> *) (a :: k). Eq (f a) => WithBlockNo f a -> WithBlockNo f a -> Bool /= :: WithBlockNo f a -> WithBlockNo f a -> Bool $c/= :: forall k (f :: k -> *) (a :: k). Eq (f a) => WithBlockNo f a -> WithBlockNo f a -> Bool == :: WithBlockNo f a -> WithBlockNo f a -> Bool $c== :: forall k (f :: k -> *) (a :: k). Eq (f a) => WithBlockNo f a -> WithBlockNo f a -> Bool Eq, (forall x. WithBlockNo f a -> Rep (WithBlockNo f a) x) -> (forall x. Rep (WithBlockNo f a) x -> WithBlockNo f a) -> Generic (WithBlockNo f a) forall x. Rep (WithBlockNo f a) x -> WithBlockNo f a forall x. WithBlockNo f a -> Rep (WithBlockNo f a) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall k (f :: k -> *) (a :: k) x. Rep (WithBlockNo f a) x -> WithBlockNo f a forall k (f :: k -> *) (a :: k) x. WithBlockNo f a -> Rep (WithBlockNo f a) x $cto :: forall k (f :: k -> *) (a :: k) x. Rep (WithBlockNo f a) x -> WithBlockNo f a $cfrom :: forall k (f :: k -> *) (a :: k) x. WithBlockNo f a -> Rep (WithBlockNo f a) x Generic, Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) Proxy (WithBlockNo f a) -> String (Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)) -> (Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)) -> (Proxy (WithBlockNo f a) -> String) -> NoThunks (WithBlockNo f a) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall k (f :: k -> *) (a :: k). NoThunks (f a) => Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) forall k (f :: k -> *) (a :: k). NoThunks (f a) => Proxy (WithBlockNo f a) -> String showTypeOf :: Proxy (WithBlockNo f a) -> String $cshowTypeOf :: forall k (f :: k -> *) (a :: k). NoThunks (f a) => Proxy (WithBlockNo f a) -> String wNoThunks :: Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) $cwNoThunks :: forall k (f :: k -> *) (a :: k). NoThunks (f a) => Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) noThunks :: Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) $cnoThunks :: forall k (f :: k -> *) (a :: k). NoThunks (f a) => Context -> WithBlockNo f a -> IO (Maybe ThunkInfo) NoThunks) mapWithBlockNo :: (f x -> g y) -> WithBlockNo f x -> WithBlockNo g y mapWithBlockNo :: (f x -> g y) -> WithBlockNo f x -> WithBlockNo g y mapWithBlockNo f x -> g y f (WithBlockNo BlockNo bno f x fx) = BlockNo -> g y -> WithBlockNo g y forall k (f :: k -> *) (a :: k). BlockNo -> f a -> WithBlockNo f a WithBlockNo BlockNo bno (f x -> g y f f x fx) distribBlockNo :: SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs distribBlockNo :: WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs distribBlockNo (WithBlockNo BlockNo b NS f xs ns) = (forall (a :: k). f a -> WithBlockNo f a) -> NS f xs -> NS (WithBlockNo f) xs forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *). (SListIN (Prod h) xs, HAp h) => (forall (a :: k). f a -> f' a) -> h f xs -> h f' xs hmap (BlockNo -> f a -> WithBlockNo f a forall k (f :: k -> *) (a :: k). BlockNo -> f a -> WithBlockNo f a WithBlockNo BlockNo b) NS f xs ns {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} invert :: Ordering -> Ordering invert :: Ordering -> Ordering invert Ordering LT = Ordering GT invert Ordering GT = Ordering LT invert Ordering EQ = Ordering EQ