{-# 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)