{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Protocol (
    -- * Re-exports to keep 'Protocol.State' an internal module
    HardForkChainDepState
  , HardForkIsLeader
  , HardForkCanBeLeader
  , HardForkValidationErr(..)
    -- * Re-exports to keep 'Protocol.LedgerView' an internal module
  , HardForkLedgerView_(..)
  , HardForkLedgerView
    -- * Type family instances
  , Ticked(..)
  ) where

import           Control.Monad.Except
import           Data.Functor.Product
import           Data.SOP.Strict
import           GHC.Generics (Generic)
import           GHC.Stack
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util ((.:))

import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.HardFork.Combinator.Block
import           Ouroboros.Consensus.HardFork.Combinator.Info
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import           Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel
import           Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView
                     (HardForkLedgerView, HardForkLedgerView_ (..),
                     Ticked (..))
import           Ouroboros.Consensus.HardFork.Combinator.State (HardForkState,
                     HardForkState, Translate (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.HardFork.Combinator.Translation
import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
                     (InPairs (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match

{-------------------------------------------------------------------------------
  ChainSelection
-------------------------------------------------------------------------------}

type HardForkSelectView xs = WithBlockNo OneEraSelectView xs

mkHardForkSelectView ::
     BlockNo
  -> NS WrapSelectView xs
  -> HardForkSelectView xs
mkHardForkSelectView :: BlockNo -> NS WrapSelectView xs -> HardForkSelectView xs
mkHardForkSelectView BlockNo
bno NS WrapSelectView xs
view = BlockNo -> OneEraSelectView xs -> HardForkSelectView xs
forall k (f :: k -> *) (a :: k). BlockNo -> f a -> WithBlockNo f a
WithBlockNo BlockNo
bno (NS WrapSelectView xs -> OneEraSelectView xs
forall (xs :: [*]). NS WrapSelectView xs -> OneEraSelectView xs
OneEraSelectView NS WrapSelectView xs
view)

-- | Chain selection across eras
instance CanHardFork xs => ChainSelection (HardForkProtocol xs) where
  type ChainSelConfig (HardForkProtocol xs) = PerEraChainSelConfig xs
  type SelectView     (HardForkProtocol xs) = HardForkSelectView   xs

  -- We leave 'preferCandidate' at the default

  compareCandidates :: proxy (HardForkProtocol xs)
-> ChainSelConfig (HardForkProtocol xs)
-> SelectView (HardForkProtocol xs)
-> SelectView (HardForkProtocol xs)
-> Ordering
compareCandidates proxy (HardForkProtocol xs)
_ (PerEraChainSelConfig cfgs) SelectView (HardForkProtocol xs)
l SelectView (HardForkProtocol xs)
r =
       NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Ordering
forall (xs :: [*]).
All SingleEraBlock xs =>
NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Ordering
acrossEraSelection
         NP WrapChainSelConfig xs
cfgs
         Tails AcrossEraSelection xs
forall (xs :: [*]). CanHardFork xs => Tails AcrossEraSelection xs
hardForkChainSel
         ((OneEraSelectView xs -> NS WrapSelectView xs)
-> WithBlockNo OneEraSelectView xs
-> WithBlockNo (NS WrapSelectView) xs
forall k1 k2 (f :: k1 -> *) (x :: k1) (g :: k2 -> *) (y :: k2).
(f x -> g y) -> WithBlockNo f x -> WithBlockNo g y
mapWithBlockNo OneEraSelectView xs -> NS WrapSelectView xs
forall (xs :: [*]). OneEraSelectView xs -> NS WrapSelectView xs
getOneEraSelectView SelectView (HardForkProtocol xs)
WithBlockNo OneEraSelectView xs
l)
         ((OneEraSelectView xs -> NS WrapSelectView xs)
-> WithBlockNo OneEraSelectView xs
-> WithBlockNo (NS WrapSelectView) xs
forall k1 k2 (f :: k1 -> *) (x :: k1) (g :: k2 -> *) (y :: k2).
(f x -> g y) -> WithBlockNo f x -> WithBlockNo g y
mapWithBlockNo OneEraSelectView xs -> NS WrapSelectView xs
forall (xs :: [*]). OneEraSelectView xs -> NS WrapSelectView xs
getOneEraSelectView SelectView (HardForkProtocol xs)
WithBlockNo OneEraSelectView xs
r)

{-------------------------------------------------------------------------------
  ConsensusProtocol
-------------------------------------------------------------------------------}

type HardForkChainDepState xs = HardForkState WrapChainDepState xs

instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where
  type ChainDepState (HardForkProtocol xs) = HardForkChainDepState xs
  type ValidationErr (HardForkProtocol xs) = HardForkValidationErr xs
  type LedgerView    (HardForkProtocol xs) = HardForkLedgerView    xs
  type CanBeLeader   (HardForkProtocol xs) = HardForkCanBeLeader   xs
  type IsLeader      (HardForkProtocol xs) = HardForkIsLeader      xs
  type ValidateView  (HardForkProtocol xs) = OneEraValidateView    xs

  -- Operations on the state

  tickChainDepState :: ConsensusConfig (HardForkProtocol xs)
-> Ticked (LedgerView (HardForkProtocol xs))
-> SlotNo
-> ChainDepState (HardForkProtocol xs)
-> Ticked (ChainDepState (HardForkProtocol xs))
tickChainDepState     = ConsensusConfig (HardForkProtocol xs)
-> Ticked (LedgerView (HardForkProtocol xs))
-> SlotNo
-> ChainDepState (HardForkProtocol xs)
-> Ticked (ChainDepState (HardForkProtocol xs))
forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> Ticked (HardForkLedgerView xs)
-> SlotNo
-> HardForkChainDepState xs
-> Ticked (HardForkChainDepState xs)
tick
  checkIsLeader :: ConsensusConfig (HardForkProtocol xs)
-> CanBeLeader (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (IsLeader (HardForkProtocol xs))
checkIsLeader         = ConsensusConfig (HardForkProtocol xs)
-> CanBeLeader (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (IsLeader (HardForkProtocol xs))
forall (xs :: [*]).
(CanHardFork xs, HasCallStack) =>
ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
check
  updateChainDepState :: ConsensusConfig (HardForkProtocol xs)
-> ValidateView (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Except
     (ValidationErr (HardForkProtocol xs))
     (ChainDepState (HardForkProtocol xs))
updateChainDepState   = ConsensusConfig (HardForkProtocol xs)
-> ValidateView (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Except
     (ValidationErr (HardForkProtocol xs))
     (ChainDepState (HardForkProtocol xs))
forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update
  reupdateChainDepState :: ConsensusConfig (HardForkProtocol xs)
-> ValidateView (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> ChainDepState (HardForkProtocol xs)
reupdateChainDepState = ConsensusConfig (HardForkProtocol xs)
-> ValidateView (HardForkProtocol xs)
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> ChainDepState (HardForkProtocol xs)
forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkChainDepState xs
reupdate

  --
  -- Straight-forward extensions
  --

  -- Security parameter must be equal across /all/ eras
  protocolSecurityParam :: ConsensusConfig (HardForkProtocol xs) -> SecurityParam
protocolSecurityParam = ConsensusConfig (HardForkProtocol xs) -> SecurityParam
forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigK

  -- Extract 'ChainSelConfig'
  chainSelConfig :: ConsensusConfig (HardForkProtocol xs)
-> ChainSelConfig (HardForkProtocol xs)
chainSelConfig =
        NP WrapChainSelConfig xs -> PerEraChainSelConfig xs
forall (xs :: [*]).
NP WrapChainSelConfig xs -> PerEraChainSelConfig xs
PerEraChainSelConfig
      (NP WrapChainSelConfig xs -> PerEraChainSelConfig xs)
-> (ConsensusConfig (HardForkProtocol xs)
    -> NP WrapChainSelConfig xs)
-> ConsensusConfig (HardForkProtocol xs)
-> PerEraChainSelConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a -> WrapChainSelConfig a)
-> NP WrapPartialConsensusConfig xs
-> NP WrapChainSelConfig 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 forall a.
SingleEraBlock a =>
WrapPartialConsensusConfig a -> WrapChainSelConfig a
aux
      (NP WrapPartialConsensusConfig xs -> NP WrapChainSelConfig xs)
-> (ConsensusConfig (HardForkProtocol xs)
    -> NP WrapPartialConsensusConfig xs)
-> ConsensusConfig (HardForkProtocol xs)
-> NP WrapChainSelConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig
      (PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs)
-> (ConsensusConfig (HardForkProtocol xs)
    -> PerEraConsensusConfig xs)
-> ConsensusConfig (HardForkProtocol xs)
-> NP WrapPartialConsensusConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigPerEra
    where
      aux :: forall blk. SingleEraBlock blk
          => WrapPartialConsensusConfig blk
          -> WrapChainSelConfig blk
      aux :: WrapPartialConsensusConfig blk -> WrapChainSelConfig blk
aux = ChainSelConfig (BlockProtocol blk) -> WrapChainSelConfig blk
forall blk.
ChainSelConfig (BlockProtocol blk) -> WrapChainSelConfig blk
WrapChainSelConfig
          (ChainSelConfig (BlockProtocol blk) -> WrapChainSelConfig blk)
-> (WrapPartialConsensusConfig blk
    -> ChainSelConfig (BlockProtocol blk))
-> WrapPartialConsensusConfig blk
-> WrapChainSelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (BlockProtocol blk)
-> PartialConsensusConfig (BlockProtocol blk)
-> ChainSelConfig (BlockProtocol blk)
forall p (proxy :: * -> *).
HasPartialConsensusConfig p =>
proxy p -> PartialConsensusConfig p -> ChainSelConfig p
partialChainSelConfig (Proxy (BlockProtocol blk)
forall k (t :: k). Proxy t
Proxy @(BlockProtocol blk))
          (PartialConsensusConfig (BlockProtocol blk)
 -> ChainSelConfig (BlockProtocol blk))
-> (WrapPartialConsensusConfig blk
    -> PartialConsensusConfig (BlockProtocol blk))
-> WrapPartialConsensusConfig blk
-> ChainSelConfig (BlockProtocol blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
forall blk.
WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
unwrapPartialConsensusConfig

{-------------------------------------------------------------------------------
  BlockSupportsProtocol
-------------------------------------------------------------------------------}

instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where
  validateView :: BlockConfig (HardForkBlock xs)
-> Header (HardForkBlock xs)
-> ValidateView (BlockProtocol (HardForkBlock xs))
validateView HardForkBlockConfig{..} =
        NS WrapValidateView xs -> OneEraValidateView xs
forall (xs :: [*]). NS WrapValidateView xs -> OneEraValidateView xs
OneEraValidateView
      (NS WrapValidateView xs -> OneEraValidateView xs)
-> (Header (HardForkBlock xs) -> NS WrapValidateView xs)
-> Header (HardForkBlock xs)
-> OneEraValidateView xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    BlockConfig a -> Header a -> WrapValidateView a)
-> Prod NS BlockConfig xs
-> NS Header xs
-> NS WrapValidateView xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith Proxy SingleEraBlock
proxySingle (ValidateView (BlockProtocol a) -> WrapValidateView a
forall blk.
ValidateView (BlockProtocol blk) -> WrapValidateView blk
WrapValidateView (ValidateView (BlockProtocol a) -> WrapValidateView a)
-> (BlockConfig a -> Header a -> ValidateView (BlockProtocol a))
-> BlockConfig a
-> Header a
-> WrapValidateView a
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: BlockConfig a -> Header a -> ValidateView (BlockProtocol a)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView) Prod NS BlockConfig xs
NP BlockConfig xs
cfgs
      (NS Header xs -> NS WrapValidateView xs)
-> (Header (HardForkBlock xs) -> NS Header xs)
-> Header (HardForkBlock xs)
-> NS WrapValidateView xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraHeader xs -> NS Header xs
forall (xs :: [*]). OneEraHeader xs -> NS Header xs
getOneEraHeader
      (OneEraHeader xs -> NS Header xs)
-> (Header (HardForkBlock xs) -> OneEraHeader xs)
-> Header (HardForkBlock xs)
-> NS Header xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (HardForkBlock xs) -> OneEraHeader xs
forall (xs :: [*]). Header (HardForkBlock xs) -> OneEraHeader xs
getHardForkHeader
    where
      cfgs :: NP BlockConfig xs
cfgs = PerEraBlockConfig xs -> NP BlockConfig xs
forall (xs :: [*]). PerEraBlockConfig xs -> NP BlockConfig xs
getPerEraBlockConfig PerEraBlockConfig xs
hardForkBlockConfigPerEra

  selectView :: BlockConfig (HardForkBlock xs)
-> Header (HardForkBlock xs)
-> SelectView (BlockProtocol (HardForkBlock xs))
selectView HardForkBlockConfig{..} Header (HardForkBlock xs)
hdr =
        BlockNo -> NS WrapSelectView xs -> HardForkSelectView xs
forall (xs :: [*]).
BlockNo -> NS WrapSelectView xs -> HardForkSelectView xs
mkHardForkSelectView (Header (HardForkBlock xs) -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header (HardForkBlock xs)
hdr)
      (NS WrapSelectView xs -> HardForkSelectView xs)
-> (OneEraHeader xs -> NS WrapSelectView xs)
-> OneEraHeader xs
-> HardForkSelectView xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    BlockConfig a -> Header a -> WrapSelectView a)
-> Prod NS BlockConfig xs
-> NS Header xs
-> NS WrapSelectView xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith Proxy SingleEraBlock
proxySingle (SelectView (BlockProtocol a) -> WrapSelectView a
forall blk. SelectView (BlockProtocol blk) -> WrapSelectView blk
WrapSelectView (SelectView (BlockProtocol a) -> WrapSelectView a)
-> (BlockConfig a -> Header a -> SelectView (BlockProtocol a))
-> BlockConfig a
-> Header a
-> WrapSelectView a
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: BlockConfig a -> Header a -> SelectView (BlockProtocol a)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView) Prod NS BlockConfig xs
NP BlockConfig xs
cfgs
      (NS Header xs -> NS WrapSelectView xs)
-> (OneEraHeader xs -> NS Header xs)
-> OneEraHeader xs
-> NS WrapSelectView xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraHeader xs -> NS Header xs
forall (xs :: [*]). OneEraHeader xs -> NS Header xs
getOneEraHeader
      (OneEraHeader xs -> HardForkSelectView xs)
-> OneEraHeader xs -> HardForkSelectView xs
forall a b. (a -> b) -> a -> b
$ Header (HardForkBlock xs) -> OneEraHeader xs
forall (xs :: [*]). Header (HardForkBlock xs) -> OneEraHeader xs
getHardForkHeader Header (HardForkBlock xs)
hdr
    where
      cfgs :: NP BlockConfig xs
cfgs = PerEraBlockConfig xs -> NP BlockConfig xs
forall (xs :: [*]). PerEraBlockConfig xs -> NP BlockConfig xs
getPerEraBlockConfig PerEraBlockConfig xs
hardForkBlockConfigPerEra

{-------------------------------------------------------------------------------
  Ticking the chain dependent state
-------------------------------------------------------------------------------}

data instance Ticked (HardForkChainDepState xs) =
    TickedHardForkChainDepState {
        Ticked (HardForkChainDepState xs)
-> HardForkState (Ticked :.: WrapChainDepState) xs
tickedHardForkChainDepStatePerEra ::
             HardForkState (Ticked :.: WrapChainDepState) xs

        -- | 'EpochInfo' constructed from the ticked 'LedgerView'
      , Ticked (HardForkChainDepState xs) -> EpochInfo Identity
tickedHardForkChainDepStateEpochInfo :: EpochInfo Identity
      }

tick :: CanHardFork xs
     => ConsensusConfig (HardForkProtocol xs)
     -> Ticked (HardForkLedgerView xs)
     -> SlotNo
     -> HardForkChainDepState xs
     -> Ticked (HardForkChainDepState xs)
tick :: ConsensusConfig (HardForkProtocol xs)
-> Ticked (HardForkLedgerView xs)
-> SlotNo
-> HardForkChainDepState xs
-> Ticked (HardForkChainDepState xs)
tick cfg :: ConsensusConfig (HardForkProtocol xs)
cfg@HardForkConsensusConfig{..}
     (TickedHardForkLedgerView transition ledgerView)
     SlotNo
slot
     HardForkChainDepState xs
chainDepState = TickedHardForkChainDepState :: forall (xs :: [*]).
HardForkState (Ticked :.: WrapChainDepState) xs
-> EpochInfo Identity -> Ticked (HardForkChainDepState xs)
TickedHardForkChainDepState {
      tickedHardForkChainDepStateEpochInfo :: EpochInfo Identity
tickedHardForkChainDepStateEpochInfo = EpochInfo Identity
ei
    , tickedHardForkChainDepStatePerEra :: HardForkState (Ticked :.: WrapChainDepState) xs
tickedHardForkChainDepStatePerEra =
         InPairs (Translate WrapChainDepState) xs
-> NP
     ((Ticked :.: WrapLedgerView)
      -.-> (WrapChainDepState -.-> (Ticked :.: WrapChainDepState)))
     xs
-> HardForkState (Ticked :.: WrapLedgerView) xs
-> HardForkChainDepState xs
-> HardForkState (Ticked :.: WrapChainDepState) xs
forall (xs :: [*]) (f :: * -> *) (f' :: * -> *) (f'' :: * -> *).
All SingleEraBlock xs =>
InPairs (Translate f) xs
-> NP (f' -.-> (f -.-> f'')) xs
-> HardForkState f' xs
-> HardForkState f xs
-> HardForkState f'' xs
State.align
           (EpochInfo Identity
-> ConsensusConfig (HardForkProtocol xs)
-> InPairs (Translate WrapChainDepState) xs
forall (xs :: [*]).
CanHardFork xs =>
EpochInfo Identity
-> ConsensusConfig (HardForkProtocol xs)
-> InPairs (Translate WrapChainDepState) xs
translateConsensus EpochInfo Identity
ei ConsensusConfig (HardForkProtocol xs)
cfg)
           (Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a
    -> (-.->)
         (Ticked :.: WrapLedgerView)
         (WrapChainDepState -.-> (Ticked :.: WrapChainDepState))
         a)
-> NP WrapPartialConsensusConfig xs
-> NP
     ((Ticked :.: WrapLedgerView)
      -.-> (WrapChainDepState -.-> (Ticked :.: WrapChainDepState)))
     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 (((:.:) Ticked WrapLedgerView a
 -> WrapChainDepState a -> (:.:) Ticked WrapChainDepState a)
-> (-.->)
     (Ticked :.: WrapLedgerView)
     (WrapChainDepState -.-> (Ticked :.: WrapChainDepState))
     a
forall k (f :: k -> *) (a :: k) (f' :: k -> *) (f'' :: k -> *).
(f a -> f' a -> f'' a) -> (-.->) f (f' -.-> f'') a
fn_2 (((:.:) Ticked WrapLedgerView a
  -> WrapChainDepState a -> (:.:) Ticked WrapChainDepState a)
 -> (-.->)
      (Ticked :.: WrapLedgerView)
      (WrapChainDepState -.-> (Ticked :.: WrapChainDepState))
      a)
-> (WrapPartialConsensusConfig a
    -> (:.:) Ticked WrapLedgerView a
    -> WrapChainDepState a
    -> (:.:) Ticked WrapChainDepState a)
-> WrapPartialConsensusConfig a
-> (-.->)
     (Ticked :.: WrapLedgerView)
     (WrapChainDepState -.-> (Ticked :.: WrapChainDepState))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialConsensusConfig a
-> (:.:) Ticked WrapLedgerView a
-> WrapChainDepState a
-> (:.:) Ticked WrapChainDepState a
forall blk.
SingleEraBlock blk =>
WrapPartialConsensusConfig blk
-> (:.:) Ticked WrapLedgerView blk
-> WrapChainDepState blk
-> (:.:) Ticked WrapChainDepState blk
tickOne) NP WrapPartialConsensusConfig xs
cfgs)
           HardForkState (Ticked :.: WrapLedgerView) xs
ledgerView
           HardForkChainDepState xs
chainDepState
    }
  where
    cfgs :: NP WrapPartialConsensusConfig xs
cfgs = PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig PerEraConsensusConfig xs
hardForkConsensusConfigPerEra
    ei :: EpochInfo Identity
ei   = Shape xs
-> TransitionInfo
-> HardForkState (Ticked :.: WrapLedgerView) xs
-> EpochInfo Identity
forall (xs :: [*]) (f :: * -> *).
Shape xs
-> TransitionInfo -> HardForkState f xs -> EpochInfo Identity
State.epochInfoPrecomputedTransitionInfo
             Shape xs
hardForkConsensusConfigShape
             TransitionInfo
transition
             HardForkState (Ticked :.: WrapLedgerView) xs
ledgerView

    tickOne :: SingleEraBlock                 blk
            => WrapPartialConsensusConfig     blk
            -> (Ticked :.: WrapLedgerView)    blk
            -> WrapChainDepState              blk
            -> (Ticked :.: WrapChainDepState) blk
    tickOne :: WrapPartialConsensusConfig blk
-> (:.:) Ticked WrapLedgerView blk
-> WrapChainDepState blk
-> (:.:) Ticked WrapChainDepState blk
tickOne WrapPartialConsensusConfig blk
cfg' (Comp Ticked (WrapLedgerView blk)
ledgerView') WrapChainDepState blk
chainDepState' = Ticked (WrapChainDepState blk)
-> (:.:) Ticked WrapChainDepState blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Ticked (WrapChainDepState blk)
 -> (:.:) Ticked WrapChainDepState blk)
-> Ticked (WrapChainDepState blk)
-> (:.:) Ticked WrapChainDepState blk
forall a b. (a -> b) -> a -> b
$
        Ticked (ChainDepState (BlockProtocol blk))
-> Ticked (WrapChainDepState blk)
forall blk.
Ticked (ChainDepState (BlockProtocol blk))
-> Ticked (WrapChainDepState blk)
WrapTickedChainDepState (Ticked (ChainDepState (BlockProtocol blk))
 -> Ticked (WrapChainDepState blk))
-> Ticked (ChainDepState (BlockProtocol blk))
-> Ticked (WrapChainDepState blk)
forall a b. (a -> b) -> a -> b
$
          ConsensusConfig (BlockProtocol blk)
-> Ticked (LedgerView (BlockProtocol blk))
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> Ticked (LedgerView p)
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState
            (EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo Identity
ei WrapPartialConsensusConfig blk
cfg')
            (Ticked (WrapLedgerView blk)
-> Ticked (LedgerView (BlockProtocol blk))
forall blk.
Ticked (WrapLedgerView blk)
-> Ticked (LedgerView (BlockProtocol blk))
unwrapTickedLedgerView Ticked (WrapLedgerView blk)
ledgerView')
            SlotNo
slot
            (WrapChainDepState blk -> ChainDepState (BlockProtocol blk)
forall blk.
WrapChainDepState blk -> ChainDepState (BlockProtocol blk)
unwrapChainDepState WrapChainDepState blk
chainDepState')

{-------------------------------------------------------------------------------
  Leader check

  NOTE: The precondition to 'align' is satisfied: the consensus state will never
  be ahead (but possibly behind) the ledger state, which we tick first.
-------------------------------------------------------------------------------}

-- | We are a leader if we have a proof from one of the eras
type HardForkIsLeader xs = OneEraIsLeader xs

-- | We have one or more 'BlockForging's, and thus 'CanBeLeader' proofs, for
-- each era in which we can forge blocks.
type HardForkCanBeLeader xs = OneEraCanBeLeader xs

-- | POSTCONDITION: if the result is @Just isLeader@, then 'HardForkCanBeLeader'
-- and the ticked 'ChainDepState' must be in the same era. The returned
-- @isLeader@ will be from the same era.
check :: forall xs. (CanHardFork xs, HasCallStack)
      => ConsensusConfig (HardForkProtocol xs)
      -> HardForkCanBeLeader xs
      -> SlotNo
      -> Ticked (ChainDepState (HardForkProtocol xs))
      -> Maybe (HardForkIsLeader xs)
check :: ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
check HardForkConsensusConfig{..}
      (OneEraCanBeLeader NS WrapCanBeLeader xs
canBeLeader)
      SlotNo
slot
      (TickedHardForkChainDepState chainDepState ei) =
    case NS WrapCanBeLeader xs
-> HardForkState (Ticked :.: WrapChainDepState) xs
-> Either
     (Mismatch
        WrapCanBeLeader (Current (Ticked :.: WrapChainDepState)) xs)
     (HardForkState
        (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs)
forall (xs :: [*]) (h :: * -> *) (f :: * -> *).
SListI xs =>
NS h xs
-> HardForkState f xs
-> Either
     (Mismatch h (Current f) xs) (HardForkState (Product h f) xs)
State.match NS WrapCanBeLeader xs
canBeLeader HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState of
      -- Not a leader in this era
      Left Mismatch
  WrapCanBeLeader (Current (Ticked :.: WrapChainDepState)) xs
_mismatch -> Maybe (HardForkIsLeader xs)
forall a. Maybe a
Nothing
      Right HardForkState
  (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs
matched  -> NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs)
undistrib (NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs))
-> NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs)
forall a b. (a -> b) -> a -> b
$
        Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a
    -> Product WrapCanBeLeader (Ticked :.: WrapChainDepState) a
    -> (:.:) Maybe WrapIsLeader a)
-> Prod NS WrapPartialConsensusConfig xs
-> NS (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs
-> NS (Maybe :.: WrapIsLeader) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith
          Proxy SingleEraBlock
proxySingle
          forall a.
SingleEraBlock a =>
WrapPartialConsensusConfig a
-> Product WrapCanBeLeader (Ticked :.: WrapChainDepState) a
-> (:.:) Maybe WrapIsLeader a
checkOne
          Prod NS WrapPartialConsensusConfig xs
NP WrapPartialConsensusConfig xs
cfgs
          (HardForkState
  (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs
-> NS (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip HardForkState
  (Product WrapCanBeLeader (Ticked :.: WrapChainDepState)) xs
matched)
  where
    cfgs :: NP WrapPartialConsensusConfig xs
cfgs = PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig PerEraConsensusConfig xs
hardForkConsensusConfigPerEra

    checkOne ::
         SingleEraBlock                                         blk
      => WrapPartialConsensusConfig                             blk
      -> Product WrapCanBeLeader (Ticked :.: WrapChainDepState) blk
      -> (Maybe :.: WrapIsLeader)                               blk
    checkOne :: WrapPartialConsensusConfig blk
-> Product WrapCanBeLeader (Ticked :.: WrapChainDepState) blk
-> (:.:) Maybe WrapIsLeader blk
checkOne WrapPartialConsensusConfig blk
cfg' (Pair WrapCanBeLeader blk
canBeLeader' (Comp Ticked (WrapChainDepState blk)
chainDepState')) = Maybe (WrapIsLeader blk) -> (:.:) Maybe WrapIsLeader blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Maybe (WrapIsLeader blk) -> (:.:) Maybe WrapIsLeader blk)
-> Maybe (WrapIsLeader blk) -> (:.:) Maybe WrapIsLeader blk
forall a b. (a -> b) -> a -> b
$
          IsLeader (BlockProtocol blk) -> WrapIsLeader blk
forall blk. IsLeader (BlockProtocol blk) -> WrapIsLeader blk
WrapIsLeader (IsLeader (BlockProtocol blk) -> WrapIsLeader blk)
-> Maybe (IsLeader (BlockProtocol blk)) -> Maybe (WrapIsLeader blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ConsensusConfig (BlockProtocol blk)
-> CanBeLeader (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> Maybe (IsLeader (BlockProtocol blk))
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> CanBeLeader p
-> SlotNo
-> Ticked (ChainDepState p)
-> Maybe (IsLeader p)
checkIsLeader
              (EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo Identity
ei WrapPartialConsensusConfig blk
cfg')
              (WrapCanBeLeader blk -> CanBeLeader (BlockProtocol blk)
forall blk. WrapCanBeLeader blk -> CanBeLeader (BlockProtocol blk)
unwrapCanBeLeader WrapCanBeLeader blk
canBeLeader')
              SlotNo
slot
              (Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState Ticked (WrapChainDepState blk)
chainDepState')

    undistrib :: NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs)
    undistrib :: NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs)
undistrib = NS (K (Maybe (HardForkIsLeader xs))) xs
-> Maybe (HardForkIsLeader xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (Maybe (HardForkIsLeader xs))) xs
 -> Maybe (HardForkIsLeader xs))
-> (NS (Maybe :.: WrapIsLeader) xs
    -> NS (K (Maybe (HardForkIsLeader xs))) xs)
-> NS (Maybe :.: WrapIsLeader) xs
-> Maybe (HardForkIsLeader xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 Injection WrapIsLeader xs a
 -> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a)
-> Prod NS (Injection WrapIsLeader xs) xs
-> NS (Maybe :.: WrapIsLeader) xs
-> NS (K (Maybe (HardForkIsLeader xs))) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hzipWith forall a.
Injection WrapIsLeader xs a
-> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a
inj Prod NS (Injection WrapIsLeader xs) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections
      where
        inj :: Injection WrapIsLeader xs blk
            -> (Maybe :.: WrapIsLeader) blk
            -> K (Maybe (HardForkIsLeader xs)) blk
        inj :: Injection WrapIsLeader xs blk
-> (:.:) Maybe WrapIsLeader blk
-> K (Maybe (HardForkIsLeader xs)) blk
inj Injection WrapIsLeader xs blk
injIsLeader (Comp Maybe (WrapIsLeader blk)
mIsLeader) = Maybe (HardForkIsLeader xs) -> K (Maybe (HardForkIsLeader xs)) blk
forall k a (b :: k). a -> K a b
K (Maybe (HardForkIsLeader xs)
 -> K (Maybe (HardForkIsLeader xs)) blk)
-> Maybe (HardForkIsLeader xs)
-> K (Maybe (HardForkIsLeader xs)) blk
forall a b. (a -> b) -> a -> b
$
            NS WrapIsLeader xs -> HardForkIsLeader xs
forall (xs :: [*]). NS WrapIsLeader xs -> OneEraIsLeader xs
OneEraIsLeader (NS WrapIsLeader xs -> HardForkIsLeader xs)
-> (WrapIsLeader blk -> NS WrapIsLeader xs)
-> WrapIsLeader blk
-> HardForkIsLeader xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapIsLeader xs) blk -> NS WrapIsLeader xs
forall k a (b :: k). K a b -> a
unK (K (NS WrapIsLeader xs) blk -> NS WrapIsLeader xs)
-> (WrapIsLeader blk -> K (NS WrapIsLeader xs) blk)
-> WrapIsLeader blk
-> NS WrapIsLeader xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Injection WrapIsLeader xs blk
-> WrapIsLeader blk -> K (NS WrapIsLeader xs) blk
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn Injection WrapIsLeader xs blk
injIsLeader (WrapIsLeader blk -> HardForkIsLeader xs)
-> Maybe (WrapIsLeader blk) -> Maybe (HardForkIsLeader xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (WrapIsLeader blk)
mIsLeader

{-------------------------------------------------------------------------------
  Rolling forward and backward
-------------------------------------------------------------------------------}

data HardForkValidationErr xs =
    -- | Validation error from one of the eras
    HardForkValidationErrFromEra (OneEraValidationErr xs)

    -- | We tried to apply a block from the wrong era
  | HardForkValidationErrWrongEra (MismatchEraInfo xs)
  deriving ((forall x.
 HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x)
-> (forall x.
    Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs)
-> Generic (HardForkValidationErr xs)
forall (xs :: [*]) x.
Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs
forall (xs :: [*]) x.
HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x
forall x.
Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs
forall x.
HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (xs :: [*]) x.
Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs
$cfrom :: forall (xs :: [*]) x.
HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x
Generic)

update :: forall xs. CanHardFork xs
       => ConsensusConfig (HardForkProtocol xs)
       -> OneEraValidateView xs
       -> SlotNo
       -> Ticked (HardForkChainDepState xs)
       -> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update :: ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update HardForkConsensusConfig{..}
       (OneEraValidateView NS WrapValidateView xs
view)
       SlotNo
slot
       (TickedHardForkChainDepState chainDepState ei) =
    case NS WrapValidateView xs
-> HardForkState (Ticked :.: WrapChainDepState) xs
-> Either
     (Mismatch
        WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs)
     (HardForkState
        (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs)
forall (xs :: [*]) (h :: * -> *) (f :: * -> *).
SListI xs =>
NS h xs
-> HardForkState f xs
-> Either
     (Mismatch h (Current f) xs) (HardForkState (Product h f) xs)
State.match NS WrapValidateView xs
view HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState of
      Left Mismatch
  WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
mismatch ->
        HardForkValidationErr xs
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HardForkValidationErr xs
 -> Except (HardForkValidationErr xs) (HardForkChainDepState xs))
-> HardForkValidationErr xs
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall a b. (a -> b) -> a -> b
$ MismatchEraInfo xs -> HardForkValidationErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkValidationErr xs
HardForkValidationErrWrongEra (MismatchEraInfo xs -> HardForkValidationErr xs)
-> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkValidationErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs
 -> HardForkValidationErr xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkValidationErr xs
forall a b. (a -> b) -> a -> b
$
          Proxy SingleEraBlock
-> (forall x.
    SingleEraBlock x =>
    WrapValidateView x -> SingleEraInfo x)
-> (forall x.
    SingleEraBlock x =>
    Current (Ticked :.: WrapChainDepState) x -> LedgerEraInfo x)
-> Mismatch
     WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall k (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *)
       (g :: k -> *) (g' :: k -> *).
All c xs =>
proxy c
-> (forall (x :: k). c x => f x -> f' x)
-> (forall (x :: k). c x => g x -> g' x)
-> Mismatch f g xs
-> Mismatch f' g' xs
Match.bihcmap
            Proxy SingleEraBlock
proxySingle
            forall x. SingleEraBlock x => WrapValidateView x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo
            (SingleEraInfo x -> LedgerEraInfo x
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo x -> LedgerEraInfo x)
-> (Current (Ticked :.: WrapChainDepState) x -> SingleEraInfo x)
-> Current (Ticked :.: WrapChainDepState) x
-> LedgerEraInfo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) Ticked WrapChainDepState x -> SingleEraInfo x
forall blk.
SingleEraBlock blk =>
(:.:) Ticked WrapChainDepState blk -> SingleEraInfo blk
chainDepStateInfo ((:.:) Ticked WrapChainDepState x -> SingleEraInfo x)
-> (Current (Ticked :.: WrapChainDepState) x
    -> (:.:) Ticked WrapChainDepState x)
-> Current (Ticked :.: WrapChainDepState) x
-> SingleEraInfo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current (Ticked :.: WrapChainDepState) x
-> (:.:) Ticked WrapChainDepState x
forall (f :: * -> *) blk. Current f blk -> f blk
State.currentState)
            Mismatch
  WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
mismatch
      Right HardForkState
  (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
matched ->
           HardForkState
  (ExceptT (HardForkValidationErr xs) Identity :.: WrapChainDepState)
  xs
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
hsequence'
         (HardForkState
   (ExceptT (HardForkValidationErr xs) Identity :.: WrapChainDepState)
   xs
 -> Except (HardForkValidationErr xs) (HardForkChainDepState xs))
-> (HardForkState
      (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
    -> HardForkState
         (ExceptT (HardForkValidationErr xs) Identity :.: WrapChainDepState)
         xs)
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a
    -> Injection WrapValidationErr xs a
    -> Product WrapValidateView (Ticked :.: WrapChainDepState) a
    -> (:.:)
         (ExceptT (HardForkValidationErr xs) Identity) WrapChainDepState a)
-> Prod HardForkState WrapPartialConsensusConfig xs
-> Prod HardForkState (Injection WrapValidationErr xs) xs
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> HardForkState
     (ExceptT (HardForkValidationErr xs) Identity :.: WrapChainDepState)
     xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a -> f''' a)
-> Prod h f xs
-> Prod h f' xs
-> h f'' xs
-> h f''' xs
hczipWith3 Proxy SingleEraBlock
proxySingle (EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig a
-> Injection WrapValidationErr xs a
-> Product WrapValidateView (Ticked :.: WrapChainDepState) a
-> (:.:)
     (ExceptT (HardForkValidationErr xs) Identity) WrapChainDepState a
forall (xs :: [*]) blk.
SingleEraBlock blk =>
EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Injection WrapValidationErr xs blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
updateEra EpochInfo Identity
ei SlotNo
slot) Prod HardForkState WrapPartialConsensusConfig xs
NP WrapPartialConsensusConfig xs
cfgs Prod HardForkState (Injection WrapValidationErr xs) xs
NP (Injection WrapValidationErr xs) xs
errInjections
         (HardForkState
   (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
 -> Except (HardForkValidationErr xs) (HardForkChainDepState xs))
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall a b. (a -> b) -> a -> b
$ HardForkState
  (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
matched
  where
    cfgs :: NP WrapPartialConsensusConfig xs
cfgs = PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig PerEraConsensusConfig xs
hardForkConsensusConfigPerEra

    errInjections :: NP (Injection WrapValidationErr xs) xs
    errInjections :: NP (Injection WrapValidationErr xs) xs
errInjections = NP (Injection WrapValidationErr xs) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections

updateEra :: forall xs blk. SingleEraBlock blk
          => EpochInfo Identity
          -> SlotNo
          -> WrapPartialConsensusConfig blk
          -> Injection WrapValidationErr xs blk
          -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
          -> (Except (HardForkValidationErr xs) :.: WrapChainDepState) blk
updateEra :: EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Injection WrapValidationErr xs blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
updateEra EpochInfo Identity
ei SlotNo
slot WrapPartialConsensusConfig blk
cfg Injection WrapValidationErr xs blk
injectErr
          (Pair WrapValidateView blk
view (Comp Ticked (WrapChainDepState blk)
chainDepState)) = ExceptT (HardForkValidationErr xs) Identity (WrapChainDepState blk)
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (ExceptT
   (HardForkValidationErr xs) Identity (WrapChainDepState blk)
 -> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk)
-> ExceptT
     (HardForkValidationErr xs) Identity (WrapChainDepState blk)
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
forall a b. (a -> b) -> a -> b
$
    (ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs)
-> Except
     (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
-> ExceptT
     (HardForkValidationErr xs) Identity (WrapChainDepState blk)
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (Injection WrapValidationErr xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
forall (xs :: [*]) blk.
Injection WrapValidationErr xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
injectValidationErr Injection WrapValidationErr xs blk
injectErr) (Except (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
 -> ExceptT
      (HardForkValidationErr xs) Identity (WrapChainDepState blk))
-> Except
     (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
-> ExceptT
     (HardForkValidationErr xs) Identity (WrapChainDepState blk)
forall a b. (a -> b) -> a -> b
$
      (ChainDepState (BlockProtocol blk) -> WrapChainDepState blk)
-> ExceptT
     (ValidationErr (BlockProtocol blk))
     Identity
     (ChainDepState (BlockProtocol blk))
-> Except
     (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState (ExceptT
   (ValidationErr (BlockProtocol blk))
   Identity
   (ChainDepState (BlockProtocol blk))
 -> Except
      (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk))
-> ExceptT
     (ValidationErr (BlockProtocol blk))
     Identity
     (ChainDepState (BlockProtocol blk))
-> Except
     (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
forall a b. (a -> b) -> a -> b
$
        ConsensusConfig (BlockProtocol blk)
-> ValidateView (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> ExceptT
     (ValidationErr (BlockProtocol blk))
     Identity
     (ChainDepState (BlockProtocol blk))
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> ValidateView p
-> SlotNo
-> Ticked (ChainDepState p)
-> Except (ValidationErr p) (ChainDepState p)
updateChainDepState
          (EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo Identity
ei WrapPartialConsensusConfig blk
cfg)
          (WrapValidateView blk -> ValidateView (BlockProtocol blk)
forall blk.
WrapValidateView blk -> ValidateView (BlockProtocol blk)
unwrapValidateView WrapValidateView blk
view)
          SlotNo
slot
          (Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState Ticked (WrapChainDepState blk)
chainDepState)

reupdate :: forall xs. CanHardFork xs
         => ConsensusConfig (HardForkProtocol xs)
         -> OneEraValidateView xs
         -> SlotNo
         -> Ticked (HardForkChainDepState xs)
         -> HardForkChainDepState xs
reupdate :: ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkChainDepState xs
reupdate HardForkConsensusConfig{..}
         (OneEraValidateView NS WrapValidateView xs
view)
         SlotNo
slot
         (TickedHardForkChainDepState chainDepState ei) =
    case NS WrapValidateView xs
-> HardForkState (Ticked :.: WrapChainDepState) xs
-> Either
     (Mismatch
        WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs)
     (HardForkState
        (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs)
forall (xs :: [*]) (h :: * -> *) (f :: * -> *).
SListI xs =>
NS h xs
-> HardForkState f xs
-> Either
     (Mismatch h (Current f) xs) (HardForkState (Product h f) xs)
State.match NS WrapValidateView xs
view HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState of
      Left Mismatch
  WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
mismatch ->
        [Char] -> HardForkChainDepState xs
forall a. HasCallStack => [Char] -> a
error ([Char] -> HardForkChainDepState xs)
-> [Char] -> HardForkChainDepState xs
forall a b. (a -> b) -> a -> b
$ HardForkValidationErr xs -> [Char]
forall a. Show a => a -> [Char]
show (HardForkValidationErr xs -> [Char])
-> (Mismatch SingleEraInfo LedgerEraInfo xs
    -> HardForkValidationErr xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MismatchEraInfo xs -> HardForkValidationErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkValidationErr xs
HardForkValidationErrWrongEra (MismatchEraInfo xs -> HardForkValidationErr xs)
-> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkValidationErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> [Char])
-> Mismatch SingleEraInfo LedgerEraInfo xs -> [Char]
forall a b. (a -> b) -> a -> b
$
          Proxy SingleEraBlock
-> (forall x.
    SingleEraBlock x =>
    WrapValidateView x -> SingleEraInfo x)
-> (forall x.
    SingleEraBlock x =>
    Current (Ticked :.: WrapChainDepState) x -> LedgerEraInfo x)
-> Mismatch
     WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall k (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *)
       (g :: k -> *) (g' :: k -> *).
All c xs =>
proxy c
-> (forall (x :: k). c x => f x -> f' x)
-> (forall (x :: k). c x => g x -> g' x)
-> Mismatch f g xs
-> Mismatch f' g' xs
Match.bihcmap
            Proxy SingleEraBlock
proxySingle
            forall x. SingleEraBlock x => WrapValidateView x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo
            (SingleEraInfo x -> LedgerEraInfo x
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo x -> LedgerEraInfo x)
-> (Current (Ticked :.: WrapChainDepState) x -> SingleEraInfo x)
-> Current (Ticked :.: WrapChainDepState) x
-> LedgerEraInfo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) Ticked WrapChainDepState x -> SingleEraInfo x
forall blk.
SingleEraBlock blk =>
(:.:) Ticked WrapChainDepState blk -> SingleEraInfo blk
chainDepStateInfo ((:.:) Ticked WrapChainDepState x -> SingleEraInfo x)
-> (Current (Ticked :.: WrapChainDepState) x
    -> (:.:) Ticked WrapChainDepState x)
-> Current (Ticked :.: WrapChainDepState) x
-> SingleEraInfo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current (Ticked :.: WrapChainDepState) x
-> (:.:) Ticked WrapChainDepState x
forall (f :: * -> *) blk. Current f blk -> f blk
State.currentState)
            Mismatch
  WrapValidateView (Current (Ticked :.: WrapChainDepState)) xs
mismatch
      Right HardForkState
  (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
matched ->
           Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a
    -> Product WrapValidateView (Ticked :.: WrapChainDepState) a
    -> WrapChainDepState a)
-> Prod HardForkState WrapPartialConsensusConfig xs
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> HardForkChainDepState xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith Proxy SingleEraBlock
proxySingle (EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig a
-> Product WrapValidateView (Ticked :.: WrapChainDepState) a
-> WrapChainDepState a
forall blk.
SingleEraBlock blk =>
EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> WrapChainDepState blk
reupdateEra EpochInfo Identity
ei SlotNo
slot) Prod HardForkState WrapPartialConsensusConfig xs
NP WrapPartialConsensusConfig xs
cfgs
         (HardForkState
   (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
 -> HardForkChainDepState xs)
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> HardForkChainDepState xs
forall a b. (a -> b) -> a -> b
$ HardForkState
  (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
matched
  where
    cfgs :: NP WrapPartialConsensusConfig xs
cfgs = PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig PerEraConsensusConfig xs
hardForkConsensusConfigPerEra

reupdateEra :: SingleEraBlock blk
            => EpochInfo Identity
            -> SlotNo
            -> WrapPartialConsensusConfig blk
            -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
            -> WrapChainDepState blk
reupdateEra :: EpochInfo Identity
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> WrapChainDepState blk
reupdateEra EpochInfo Identity
ei SlotNo
slot WrapPartialConsensusConfig blk
cfg (Pair WrapValidateView blk
view (Comp Ticked (WrapChainDepState blk)
chainDepState)) =
    ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState (ChainDepState (BlockProtocol blk) -> WrapChainDepState blk)
-> ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
forall a b. (a -> b) -> a -> b
$
      ConsensusConfig (BlockProtocol blk)
-> ValidateView (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> ChainDepState (BlockProtocol blk)
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> ValidateView p
-> SlotNo
-> Ticked (ChainDepState p)
-> ChainDepState p
reupdateChainDepState
        (EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo Identity
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo Identity
ei WrapPartialConsensusConfig blk
cfg)
        (WrapValidateView blk -> ValidateView (BlockProtocol blk)
forall blk.
WrapValidateView blk -> ValidateView (BlockProtocol blk)
unwrapValidateView WrapValidateView blk
view)
        SlotNo
slot
        (Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState Ticked (WrapChainDepState blk)
chainDepState)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

chainDepStateInfo :: forall blk. SingleEraBlock blk
                  => (Ticked :.: WrapChainDepState) blk -> SingleEraInfo blk
chainDepStateInfo :: (:.:) Ticked WrapChainDepState blk -> SingleEraInfo blk
chainDepStateInfo (:.:) Ticked WrapChainDepState blk
_ = Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

translateConsensus :: forall xs. CanHardFork xs
                   => EpochInfo Identity
                   -> ConsensusConfig (HardForkProtocol xs)
                   -> InPairs (Translate WrapChainDepState) xs
translateConsensus :: EpochInfo Identity
-> ConsensusConfig (HardForkProtocol xs)
-> InPairs (Translate WrapChainDepState) xs
translateConsensus EpochInfo Identity
ei HardForkConsensusConfig{..} =
    NP WrapConsensusConfig xs
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     xs
-> InPairs (Translate WrapChainDepState) xs
forall k (h :: k -> *) (xs :: [k]) (f :: k -> k -> *).
NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs
InPairs.requiringBoth NP WrapConsensusConfig xs
cfgs (InPairs
   (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
   xs
 -> InPairs (Translate WrapChainDepState) xs)
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     xs
-> InPairs (Translate WrapChainDepState) xs
forall a b. (a -> b) -> a -> b
$
       EraTranslation xs
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     xs
forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     xs
translateChainDepState EraTranslation xs
forall (xs :: [*]). CanHardFork xs => EraTranslation xs
hardForkEraTranslation
  where
    pcfgs :: NP WrapPartialConsensusConfig xs
pcfgs = PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig PerEraConsensusConfig xs
hardForkConsensusConfigPerEra
    cfgs :: NP WrapConsensusConfig xs
cfgs  = Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialConsensusConfig a -> WrapConsensusConfig a)
-> NP WrapPartialConsensusConfig xs
-> NP WrapConsensusConfig 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 (EpochInfo Identity
-> WrapPartialConsensusConfig a -> WrapConsensusConfig a
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo Identity
-> WrapPartialConsensusConfig blk -> WrapConsensusConfig blk
completeConsensusConfig'' EpochInfo Identity
ei) NP WrapPartialConsensusConfig xs
pcfgs

injectValidationErr :: Injection WrapValidationErr xs blk
                    -> ValidationErr (BlockProtocol blk)
                    -> HardForkValidationErr xs
injectValidationErr :: Injection WrapValidationErr xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
injectValidationErr Injection WrapValidationErr xs blk
inj =
      OneEraValidationErr xs -> HardForkValidationErr xs
forall (xs :: [*]).
OneEraValidationErr xs -> HardForkValidationErr xs
HardForkValidationErrFromEra
    (OneEraValidationErr xs -> HardForkValidationErr xs)
-> (ValidationErr (BlockProtocol blk) -> OneEraValidationErr xs)
-> ValidationErr (BlockProtocol blk)
-> HardForkValidationErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapValidationErr xs -> OneEraValidationErr xs
forall (xs :: [*]).
NS WrapValidationErr xs -> OneEraValidationErr xs
OneEraValidationErr
    (NS WrapValidationErr xs -> OneEraValidationErr xs)
-> (ValidationErr (BlockProtocol blk) -> NS WrapValidationErr xs)
-> ValidationErr (BlockProtocol blk)
-> OneEraValidationErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapValidationErr xs) blk -> NS WrapValidationErr xs
forall k a (b :: k). K a b -> a
unK
    (K (NS WrapValidationErr xs) blk -> NS WrapValidationErr xs)
-> (ValidationErr (BlockProtocol blk)
    -> K (NS WrapValidationErr xs) blk)
-> ValidationErr (BlockProtocol blk)
-> NS WrapValidationErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Injection WrapValidationErr xs blk
-> WrapValidationErr blk -> K (NS WrapValidationErr xs) blk
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn Injection WrapValidationErr xs blk
inj
    (WrapValidationErr blk -> K (NS WrapValidationErr xs) blk)
-> (ValidationErr (BlockProtocol blk) -> WrapValidationErr blk)
-> ValidationErr (BlockProtocol blk)
-> K (NS WrapValidationErr xs) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationErr (BlockProtocol blk) -> WrapValidationErr blk
forall blk.
ValidationErr (BlockProtocol blk) -> WrapValidationErr blk
WrapValidationErr

{-------------------------------------------------------------------------------
  Instances
-------------------------------------------------------------------------------}

deriving instance CanHardFork xs => Eq       (HardForkValidationErr xs)
deriving instance CanHardFork xs => Show     (HardForkValidationErr xs)
deriving instance CanHardFork xs => NoThunks (HardForkValidationErr xs)