{-# 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 (..)
  , PerEraChainOrderConfig (..)
  , 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 (..)
  , OneEraTentativeHeaderState (..)
  , OneEraTentativeHeaderView (..)
  , 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.Function (on)
import           Data.Proxy
import           Data.SOP.BasicFunctors
import           Data.SOP.Constraint
import           Data.SOP.Match (Mismatch)
import qualified Data.SOP.Match as Match
import           Data.SOP.OptNP (NonEmptyOptNP)
import           Data.SOP.Strict
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.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.Info
import           Ouroboros.Consensus.HardFork.Combinator.Lifting
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
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 (..))

{-------------------------------------------------------------------------------
  Value for /each/ era
-------------------------------------------------------------------------------}

newtype PerEraBlockConfig      xs = PerEraBlockConfig      { forall (xs :: [*]). PerEraBlockConfig xs -> NP BlockConfig xs
getPerEraBlockConfig      :: NP BlockConfig                xs }
newtype PerEraChainOrderConfig xs = PerEraChainOrderConfig { forall (xs :: [*]).
PerEraChainOrderConfig xs -> NP WrapChainOrderConfig xs
getPerEraChainOrderConfig :: NP WrapChainOrderConfig       xs }
newtype PerEraCodecConfig      xs = PerEraCodecConfig      { forall (xs :: [*]). PerEraCodecConfig xs -> NP CodecConfig xs
getPerEraCodecConfig      :: NP CodecConfig                xs }
newtype PerEraConsensusConfig  xs = PerEraConsensusConfig  { forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig  :: NP WrapPartialConsensusConfig xs }
newtype PerEraLedgerConfig     xs = PerEraLedgerConfig     { forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig     :: NP WrapPartialLedgerConfig    xs }
newtype PerEraStorageConfig    xs = PerEraStorageConfig    { forall (xs :: [*]). 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 { forall (xs :: [*]).
SomeErasCanBeLeader xs -> NonEmptyOptNP WrapCanBeLeader xs
getSomeErasCanBeLeader :: NonEmptyOptNP WrapCanBeLeader xs }

{-------------------------------------------------------------------------------
  Value for /one/ era
-------------------------------------------------------------------------------}

newtype OneEraApplyTxErr            xs = OneEraApplyTxErr            { forall (xs :: [*]). OneEraApplyTxErr xs -> NS WrapApplyTxErr xs
getOneEraApplyTxErr            :: NS WrapApplyTxErr            xs }
newtype OneEraBlock                 xs = OneEraBlock                 { forall (xs :: [*]). OneEraBlock xs -> NS I xs
getOneEraBlock                 :: NS I                         xs }
newtype OneEraCannotForge           xs = OneEraCannotForge           { forall (xs :: [*]). OneEraCannotForge xs -> NS WrapCannotForge xs
getOneEraCannotForge           :: NS WrapCannotForge           xs }
newtype OneEraEnvelopeErr           xs = OneEraEnvelopeErr           { forall (xs :: [*]). OneEraEnvelopeErr xs -> NS WrapEnvelopeErr xs
getOneEraEnvelopeErr           :: NS WrapEnvelopeErr           xs }
newtype OneEraForgeStateInfo        xs = OneEraForgeStateInfo        { forall (xs :: [*]).
OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
getOneEraForgeStateInfo        :: NS WrapForgeStateInfo        xs }
newtype OneEraForgeStateUpdateError xs = OneEraForgeStateUpdateError { forall (xs :: [*]).
OneEraForgeStateUpdateError xs -> NS WrapForgeStateUpdateError xs
getOneEraForgeStateUpdateError :: NS WrapForgeStateUpdateError xs }
newtype OneEraGenTx                 xs = OneEraGenTx                 { forall (xs :: [*]). OneEraGenTx xs -> NS GenTx xs
getOneEraGenTx                 :: NS GenTx                     xs }
newtype OneEraGenTxId               xs = OneEraGenTxId               { forall (xs :: [*]). OneEraGenTxId xs -> NS WrapGenTxId xs
getOneEraGenTxId               :: NS WrapGenTxId               xs }
newtype OneEraHeader                xs = OneEraHeader                { forall (xs :: [*]). OneEraHeader xs -> NS Header xs
getOneEraHeader                :: NS Header                    xs }
newtype OneEraIsLeader              xs = OneEraIsLeader              { forall (xs :: [*]). OneEraIsLeader xs -> NS WrapIsLeader xs
getOneEraIsLeader              :: NS WrapIsLeader              xs }
newtype OneEraLedgerError           xs = OneEraLedgerError           { forall (xs :: [*]). OneEraLedgerError xs -> NS WrapLedgerErr xs
getOneEraLedgerError           :: NS WrapLedgerErr             xs }
newtype OneEraLedgerEvent           xs = OneEraLedgerEvent           { forall (xs :: [*]). OneEraLedgerEvent xs -> NS WrapLedgerEvent xs
getOneEraLedgerEvent           :: NS WrapLedgerEvent           xs }
newtype OneEraLedgerUpdate          xs = OneEraLedgerUpdate          { forall (xs :: [*]). OneEraLedgerUpdate xs -> NS WrapLedgerUpdate xs
getOneEraLedgerUpdate          :: NS WrapLedgerUpdate          xs }
newtype OneEraLedgerWarning         xs = OneEraLedgerWarning         { forall (xs :: [*]).
OneEraLedgerWarning xs -> NS WrapLedgerWarning xs
getOneEraLedgerWarning         :: NS WrapLedgerWarning         xs }
newtype OneEraSelectView            xs = OneEraSelectView            { forall (xs :: [*]). OneEraSelectView xs -> NS WrapSelectView xs
getOneEraSelectView            :: NS WrapSelectView            xs }
newtype OneEraTentativeHeaderState  xs = OneEraTentativeHeaderState  { forall (xs :: [*]).
OneEraTentativeHeaderState xs -> NS WrapTentativeHeaderState xs
getOneEraTentativeHeaderState  :: NS WrapTentativeHeaderState  xs }
newtype OneEraTentativeHeaderView   xs = OneEraTentativeHeaderView   { forall (xs :: [*]).
OneEraTentativeHeaderView xs -> NS WrapTentativeHeaderView xs
getOneEraTentativeHeaderView   :: NS WrapTentativeHeaderView   xs }
newtype OneEraTipInfo               xs = OneEraTipInfo               { forall (xs :: [*]). OneEraTipInfo xs -> NS WrapTipInfo xs
getOneEraTipInfo               :: NS WrapTipInfo               xs }
newtype OneEraValidateView          xs = OneEraValidateView          { forall (xs :: [*]). OneEraValidateView xs -> NS WrapValidateView xs
getOneEraValidateView          :: NS WrapValidateView          xs }
newtype OneEraValidatedGenTx        xs = OneEraValidatedGenTx        { forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx        :: NS WrapValidatedGenTx        xs }
newtype OneEraValidationErr         xs = OneEraValidationErr         { forall (xs :: [*]).
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 { forall k (xs :: [k]). 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
$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
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
$ccompare :: forall k (xs :: [k]). OneEraHash xs -> OneEraHash xs -> Ordering
compare :: OneEraHash xs -> OneEraHash xs -> Ordering
$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
>= :: OneEraHash xs -> OneEraHash xs -> Bool
$cmax :: forall k (xs :: [k]).
OneEraHash xs -> OneEraHash xs -> OneEraHash xs
max :: OneEraHash xs -> OneEraHash xs -> OneEraHash xs
$cmin :: forall k (xs :: [k]).
OneEraHash xs -> OneEraHash xs -> OneEraHash xs
min :: OneEraHash xs -> OneEraHash xs -> 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
$cnoThunks :: forall k (xs :: [k]).
Context -> OneEraHash xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> OneEraHash xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall k (xs :: [k]).
Context -> OneEraHash xs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> OneEraHash xs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall k (xs :: [k]). Proxy (OneEraHash xs) -> String
showTypeOf :: Proxy (OneEraHash xs) -> String
NoThunks, [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)
$cencode :: forall k (xs :: [k]). OneEraHash xs -> Encoding
encode :: OneEraHash xs -> Encoding
$cdecode :: forall k (xs :: [k]) s. Decoder s (OneEraHash xs)
decode :: forall s. Decoder s (OneEraHash xs)
$cencodeList :: forall k (xs :: [k]). [OneEraHash xs] -> Encoding
encodeList :: [OneEraHash xs] -> Encoding
$cdecodeList :: forall k (xs :: [k]) s. Decoder s [OneEraHash xs]
decodeList :: forall s. Decoder s [OneEraHash xs]
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

{-------------------------------------------------------------------------------
  OneEraGenTxId
-------------------------------------------------------------------------------}

-- | This instance compares the underlying raw hash ('toRawTxIdHash') of the
-- 'TxId'.
--
-- Note that this means that transactions in different eras can have equal
-- 'TxId's. This should only be the case when the transaction format is
-- backwards compatible from one era to the next.
instance CanHardFork xs => Eq (OneEraGenTxId xs) where
  == :: OneEraGenTxId xs -> OneEraGenTxId xs -> Bool
(==) = ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ShortByteString -> ShortByteString -> Bool)
-> (OneEraGenTxId xs -> ShortByteString)
-> OneEraGenTxId xs
-> OneEraGenTxId xs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OneEraGenTxId xs -> ShortByteString
forall (xs :: [*]).
CanHardFork xs =>
OneEraGenTxId xs -> ShortByteString
oneEraGenTxIdRawHash

-- | See the corresponding 'Eq' instance.
instance CanHardFork xs => Ord (OneEraGenTxId xs) where
  compare :: OneEraGenTxId xs -> OneEraGenTxId xs -> Ordering
compare = ShortByteString -> ShortByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ShortByteString -> ShortByteString -> Ordering)
-> (OneEraGenTxId xs -> ShortByteString)
-> OneEraGenTxId xs
-> OneEraGenTxId xs
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OneEraGenTxId xs -> ShortByteString
forall (xs :: [*]).
CanHardFork xs =>
OneEraGenTxId xs -> ShortByteString
oneEraGenTxIdRawHash

{-------------------------------------------------------------------------------
  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.
      forall (xs :: [*]).
MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs
getMismatchEraInfo :: Mismatch SingleEraInfo LedgerEraInfo xs
    }

mismatchOneEra :: MismatchEraInfo '[b] -> Void
mismatchOneEra :: forall b. 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 :: forall (xs :: [*]) x.
SListI xs =>
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 LedgerEraInfo a -> SingleEraInfo a
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
$c== :: EraMismatch -> EraMismatch -> Bool
== :: EraMismatch -> EraMismatch -> Bool
$c/= :: EraMismatch -> EraMismatch -> Bool
/= :: 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
$cshowsPrec :: Int -> EraMismatch -> ShowS
showsPrec :: Int -> EraMismatch -> ShowS
$cshow :: EraMismatch -> String
show :: EraMismatch -> String
$cshowList :: [EraMismatch] -> ShowS
showList :: [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
$cfrom :: forall x. EraMismatch -> Rep EraMismatch x
from :: forall x. EraMismatch -> Rep EraMismatch x
$cto :: forall x. Rep EraMismatch x -> EraMismatch
to :: forall x. Rep EraMismatch x -> EraMismatch
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 :: forall (xs :: [*]). SListI xs => 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 :: forall (xs :: [*]).
SListI xs =>
Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch
go (Match.ML SingleEraInfo x
otherEra NS LedgerEraInfo xs1
ledgerEra) = EraMismatch {
          ledgerEraName :: Text
ledgerEraName = NS (K Text) xs1 -> CollapseTo NS Text
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
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) xs1 -> CollapseTo NS Text)
-> NS (K Text) xs1 -> CollapseTo NS Text
forall a b. (a -> b) -> a -> b
$ (forall a. LedgerEraInfo a -> K Text a)
-> NS LedgerEraInfo xs1 -> NS (K Text) xs1
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 xs1
ledgerEra
        , otherEraName :: Text
otherEraName  = SingleEraInfo x -> Text
forall blk. SingleEraInfo blk -> Text
otherName SingleEraInfo x
otherEra
        }
    go (Match.MR NS SingleEraInfo xs1
otherEra LedgerEraInfo x
ledgerEra) = EraMismatch {
          ledgerEraName :: Text
ledgerEraName = LedgerEraInfo x -> Text
forall blk. LedgerEraInfo blk -> Text
ledgerName LedgerEraInfo x
ledgerEra
        , otherEraName :: Text
otherEraName  = NS (K Text) xs1 -> CollapseTo NS Text
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
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) xs1 -> CollapseTo NS Text)
-> NS (K Text) xs1 -> CollapseTo NS Text
forall a b. (a -> b) -> a -> b
$ (forall a. SingleEraInfo a -> K Text a)
-> NS SingleEraInfo xs1 -> NS (K Text) xs1
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 xs1
otherEra
        }
    go (Match.MS Mismatch SingleEraInfo LedgerEraInfo xs1
m) = Mismatch SingleEraInfo LedgerEraInfo xs1 -> EraMismatch
forall (xs :: [*]).
SListI xs =>
Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch
go Mismatch SingleEraInfo LedgerEraInfo xs1
m

    ledgerName :: LedgerEraInfo blk -> Text
    ledgerName :: forall blk. 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 :: forall blk. SingleEraInfo blk -> Text
otherName = SingleEraInfo blk -> Text
forall blk. SingleEraInfo blk -> Text
singleEraName

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

oneEraBlockHeader :: CanHardFork xs => OneEraBlock xs -> OneEraHeader xs
oneEraBlockHeader :: forall (xs :: [*]).
CanHardFork xs =>
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 :: forall {k} (xs :: [k]) a.
(IsNonEmpty xs, Eq a, SListI xs, HasCallStack) =>
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
forall (proxy :: [k] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty (forall (t :: [k]). Proxy t
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 : xs1) -> 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 : xs1)
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 (xs :: [k]) a.
SListIN NP xs =>
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 a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise
        = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"differing values across hard fork"

oneEraGenTxIdRawHash :: CanHardFork xs => OneEraGenTxId xs -> ShortByteString
oneEraGenTxIdRawHash :: forall (xs :: [*]).
CanHardFork xs =>
OneEraGenTxId xs -> ShortByteString
oneEraGenTxIdRawHash =
      NS (K ShortByteString) xs -> ShortByteString
NS (K ShortByteString) xs -> CollapseTo NS ShortByteString
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
    (NS (K ShortByteString) xs -> ShortByteString)
-> (OneEraGenTxId xs -> NS (K ShortByteString) xs)
-> OneEraGenTxId xs
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapGenTxId a -> K ShortByteString a)
-> NS WrapGenTxId xs
-> NS (K ShortByteString) 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 (ShortByteString -> K ShortByteString a
forall k a (b :: k). a -> K a b
K (ShortByteString -> K ShortByteString a)
-> (WrapGenTxId a -> ShortByteString)
-> WrapGenTxId a
-> K ShortByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId (GenTx a) -> ShortByteString
forall tx. ConvertRawTxId tx => TxId tx -> ShortByteString
toRawTxIdHash (TxId (GenTx a) -> ShortByteString)
-> (WrapGenTxId a -> TxId (GenTx a))
-> WrapGenTxId a
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapGenTxId a -> TxId (GenTx a)
forall blk. WrapGenTxId blk -> GenTxId blk
unwrapGenTxId)
    (NS WrapGenTxId xs -> NS (K ShortByteString) xs)
-> (OneEraGenTxId xs -> NS WrapGenTxId xs)
-> OneEraGenTxId xs
-> NS (K ShortByteString) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraGenTxId xs -> NS WrapGenTxId xs
forall (xs :: [*]). OneEraGenTxId xs -> NS WrapGenTxId xs
getOneEraGenTxId

{-------------------------------------------------------------------------------
  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 "OneEraTentativeHeaderState" WrapTentativeHeaderState xs
         instance CanHardFork xs => NoThunks (OneEraTentativeHeaderState 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 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 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 WrapTentativeHeaderState  xs instance CanHardFork xs => Show (OneEraTentativeHeaderState  xs)
deriving via LiftNS WrapTentativeHeaderView   xs instance CanHardFork xs => Show (OneEraTentativeHeaderView   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)