{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.AcrossEras ( -- * Value for /each/ era PerEraBlockConfig (..) , PerEraCodecConfig (..) , PerEraConsensusConfig (..) , PerEraLedgerConfig (..) , PerEraStorageConfig (..) -- * Values for /some/ eras , SomeErasCanBeLeader (..) -- * Value for /one/ era , OneEraApplyTxErr (..) , OneEraBlock (..) , OneEraCannotForge (..) , OneEraEnvelopeErr (..) , OneEraForgeStateInfo (..) , OneEraForgeStateUpdateError (..) , OneEraGenTx (..) , OneEraGenTxId (..) , OneEraHash (..) , OneEraHeader (..) , OneEraIsLeader (..) , OneEraLedgerError (..) , OneEraLedgerEvent (..) , OneEraLedgerUpdate (..) , OneEraLedgerWarning (..) , OneEraSelectView (..) , OneEraTipInfo (..) , OneEraValidateView (..) , OneEraValidatedGenTx (..) , OneEraValidationErr (..) -- * Value for two /different/ eras , EraMismatch (..) , MismatchEraInfo (..) , mismatchFutureEra , mismatchOneEra , mkEraMismatch -- * Utility , getSameValue , oneEraBlockHeader ) where import Codec.Serialise (Serialise (..)) import Control.Monad.Except (throwError) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as Short import Data.SOP.Strict hiding (shift) import Data.Text (Text) import Data.Void import GHC.Generics (Generic) import GHC.Stack import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (allEqual) import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.OptNP (NonEmptyOptNP) import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Util.DerivingVia import Ouroboros.Consensus.HardFork.Combinator.Util.Match (Mismatch) import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match {------------------------------------------------------------------------------- Value for /each/ era -------------------------------------------------------------------------------} newtype PerEraBlockConfig xs = PerEraBlockConfig { PerEraBlockConfig xs -> NP BlockConfig xs getPerEraBlockConfig :: NP BlockConfig xs } newtype PerEraCodecConfig xs = PerEraCodecConfig { PerEraCodecConfig xs -> NP CodecConfig xs getPerEraCodecConfig :: NP CodecConfig xs } newtype PerEraConsensusConfig xs = PerEraConsensusConfig { PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs getPerEraConsensusConfig :: NP WrapPartialConsensusConfig xs } newtype PerEraLedgerConfig xs = PerEraLedgerConfig { PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs getPerEraLedgerConfig :: NP WrapPartialLedgerConfig xs } newtype PerEraStorageConfig xs = PerEraStorageConfig { PerEraStorageConfig xs -> NP StorageConfig xs getPerEraStorageConfig :: NP StorageConfig xs } {------------------------------------------------------------------------------- Values for /some/ eras The reason for using @NonEmptyOptNP f xs@ as opposed to @NP (Maybe :.: f) xs@ is to maintain the isomorphism between @blk@ and @HardForkBlock '[blk]@ in "Ouroboros.Consensus.HardFork.Combinator.Embed.Unary" -------------------------------------------------------------------------------} newtype SomeErasCanBeLeader xs = SomeErasCanBeLeader { SomeErasCanBeLeader xs -> NonEmptyOptNP WrapCanBeLeader xs getSomeErasCanBeLeader :: NonEmptyOptNP WrapCanBeLeader xs } {------------------------------------------------------------------------------- Value for /one/ era -------------------------------------------------------------------------------} newtype OneEraApplyTxErr xs = OneEraApplyTxErr { OneEraApplyTxErr xs -> NS WrapApplyTxErr xs getOneEraApplyTxErr :: NS WrapApplyTxErr xs } newtype OneEraBlock xs = OneEraBlock { OneEraBlock xs -> NS I xs getOneEraBlock :: NS I xs } newtype OneEraCannotForge xs = OneEraCannotForge { OneEraCannotForge xs -> NS WrapCannotForge xs getOneEraCannotForge :: NS WrapCannotForge xs } newtype OneEraEnvelopeErr xs = OneEraEnvelopeErr { OneEraEnvelopeErr xs -> NS WrapEnvelopeErr xs getOneEraEnvelopeErr :: NS WrapEnvelopeErr xs } newtype OneEraForgeStateInfo xs = OneEraForgeStateInfo { OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs getOneEraForgeStateInfo :: NS WrapForgeStateInfo xs } newtype OneEraForgeStateUpdateError xs = OneEraForgeStateUpdateError { OneEraForgeStateUpdateError xs -> NS WrapForgeStateUpdateError xs getOneEraForgeStateUpdateError :: NS WrapForgeStateUpdateError xs } newtype OneEraGenTx xs = OneEraGenTx { OneEraGenTx xs -> NS GenTx xs getOneEraGenTx :: NS GenTx xs } newtype OneEraGenTxId xs = OneEraGenTxId { OneEraGenTxId xs -> NS WrapGenTxId xs getOneEraGenTxId :: NS WrapGenTxId xs } newtype OneEraHeader xs = OneEraHeader { OneEraHeader xs -> NS Header xs getOneEraHeader :: NS Header xs } newtype OneEraIsLeader xs = OneEraIsLeader { OneEraIsLeader xs -> NS WrapIsLeader xs getOneEraIsLeader :: NS WrapIsLeader xs } newtype OneEraLedgerError xs = OneEraLedgerError { OneEraLedgerError xs -> NS WrapLedgerErr xs getOneEraLedgerError :: NS WrapLedgerErr xs } newtype OneEraLedgerEvent xs = OneEraLedgerEvent { OneEraLedgerEvent xs -> NS WrapLedgerEvent xs getOneEraLedgerEvent :: NS WrapLedgerEvent xs } newtype OneEraLedgerUpdate xs = OneEraLedgerUpdate { OneEraLedgerUpdate xs -> NS WrapLedgerUpdate xs getOneEraLedgerUpdate :: NS WrapLedgerUpdate xs } newtype OneEraLedgerWarning xs = OneEraLedgerWarning { OneEraLedgerWarning xs -> NS WrapLedgerWarning xs getOneEraLedgerWarning :: NS WrapLedgerWarning xs } newtype OneEraSelectView xs = OneEraSelectView { OneEraSelectView xs -> NS WrapSelectView xs getOneEraSelectView :: NS WrapSelectView xs } newtype OneEraTipInfo xs = OneEraTipInfo { OneEraTipInfo xs -> NS WrapTipInfo xs getOneEraTipInfo :: NS WrapTipInfo xs } newtype OneEraValidateView xs = OneEraValidateView { OneEraValidateView xs -> NS WrapValidateView xs getOneEraValidateView :: NS WrapValidateView xs } newtype OneEraValidatedGenTx xs = OneEraValidatedGenTx { OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs getOneEraValidatedGenTx :: NS WrapValidatedGenTx xs } newtype OneEraValidationErr xs = OneEraValidationErr { OneEraValidationErr xs -> NS WrapValidationErr xs getOneEraValidationErr :: NS WrapValidationErr xs } {------------------------------------------------------------------------------- Hash -------------------------------------------------------------------------------} -- | The hash for an era -- -- This type is special: we don't use an NS here, because the hash by itself -- should not allow us to differentiate between eras. If it did, the /size/ -- of the hash would necessarily have to increase, and that leads to trouble. -- So, the type parameter @xs@ here is merely a phantom one, and we just store -- the underlying raw hash. newtype OneEraHash (xs :: [k]) = OneEraHash { OneEraHash xs -> ShortByteString getOneEraHash :: ShortByteString } deriving newtype (OneEraHash xs -> OneEraHash xs -> Bool (OneEraHash xs -> OneEraHash xs -> Bool) -> (OneEraHash xs -> OneEraHash xs -> Bool) -> Eq (OneEraHash xs) forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool /= :: OneEraHash xs -> OneEraHash xs -> Bool $c/= :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool == :: OneEraHash xs -> OneEraHash xs -> Bool $c== :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool Eq, Eq (OneEraHash xs) Eq (OneEraHash xs) -> (OneEraHash xs -> OneEraHash xs -> Ordering) -> (OneEraHash xs -> OneEraHash xs -> Bool) -> (OneEraHash xs -> OneEraHash xs -> Bool) -> (OneEraHash xs -> OneEraHash xs -> Bool) -> (OneEraHash xs -> OneEraHash xs -> Bool) -> (OneEraHash xs -> OneEraHash xs -> OneEraHash xs) -> (OneEraHash xs -> OneEraHash xs -> OneEraHash xs) -> Ord (OneEraHash xs) OneEraHash xs -> OneEraHash xs -> Bool OneEraHash xs -> OneEraHash xs -> Ordering OneEraHash xs -> OneEraHash xs -> OneEraHash xs forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a forall k (xs :: [k]). Eq (OneEraHash xs) forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Ordering forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> OneEraHash xs min :: OneEraHash xs -> OneEraHash xs -> OneEraHash xs $cmin :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> OneEraHash xs max :: OneEraHash xs -> OneEraHash xs -> OneEraHash xs $cmax :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> OneEraHash xs >= :: OneEraHash xs -> OneEraHash xs -> Bool $c>= :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool > :: OneEraHash xs -> OneEraHash xs -> Bool $c> :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool <= :: OneEraHash xs -> OneEraHash xs -> Bool $c<= :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool < :: OneEraHash xs -> OneEraHash xs -> Bool $c< :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Bool compare :: OneEraHash xs -> OneEraHash xs -> Ordering $ccompare :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Ordering $cp1Ord :: forall k (xs :: [k]). Eq (OneEraHash xs) Ord, Context -> OneEraHash xs -> IO (Maybe ThunkInfo) Proxy (OneEraHash xs) -> String (Context -> OneEraHash xs -> IO (Maybe ThunkInfo)) -> (Context -> OneEraHash xs -> IO (Maybe ThunkInfo)) -> (Proxy (OneEraHash xs) -> String) -> NoThunks (OneEraHash xs) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall k (xs :: [k]). Context -> OneEraHash xs -> IO (Maybe ThunkInfo) forall k (xs :: [k]). Proxy (OneEraHash xs) -> String showTypeOf :: Proxy (OneEraHash xs) -> String $cshowTypeOf :: forall k (xs :: [k]). Proxy (OneEraHash xs) -> String wNoThunks :: Context -> OneEraHash xs -> IO (Maybe ThunkInfo) $cwNoThunks :: forall k (xs :: [k]). Context -> OneEraHash xs -> IO (Maybe ThunkInfo) noThunks :: Context -> OneEraHash xs -> IO (Maybe ThunkInfo) $cnoThunks :: forall k (xs :: [k]). Context -> OneEraHash xs -> IO (Maybe ThunkInfo) NoThunks, Decoder s (OneEraHash xs) Decoder s [OneEraHash xs] [OneEraHash xs] -> Encoding OneEraHash xs -> Encoding (OneEraHash xs -> Encoding) -> (forall s. Decoder s (OneEraHash xs)) -> ([OneEraHash xs] -> Encoding) -> (forall s. Decoder s [OneEraHash xs]) -> Serialise (OneEraHash xs) forall s. Decoder s [OneEraHash xs] forall s. Decoder s (OneEraHash xs) forall a. (a -> Encoding) -> (forall s. Decoder s a) -> ([a] -> Encoding) -> (forall s. Decoder s [a]) -> Serialise a forall k (xs :: [k]). [OneEraHash xs] -> Encoding forall k (xs :: [k]). OneEraHash xs -> Encoding forall k (xs :: [k]) s. Decoder s [OneEraHash xs] forall k (xs :: [k]) s. Decoder s (OneEraHash xs) decodeList :: Decoder s [OneEraHash xs] $cdecodeList :: forall k (xs :: [k]) s. Decoder s [OneEraHash xs] encodeList :: [OneEraHash xs] -> Encoding $cencodeList :: forall k (xs :: [k]). [OneEraHash xs] -> Encoding decode :: Decoder s (OneEraHash xs) $cdecode :: forall k (xs :: [k]) s. Decoder s (OneEraHash xs) encode :: OneEraHash xs -> Encoding $cencode :: forall k (xs :: [k]). OneEraHash xs -> Encoding Serialise) instance Show (OneEraHash xs) where show :: OneEraHash xs -> String show = ByteString -> String BSC.unpack (ByteString -> String) -> (OneEraHash xs -> ByteString) -> OneEraHash xs -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString B16.encode (ByteString -> ByteString) -> (OneEraHash xs -> ByteString) -> OneEraHash xs -> ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . ShortByteString -> ByteString Short.fromShort (ShortByteString -> ByteString) -> (OneEraHash xs -> ShortByteString) -> OneEraHash xs -> ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . OneEraHash xs -> ShortByteString forall k (xs :: [k]). OneEraHash xs -> ShortByteString getOneEraHash instance Condense (OneEraHash xs) where condense :: OneEraHash xs -> String condense = OneEraHash xs -> String forall a. Show a => a -> String show {------------------------------------------------------------------------------- Value for two /different/ eras -------------------------------------------------------------------------------} newtype MismatchEraInfo xs = MismatchEraInfo { -- | Era mismatch -- -- We have an era mismatch between the era of a block/header/tx/query -- and the era of the current ledger. MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs getMismatchEraInfo :: Mismatch SingleEraInfo LedgerEraInfo xs } mismatchOneEra :: MismatchEraInfo '[b] -> Void mismatchOneEra :: MismatchEraInfo '[b] -> Void mismatchOneEra = Mismatch SingleEraInfo LedgerEraInfo '[b] -> Void forall k (f :: k -> *) (g :: k -> *) (x :: k). Mismatch f g '[x] -> Void Match.mismatchOne (Mismatch SingleEraInfo LedgerEraInfo '[b] -> Void) -> (MismatchEraInfo '[b] -> Mismatch SingleEraInfo LedgerEraInfo '[b]) -> MismatchEraInfo '[b] -> Void forall b c a. (b -> c) -> (a -> b) -> a -> c . MismatchEraInfo '[b] -> Mismatch SingleEraInfo LedgerEraInfo '[b] forall (xs :: [*]). MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs getMismatchEraInfo -- | A mismatch _must_ involve a future era mismatchFutureEra :: SListI xs => MismatchEraInfo (x ': xs) -> NS SingleEraInfo xs mismatchFutureEra :: MismatchEraInfo (x : xs) -> NS SingleEraInfo xs mismatchFutureEra = (NS SingleEraInfo xs -> NS SingleEraInfo xs) -> (NS LedgerEraInfo xs -> NS SingleEraInfo xs) -> Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs) -> NS SingleEraInfo xs forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either NS SingleEraInfo xs -> NS SingleEraInfo xs forall a. a -> a id ((forall a. LedgerEraInfo a -> SingleEraInfo a) -> NS LedgerEraInfo xs -> NS SingleEraInfo 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 forall a. LedgerEraInfo a -> SingleEraInfo a getLedgerEraInfo) (Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs) -> NS SingleEraInfo xs) -> (MismatchEraInfo (x : xs) -> Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs)) -> MismatchEraInfo (x : xs) -> NS SingleEraInfo xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Mismatch SingleEraInfo LedgerEraInfo (x : xs) -> Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs) forall k (f :: k -> *) (g :: k -> *) (x :: k) (xs :: [k]). Mismatch f g (x : xs) -> Either (NS f xs) (NS g xs) Match.mismatchNotFirst (Mismatch SingleEraInfo LedgerEraInfo (x : xs) -> Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs)) -> (MismatchEraInfo (x : xs) -> Mismatch SingleEraInfo LedgerEraInfo (x : xs)) -> MismatchEraInfo (x : xs) -> Either (NS SingleEraInfo xs) (NS LedgerEraInfo xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . MismatchEraInfo (x : xs) -> Mismatch SingleEraInfo LedgerEraInfo (x : xs) forall (xs :: [*]). MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs getMismatchEraInfo {------------------------------------------------------------------------------- Untyped version of 'MismatchEraInfo' -------------------------------------------------------------------------------} -- | Extra info for errors caused by applying a block, header, transaction, or -- query from one era to a ledger from a different era. data EraMismatch = EraMismatch { -- | Name of the era of the ledger ("Byron" or "Shelley"). EraMismatch -> Text ledgerEraName :: !Text -- | Era of the block, header, transaction, or query. , EraMismatch -> Text otherEraName :: !Text } deriving (EraMismatch -> EraMismatch -> Bool (EraMismatch -> EraMismatch -> Bool) -> (EraMismatch -> EraMismatch -> Bool) -> Eq EraMismatch forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: EraMismatch -> EraMismatch -> Bool $c/= :: EraMismatch -> EraMismatch -> Bool == :: EraMismatch -> EraMismatch -> Bool $c== :: EraMismatch -> EraMismatch -> Bool Eq, Int -> EraMismatch -> ShowS [EraMismatch] -> ShowS EraMismatch -> String (Int -> EraMismatch -> ShowS) -> (EraMismatch -> String) -> ([EraMismatch] -> ShowS) -> Show EraMismatch forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [EraMismatch] -> ShowS $cshowList :: [EraMismatch] -> ShowS show :: EraMismatch -> String $cshow :: EraMismatch -> String showsPrec :: Int -> EraMismatch -> ShowS $cshowsPrec :: Int -> EraMismatch -> ShowS Show, (forall x. EraMismatch -> Rep EraMismatch x) -> (forall x. Rep EraMismatch x -> EraMismatch) -> Generic EraMismatch forall x. Rep EraMismatch x -> EraMismatch forall x. EraMismatch -> Rep EraMismatch x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep EraMismatch x -> EraMismatch $cfrom :: forall x. EraMismatch -> Rep EraMismatch x Generic) -- | When a transaction or block from a certain era was applied to a ledger -- from another era, we get a 'MismatchEraInfo'. -- -- Given such a 'MismatchEraInfo', return the name of the era of the -- transaction/block and the name of the era of the ledger. mkEraMismatch :: SListI xs => MismatchEraInfo xs -> EraMismatch mkEraMismatch :: MismatchEraInfo xs -> EraMismatch mkEraMismatch (MismatchEraInfo Mismatch SingleEraInfo LedgerEraInfo xs mismatch) = Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch forall (xs :: [*]). SListI xs => Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch go Mismatch SingleEraInfo LedgerEraInfo xs mismatch where go :: SListI xs => Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch go :: Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch go (Match.ML SingleEraInfo x otherEra NS LedgerEraInfo xs ledgerEra) = EraMismatch :: Text -> Text -> EraMismatch EraMismatch { ledgerEraName :: Text ledgerEraName = NS (K Text) xs -> CollapseTo NS Text forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K Text) xs -> CollapseTo NS Text) -> NS (K Text) xs -> CollapseTo NS Text forall a b. (a -> b) -> a -> b $ (forall a. LedgerEraInfo a -> K Text a) -> NS LedgerEraInfo xs -> NS (K Text) 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 (Text -> K Text a forall k a (b :: k). a -> K a b K (Text -> K Text a) -> (LedgerEraInfo a -> Text) -> LedgerEraInfo a -> K Text a forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerEraInfo a -> Text forall blk. LedgerEraInfo blk -> Text ledgerName) NS LedgerEraInfo xs ledgerEra , otherEraName :: Text otherEraName = SingleEraInfo x -> Text forall blk. SingleEraInfo blk -> Text otherName SingleEraInfo x otherEra } go (Match.MR NS SingleEraInfo xs otherEra LedgerEraInfo x ledgerEra) = EraMismatch :: Text -> Text -> EraMismatch EraMismatch { ledgerEraName :: Text ledgerEraName = LedgerEraInfo x -> Text forall blk. LedgerEraInfo blk -> Text ledgerName LedgerEraInfo x ledgerEra , otherEraName :: Text otherEraName = NS (K Text) xs -> CollapseTo NS Text forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K Text) xs -> CollapseTo NS Text) -> NS (K Text) xs -> CollapseTo NS Text forall a b. (a -> b) -> a -> b $ (forall a. SingleEraInfo a -> K Text a) -> NS SingleEraInfo xs -> NS (K Text) 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 (Text -> K Text a forall k a (b :: k). a -> K a b K (Text -> K Text a) -> (SingleEraInfo a -> Text) -> SingleEraInfo a -> K Text a forall b c a. (b -> c) -> (a -> b) -> a -> c . SingleEraInfo a -> Text forall blk. SingleEraInfo blk -> Text otherName) NS SingleEraInfo xs otherEra } go (Match.MS Mismatch SingleEraInfo LedgerEraInfo xs m) = Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch forall (xs :: [*]). SListI xs => Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch go Mismatch SingleEraInfo LedgerEraInfo xs m ledgerName :: LedgerEraInfo blk -> Text ledgerName :: LedgerEraInfo blk -> Text ledgerName = SingleEraInfo blk -> Text forall blk. SingleEraInfo blk -> Text singleEraName (SingleEraInfo blk -> Text) -> (LedgerEraInfo blk -> SingleEraInfo blk) -> LedgerEraInfo blk -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerEraInfo blk -> SingleEraInfo blk forall a. LedgerEraInfo a -> SingleEraInfo a getLedgerEraInfo otherName :: SingleEraInfo blk -> Text otherName :: SingleEraInfo blk -> Text otherName = SingleEraInfo blk -> Text forall blk. SingleEraInfo blk -> Text singleEraName {------------------------------------------------------------------------------- Utility -------------------------------------------------------------------------------} oneEraBlockHeader :: CanHardFork xs => OneEraBlock xs -> OneEraHeader xs oneEraBlockHeader :: OneEraBlock xs -> OneEraHeader xs oneEraBlockHeader = NS Header xs -> OneEraHeader xs forall (xs :: [*]). NS Header xs -> OneEraHeader xs OneEraHeader (NS Header xs -> OneEraHeader xs) -> (OneEraBlock xs -> NS Header xs) -> OneEraBlock xs -> OneEraHeader xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Proxy SingleEraBlock -> (forall a. SingleEraBlock a => I a -> Header a) -> NS I xs -> NS Header xs forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *). (AllN (Prod h) c xs, HAp h) => proxy c -> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs hcmap Proxy SingleEraBlock proxySingle (a -> Header a forall blk. GetHeader blk => blk -> Header blk getHeader (a -> Header a) -> (I a -> a) -> I a -> Header a forall b c a. (b -> c) -> (a -> b) -> a -> c . I a -> a forall a. I a -> a unI) (NS I xs -> NS Header xs) -> (OneEraBlock xs -> NS I xs) -> OneEraBlock xs -> NS Header xs forall b c a. (b -> c) -> (a -> b) -> a -> c . OneEraBlock xs -> NS I xs forall (xs :: [*]). OneEraBlock xs -> NS I xs getOneEraBlock getSameValue :: forall xs a. (IsNonEmpty xs, Eq a, SListI xs, HasCallStack) => NP (K a) xs -> a getSameValue :: NP (K a) xs -> a getSameValue NP (K a) xs values = case Proxy xs -> ProofNonEmpty xs forall a (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs isNonEmpty (Proxy xs forall k (t :: k). Proxy t Proxy @xs) of ProofNonEmpty {} -> Either String () -> a -> a forall a. HasCallStack => Either String () -> a -> a assertWithMsg Either String () allEqualCheck (K a x -> a forall k a (b :: k). K a b -> a unK (NP (K a) (x : xs) -> K a x forall k (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x hd NP (K a) xs NP (K a) (x : xs) values)) where allEqualCheck :: Either String () allEqualCheck :: Either String () allEqualCheck | [a] -> Bool forall a. Eq a => [a] -> Bool allEqual (NP (K a) xs -> CollapseTo NP a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse NP (K a) xs values) = () -> Either String () forall (m :: * -> *) a. Monad m => a -> m a return () | Bool otherwise = String -> Either String () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError String "differing values across hard fork" {------------------------------------------------------------------------------- NoThunks instances -------------------------------------------------------------------------------} deriving via LiftNamedNP "PerEraBlockConfig" BlockConfig xs instance CanHardFork xs => NoThunks (PerEraBlockConfig xs) deriving via LiftNamedNP "PerEraCodecConfig" CodecConfig xs instance CanHardFork xs => NoThunks (PerEraCodecConfig xs) deriving via LiftNamedNP "PerEraConsensusConfig" WrapPartialConsensusConfig xs instance CanHardFork xs => NoThunks (PerEraConsensusConfig xs) deriving via LiftNamedNP "PerEraLedgerConfig" WrapPartialLedgerConfig xs instance CanHardFork xs => NoThunks (PerEraLedgerConfig xs) deriving via LiftNamedNP "PerEraStorageConfig" StorageConfig xs instance CanHardFork xs => NoThunks (PerEraStorageConfig xs) deriving via LiftNamedNS "OneEraEnvelopeErr" WrapEnvelopeErr xs instance CanHardFork xs => NoThunks (OneEraEnvelopeErr xs) deriving via LiftNamedNS "OneEraGenTx" GenTx xs instance CanHardFork xs => NoThunks (OneEraGenTx xs) deriving via LiftNamedNS "OneEraGenTxId" WrapGenTxId xs instance CanHardFork xs => NoThunks (OneEraGenTxId xs) deriving via LiftNamedNS "OneEraHeader" Header xs instance CanHardFork xs => NoThunks (OneEraHeader xs) deriving via LiftNamedNS "OneEraLedgerError" WrapLedgerErr xs instance CanHardFork xs => NoThunks (OneEraLedgerError xs) deriving via LiftNamedNS "OneEraSelectView" WrapSelectView xs instance CanHardFork xs => NoThunks (OneEraSelectView xs) deriving via LiftNamedNS "OneEraTipInfo" WrapTipInfo xs instance CanHardFork xs => NoThunks (OneEraTipInfo xs) deriving via LiftNamedNS "OneEraValidated" WrapValidatedGenTx xs instance CanHardFork xs => NoThunks (OneEraValidatedGenTx xs) deriving via LiftNamedNS "OneEraValidationErr" WrapValidationErr xs instance CanHardFork xs => NoThunks (OneEraValidationErr xs) deriving via LiftNamedMismatch "MismatchEraInfo" SingleEraInfo LedgerEraInfo xs instance CanHardFork xs => NoThunks (MismatchEraInfo xs) {------------------------------------------------------------------------------- Other instances -------------------------------------------------------------------------------} 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 GenTx xs instance CanHardFork xs => Eq (OneEraGenTx 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 WrapLedgerUpdate xs instance CanHardFork xs => Eq (OneEraLedgerUpdate xs) deriving via LiftNS WrapLedgerWarning xs instance CanHardFork xs => Eq (OneEraLedgerWarning xs) deriving via LiftNS WrapSelectView xs instance CanHardFork xs => Eq (OneEraSelectView xs) deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Eq (OneEraTipInfo xs) deriving via LiftNS WrapValidatedGenTx xs instance CanHardFork xs => Eq (OneEraValidatedGenTx 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 LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Show (OneEraEnvelopeErr xs) deriving via LiftNS WrapForgeStateInfo xs instance CanHardFork xs => Show (OneEraForgeStateInfo xs) deriving via LiftNS WrapForgeStateUpdateError xs instance CanHardFork xs => Show (OneEraForgeStateUpdateError xs) deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Show (OneEraLedgerError xs) deriving via LiftNS WrapLedgerUpdate xs instance CanHardFork xs => Show (OneEraLedgerUpdate xs) deriving via LiftNS WrapLedgerWarning xs instance CanHardFork xs => Show (OneEraLedgerWarning xs) deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Show (OneEraTipInfo xs) deriving via LiftNS WrapValidatedGenTx xs instance CanHardFork xs => Show (OneEraValidatedGenTx xs) deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Show (OneEraValidationErr xs) deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance All SingleEraBlock xs => Eq (MismatchEraInfo xs) deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance All SingleEraBlock xs => Show (MismatchEraInfo xs) {------------------------------------------------------------------------------- Show instances used in tests only -------------------------------------------------------------------------------} deriving via LiftNS WrapApplyTxErr xs instance CanHardFork xs => Show (OneEraApplyTxErr xs) deriving via LiftNS I xs instance CanHardFork xs => Show (OneEraBlock xs) deriving via LiftNS WrapCannotForge xs instance CanHardFork xs => Show (OneEraCannotForge xs) deriving via LiftNS GenTx xs instance CanHardFork xs => Show (OneEraGenTx xs) deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Show (OneEraGenTxId xs) deriving via LiftNS Header xs instance CanHardFork xs => Show (OneEraHeader xs) deriving via LiftNS WrapSelectView xs instance CanHardFork xs => Show (OneEraSelectView xs)