{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
module Ouroboros.Consensus.HardFork.Combinator.Forging (
    HardForkCannotForge
  , HardForkForgeStateInfo (..)
  , HardForkForgeStateUpdateError
  , hardForkBlockForging
  ) where

import           Data.Functor.Product
import           Data.Maybe (fromMaybe)
import           Data.SOP.BasicFunctors
import           Data.SOP.Strict
import           Data.Text (Text)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util ((.:))
import           Ouroboros.Consensus.Util.OptNP (NonEmptyOptNP, OptNP,
                     ViewOptNP (..))
import qualified Ouroboros.Consensus.Util.OptNP as OptNP
import           Ouroboros.Consensus.Util.SOP

import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.HardFork.Combinator.InjectTxs
import           Ouroboros.Consensus.HardFork.Combinator.Ledger (Ticked (..))
import           Ouroboros.Consensus.HardFork.Combinator.Mempool
import           Ouroboros.Consensus.HardFork.Combinator.Protocol
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
                     (Product2 (..))
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

-- | If we cannot forge, it's because the current era could not forge
type HardForkCannotForge xs = OneEraCannotForge xs

type instance CannotForge (HardForkBlock xs) = HardForkCannotForge xs

-- | For each era in which we want to forge blocks, we have a 'BlockForging',
-- and thus 'ForgeStateInfo'.
--
-- When we update the hard fork forge state, we only update the forge state of
-- the current era. However, the current era /might not/ have a forge state as
-- it lacks a 'BlockForging'.
--
-- TODO #2766: expire past 'ForgeState'
data HardForkForgeStateInfo xs where
    -- | There is no 'BlockForging' record for the current era.
    CurrentEraLacksBlockForging ::
         EraIndex (x ': y ': xs)
      -> HardForkForgeStateInfo (x ': y ': xs)

    -- | The 'ForgeState' of the current era was updated.
    CurrentEraForgeStateUpdated ::
         OneEraForgeStateInfo xs
      -> HardForkForgeStateInfo xs

deriving instance CanHardFork xs => Show (HardForkForgeStateInfo xs)

type instance ForgeStateInfo (HardForkBlock xs) = HardForkForgeStateInfo xs

-- | For each era in which we want to forge blocks, we have a 'BlockForging',
-- and thus 'ForgeStateUpdateError'.
type HardForkForgeStateUpdateError xs = OneEraForgeStateUpdateError xs

type instance ForgeStateUpdateError (HardForkBlock xs) =
  HardForkForgeStateUpdateError xs

hardForkBlockForging ::
     forall m xs. (CanHardFork xs, Monad m)
  => Text
     -- ^ Used as the 'forgeLabel', the labels of the given 'BlockForging's will
     -- be ignored.
  -> NonEmptyOptNP (BlockForging m) xs
  -> BlockForging m (HardForkBlock xs)
hardForkBlockForging :: Text
-> NonEmptyOptNP (BlockForging m) xs
-> BlockForging m (HardForkBlock xs)
hardForkBlockForging Text
forgeLabel NonEmptyOptNP (BlockForging m) xs
blockForging =
    BlockForging :: forall (m :: * -> *) blk.
Text
-> CanBeLeader (BlockProtocol blk)
-> (TopLevelConfig blk
    -> SlotNo
    -> Ticked (ChainDepState (BlockProtocol blk))
    -> m (ForgeStateUpdateInfo blk))
-> (TopLevelConfig blk
    -> SlotNo
    -> Ticked (ChainDepState (BlockProtocol blk))
    -> IsLeader (BlockProtocol blk)
    -> ForgeStateInfo blk
    -> Either (CannotForge blk) ())
-> (TopLevelConfig blk
    -> BlockNo
    -> SlotNo
    -> TickedLedgerState blk
    -> [Validated (GenTx blk)]
    -> IsLeader (BlockProtocol blk)
    -> m blk)
-> BlockForging m blk
BlockForging {
        forgeLabel :: Text
forgeLabel       = Text
forgeLabel
      , canBeLeader :: CanBeLeader (BlockProtocol (HardForkBlock xs))
canBeLeader      = NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs
forall (xs :: [*]) (m :: * -> *).
CanHardFork xs =>
NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader               NonEmptyOptNP (BlockForging m) xs
blockForging
      , updateForgeState :: TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol (HardForkBlock xs)))
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
updateForgeState = NonEmptyOptNP (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
NonEmptyOptNP (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState          NonEmptyOptNP (BlockForging m) xs
blockForging
      , checkCanForge :: TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol (HardForkBlock xs)))
-> IsLeader (BlockProtocol (HardForkBlock xs))
-> ForgeStateInfo (HardForkBlock xs)
-> Either (CannotForge (HardForkBlock xs)) ()
checkCanForge    = NonEmptyOptNP (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
forall (m :: * -> *) (xs :: [*]) (empty :: Bool).
CanHardFork xs =>
OptNP empty (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge             NonEmptyOptNP (BlockForging m) xs
blockForging
      , forgeBlock :: TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [Validated (GenTx (HardForkBlock xs))]
-> IsLeader (BlockProtocol (HardForkBlock xs))
-> m (HardForkBlock xs)
forgeBlock       = NonEmptyOptNP (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [Validated (GenTx (HardForkBlock xs))]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
forall (m :: * -> *) (xs :: [*]) (empty :: Bool).
(CanHardFork xs, Monad m) =>
OptNP empty (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [Validated (GenTx (HardForkBlock xs))]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
hardForkForgeBlock                NonEmptyOptNP (BlockForging m) xs
blockForging
      }

hardForkCanBeLeader ::
     CanHardFork xs
  => NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader :: NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader =
      NonEmptyOptNP WrapCanBeLeader xs -> HardForkCanBeLeader xs
forall (xs :: [*]).
NonEmptyOptNP WrapCanBeLeader xs -> SomeErasCanBeLeader xs
SomeErasCanBeLeader
    (NonEmptyOptNP WrapCanBeLeader xs -> HardForkCanBeLeader xs)
-> (NonEmptyOptNP (BlockForging m) xs
    -> NonEmptyOptNP WrapCanBeLeader xs)
-> NonEmptyOptNP (BlockForging m) xs
-> HardForkCanBeLeader xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. BlockForging m a -> WrapCanBeLeader a)
-> NonEmptyOptNP (BlockForging m) xs
-> NonEmptyOptNP WrapCanBeLeader xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (CanBeLeader (BlockProtocol a) -> WrapCanBeLeader a
forall blk. CanBeLeader (BlockProtocol blk) -> WrapCanBeLeader blk
WrapCanBeLeader (CanBeLeader (BlockProtocol a) -> WrapCanBeLeader a)
-> (BlockForging m a -> CanBeLeader (BlockProtocol a))
-> BlockForging m a
-> WrapCanBeLeader a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockForging m a -> CanBeLeader (BlockProtocol a)
forall (m :: * -> *) blk.
BlockForging m blk -> CanBeLeader (BlockProtocol blk)
canBeLeader)

-- | POSTCONDITION: the returned 'ForgeStateUpdateInfo' is from the same era as
-- the ticked 'ChainDepState'.
hardForkUpdateForgeState ::
     forall m xs. (CanHardFork xs, Monad m)
  => NonEmptyOptNP (BlockForging m) xs
  -> TopLevelConfig (HardForkBlock xs)
  -> SlotNo
  -> Ticked (HardForkChainDepState xs)
  -> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState :: NonEmptyOptNP (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState NonEmptyOptNP (BlockForging m) xs
blockForging
                         TopLevelConfig (HardForkBlock xs)
cfg
                         SlotNo
curSlot
                         (TickedHardForkChainDepState chainDepState ei) =
    case NonEmptyOptNP (BlockForging m) xs -> ViewOptNP (BlockForging m) xs
forall k (f :: k -> *) (xs :: [k]).
NonEmptyOptNP f xs -> ViewOptNP f xs
OptNP.view NonEmptyOptNP (BlockForging m) xs
blockForging of
      OptNP_ExactlyOne BlockForging m x
blockForging' ->
        ForgeStateUpdateInfo x -> ForgeStateUpdateInfo (HardForkBlock '[x])
forall blk.
(xs ~ '[blk]) =>
ForgeStateUpdateInfo blk
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
injectSingle (ForgeStateUpdateInfo x
 -> ForgeStateUpdateInfo (HardForkBlock '[x]))
-> m (ForgeStateUpdateInfo x)
-> m (ForgeStateUpdateInfo (HardForkBlock '[x]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          BlockForging m x
-> TopLevelConfig x
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol x))
-> m (ForgeStateUpdateInfo x)
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState
            BlockForging m x
blockForging'
            (NP TopLevelConfig '[x] -> TopLevelConfig x
forall k (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd (EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg))
            SlotNo
curSlot
            (Ticked (WrapChainDepState x)
-> Ticked (ChainDepState (BlockProtocol x))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState (Ticked (WrapChainDepState x)
 -> Ticked (ChainDepState (BlockProtocol x)))
-> (HardForkState (Ticked :.: WrapChainDepState) '[x]
    -> Ticked (WrapChainDepState x))
-> HardForkState (Ticked :.: WrapChainDepState) '[x]
-> Ticked (ChainDepState (BlockProtocol x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) Ticked WrapChainDepState x -> Ticked (WrapChainDepState x)
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
(:.:) f g p -> f (g p)
unComp ((:.:) Ticked WrapChainDepState x -> Ticked (WrapChainDepState x))
-> (HardForkState (Ticked :.: WrapChainDepState) '[x]
    -> (:.:) Ticked WrapChainDepState x)
-> HardForkState (Ticked :.: WrapChainDepState) '[x]
-> Ticked (WrapChainDepState x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState (Ticked :.: WrapChainDepState) '[x]
-> (:.:) Ticked WrapChainDepState x
forall (f :: * -> *) blk. HardForkState f '[blk] -> f blk
State.fromTZ (HardForkState (Ticked :.: WrapChainDepState) '[x]
 -> Ticked (ChainDepState (BlockProtocol x)))
-> HardForkState (Ticked :.: WrapChainDepState) '[x]
-> Ticked (ChainDepState (BlockProtocol x))
forall a b. (a -> b) -> a -> b
$ HardForkState (Ticked :.: WrapChainDepState) xs
HardForkState (Ticked :.: WrapChainDepState) '[x]
chainDepState)
      ViewOptNP (BlockForging m) xs
OptNP_AtLeastTwo ->
          (NS (Maybe :.: ForgeStateUpdateInfo) xs
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> m (NS (Maybe :.: ForgeStateUpdateInfo) xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NS (Maybe :.: ForgeStateUpdateInfo) xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall x y (zs :: [*]).
(xs ~ (x : y : zs)) =>
NS (Maybe :.: ForgeStateUpdateInfo) xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
undistrib
        (m (NS (Maybe :.: ForgeStateUpdateInfo) xs)
 -> m (ForgeStateUpdateInfo (HardForkBlock xs)))
-> m (NS (Maybe :.: ForgeStateUpdateInfo) xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
forall a b. (a -> b) -> a -> b
$ NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs
-> m (NS (Maybe :.: ForgeStateUpdateInfo) 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'
        (NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs
 -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs))
-> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs
-> m (NS (Maybe :.: ForgeStateUpdateInfo) xs)
forall a b. (a -> b) -> a -> b
$ (forall a.
 (:.:) Maybe (BlockForging m) a
 -> TopLevelConfig a
 -> (:.:) Ticked WrapChainDepState a
 -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a)
-> Prod NS (Maybe :.: BlockForging m) xs
-> Prod NS TopLevelConfig xs
-> NS (Ticked :.: WrapChainDepState) xs
-> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a -> f''' a)
-> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs
hzipWith3
            forall a.
(:.:) Maybe (BlockForging m) a
-> TopLevelConfig a
-> (:.:) Ticked WrapChainDepState a
-> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a
aux
            (NonEmptyOptNP (BlockForging m) xs
-> NP (Maybe :.: BlockForging m) xs
forall k (empty :: Bool) (f :: k -> *) (xs :: [k]).
OptNP empty f xs -> NP (Maybe :.: f) xs
OptNP.toNP NonEmptyOptNP (BlockForging m) xs
blockForging)
            (EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg)
        (NS (Ticked :.: WrapChainDepState) xs
 -> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs)
-> NS (Ticked :.: WrapChainDepState) xs
-> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs
forall a b. (a -> b) -> a -> b
$ 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
    injectSingle ::
         xs ~ '[blk]
      => ForgeStateUpdateInfo blk
      -> ForgeStateUpdateInfo (HardForkBlock '[blk])
    injectSingle :: ForgeStateUpdateInfo blk
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
injectSingle ForgeStateUpdateInfo blk
forgeStateUpdateInfo =
        case ForgeStateUpdateInfo blk
forgeStateUpdateInfo of
          ForgeStateUpdated      ForgeStateInfo blk
info -> ForgeStateInfo (HardForkBlock '[blk])
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated      (ForgeStateInfo (HardForkBlock '[blk])
 -> ForgeStateUpdateInfo (HardForkBlock '[blk]))
-> ForgeStateInfo (HardForkBlock '[blk])
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
forall a b. (a -> b) -> a -> b
$ Index xs blk
-> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs)
forall blk.
Index xs blk
-> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs)
injInfo        Index xs blk
forall blk. Index '[blk] blk
index ForgeStateInfo blk
info
          ForgeStateUpdateFailed ForgeStateUpdateError blk
err  -> ForgeStateUpdateError (HardForkBlock '[blk])
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk
ForgeStateUpdateFailed (ForgeStateUpdateError (HardForkBlock '[blk])
 -> ForgeStateUpdateInfo (HardForkBlock '[blk]))
-> ForgeStateUpdateError (HardForkBlock '[blk])
-> ForgeStateUpdateInfo (HardForkBlock '[blk])
forall a b. (a -> b) -> a -> b
$ Index xs blk
-> ForgeStateUpdateError blk
-> ForgeStateUpdateError (HardForkBlock xs)
forall blk.
Index xs blk
-> ForgeStateUpdateError blk
-> ForgeStateUpdateError (HardForkBlock xs)
injUpdateError Index xs blk
forall blk. Index '[blk] blk
index ForgeStateUpdateError blk
err
          ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed  -> ForgeStateUpdateInfo (HardForkBlock '[blk])
forall blk. ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed
      where
        index :: Index '[blk] blk
        index :: Index '[blk] blk
index = Index '[blk] blk
forall a (x :: a) (xs :: [a]). Index (x : xs) x
IZ

    aux ::
         (Maybe :.: BlockForging m)               blk
      -> TopLevelConfig                           blk
      -> (Ticked :.: WrapChainDepState)           blk
      -> (m :.: (Maybe :.: ForgeStateUpdateInfo)) blk
    aux :: (:.:) Maybe (BlockForging m) blk
-> TopLevelConfig blk
-> (:.:) Ticked WrapChainDepState blk
-> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk
aux (Comp Maybe (BlockForging m blk)
mBlockForging) TopLevelConfig blk
cfg' (Comp Ticked (WrapChainDepState blk)
chainDepState') =
        m ((:.:) Maybe ForgeStateUpdateInfo blk)
-> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (m ((:.:) Maybe ForgeStateUpdateInfo blk)
 -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk)
-> m ((:.:) Maybe ForgeStateUpdateInfo blk)
-> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk
forall a b. (a -> b) -> a -> b
$ (Maybe (ForgeStateUpdateInfo blk)
 -> (:.:) Maybe ForgeStateUpdateInfo blk)
-> m (Maybe (ForgeStateUpdateInfo blk))
-> m ((:.:) Maybe ForgeStateUpdateInfo blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (ForgeStateUpdateInfo blk)
-> (:.:) Maybe ForgeStateUpdateInfo blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (m (Maybe (ForgeStateUpdateInfo blk))
 -> m ((:.:) Maybe ForgeStateUpdateInfo blk))
-> m (Maybe (ForgeStateUpdateInfo blk))
-> m ((:.:) Maybe ForgeStateUpdateInfo blk)
forall a b. (a -> b) -> a -> b
$ case Maybe (BlockForging m blk)
mBlockForging of
          Maybe (BlockForging m blk)
Nothing -> Maybe (ForgeStateUpdateInfo blk)
-> m (Maybe (ForgeStateUpdateInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ForgeStateUpdateInfo blk)
forall a. Maybe a
Nothing
          Just BlockForging m blk
blockForging' -> ForgeStateUpdateInfo blk -> Maybe (ForgeStateUpdateInfo blk)
forall a. a -> Maybe a
Just (ForgeStateUpdateInfo blk -> Maybe (ForgeStateUpdateInfo blk))
-> m (ForgeStateUpdateInfo blk)
-> m (Maybe (ForgeStateUpdateInfo blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState
              BlockForging m blk
blockForging'
              TopLevelConfig blk
cfg'
              SlotNo
curSlot
              (Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState Ticked (WrapChainDepState blk)
chainDepState')

    injInfo ::
         Index xs blk
      -> ForgeStateInfo blk
      -> ForgeStateInfo (HardForkBlock xs)
    injInfo :: Index xs blk
-> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs)
injInfo Index xs blk
index =
          OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs
forall (xs :: [*]).
OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs
CurrentEraForgeStateUpdated
        (OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs)
-> (ForgeStateInfo blk -> OneEraForgeStateInfo xs)
-> ForgeStateInfo blk
-> HardForkForgeStateInfo xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs
forall (xs :: [*]).
NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs
OneEraForgeStateInfo
        (NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs)
-> (ForgeStateInfo blk -> NS WrapForgeStateInfo xs)
-> ForgeStateInfo blk
-> OneEraForgeStateInfo xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapForgeStateInfo blk -> NS WrapForgeStateInfo xs
forall k (f :: k -> *) (x :: k) (xs :: [k]).
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index
        (WrapForgeStateInfo blk -> NS WrapForgeStateInfo xs)
-> (ForgeStateInfo blk -> WrapForgeStateInfo blk)
-> ForgeStateInfo blk
-> NS WrapForgeStateInfo xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeStateInfo blk -> WrapForgeStateInfo blk
forall blk. ForgeStateInfo blk -> WrapForgeStateInfo blk
WrapForgeStateInfo

    injUpdateError ::
         Index xs blk
      -> ForgeStateUpdateError blk
      -> ForgeStateUpdateError (HardForkBlock xs)
    injUpdateError :: Index xs blk
-> ForgeStateUpdateError blk
-> ForgeStateUpdateError (HardForkBlock xs)
injUpdateError Index xs blk
index =
          NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs
forall (xs :: [*]).
NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs
OneEraForgeStateUpdateError
        (NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs)
-> (ForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs)
-> ForgeStateUpdateError blk
-> OneEraForgeStateUpdateError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk
-> WrapForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs
forall k (f :: k -> *) (x :: k) (xs :: [k]).
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index
        (WrapForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs)
-> (ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk)
-> ForgeStateUpdateError blk
-> NS WrapForgeStateUpdateError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk
forall blk.
ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk
WrapForgeStateUpdateError

    undistrib ::
         xs ~ (x ': y ': zs)
      => NS (Maybe :.: ForgeStateUpdateInfo) xs
      -> ForgeStateUpdateInfo (HardForkBlock xs)
    undistrib :: NS (Maybe :.: ForgeStateUpdateInfo) xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
undistrib = NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs
-> ForgeStateUpdateInfo (HardForkBlock 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 (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> (NS (Maybe :.: ForgeStateUpdateInfo) xs
    -> NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs)
-> NS (Maybe :.: ForgeStateUpdateInfo) xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 Index xs a
 -> (:.:) Maybe ForgeStateUpdateInfo a
 -> K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) a)
-> NS (Maybe :.: ForgeStateUpdateInfo) xs
-> NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) 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 forall blk.
Index xs blk
-> (:.:) Maybe ForgeStateUpdateInfo blk
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
forall a.
Index xs a
-> (:.:) Maybe ForgeStateUpdateInfo a
-> K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) a
inj
      where
        inj :: forall blk.
               Index xs blk
            -> (Maybe :.: ForgeStateUpdateInfo) blk
            -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
        inj :: Index xs blk
-> (:.:) Maybe ForgeStateUpdateInfo blk
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
inj Index xs blk
index (Comp Maybe (ForgeStateUpdateInfo blk)
mForgeStateUpdateInfo) =
            ForgeStateUpdateInfo (HardForkBlock xs)
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
forall k a (b :: k). a -> K a b
K (ForgeStateUpdateInfo (HardForkBlock xs)
 -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk)
-> ForgeStateUpdateInfo (HardForkBlock xs)
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
forall a b. (a -> b) -> a -> b
$ case Maybe (ForgeStateUpdateInfo blk)
mForgeStateUpdateInfo of
                Maybe (ForgeStateUpdateInfo blk)
Nothing -> ForgeStateInfo (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated (ForgeStateInfo (HardForkBlock xs)
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> ForgeStateInfo (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs)
forall x y (xs :: [*]).
EraIndex (x : y : xs) -> HardForkForgeStateInfo (x : y : xs)
CurrentEraLacksBlockForging (EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs))
-> EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs)
forall a b. (a -> b) -> a -> b
$ Index xs blk -> EraIndex xs
forall (xs :: [*]) blk. Index xs blk -> EraIndex xs
eraIndexFromIndex Index xs blk
index
                Just ForgeStateUpdateInfo blk
forgeStateUpdateInfo ->
                  case ForgeStateUpdateInfo blk
forgeStateUpdateInfo of
                    ForgeStateUpdated      ForgeStateInfo blk
info -> ForgeStateInfo (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated      (ForgeStateInfo (HardForkBlock xs)
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> ForgeStateInfo (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ Index xs blk
-> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs)
forall blk.
Index xs blk
-> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs)
injInfo        Index xs blk
index ForgeStateInfo blk
info
                    ForgeStateUpdateFailed ForgeStateUpdateError blk
err  -> ForgeStateUpdateError (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk
ForgeStateUpdateFailed (ForgeStateUpdateError (HardForkBlock xs)
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> ForgeStateUpdateError (HardForkBlock xs)
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ Index xs blk
-> ForgeStateUpdateError blk
-> ForgeStateUpdateError (HardForkBlock xs)
forall blk.
Index xs blk
-> ForgeStateUpdateError blk
-> ForgeStateUpdateError (HardForkBlock xs)
injUpdateError Index xs blk
index ForgeStateUpdateError blk
err
                    ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed  -> ForgeStateUpdateInfo (HardForkBlock xs)
forall blk. ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed

-- | PRECONDITION: the ticked 'ChainDepState', the 'HardForkIsLeader', and the
-- 'HardForkStateInfo' are all from the same era, and we must have a
-- 'BlockForging' for that era.
--
-- This follows from the postconditions of 'check' and
-- 'hardForkUpdateForgeState'.
hardForkCheckCanForge ::
     forall m xs empty. CanHardFork xs
  => OptNP empty (BlockForging m) xs
  -> TopLevelConfig (HardForkBlock xs)
  -> SlotNo
  -> Ticked (HardForkChainDepState xs)
  -> HardForkIsLeader xs
  -> HardForkForgeStateInfo xs
  -> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge :: OptNP empty (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge OptNP empty (BlockForging m) xs
blockForging
                      TopLevelConfig (HardForkBlock xs)
cfg
                      SlotNo
curSlot
                      (TickedHardForkChainDepState chainDepState ei)
                      HardForkIsLeader xs
isLeader
                      HardForkForgeStateInfo xs
forgeStateInfo =
    NS (Maybe :.: WrapCannotForge) xs
-> Either (HardForkCannotForge xs) ()
distrib (NS (Maybe :.: WrapCannotForge) xs
 -> Either (HardForkCannotForge xs) ())
-> NS (Maybe :.: WrapCannotForge) xs
-> Either (HardForkCannotForge xs) ()
forall a b. (a -> b) -> a -> b
$
      (forall a.
 Index xs a
 -> TopLevelConfig a
 -> (:.:) Maybe (BlockForging m) a
 -> Product
      WrapForgeStateInfo
      (Product WrapIsLeader (Ticked :.: WrapChainDepState))
      a
 -> (:.:) Maybe WrapCannotForge a)
-> NP TopLevelConfig xs
-> NP (Maybe :.: BlockForging m) xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product WrapIsLeader (Ticked :.: WrapChainDepState)))
     xs
-> NS (Maybe :.: WrapCannotForge) xs
forall k (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *) (f4 :: k -> *).
(HAp h, SListI xs, Prod h ~ NP) =>
(forall (a :: k). Index xs a -> f1 a -> f2 a -> f3 a -> f4 a)
-> NP f1 xs -> NP f2 xs -> h f3 xs -> h f4 xs
hizipWith3
        forall a.
Index xs a
-> TopLevelConfig a
-> (:.:) Maybe (BlockForging m) a
-> Product
     WrapForgeStateInfo
     (Product WrapIsLeader (Ticked :.: WrapChainDepState))
     a
-> (:.:) Maybe WrapCannotForge a
checkOne
        (EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg)
        (OptNP empty (BlockForging m) xs -> NP (Maybe :.: BlockForging m) xs
forall k (empty :: Bool) (f :: k -> *) (xs :: [k]).
OptNP empty f xs -> NP (Maybe :.: f) xs
OptNP.toNP OptNP empty (BlockForging m) xs
blockForging)
        -- We know all three NSs must be from the same era, because they were
        -- all produced from the same 'BlockForging'. Unfortunately, we can't
        -- enforce it statically.
        ( String
-> NS WrapForgeStateInfo xs
-> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product WrapIsLeader (Ticked :.: WrapChainDepState)))
     xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
HasCallStack =>
String -> NS f xs -> NS g xs -> NS (Product f g) xs
Match.mustMatchNS String
"ForgeStateInfo" NS WrapForgeStateInfo xs
forgeStateInfo'
        (NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs
 -> NS
      (Product
         WrapForgeStateInfo
         (Product WrapIsLeader (Ticked :.: WrapChainDepState)))
      xs)
-> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product WrapIsLeader (Ticked :.: WrapChainDepState)))
     xs
forall a b. (a -> b) -> a -> b
$ String
-> NS WrapIsLeader xs
-> NS (Ticked :.: WrapChainDepState) xs
-> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
HasCallStack =>
String -> NS f xs -> NS g xs -> NS (Product f g) xs
Match.mustMatchNS String
"IsLeader"       (HardForkIsLeader xs -> NS WrapIsLeader xs
forall (xs :: [*]). OneEraIsLeader xs -> NS WrapIsLeader xs
getOneEraIsLeader HardForkIsLeader xs
isLeader)
        (NS (Ticked :.: WrapChainDepState) xs
 -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs)
-> NS (Ticked :.: WrapChainDepState) xs
-> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs
forall a b. (a -> b) -> a -> b
$ 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
    distrib ::
         NS (Maybe :.: WrapCannotForge) xs
      -> Either (HardForkCannotForge xs) ()
    distrib :: NS (Maybe :.: WrapCannotForge) xs
-> Either (HardForkCannotForge xs) ()
distrib = Either (HardForkCannotForge xs) ()
-> (NS WrapCannotForge xs -> Either (HardForkCannotForge xs) ())
-> Maybe (NS WrapCannotForge xs)
-> Either (HardForkCannotForge xs) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either (HardForkCannotForge xs) ()
forall a b. b -> Either a b
Right ()) (HardForkCannotForge xs -> Either (HardForkCannotForge xs) ()
forall a b. a -> Either a b
Left (HardForkCannotForge xs -> Either (HardForkCannotForge xs) ())
-> (NS WrapCannotForge xs -> HardForkCannotForge xs)
-> NS WrapCannotForge xs
-> Either (HardForkCannotForge xs) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapCannotForge xs -> HardForkCannotForge xs
forall (xs :: [*]). NS WrapCannotForge xs -> OneEraCannotForge xs
OneEraCannotForge) (Maybe (NS WrapCannotForge xs)
 -> Either (HardForkCannotForge xs) ())
-> (NS (Maybe :.: WrapCannotForge) xs
    -> Maybe (NS WrapCannotForge xs))
-> NS (Maybe :.: WrapCannotForge) xs
-> Either (HardForkCannotForge xs) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (Maybe :.: WrapCannotForge) xs -> Maybe (NS WrapCannotForge 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'

    missingBlockForgingImpossible :: EraIndex xs -> String
    missingBlockForgingImpossible :: EraIndex xs -> String
missingBlockForgingImpossible EraIndex xs
eraIndex =
        String
"impossible: current era lacks block forging but we have an IsLeader proof "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EraIndex xs -> String
forall a. Show a => a -> String
show EraIndex xs
eraIndex

    forgeStateInfo' :: NS WrapForgeStateInfo xs
    forgeStateInfo' :: NS WrapForgeStateInfo xs
forgeStateInfo' = case HardForkForgeStateInfo xs
forgeStateInfo of
      CurrentEraForgeStateUpdated OneEraForgeStateInfo xs
info     -> OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
forall (xs :: [*]).
OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
getOneEraForgeStateInfo OneEraForgeStateInfo xs
info
      CurrentEraLacksBlockForging EraIndex (x : y : xs)
eraIndex ->
        String -> NS WrapForgeStateInfo xs
forall a. HasCallStack => String -> a
error (String -> NS WrapForgeStateInfo xs)
-> String -> NS WrapForgeStateInfo xs
forall a b. (a -> b) -> a -> b
$ EraIndex xs -> String
missingBlockForgingImpossible EraIndex xs
EraIndex (x : y : xs)
eraIndex

    checkOne ::
         Index xs blk
      -> TopLevelConfig blk
      -> (Maybe :.: BlockForging m) blk
      -> Product
           WrapForgeStateInfo
           (Product
             WrapIsLeader
             (Ticked :.: WrapChainDepState))
           blk
      -> (Maybe :.: WrapCannotForge) blk
         -- ^ We use @Maybe x@ instead of @Either x ()@ because the former can
         -- be partially applied.
    checkOne :: Index xs blk
-> TopLevelConfig blk
-> (:.:) Maybe (BlockForging m) blk
-> Product
     WrapForgeStateInfo
     (Product WrapIsLeader (Ticked :.: WrapChainDepState))
     blk
-> (:.:) Maybe WrapCannotForge blk
checkOne Index xs blk
index
             TopLevelConfig blk
cfg'
             (Comp Maybe (BlockForging m blk)
mBlockForging')
             (Pair
               (WrapForgeStateInfo ForgeStateInfo blk
forgeStateInfo'')
               (Pair
                 (WrapIsLeader IsLeader (BlockProtocol blk)
isLeader')
                 (Comp Ticked (WrapChainDepState blk)
tickedChainDepState))) =
        Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk)
-> Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk
forall a b. (a -> b) -> a -> b
$ (CannotForge blk -> Maybe (WrapCannotForge blk))
-> (() -> Maybe (WrapCannotForge blk))
-> Either (CannotForge blk) ()
-> Maybe (WrapCannotForge blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (WrapCannotForge blk -> Maybe (WrapCannotForge blk)
forall a. a -> Maybe a
Just (WrapCannotForge blk -> Maybe (WrapCannotForge blk))
-> (CannotForge blk -> WrapCannotForge blk)
-> CannotForge blk
-> Maybe (WrapCannotForge blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotForge blk -> WrapCannotForge blk
forall blk. CannotForge blk -> WrapCannotForge blk
WrapCannotForge) (Maybe (WrapCannotForge blk) -> () -> Maybe (WrapCannotForge blk)
forall a b. a -> b -> a
const Maybe (WrapCannotForge blk)
forall a. Maybe a
Nothing) (Either (CannotForge blk) () -> Maybe (WrapCannotForge blk))
-> Either (CannotForge blk) () -> Maybe (WrapCannotForge blk)
forall a b. (a -> b) -> a -> b
$
          BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
checkCanForge
            (BlockForging m blk
-> Maybe (BlockForging m blk) -> BlockForging m blk
forall a. a -> Maybe a -> a
fromMaybe
              (String -> BlockForging m blk
forall a. HasCallStack => String -> a
error (EraIndex xs -> String
missingBlockForgingImpossible (Index xs blk -> EraIndex xs
forall (xs :: [*]) blk. Index xs blk -> EraIndex xs
eraIndexFromIndex Index xs blk
index)))
              Maybe (BlockForging m blk)
mBlockForging')
            TopLevelConfig blk
cfg'
            SlotNo
curSlot
            (Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState Ticked (WrapChainDepState blk)
tickedChainDepState)
            IsLeader (BlockProtocol blk)
isLeader'
            ForgeStateInfo blk
forgeStateInfo''

-- | PRECONDITION: the ticked 'LedgerState' and 'HardForkIsLeader' are from the
-- same era, and we must have a 'BlockForging' for that era.
--
-- This follows from the postcondition of 'check' and the fact that the ticked
-- 'ChainDepState' and ticked 'LedgerState' are from the same era.
hardForkForgeBlock ::
     forall m xs empty. (CanHardFork xs, Monad m)
  => OptNP empty (BlockForging m) xs
  -> TopLevelConfig (HardForkBlock xs)
  -> BlockNo
  -> SlotNo
  -> TickedLedgerState (HardForkBlock xs)
  -> [Validated (GenTx (HardForkBlock xs))]
  -> HardForkIsLeader xs
  -> m (HardForkBlock xs)
hardForkForgeBlock :: OptNP empty (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [Validated (GenTx (HardForkBlock xs))]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
hardForkForgeBlock OptNP empty (BlockForging m) xs
blockForging
                   TopLevelConfig (HardForkBlock xs)
cfg
                   BlockNo
bno
                   SlotNo
sno
                   (TickedHardForkLedgerState transition ledgerState)
                   [Validated (GenTx (HardForkBlock xs))]
txs
                   HardForkIsLeader xs
isLeader =
        (NS I xs -> HardForkBlock xs)
-> m (NS I xs) -> m (HardForkBlock xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OneEraBlock xs -> HardForkBlock xs
forall (xs :: [*]). OneEraBlock xs -> HardForkBlock xs
HardForkBlock (OneEraBlock xs -> HardForkBlock xs)
-> (NS I xs -> OneEraBlock xs) -> NS I xs -> HardForkBlock xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS I xs -> OneEraBlock xs
forall (xs :: [*]). NS I xs -> OneEraBlock xs
OneEraBlock)
      (m (NS I xs) -> m (HardForkBlock xs))
-> m (NS I xs) -> m (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ NS m xs -> m (NS I xs)
forall l (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence
      (NS m xs -> m (NS I xs)) -> NS m xs -> m (NS I xs)
forall a b. (a -> b) -> a -> b
$ (forall a.
 Index xs a
 -> TopLevelConfig a
 -> (:.:) Maybe (BlockForging m) a
 -> Product
      (Product WrapIsLeader (Ticked :.: LedgerState))
      ([] :.: WrapValidatedGenTx)
      a
 -> m a)
-> NP TopLevelConfig xs
-> NP (Maybe :.: BlockForging m) xs
-> NS
     (Product
        (Product WrapIsLeader (Ticked :.: LedgerState))
        ([] :.: WrapValidatedGenTx))
     xs
-> NS m xs
forall k (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *) (f4 :: k -> *).
(HAp h, SListI xs, Prod h ~ NP) =>
(forall (a :: k). Index xs a -> f1 a -> f2 a -> f3 a -> f4 a)
-> NP f1 xs -> NP f2 xs -> h f3 xs -> h f4 xs
hizipWith3
          forall a.
Index xs a
-> TopLevelConfig a
-> (:.:) Maybe (BlockForging m) a
-> Product
     (Product WrapIsLeader (Ticked :.: LedgerState))
     ([] :.: WrapValidatedGenTx)
     a
-> m a
forgeBlockOne
          NP TopLevelConfig xs
cfgs
          (OptNP empty (BlockForging m) xs -> NP (Maybe :.: BlockForging m) xs
forall k (empty :: Bool) (f :: k -> *) (xs :: [k]).
OptNP empty f xs -> NP (Maybe :.: f) xs
OptNP.toNP OptNP empty (BlockForging m) xs
blockForging)
      (NS
   (Product
      (Product WrapIsLeader (Ticked :.: LedgerState))
      ([] :.: WrapValidatedGenTx))
   xs
 -> NS m xs)
-> NS
     (Product
        (Product WrapIsLeader (Ticked :.: LedgerState))
        ([] :.: WrapValidatedGenTx))
     xs
-> NS m xs
forall a b. (a -> b) -> a -> b
$ [NS WrapValidatedGenTx xs]
-> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs
-> NS
     (Product
        (Product WrapIsLeader (Ticked :.: LedgerState))
        ([] :.: WrapValidatedGenTx))
     xs
forall (f :: * -> *).
[NS WrapValidatedGenTx xs]
-> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs
injectValidatedTxs ((Validated (GenTx (HardForkBlock xs)) -> NS WrapValidatedGenTx xs)
-> [Validated (GenTx (HardForkBlock xs))]
-> [NS WrapValidatedGenTx xs]
forall a b. (a -> b) -> [a] -> [b]
map (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs)
-> (Validated (GenTx (HardForkBlock xs))
    -> OneEraValidatedGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
forall (xs :: [*]).
Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
getHardForkValidatedGenTx) [Validated (GenTx (HardForkBlock xs))]
txs)
      -- We know both NSs must be from the same era, because they were all
      -- produced from the same 'BlockForging'. Unfortunately, we can't enforce
      -- it statically.
      (NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs
 -> NS
      (Product
         (Product WrapIsLeader (Ticked :.: LedgerState))
         ([] :.: WrapValidatedGenTx))
      xs)
-> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs
-> NS
     (Product
        (Product WrapIsLeader (Ticked :.: LedgerState))
        ([] :.: WrapValidatedGenTx))
     xs
forall a b. (a -> b) -> a -> b
$ String
-> NS WrapIsLeader xs
-> NS (Ticked :.: LedgerState) xs
-> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
HasCallStack =>
String -> NS f xs -> NS g xs -> NS (Product f g) xs
Match.mustMatchNS
          String
"IsLeader"
          (HardForkIsLeader xs -> NS WrapIsLeader xs
forall (xs :: [*]). OneEraIsLeader xs -> NS WrapIsLeader xs
getOneEraIsLeader HardForkIsLeader xs
isLeader)
          (HardForkState (Ticked :.: LedgerState) xs
-> NS (Ticked :.: LedgerState) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip HardForkState (Ticked :.: LedgerState) xs
ledgerState)
  where
    cfgs :: NP TopLevelConfig xs
cfgs = EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg
    ei :: EpochInfo (Except PastHorizonException)
ei   = Shape xs
-> TransitionInfo
-> HardForkState (Ticked :.: LedgerState) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (f :: * -> *).
Shape xs
-> TransitionInfo
-> HardForkState f xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoPrecomputedTransitionInfo
             (HardForkLedgerConfig xs -> Shape xs
forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape (TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
cfg))
             TransitionInfo
transition
             HardForkState (Ticked :.: LedgerState) xs
ledgerState

    missingBlockForgingImpossible :: EraIndex xs -> String
    missingBlockForgingImpossible :: EraIndex xs -> String
missingBlockForgingImpossible EraIndex xs
eraIndex =
        String
"impossible: current era lacks block forging but we have an IsLeader proof "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EraIndex xs -> String
forall a. Show a => a -> String
show EraIndex xs
eraIndex

    injectValidatedTxs ::
         [NS WrapValidatedGenTx xs]
      -> NS f xs
      -> NS (Product f ([] :.: WrapValidatedGenTx)) xs
    injectValidatedTxs :: [NS WrapValidatedGenTx xs]
-> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs
injectValidatedTxs = ([Mismatch WrapValidatedGenTx f xs],
 NS (Product f ([] :.: WrapValidatedGenTx)) xs)
-> NS (Product f ([] :.: WrapValidatedGenTx)) xs
forall (f :: * -> *).
([Mismatch WrapValidatedGenTx f xs],
 NS (Product f ([] :.: WrapValidatedGenTx)) xs)
-> NS (Product f ([] :.: WrapValidatedGenTx)) xs
noMismatches (([Mismatch WrapValidatedGenTx f xs],
  NS (Product f ([] :.: WrapValidatedGenTx)) xs)
 -> NS (Product f ([] :.: WrapValidatedGenTx)) xs)
-> ([NS WrapValidatedGenTx xs]
    -> NS f xs
    -> ([Mismatch WrapValidatedGenTx f xs],
        NS (Product f ([] :.: WrapValidatedGenTx)) xs))
-> [NS WrapValidatedGenTx xs]
-> NS f xs
-> NS (Product f ([] :.: WrapValidatedGenTx)) xs
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: (NS f xs
 -> [NS WrapValidatedGenTx xs]
 -> ([Mismatch WrapValidatedGenTx f xs],
     NS (Product f ([] :.: WrapValidatedGenTx)) xs))
-> [NS WrapValidatedGenTx xs]
-> NS f xs
-> ([Mismatch WrapValidatedGenTx f xs],
    NS (Product f ([] :.: WrapValidatedGenTx)) xs)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (InPairs InjectValidatedTx xs
-> NS f xs
-> [NS WrapValidatedGenTx xs]
-> ([Mismatch WrapValidatedGenTx f xs],
    NS (Product f ([] :.: WrapValidatedGenTx)) xs)
forall (f :: * -> *) (xs :: [*]).
SListI xs =>
InPairs InjectValidatedTx xs
-> NS f xs
-> [NS WrapValidatedGenTx xs]
-> ([Mismatch WrapValidatedGenTx f xs],
    NS (Product f ([] :.: WrapValidatedGenTx)) xs)
matchValidatedTxsNS InPairs InjectValidatedTx xs
injTxs)
      where
        injTxs :: InPairs InjectValidatedTx xs
        injTxs :: InPairs InjectValidatedTx xs
injTxs =
              (forall x y.
 Product2 InjectTx InjectValidatedTx x y -> InjectValidatedTx x y)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs InjectValidatedTx xs
forall k (xs :: [k]) (f :: k -> k -> *) (g :: k -> k -> *).
SListI xs =>
(forall (x :: k) (y :: k). f x y -> g x y)
-> InPairs f xs -> InPairs g xs
InPairs.hmap (\(Pair2 _ x) -> InjectValidatedTx x y
x)
            (InPairs (Product2 InjectTx InjectValidatedTx) xs
 -> InPairs InjectValidatedTx xs)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs InjectValidatedTx xs
forall a b. (a -> b) -> a -> b
$ NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     xs
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
forall k (h :: k -> *) (xs :: [k]) (f :: k -> k -> *).
NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs
InPairs.requiringBoth
                ((forall a. TopLevelConfig a -> WrapLedgerConfig a)
-> NP TopLevelConfig xs -> NP WrapLedgerConfig xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (LedgerConfig a -> WrapLedgerConfig a
forall blk. LedgerConfig blk -> WrapLedgerConfig blk
WrapLedgerConfig (LedgerConfig a -> WrapLedgerConfig a)
-> (TopLevelConfig a -> LedgerConfig a)
-> TopLevelConfig a
-> WrapLedgerConfig a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig a -> LedgerConfig a
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger) NP TopLevelConfig xs
cfgs)
                InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  xs
forall (xs :: [*]).
CanHardFork xs =>
InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  xs
hardForkInjectTxs

        -- | We know the transactions must be valid w.r.t. the given ledger
        -- state, the Mempool maintains that invariant. That means they are
        -- either from the same era, or can be injected into that era.
        noMismatches ::
             ([Match.Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs)
           -> NS (Product f ([] :.: WrapValidatedGenTx)) xs
        noMismatches :: ([Mismatch WrapValidatedGenTx f xs],
 NS (Product f ([] :.: WrapValidatedGenTx)) xs)
-> NS (Product f ([] :.: WrapValidatedGenTx)) xs
noMismatches ([], NS (Product f ([] :.: WrapValidatedGenTx)) xs
xs)   = NS (Product f ([] :.: WrapValidatedGenTx)) xs
xs
        noMismatches ([Mismatch WrapValidatedGenTx f xs]
_errs, NS (Product f ([] :.: WrapValidatedGenTx)) xs
_) = String -> NS (Product f ([] :.: WrapValidatedGenTx)) xs
forall a. HasCallStack => String -> a
error String
"unexpected unmatchable transactions"

    -- | Unwraps all the layers needed for SOP and call 'forgeBlock'.
    forgeBlockOne ::
         Index xs blk
      -> TopLevelConfig blk
      -> (Maybe :.: BlockForging m) blk
      -> Product
           (Product
              WrapIsLeader
              (Ticked :.: LedgerState))
           ([] :.: WrapValidatedGenTx)
           blk
      -> m blk
    forgeBlockOne :: Index xs blk
-> TopLevelConfig blk
-> (:.:) Maybe (BlockForging m) blk
-> Product
     (Product WrapIsLeader (Ticked :.: LedgerState))
     ([] :.: WrapValidatedGenTx)
     blk
-> m blk
forgeBlockOne Index xs blk
index
                  TopLevelConfig blk
cfg'
                  (Comp Maybe (BlockForging m blk)
mBlockForging')
                  (Pair
                    (Pair (WrapIsLeader IsLeader (BlockProtocol blk)
isLeader') (Comp Ticked (LedgerState blk)
ledgerState'))
                    (Comp [WrapValidatedGenTx blk]
txs')) =
        BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock
          (BlockForging m blk
-> Maybe (BlockForging m blk) -> BlockForging m blk
forall a. a -> Maybe a -> a
fromMaybe
              (String -> BlockForging m blk
forall a. HasCallStack => String -> a
error (EraIndex xs -> String
missingBlockForgingImpossible (Index xs blk -> EraIndex xs
forall (xs :: [*]) blk. Index xs blk -> EraIndex xs
eraIndexFromIndex Index xs blk
index)))
              Maybe (BlockForging m blk)
mBlockForging')
          TopLevelConfig blk
cfg'
          BlockNo
bno
          SlotNo
sno
          Ticked (LedgerState blk)
ledgerState'
          ((WrapValidatedGenTx blk -> Validated (GenTx blk))
-> [WrapValidatedGenTx blk] -> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map WrapValidatedGenTx blk -> Validated (GenTx blk)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx [WrapValidatedGenTx blk]
txs')
          IsLeader (BlockProtocol blk)
isLeader'