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

import           Data.Functor.Product
import           Data.SOP.BasicFunctors
import           Data.SOP.Strict

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers
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.Ledger (Ticked (..))
import           Ouroboros.Consensus.HardFork.Combinator.Mempool
import           Ouroboros.Consensus.HardFork.Combinator.Protocol
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
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'.
type HardForkForgeStateInfo xs = OneEraForgeStateInfo 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)
  => NS (BlockForging m) xs
  -> BlockForging m (HardForkBlock xs)
hardForkBlockForging :: NS (BlockForging m) xs -> BlockForging m (HardForkBlock xs)
hardForkBlockForging NS (BlockForging m) xs
blockForging =
    BlockForging :: forall (m :: * -> *) blk.
Text
-> CanBeLeader (BlockProtocol blk)
-> (SlotNo -> m (ForgeStateUpdateInfo blk))
-> (forall p.
    (BlockProtocol blk ~ p) =>
    TopLevelConfig blk
    -> SlotNo
    -> Ticked (ChainDepState p)
    -> IsLeader p
    -> ForgeStateInfo blk
    -> Either (CannotForge blk) ())
-> (TopLevelConfig blk
    -> BlockNo
    -> SlotNo
    -> TickedLedgerState blk
    -> [GenTx blk]
    -> IsLeader (BlockProtocol blk)
    -> m blk)
-> BlockForging m blk
BlockForging {
        forgeLabel :: Text
forgeLabel       = NS (K Text) xs -> CollapseTo NS Text
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K Text) xs -> CollapseTo NS Text)
-> NS (K Text) xs -> CollapseTo NS Text
forall a b. (a -> b) -> a -> b
$ (forall a. BlockForging m a -> K Text a)
-> NS (BlockForging m) xs -> NS (K Text) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (Text -> K Text a
forall k a (b :: k). a -> K a b
K (Text -> K Text a)
-> (BlockForging m a -> Text) -> BlockForging m a -> K Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockForging m a -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel) NS (BlockForging m) xs
blockForging
      , canBeLeader :: CanBeLeader (BlockProtocol (HardForkBlock xs))
canBeLeader      = NS (BlockForging m) xs -> HardForkCanBeLeader xs
forall (xs :: [*]) (m :: * -> *).
CanHardFork xs =>
NS (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader               NS (BlockForging m) xs
blockForging
      , updateForgeState :: SlotNo -> m (ForgeStateUpdateInfo (HardForkBlock xs))
updateForgeState = NS (BlockForging m) xs
-> SlotNo -> m (ForgeStateUpdateInfo (HardForkBlock xs))
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
NS (BlockForging m) xs
-> SlotNo -> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState          NS (BlockForging m) xs
blockForging
      , checkCanForge :: forall p.
(BlockProtocol (HardForkBlock xs) ~ p) =>
TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (ChainDepState p)
-> IsLeader p
-> ForgeStateInfo (HardForkBlock xs)
-> Either (CannotForge (HardForkBlock xs)) ()
checkCanForge    = NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
forall (m :: * -> *) (xs :: [*]).
CanHardFork xs =>
NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge             NS (BlockForging m) xs
blockForging
      , forgeBlock :: TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [GenTx (HardForkBlock xs)]
-> IsLeader (BlockProtocol (HardForkBlock xs))
-> m (HardForkBlock xs)
forgeBlock       = NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [GenTx (HardForkBlock xs)]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [GenTx (HardForkBlock xs)]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
hardForkForgeBlock                NS (BlockForging m) xs
blockForging
      }

hardForkCanBeLeader ::
     CanHardFork xs
  => NS (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader :: NS (BlockForging m) xs -> HardForkCanBeLeader xs
hardForkCanBeLeader =
    NS WrapCanBeLeader xs -> HardForkCanBeLeader xs
forall (xs :: [*]). NS WrapCanBeLeader xs -> OneEraCanBeLeader xs
OneEraCanBeLeader (NS WrapCanBeLeader xs -> HardForkCanBeLeader xs)
-> (NS (BlockForging m) xs -> NS WrapCanBeLeader xs)
-> NS (BlockForging m) xs
-> HardForkCanBeLeader xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. BlockForging m a -> WrapCanBeLeader a)
-> NS (BlockForging m) xs -> NS 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 given 'NS' of 'BlockForging's.
hardForkUpdateForgeState ::
     forall m xs. (CanHardFork xs, Monad m)
  => NS (BlockForging m) xs
  -> SlotNo
  -> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState :: NS (BlockForging m) xs
-> SlotNo -> m (ForgeStateUpdateInfo (HardForkBlock xs))
hardForkUpdateForgeState NS (BlockForging m) xs
blockForging SlotNo
curSlot =
    NS ForgeStateUpdateInfo xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
undistrib (NS ForgeStateUpdateInfo xs
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> m (NS ForgeStateUpdateInfo xs)
-> m (ForgeStateUpdateInfo (HardForkBlock xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. BlockForging m a -> m (ForgeStateUpdateInfo a))
-> NS (BlockForging m) xs -> m (NS ForgeStateUpdateInfo xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (g :: * -> *)
       (f :: k -> *) (f' :: k -> *).
(HSequence h, SListIN h xs, Applicative g) =>
(forall (a :: k). f a -> g (f' a)) -> h f xs -> g (h f' xs)
htraverse' ((BlockForging m a -> SlotNo -> m (ForgeStateUpdateInfo a))
-> SlotNo -> BlockForging m a -> m (ForgeStateUpdateInfo a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockForging m a -> SlotNo -> m (ForgeStateUpdateInfo a)
forall (m :: * -> *) blk.
BlockForging m blk -> SlotNo -> m (ForgeStateUpdateInfo blk)
updateForgeState SlotNo
curSlot) NS (BlockForging m) xs
blockForging
  where
    undistrib ::
         NS ForgeStateUpdateInfo xs
      -> ForgeStateUpdateInfo (HardForkBlock xs)
    undistrib :: NS ForgeStateUpdateInfo xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
undistrib = NS (K (ForgeStateUpdateInfo (HardForkBlock xs))) 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 xs))) xs
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> (NS ForgeStateUpdateInfo xs
    -> NS (K (ForgeStateUpdateInfo (HardForkBlock xs))) xs)
-> NS ForgeStateUpdateInfo xs
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 Injection WrapForgeStateInfo xs a
 -> Injection WrapForgeStateUpdateError xs a
 -> ForgeStateUpdateInfo a
 -> K (ForgeStateUpdateInfo (HardForkBlock xs)) a)
-> Prod NS (Injection WrapForgeStateInfo xs) xs
-> Prod NS (Injection WrapForgeStateUpdateError xs) xs
-> NS ForgeStateUpdateInfo xs
-> NS (K (ForgeStateUpdateInfo (HardForkBlock xs))) 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.
Injection WrapForgeStateInfo xs a
-> Injection WrapForgeStateUpdateError xs a
-> ForgeStateUpdateInfo a
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) a
inj Prod NS (Injection WrapForgeStateInfo xs) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections Prod NS (Injection WrapForgeStateUpdateError xs) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections
      where
        inj :: forall blk.
               Injection WrapForgeStateInfo xs blk
            -> Injection WrapForgeStateUpdateError xs blk
            -> ForgeStateUpdateInfo blk
            -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
        inj :: Injection WrapForgeStateInfo xs blk
-> Injection WrapForgeStateUpdateError xs blk
-> ForgeStateUpdateInfo blk
-> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk
inj Injection WrapForgeStateInfo xs blk
injInfo Injection WrapForgeStateUpdateError xs blk
injUpdateError ForgeStateUpdateInfo blk
forgeStateUpdateInfo =
            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
$ UpdateInfo
  (ForgeStateInfo (HardForkBlock xs))
  (ForgeStateInfo (HardForkBlock xs))
  (ForgeStateUpdateError (HardForkBlock xs))
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall blk.
UpdateInfo
  (ForgeStateInfo blk)
  (ForgeStateInfo blk)
  (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
ForgeStateUpdateInfo (UpdateInfo
   (ForgeStateInfo (HardForkBlock xs))
   (ForgeStateInfo (HardForkBlock xs))
   (ForgeStateUpdateError (HardForkBlock xs))
 -> ForgeStateUpdateInfo (HardForkBlock xs))
-> UpdateInfo
     (ForgeStateInfo (HardForkBlock xs))
     (ForgeStateInfo (HardForkBlock xs))
     (ForgeStateUpdateError (HardForkBlock xs))
-> ForgeStateUpdateInfo (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
              case ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
forall blk.
ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
getForgeStateUpdateInfo ForgeStateUpdateInfo blk
forgeStateUpdateInfo of
                Updated      ForgeStateInfo blk
info -> OneEraForgeStateInfo xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall updated unchanged failed.
updated -> UpdateInfo updated unchanged failed
Updated      (OneEraForgeStateInfo xs
 -> UpdateInfo
      (OneEraForgeStateInfo xs)
      (OneEraForgeStateInfo xs)
      (HardForkForgeStateUpdateError xs))
-> OneEraForgeStateInfo xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall a b. (a -> b) -> a -> b
$ ForgeStateInfo blk -> OneEraForgeStateInfo xs
injInfo'        ForgeStateInfo blk
info
                Unchanged    ForgeStateInfo blk
info -> OneEraForgeStateInfo xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall updated unchanged failed.
unchanged -> UpdateInfo updated unchanged failed
Unchanged    (OneEraForgeStateInfo xs
 -> UpdateInfo
      (OneEraForgeStateInfo xs)
      (OneEraForgeStateInfo xs)
      (HardForkForgeStateUpdateError xs))
-> OneEraForgeStateInfo xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall a b. (a -> b) -> a -> b
$ ForgeStateInfo blk -> OneEraForgeStateInfo xs
injInfo'        ForgeStateInfo blk
info
                UpdateFailed ForgeStateUpdateError blk
err  -> HardForkForgeStateUpdateError xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall updated unchanged failed.
failed -> UpdateInfo updated unchanged failed
UpdateFailed (HardForkForgeStateUpdateError xs
 -> UpdateInfo
      (OneEraForgeStateInfo xs)
      (OneEraForgeStateInfo xs)
      (HardForkForgeStateUpdateError xs))
-> HardForkForgeStateUpdateError xs
-> UpdateInfo
     (OneEraForgeStateInfo xs)
     (OneEraForgeStateInfo xs)
     (HardForkForgeStateUpdateError xs)
forall a b. (a -> b) -> a -> b
$ ForgeStateUpdateError blk -> HardForkForgeStateUpdateError xs
injUpdateError' ForgeStateUpdateError blk
err
          where
            injInfo' ::
                 ForgeStateInfo blk
              -> OneEraForgeStateInfo xs
            injInfo' :: ForgeStateInfo blk -> OneEraForgeStateInfo xs
injInfo' =
                  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
. K (NS WrapForgeStateInfo xs) blk -> NS WrapForgeStateInfo xs
forall k a (b :: k). K a b -> a
unK
                (K (NS WrapForgeStateInfo xs) blk -> NS WrapForgeStateInfo xs)
-> (ForgeStateInfo blk -> K (NS WrapForgeStateInfo xs) blk)
-> ForgeStateInfo blk
-> NS WrapForgeStateInfo xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Injection WrapForgeStateInfo xs blk
-> WrapForgeStateInfo blk -> K (NS WrapForgeStateInfo xs) blk
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn Injection WrapForgeStateInfo xs blk
injInfo
                (WrapForgeStateInfo blk -> K (NS WrapForgeStateInfo xs) blk)
-> (ForgeStateInfo blk -> WrapForgeStateInfo blk)
-> ForgeStateInfo blk
-> K (NS WrapForgeStateInfo xs) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeStateInfo blk -> WrapForgeStateInfo blk
forall blk. ForgeStateInfo blk -> WrapForgeStateInfo blk
WrapForgeStateInfo

            injUpdateError' ::
                 ForgeStateUpdateError blk
              -> OneEraForgeStateUpdateError xs
            injUpdateError' :: ForgeStateUpdateError blk -> HardForkForgeStateUpdateError xs
injUpdateError' =
                  NS WrapForgeStateUpdateError xs -> HardForkForgeStateUpdateError xs
forall (xs :: [*]).
NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs
OneEraForgeStateUpdateError
                (NS WrapForgeStateUpdateError xs
 -> HardForkForgeStateUpdateError xs)
-> (ForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs)
-> ForgeStateUpdateError blk
-> HardForkForgeStateUpdateError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapForgeStateUpdateError xs) blk
-> NS WrapForgeStateUpdateError xs
forall k a (b :: k). K a b -> a
unK
                (K (NS WrapForgeStateUpdateError xs) blk
 -> NS WrapForgeStateUpdateError xs)
-> (ForgeStateUpdateError blk
    -> K (NS WrapForgeStateUpdateError xs) blk)
-> ForgeStateUpdateError blk
-> NS WrapForgeStateUpdateError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Injection WrapForgeStateUpdateError xs blk
-> WrapForgeStateUpdateError blk
-> K (NS WrapForgeStateUpdateError xs) blk
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn Injection WrapForgeStateUpdateError xs blk
injUpdateError
                (WrapForgeStateUpdateError blk
 -> K (NS WrapForgeStateUpdateError xs) blk)
-> (ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk)
-> ForgeStateUpdateError blk
-> K (NS WrapForgeStateUpdateError xs) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk
forall blk.
ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk
WrapForgeStateUpdateError

-- | PRECONDITION: the 'NS' of 'BlockForging's, the ticked 'ChainDepState', the
-- 'HardForkIsLeader', and the 'HardForkStateInfo' are all from the same era.
--
-- This follows from the postconditions of 'check' and
-- 'hardForkUpdateForgeState'.
hardForkCheckCanForge ::
     forall m xs. CanHardFork xs
  => NS (BlockForging m) xs
  -> TopLevelConfig (HardForkBlock xs)
  -> SlotNo
  -> Ticked (HardForkChainDepState xs)
  -> HardForkIsLeader xs
  -> HardForkForgeStateInfo xs
  -> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge :: NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkIsLeader xs
-> HardForkForgeStateInfo xs
-> Either (HardForkCannotForge xs) ()
hardForkCheckCanForge NS (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.
 TopLevelConfig a
 -> Product
      WrapForgeStateInfo
      (Product
         WrapIsLeader
         (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
      a
 -> (:.:) Maybe WrapCannotForge a)
-> Prod NS TopLevelConfig xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product
           WrapIsLeader
           (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
     xs
-> NS (Maybe :.: WrapCannotForge) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hzipWith
          forall a.
TopLevelConfig a
-> Product
     WrapForgeStateInfo
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     a
-> (:.:) Maybe WrapCannotForge a
checkOne
          (EpochInfo Identity
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo Identity
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo Identity
ei TopLevelConfig (HardForkBlock xs)
cfg)
        -- 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.
      (NS
   (Product
      WrapForgeStateInfo
      (Product
         WrapIsLeader
         (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
   xs
 -> NS (Maybe :.: WrapCannotForge) xs)
-> NS
     (Product
        WrapForgeStateInfo
        (Product
           WrapIsLeader
           (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
     xs
-> NS (Maybe :.: WrapCannotForge) xs
forall a b. (a -> b) -> a -> b
$ String
-> NS WrapForgeStateInfo xs
-> NS
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product
           WrapIsLeader
           (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
     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"       (HardForkForgeStateInfo xs -> NS WrapForgeStateInfo xs
forall (xs :: [*]).
OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
getOneEraForgeStateInfo HardForkForgeStateInfo xs
forgeStateInfo)
      (NS
   (Product
      WrapIsLeader
      (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
   xs
 -> NS
      (Product
         WrapForgeStateInfo
         (Product
            WrapIsLeader
            (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
      xs)
-> NS
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     xs
-> NS
     (Product
        WrapForgeStateInfo
        (Product
           WrapIsLeader
           (Product (Ticked :.: WrapChainDepState) (BlockForging m))))
     xs
forall a b. (a -> b) -> a -> b
$ String
-> NS WrapIsLeader xs
-> NS (Product (Ticked :.: WrapChainDepState) (BlockForging m)) xs
-> NS
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     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 (Product (Ticked :.: WrapChainDepState) (BlockForging m)) xs
 -> NS
      (Product
         WrapIsLeader
         (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
      xs)
-> NS (Product (Ticked :.: WrapChainDepState) (BlockForging m)) xs
-> NS
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     xs
forall a b. (a -> b) -> a -> b
$ String
-> NS (Ticked :.: WrapChainDepState) xs
-> NS (BlockForging m) xs
-> NS (Product (Ticked :.: WrapChainDepState) (BlockForging m)) 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
"Ticked ChainDepState" (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)
      (NS (BlockForging m) xs
 -> NS (Product (Ticked :.: WrapChainDepState) (BlockForging m)) xs)
-> NS (BlockForging m) xs
-> NS (Product (Ticked :.: WrapChainDepState) (BlockForging m)) xs
forall a b. (a -> b) -> a -> b
$ NS (BlockForging m) xs
blockForging
  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'

    checkOne ::
         TopLevelConfig blk
      -> Product
           WrapForgeStateInfo
           (Product
             WrapIsLeader
             (Product
               (Ticked :.: WrapChainDepState)
               (BlockForging m)))
           blk
      -> (Maybe :.: WrapCannotForge) blk
         -- ^ We use @Maybe x@ instead of @Either x ()@ because the former can
         -- be partially applied.
    checkOne :: TopLevelConfig blk
-> Product
     WrapForgeStateInfo
     (Product
        WrapIsLeader
        (Product (Ticked :.: WrapChainDepState) (BlockForging m)))
     blk
-> (:.:) Maybe WrapCannotForge blk
checkOne TopLevelConfig blk
cfg'
             (Pair
               (WrapForgeStateInfo ForgeStateInfo blk
forgeStateInfo')
               (Pair
                 (WrapIsLeader IsLeader (BlockProtocol blk)
isLeader')
                 (Pair
                   (Comp Ticked (WrapChainDepState blk)
tickedChainDepState)
                   BlockForging m blk
blockForging'))) =
        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
-> forall p.
   (BlockProtocol blk ~ p) =>
   TopLevelConfig blk
   -> SlotNo
   -> Ticked (ChainDepState p)
   -> IsLeader p
   -> ForgeStateInfo blk
   -> Either (CannotForge blk) ()
checkCanForge
            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)
tickedChainDepState)
            IsLeader (BlockProtocol blk)
isLeader'
            ForgeStateInfo blk
forgeStateInfo'

-- | PRECONDITION: the 'NS' of 'BlockForging's, the ticked 'LedgerState' and
-- 'HardForkIsLeader' are from the same 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. (CanHardFork xs, Monad m)
  => NS (BlockForging m) xs
  -> TopLevelConfig (HardForkBlock xs)
  -> BlockNo
  -> SlotNo
  -> TickedLedgerState (HardForkBlock xs)
  -> [GenTx (HardForkBlock xs)]
  -> HardForkIsLeader xs
  -> m (HardForkBlock xs)
hardForkForgeBlock :: NS (BlockForging m) xs
-> TopLevelConfig (HardForkBlock xs)
-> BlockNo
-> SlotNo
-> TickedLedgerState (HardForkBlock xs)
-> [GenTx (HardForkBlock xs)]
-> HardForkIsLeader xs
-> m (HardForkBlock xs)
hardForkForgeBlock NS (BlockForging m) xs
blockForging
                   TopLevelConfig (HardForkBlock xs)
cfg
                   BlockNo
bno
                   SlotNo
sno
                   (TickedHardForkLedgerState transition ledgerState)
                   [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.
 TopLevelConfig a
 -> (:.:) [] GenTx a
 -> Product
      WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)) a
 -> m a)
-> Prod NS TopLevelConfig xs
-> Prod NS ([] :.: GenTx) xs
-> NS
     (Product
        WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)))
     xs
-> NS m 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.
TopLevelConfig a
-> (:.:) [] GenTx a
-> Product
     WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)) a
-> m a
forgeBlockOne
          (EpochInfo Identity
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo Identity
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo Identity
ei TopLevelConfig (HardForkBlock xs)
cfg)
          -- Although we get a list with transactions that each could be from a
          -- different era, we know they have been validated against the
          -- 'LedgerState', which means they __must__ be from the same era.
          ([NS GenTx xs] -> NP ([] :.: GenTx) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
[NS f xs] -> NP ([] :.: f) xs
partition_NS ((GenTx (HardForkBlock xs) -> NS GenTx xs)
-> [GenTx (HardForkBlock xs)] -> [NS GenTx xs]
forall a b. (a -> b) -> [a] -> [b]
map (OneEraGenTx xs -> NS GenTx xs
forall (xs :: [*]). OneEraGenTx xs -> NS GenTx xs
getOneEraGenTx (OneEraGenTx xs -> NS GenTx xs)
-> (GenTx (HardForkBlock xs) -> OneEraGenTx xs)
-> GenTx (HardForkBlock xs)
-> NS GenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (HardForkBlock xs) -> OneEraGenTx xs
forall (xs :: [*]). GenTx (HardForkBlock xs) -> OneEraGenTx xs
getHardForkGenTx) [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 (Product (Ticked :.: LedgerState) (BlockForging m)))
   xs
 -> NS m xs)
-> NS
     (Product
        WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)))
     xs
-> NS m xs
forall a b. (a -> b) -> a -> b
$ String
-> NS WrapIsLeader xs
-> NS (Product (Ticked :.: LedgerState) (BlockForging m)) xs
-> NS
     (Product
        WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)))
     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 (Product (Ticked :.: LedgerState) (BlockForging m)) xs
 -> NS
      (Product
         WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)))
      xs)
-> NS (Product (Ticked :.: LedgerState) (BlockForging m)) xs
-> NS
     (Product
        WrapIsLeader (Product (Ticked :.: LedgerState) (BlockForging m)))
     xs
forall a b. (a -> b) -> a -> b
$ String
-> NS (Ticked :.: LedgerState) xs
-> NS (BlockForging m) xs
-> NS (Product (Ticked :.: LedgerState) (BlockForging m)) 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
"Ticked LedgerState" (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)
      (NS (BlockForging m) xs
 -> NS (Product (Ticked :.: LedgerState) (BlockForging m)) xs)
-> NS (BlockForging m) xs
-> NS (Product (Ticked :.: LedgerState) (BlockForging m)) xs
forall a b. (a -> b) -> a -> b
$ NS (BlockForging m) xs
blockForging
  where
    ei :: EpochInfo Identity
ei = Shape xs
-> TransitionInfo
-> HardForkState (Ticked :.: LedgerState) xs
-> EpochInfo Identity
forall (xs :: [*]) (f :: * -> *).
Shape xs
-> TransitionInfo -> HardForkState f xs -> EpochInfo Identity
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

    -- | Unwraps all the layers needed for SOP and call 'forgeBlock'.
    forgeBlockOne ::
         TopLevelConfig blk
      -> ([] :.: GenTx) blk
      -> Product
           WrapIsLeader
             (Product
               (Ticked :.: LedgerState)
               (BlockForging m))
           blk
      -> m blk
    forgeBlockOne :: TopLevelConfig blk
-> (:.:) [] GenTx blk
-> Product
     WrapIsLeader
     (Product (Ticked :.: LedgerState) (BlockForging m))
     blk
-> m blk
forgeBlockOne TopLevelConfig blk
cfg'
                  (Comp [GenTx blk]
txs')
                  (Pair
                    (WrapIsLeader IsLeader (BlockProtocol blk)
isLeader')
                    (Pair
                      (Comp Ticked (LedgerState blk)
ledgerState')
                      BlockForging m blk
blockForging')) =
        BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock
          BlockForging m blk
blockForging'
          TopLevelConfig blk
cfg'
          BlockNo
bno
          SlotNo
sno
          Ticked (LedgerState blk)
ledgerState'
          [GenTx blk]
txs'
          IsLeader (BlockProtocol blk)
isLeader'