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

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Protocol (
    HardForkSelectView (..)
    -- * Re-exports to keep 'Protocol.State' an internal module
  , HardForkCanBeLeader
  , HardForkChainDepState
  , HardForkIsLeader
  , 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.BasicFunctors
import           Data.SOP.Index
import           Data.SOP.InPairs (InPairs (..))
import qualified Data.SOP.InPairs as InPairs
import qualified Data.SOP.Match as Match
import qualified Data.SOP.OptNP as OptNP
import           Data.SOP.Strict
import           GHC.Generics (Generic)
import           GHC.Stack
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block
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_ (..))
import           Ouroboros.Consensus.HardFork.Combinator.State (HardForkState,
                     Translate (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util ((.:))

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

newtype HardForkSelectView xs = HardForkSelectView {
      forall (xs :: [*]).
HardForkSelectView xs -> WithBlockNo OneEraSelectView xs
getHardForkSelectView :: WithBlockNo OneEraSelectView xs
    }
  deriving (Int -> HardForkSelectView xs -> ShowS
[HardForkSelectView xs] -> ShowS
HardForkSelectView xs -> String
(Int -> HardForkSelectView xs -> ShowS)
-> (HardForkSelectView xs -> String)
-> ([HardForkSelectView xs] -> ShowS)
-> Show (HardForkSelectView xs)
forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkSelectView xs -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[HardForkSelectView xs] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
HardForkSelectView xs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkSelectView xs -> ShowS
showsPrec :: Int -> HardForkSelectView xs -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
HardForkSelectView xs -> String
show :: HardForkSelectView xs -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[HardForkSelectView xs] -> ShowS
showList :: [HardForkSelectView xs] -> ShowS
Show, HardForkSelectView xs -> HardForkSelectView xs -> Bool
(HardForkSelectView xs -> HardForkSelectView xs -> Bool)
-> (HardForkSelectView xs -> HardForkSelectView xs -> Bool)
-> Eq (HardForkSelectView xs)
forall (xs :: [*]).
CanHardFork xs =>
HardForkSelectView xs -> HardForkSelectView xs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
HardForkSelectView xs -> HardForkSelectView xs -> Bool
== :: HardForkSelectView xs -> HardForkSelectView xs -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
HardForkSelectView xs -> HardForkSelectView xs -> Bool
/= :: HardForkSelectView xs -> HardForkSelectView xs -> Bool
Eq)
  deriving newtype (Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
Proxy (HardForkSelectView xs) -> String
(Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo))
-> (Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo))
-> (Proxy (HardForkSelectView xs) -> String)
-> NoThunks (HardForkSelectView xs)
forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkSelectView xs) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> HardForkSelectView xs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkSelectView xs) -> String
showTypeOf :: Proxy (HardForkSelectView xs) -> String
NoThunks)

instance CanHardFork xs => Ord (HardForkSelectView xs) where
  compare :: HardForkSelectView xs -> HardForkSelectView xs -> Ordering
compare (HardForkSelectView WithBlockNo OneEraSelectView xs
l) (HardForkSelectView WithBlockNo OneEraSelectView xs
r) =
      AcrossEraMode Proxy Ordering
-> NP Proxy xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Ordering
forall (xs :: [*]) (cfg :: * -> *) a.
All SingleEraBlock xs =>
AcrossEraMode cfg a
-> NP cfg xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> a
acrossEraSelection
        AcrossEraMode Proxy Ordering
AcrossEraCompare
        ((forall a. Proxy a) -> NP Proxy xs
forall (xs :: [*]) (f :: * -> *).
SListIN NP xs =>
(forall a. f a) -> NP f xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure Proxy a
forall a. Proxy a
forall {k} (t :: k). Proxy t
Proxy)
        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 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 WithBlockNo OneEraSelectView xs
r)

instance CanHardFork xs => ChainOrder (HardForkSelectView xs) where
  type ChainOrderConfig (HardForkSelectView xs) = PerEraChainOrderConfig xs

  preferCandidate :: ChainOrderConfig (HardForkSelectView xs)
-> HardForkSelectView xs -> HardForkSelectView xs -> Bool
preferCandidate
    (PerEraChainOrderConfig NP WrapChainOrderConfig xs
cfg)
    (HardForkSelectView WithBlockNo OneEraSelectView xs
ours)
    (HardForkSelectView WithBlockNo OneEraSelectView xs
cand) =
      AcrossEraMode WrapChainOrderConfig Bool
-> NP WrapChainOrderConfig xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Bool
forall (xs :: [*]) (cfg :: * -> *) a.
All SingleEraBlock xs =>
AcrossEraMode cfg a
-> NP cfg xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> a
acrossEraSelection
        AcrossEraMode WrapChainOrderConfig Bool
AcrossEraPreferCandidate
        NP WrapChainOrderConfig xs
cfg
        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 WithBlockNo OneEraSelectView xs
ours)
        ((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 WithBlockNo OneEraSelectView xs
cand)

mkHardForkSelectView ::
     BlockNo
  -> NS WrapSelectView xs
  -> HardForkSelectView xs
mkHardForkSelectView :: forall (xs :: [*]).
BlockNo -> NS WrapSelectView xs -> HardForkSelectView xs
mkHardForkSelectView BlockNo
bno NS WrapSelectView xs
view =
    WithBlockNo OneEraSelectView xs -> HardForkSelectView xs
forall (xs :: [*]).
WithBlockNo OneEraSelectView xs -> HardForkSelectView xs
HardForkSelectView (WithBlockNo OneEraSelectView xs -> HardForkSelectView xs)
-> WithBlockNo OneEraSelectView xs -> HardForkSelectView xs
forall a b. (a -> b) -> a -> b
$ BlockNo -> OneEraSelectView xs -> WithBlockNo OneEraSelectView 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)

{-------------------------------------------------------------------------------
  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 SelectView    (HardForkProtocol xs) = HardForkSelectView    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)
-> LedgerView (HardForkProtocol xs)
-> SlotNo
-> ChainDepState (HardForkProtocol xs)
-> Ticked (ChainDepState (HardForkProtocol xs))
tickChainDepState     = ConsensusConfig (HardForkProtocol xs)
-> LedgerView (HardForkProtocol xs)
-> SlotNo
-> ChainDepState (HardForkProtocol xs)
-> Ticked (ChainDepState (HardForkProtocol xs))
ConsensusConfig (HardForkProtocol xs)
-> HardForkLedgerView xs
-> SlotNo
-> HardForkChainDepState xs
-> Ticked (HardForkChainDepState xs)
forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> HardForkLedgerView xs
-> SlotNo
-> HardForkChainDepState xs
-> Ticked (HardForkChainDepState xs)
tick
  checkIsLeader :: HasCallStack =>
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))
ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
forall (xs :: [*]).
(CanHardFork xs, HasCallStack) =>
ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
check
  updateChainDepState :: HasCallStack =>
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))
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update
  reupdateChainDepState :: HasCallStack =>
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)
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkChainDepState 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

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

instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where
  validateView :: BlockConfig (HardForkBlock xs)
-> Header (HardForkBlock xs)
-> ValidateView (BlockProtocol (HardForkBlock xs))
validateView HardForkBlockConfig{PerEraBlockConfig xs
hardForkBlockConfigPerEra :: PerEraBlockConfig xs
hardForkBlockConfigPerEra :: forall (xs :: [*]).
BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
..} =
        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{PerEraBlockConfig xs
hardForkBlockConfigPerEra :: forall (xs :: [*]).
BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
hardForkBlockConfigPerEra :: PerEraBlockConfig xs
..} 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
 -> SelectView (BlockProtocol (HardForkBlock xs)))
-> (OneEraHeader xs -> NS WrapSelectView xs)
-> OneEraHeader xs
-> SelectView (BlockProtocol (HardForkBlock 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 -> SelectView (BlockProtocol (HardForkBlock xs)))
-> OneEraHeader xs -> SelectView (BlockProtocol (HardForkBlock 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

  projectChainOrderConfig :: BlockConfig (HardForkBlock xs)
-> ChainOrderConfig (SelectView (BlockProtocol (HardForkBlock xs)))
projectChainOrderConfig =
        NP WrapChainOrderConfig xs -> PerEraChainOrderConfig xs
forall (xs :: [*]).
NP WrapChainOrderConfig xs -> PerEraChainOrderConfig xs
PerEraChainOrderConfig
      (NP WrapChainOrderConfig xs -> PerEraChainOrderConfig xs)
-> (BlockConfig (HardForkBlock xs) -> NP WrapChainOrderConfig xs)
-> BlockConfig (HardForkBlock xs)
-> PerEraChainOrderConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    BlockConfig a -> WrapChainOrderConfig a)
-> NP BlockConfig xs
-> NP WrapChainOrderConfig 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 (ChainOrderConfig (SelectView (BlockProtocol a))
-> WrapChainOrderConfig a
forall blk.
ChainOrderConfig (SelectView (BlockProtocol blk))
-> WrapChainOrderConfig blk
WrapChainOrderConfig (ChainOrderConfig (SelectView (BlockProtocol a))
 -> WrapChainOrderConfig a)
-> (BlockConfig a
    -> ChainOrderConfig (SelectView (BlockProtocol a)))
-> BlockConfig a
-> WrapChainOrderConfig a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig a -> ChainOrderConfig (SelectView (BlockProtocol a))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig)
      (NP BlockConfig xs -> NP WrapChainOrderConfig xs)
-> (BlockConfig (HardForkBlock xs) -> NP BlockConfig xs)
-> BlockConfig (HardForkBlock xs)
-> NP WrapChainOrderConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraBlockConfig xs -> NP BlockConfig xs
forall (xs :: [*]). PerEraBlockConfig xs -> NP BlockConfig xs
getPerEraBlockConfig
      (PerEraBlockConfig xs -> NP BlockConfig xs)
-> (BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs)
-> BlockConfig (HardForkBlock xs)
-> NP BlockConfig xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
forall (xs :: [*]).
BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
hardForkBlockConfigPerEra

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

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

        -- | 'EpochInfo' constructed from the 'LedgerView'
      , forall (xs :: [*]).
Ticked (HardForkChainDepState xs)
-> EpochInfo (Except PastHorizonException)
tickedHardForkChainDepStateEpochInfo ::
             EpochInfo (Except PastHorizonException)
      }

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

    tickOne :: SingleEraBlock                 blk
            => WrapPartialConsensusConfig     blk
            -> WrapLedgerView                 blk
            -> WrapChainDepState              blk
            -> (Ticked :.: WrapChainDepState) blk
    tickOne :: forall blk.
SingleEraBlock blk =>
WrapPartialConsensusConfig blk
-> WrapLedgerView blk
-> WrapChainDepState blk
-> (:.:) Ticked WrapChainDepState blk
tickOne WrapPartialConsensusConfig blk
cfg' 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)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> LedgerView p
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState
            (EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
ei WrapPartialConsensusConfig blk
cfg')
            (WrapLedgerView blk -> LedgerView (BlockProtocol blk)
forall blk. WrapLedgerView blk -> LedgerView (BlockProtocol blk)
unwrapLedgerView 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 = SomeErasCanBeLeader 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 :: forall (xs :: [*]).
(CanHardFork xs, HasCallStack) =>
ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
check HardForkConsensusConfig{SecurityParam
Shape xs
PerEraConsensusConfig xs
hardForkConsensusConfigK :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigShape :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> Shape xs
hardForkConsensusConfigPerEra :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigShape :: Shape xs
hardForkConsensusConfigPerEra :: PerEraConsensusConfig xs
..}
      (SomeErasCanBeLeader NonEmptyOptNP WrapCanBeLeader xs
canBeLeader)
      SlotNo
slot
      (TickedHardForkChainDepState HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState EpochInfo (Except PastHorizonException)
ei) =
    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
    -> (:.:) Maybe WrapCanBeLeader a
    -> (:.:) Ticked WrapChainDepState a
    -> (:.:) Maybe WrapIsLeader a)
-> Prod NS WrapPartialConsensusConfig xs
-> Prod NS (Maybe :.: WrapCanBeLeader) xs
-> NS (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 -> *) (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
        WrapPartialConsensusConfig a
-> (:.:) Maybe WrapCanBeLeader a
-> (:.:) Ticked WrapChainDepState a
-> (:.:) Maybe WrapIsLeader a
forall a.
SingleEraBlock a =>
WrapPartialConsensusConfig a
-> (:.:) Maybe WrapCanBeLeader a
-> (:.:) Ticked WrapChainDepState a
-> (:.:) Maybe WrapIsLeader a
checkOne
        Prod NS WrapPartialConsensusConfig xs
NP WrapPartialConsensusConfig xs
cfgs
        (NonEmptyOptNP WrapCanBeLeader xs
-> NP (Maybe :.: WrapCanBeLeader) xs
forall {k} (empty :: Bool) (f :: k -> *) (xs :: [k]).
OptNP empty f xs -> NP (Maybe :.: f) xs
OptNP.toNP NonEmptyOptNP WrapCanBeLeader xs
canBeLeader)
        (HardForkState (Ticked :.: WrapChainDepState) xs
-> NS (Ticked :.: WrapChainDepState) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState)
  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
      -> (Maybe :.: WrapCanBeLeader)    blk
      -> (Ticked :.: WrapChainDepState) blk
      -> (Maybe :.: WrapIsLeader)       blk
    checkOne :: forall a.
SingleEraBlock a =>
WrapPartialConsensusConfig a
-> (:.:) Maybe WrapCanBeLeader a
-> (:.:) Ticked WrapChainDepState a
-> (:.:) Maybe WrapIsLeader a
checkOne WrapPartialConsensusConfig blk
cfg' (Comp Maybe (WrapCanBeLeader blk)
mCanBeLeader) (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
$ do
        WrapCanBeLeader blk
canBeLeader' <- Maybe (WrapCanBeLeader blk)
mCanBeLeader
        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 (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
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)
NS (K (Maybe (HardForkIsLeader xs))) xs
-> CollapseTo NS (Maybe (HardForkIsLeader xs))
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 (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.
 Index xs a
 -> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a)
-> NS (Maybe :.: WrapIsLeader) xs
-> NS (K (Maybe (HardForkIsLeader xs))) xs
forall {k} (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, SListI xs, Prod h ~ NP) =>
(forall (a :: k). Index xs a -> f1 a -> f2 a) -> h f1 xs -> h f2 xs
himap Index xs a
-> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a
forall a.
Index xs a
-> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a
inj
      where
        inj :: Index xs blk
            -> (Maybe :.: WrapIsLeader) blk
            -> K (Maybe (HardForkIsLeader xs)) blk
        inj :: forall a.
Index xs a
-> (:.:) Maybe WrapIsLeader a -> K (Maybe (HardForkIsLeader xs)) a
inj Index xs blk
index (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
. Index xs blk -> WrapIsLeader blk -> NS WrapIsLeader xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index (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
$cfrom :: forall (xs :: [*]) x.
HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x
from :: forall x.
HardForkValidationErr xs -> Rep (HardForkValidationErr xs) x
$cto :: forall (xs :: [*]) x.
Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs
to :: forall x.
Rep (HardForkValidationErr xs) x -> HardForkValidationErr xs
Generic)

update :: forall xs. CanHardFork xs
       => ConsensusConfig (HardForkProtocol xs)
       -> OneEraValidateView xs
       -> SlotNo
       -> Ticked (HardForkChainDepState xs)
       -> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update :: forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update HardForkConsensusConfig{SecurityParam
Shape xs
PerEraConsensusConfig xs
hardForkConsensusConfigK :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigShape :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> Shape xs
hardForkConsensusConfigPerEra :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigShape :: Shape xs
hardForkConsensusConfigPerEra :: PerEraConsensusConfig xs
..}
       (OneEraValidateView NS WrapValidateView xs
view)
       SlotNo
slot
       (TickedHardForkChainDepState HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState EpochInfo (Except PastHorizonException)
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 a.
HardForkValidationErr xs
-> ExceptT (HardForkValidationErr xs) Identity a
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
            WrapValidateView x -> SingleEraInfo x
forall x. SingleEraBlock x => WrapValidateView x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
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 (xs :: [*]) (f :: * -> *) (g :: * -> *).
(SListIN HardForkState xs, Applicative f) =>
HardForkState (f :.: g) xs -> f (HardForkState g 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 =>
    Index xs a
    -> WrapPartialConsensusConfig a
    -> Product WrapValidateView (Ticked :.: WrapChainDepState) a
    -> (:.:)
         (ExceptT (HardForkValidationErr xs) Identity) WrapChainDepState a)
-> NP WrapPartialConsensusConfig xs
-> HardForkState
     (Product WrapValidateView (Ticked :.: WrapChainDepState)) xs
-> HardForkState
     (ExceptT (HardForkValidationErr xs) Identity :.: WrapChainDepState)
     xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a)
-> NP f1 xs
-> h f2 xs
-> h f3 xs
hcizipWith Proxy SingleEraBlock
proxySingle (EpochInfo (Except PastHorizonException)
-> SlotNo
-> Index xs a
-> WrapPartialConsensusConfig a
-> Product WrapValidateView (Ticked :.: WrapChainDepState) a
-> (:.:)
     (ExceptT (HardForkValidationErr xs) Identity) WrapChainDepState a
forall (xs :: [*]) blk.
SingleEraBlock blk =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> Index xs blk
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
updateEra EpochInfo (Except PastHorizonException)
ei SlotNo
slot) NP WrapPartialConsensusConfig xs
cfgs
         (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

updateEra :: forall xs blk. SingleEraBlock blk
          => EpochInfo (Except PastHorizonException)
          -> SlotNo
          -> Index xs blk
          -> WrapPartialConsensusConfig blk
          -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
          -> (Except (HardForkValidationErr xs) :.: WrapChainDepState) blk
updateEra :: forall (xs :: [*]) blk.
SingleEraBlock blk =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> Index xs blk
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
updateEra EpochInfo (Except PastHorizonException)
ei SlotNo
slot Index xs blk
index WrapPartialConsensusConfig blk
cfg
          (Pair WrapValidateView blk
view (Comp Ticked (WrapChainDepState blk)
chainDepState)) = Except (HardForkValidationErr xs) (WrapChainDepState blk)
-> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Except (HardForkValidationErr xs) (WrapChainDepState blk)
 -> (:.:) (Except (HardForkValidationErr xs)) WrapChainDepState blk)
-> Except (HardForkValidationErr xs) (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)
-> Except (HardForkValidationErr xs) (WrapChainDepState blk)
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (Index xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
forall (xs :: [*]) blk.
Index xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
injectValidationErr Index xs blk
index) (Except (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
 -> Except (HardForkValidationErr xs) (WrapChainDepState blk))
-> Except
     (ValidationErr (BlockProtocol blk)) (WrapChainDepState blk)
-> Except (HardForkValidationErr xs) (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 a b.
(a -> b)
-> ExceptT (ValidationErr (BlockProtocol blk)) Identity a
-> ExceptT (ValidationErr (BlockProtocol blk)) Identity b
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 (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
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 :: forall (xs :: [*]).
CanHardFork xs =>
ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkChainDepState xs
reupdate HardForkConsensusConfig{SecurityParam
Shape xs
PerEraConsensusConfig xs
hardForkConsensusConfigK :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigShape :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> Shape xs
hardForkConsensusConfigPerEra :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigShape :: Shape xs
hardForkConsensusConfigPerEra :: PerEraConsensusConfig xs
..}
         (OneEraValidateView NS WrapValidateView xs
view)
         SlotNo
slot
         (TickedHardForkChainDepState HardForkState (Ticked :.: WrapChainDepState) xs
chainDepState EpochInfo (Except PastHorizonException)
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 ->
        String -> HardForkChainDepState xs
forall a. HasCallStack => String -> a
error (String -> HardForkChainDepState xs)
-> String -> HardForkChainDepState xs
forall a b. (a -> b) -> a -> b
$ HardForkValidationErr xs -> String
forall a. Show a => a -> String
show (HardForkValidationErr xs -> String)
-> (Mismatch SingleEraInfo LedgerEraInfo xs
    -> HardForkValidationErr xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> String
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 -> String)
-> Mismatch SingleEraInfo LedgerEraInfo xs -> String
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
            WrapValidateView x -> SingleEraInfo x
forall x. SingleEraBlock x => WrapValidateView x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
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 (Except PastHorizonException)
-> SlotNo
-> WrapPartialConsensusConfig a
-> Product WrapValidateView (Ticked :.: WrapChainDepState) a
-> WrapChainDepState a
forall blk.
SingleEraBlock blk =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> WrapChainDepState blk
reupdateEra EpochInfo (Except PastHorizonException)
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 (Except PastHorizonException)
            -> SlotNo
            -> WrapPartialConsensusConfig blk
            -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
            -> WrapChainDepState blk
reupdateEra :: forall blk.
SingleEraBlock blk =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> WrapChainDepState blk
reupdateEra EpochInfo (Except PastHorizonException)
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 (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
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 :: forall blk.
SingleEraBlock blk =>
(:.:) Ticked WrapChainDepState blk -> SingleEraInfo blk
chainDepStateInfo (:.:) Ticked WrapChainDepState blk
_ = Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk
singleEraInfo (forall a. Proxy a
forall {k} (t :: k). Proxy t
Proxy @blk)

translateConsensus :: forall xs. CanHardFork xs
                   => EpochInfo (Except PastHorizonException)
                   -> ConsensusConfig (HardForkProtocol xs)
                   -> InPairs (Translate WrapChainDepState) xs
translateConsensus :: forall (xs :: [*]).
CanHardFork xs =>
EpochInfo (Except PastHorizonException)
-> ConsensusConfig (HardForkProtocol xs)
-> InPairs (Translate WrapChainDepState) xs
translateConsensus EpochInfo (Except PastHorizonException)
ei HardForkConsensusConfig{SecurityParam
Shape xs
PerEraConsensusConfig xs
hardForkConsensusConfigK :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigShape :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> Shape xs
hardForkConsensusConfigPerEra :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigShape :: Shape xs
hardForkConsensusConfigPerEra :: PerEraConsensusConfig xs
..} =
    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
HFTranslation.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 (Except PastHorizonException)
-> WrapPartialConsensusConfig a -> WrapConsensusConfig a
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk -> WrapConsensusConfig blk
completeConsensusConfig'' EpochInfo (Except PastHorizonException)
ei) NP WrapPartialConsensusConfig xs
pcfgs

injectValidationErr :: Index xs blk
                    -> ValidationErr (BlockProtocol blk)
                    -> HardForkValidationErr xs
injectValidationErr :: forall (xs :: [*]) blk.
Index xs blk
-> ValidationErr (BlockProtocol blk) -> HardForkValidationErr xs
injectValidationErr Index xs blk
index =
      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
. Index xs blk -> WrapValidationErr blk -> NS WrapValidationErr xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index
    (WrapValidationErr blk -> NS WrapValidationErr xs)
-> (ValidationErr (BlockProtocol blk) -> WrapValidationErr blk)
-> ValidationErr (BlockProtocol blk)
-> NS WrapValidationErr xs
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)