{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Ouroboros.Consensus.HardFork.Combinator.Embed.Binary (protocolInfoBinary) where

import Control.Exception (assert)
import qualified Control.Tracer as Tracer
import Data.Align (alignWith)
import Data.SOP.Counting (exactlyTwo)
import Data.SOP.Functors (Flip (..))
import Data.SOP.OptNP (NonEmptyOptNP, OptNP (..))
import Data.SOP.Strict (NP (..))
import Data.Text (Text)
import Data.These (These (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator
import qualified Ouroboros.Consensus.HardFork.History as History
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Protocol.Abstract (protocolSecurityParam)
import Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  ProtocolInfo
-------------------------------------------------------------------------------}

protocolInfoBinary ::
  forall m kesAgentTrace blk1 blk2.
  (CanHardFork '[blk1, blk2], Monad m) =>
  -- First era
  ProtocolInfo blk1 ->
  (Tracer.Tracer m kesAgentTrace -> m [MkBlockForging m blk1]) ->
  History.EraParams ->
  (ConsensusConfig (BlockProtocol blk1) -> PartialConsensusConfig (BlockProtocol blk1)) ->
  (LedgerConfig blk1 -> PartialLedgerConfig blk1) ->
  -- Second era
  ProtocolInfo blk2 ->
  (Tracer.Tracer m kesAgentTrace -> m [MkBlockForging m blk2]) ->
  History.EraParams ->
  (ConsensusConfig (BlockProtocol blk2) -> PartialConsensusConfig (BlockProtocol blk2)) ->
  (LedgerConfig blk2 -> PartialLedgerConfig blk2) ->
  ( ProtocolInfo (HardForkBlock '[blk1, blk2])
  , Tracer.Tracer m kesAgentTrace -> m [MkBlockForging m (HardForkBlock '[blk1, blk2])]
  )
protocolInfoBinary :: forall (m :: * -> *) kesAgentTrace blk1 blk2.
(CanHardFork '[blk1, blk2], Monad m) =>
ProtocolInfo blk1
-> (Tracer m kesAgentTrace -> m [MkBlockForging m blk1])
-> EraParams
-> (ConsensusConfig (BlockProtocol blk1)
    -> PartialConsensusConfig (BlockProtocol blk1))
-> (LedgerConfig blk1 -> PartialLedgerConfig blk1)
-> ProtocolInfo blk2
-> (Tracer m kesAgentTrace -> m [MkBlockForging m blk2])
-> EraParams
-> (ConsensusConfig (BlockProtocol blk2)
    -> PartialConsensusConfig (BlockProtocol blk2))
-> (LedgerConfig blk2 -> PartialLedgerConfig blk2)
-> (ProtocolInfo (HardForkBlock '[blk1, blk2]),
    Tracer m kesAgentTrace
    -> m [MkBlockForging m (HardForkBlock '[blk1, blk2])])
protocolInfoBinary
  ProtocolInfo blk1
protocolInfo1
  Tracer m kesAgentTrace -> m [MkBlockForging m blk1]
blockForging1
  EraParams
eraParams1
  ConsensusConfig (BlockProtocol blk1)
-> PartialConsensusConfig (BlockProtocol blk1)
toPartialConsensusConfig1
  LedgerConfig blk1 -> PartialLedgerConfig blk1
toPartialLedgerConfig1
  ProtocolInfo blk2
protocolInfo2
  Tracer m kesAgentTrace -> m [MkBlockForging m blk2]
blockForging2
  EraParams
eraParams2
  ConsensusConfig (BlockProtocol blk2)
-> PartialConsensusConfig (BlockProtocol blk2)
toPartialConsensusConfig2
  LedgerConfig blk2 -> PartialLedgerConfig blk2
toPartialLedgerConfig2 =
    ( ProtocolInfo
        { pInfoConfig :: TopLevelConfig (HardForkBlock '[blk1, blk2])
pInfoConfig =
            TopLevelConfig
              { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (HardForkBlock '[blk1, blk2]))
topLevelConfigProtocol =
                  HardForkConsensusConfig
                    { hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigK = SecurityParam
k
                    , hardForkConsensusConfigShape :: Shape '[blk1, blk2]
hardForkConsensusConfigShape = Shape '[blk1, blk2]
shape
                    , hardForkConsensusConfigPerEra :: PerEraConsensusConfig '[blk1, blk2]
hardForkConsensusConfigPerEra =
                        NP WrapPartialConsensusConfig '[blk1, blk2]
-> PerEraConsensusConfig '[blk1, blk2]
forall (xs :: [*]).
NP WrapPartialConsensusConfig xs -> PerEraConsensusConfig xs
PerEraConsensusConfig
                          ( PartialConsensusConfig (BlockProtocol blk1)
-> WrapPartialConsensusConfig blk1
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (ConsensusConfig (BlockProtocol blk1)
-> PartialConsensusConfig (BlockProtocol blk1)
toPartialConsensusConfig1 ConsensusConfig (BlockProtocol blk1)
consensusConfig1)
                              WrapPartialConsensusConfig blk1
-> NP WrapPartialConsensusConfig '[blk2]
-> NP WrapPartialConsensusConfig '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* PartialConsensusConfig (BlockProtocol blk2)
-> WrapPartialConsensusConfig blk2
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (ConsensusConfig (BlockProtocol blk2)
-> PartialConsensusConfig (BlockProtocol blk2)
toPartialConsensusConfig2 ConsensusConfig (BlockProtocol blk2)
consensusConfig2)
                              WrapPartialConsensusConfig blk2
-> NP WrapPartialConsensusConfig '[]
-> NP WrapPartialConsensusConfig '[blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapPartialConsensusConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
                          )
                    }
              , topLevelConfigLedger :: LedgerConfig (HardForkBlock '[blk1, blk2])
topLevelConfigLedger =
                  HardForkLedgerConfig
                    { hardForkLedgerConfigShape :: Shape '[blk1, blk2]
hardForkLedgerConfigShape = Shape '[blk1, blk2]
shape
                    , hardForkLedgerConfigPerEra :: PerEraLedgerConfig '[blk1, blk2]
hardForkLedgerConfigPerEra =
                        NP WrapPartialLedgerConfig '[blk1, blk2]
-> PerEraLedgerConfig '[blk1, blk2]
forall (xs :: [*]).
NP WrapPartialLedgerConfig xs -> PerEraLedgerConfig xs
PerEraLedgerConfig
                          ( PartialLedgerConfig blk1 -> WrapPartialLedgerConfig blk1
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (LedgerConfig blk1 -> PartialLedgerConfig blk1
toPartialLedgerConfig1 LedgerConfig blk1
ledgerConfig1)
                              WrapPartialLedgerConfig blk1
-> NP WrapPartialLedgerConfig '[blk2]
-> NP WrapPartialLedgerConfig '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* PartialLedgerConfig blk2 -> WrapPartialLedgerConfig blk2
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (LedgerConfig blk2 -> PartialLedgerConfig blk2
toPartialLedgerConfig2 LedgerConfig blk2
ledgerConfig2)
                              WrapPartialLedgerConfig blk2
-> NP WrapPartialLedgerConfig '[]
-> NP WrapPartialLedgerConfig '[blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapPartialLedgerConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
                          )
                    }
              , topLevelConfigBlock :: BlockConfig (HardForkBlock '[blk1, blk2])
topLevelConfigBlock =
                  PerEraBlockConfig '[blk1, blk2]
-> BlockConfig (HardForkBlock '[blk1, blk2])
forall (xs :: [*]).
PerEraBlockConfig xs -> BlockConfig (HardForkBlock xs)
HardForkBlockConfig (PerEraBlockConfig '[blk1, blk2]
 -> BlockConfig (HardForkBlock '[blk1, blk2]))
-> PerEraBlockConfig '[blk1, blk2]
-> BlockConfig (HardForkBlock '[blk1, blk2])
forall a b. (a -> b) -> a -> b
$
                    NP BlockConfig '[blk1, blk2] -> PerEraBlockConfig '[blk1, blk2]
forall (xs :: [*]). NP BlockConfig xs -> PerEraBlockConfig xs
PerEraBlockConfig (NP BlockConfig '[blk1, blk2] -> PerEraBlockConfig '[blk1, blk2])
-> NP BlockConfig '[blk1, blk2] -> PerEraBlockConfig '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$
                      (BlockConfig blk1
blockConfig1 BlockConfig blk1
-> NP BlockConfig '[blk2] -> NP BlockConfig '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* BlockConfig blk2
blockConfig2 BlockConfig blk2 -> NP BlockConfig '[] -> NP BlockConfig '[blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP BlockConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil)
              , topLevelConfigCodec :: CodecConfig (HardForkBlock '[blk1, blk2])
topLevelConfigCodec =
                  PerEraCodecConfig '[blk1, blk2]
-> CodecConfig (HardForkBlock '[blk1, blk2])
forall (xs :: [*]).
PerEraCodecConfig xs -> CodecConfig (HardForkBlock xs)
HardForkCodecConfig (PerEraCodecConfig '[blk1, blk2]
 -> CodecConfig (HardForkBlock '[blk1, blk2]))
-> PerEraCodecConfig '[blk1, blk2]
-> CodecConfig (HardForkBlock '[blk1, blk2])
forall a b. (a -> b) -> a -> b
$
                    NP CodecConfig '[blk1, blk2] -> PerEraCodecConfig '[blk1, blk2]
forall (xs :: [*]). NP CodecConfig xs -> PerEraCodecConfig xs
PerEraCodecConfig (NP CodecConfig '[blk1, blk2] -> PerEraCodecConfig '[blk1, blk2])
-> NP CodecConfig '[blk1, blk2] -> PerEraCodecConfig '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$
                      (CodecConfig blk1
codecConfig1 CodecConfig blk1
-> NP CodecConfig '[blk2] -> NP CodecConfig '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* CodecConfig blk2
codecConfig2 CodecConfig blk2 -> NP CodecConfig '[] -> NP CodecConfig '[blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP CodecConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil)
              , topLevelConfigStorage :: StorageConfig (HardForkBlock '[blk1, blk2])
topLevelConfigStorage =
                  PerEraStorageConfig '[blk1, blk2]
-> StorageConfig (HardForkBlock '[blk1, blk2])
forall (xs :: [*]).
PerEraStorageConfig xs -> StorageConfig (HardForkBlock xs)
HardForkStorageConfig (PerEraStorageConfig '[blk1, blk2]
 -> StorageConfig (HardForkBlock '[blk1, blk2]))
-> PerEraStorageConfig '[blk1, blk2]
-> StorageConfig (HardForkBlock '[blk1, blk2])
forall a b. (a -> b) -> a -> b
$
                    NP StorageConfig '[blk1, blk2] -> PerEraStorageConfig '[blk1, blk2]
forall (xs :: [*]). NP StorageConfig xs -> PerEraStorageConfig xs
PerEraStorageConfig (NP StorageConfig '[blk1, blk2]
 -> PerEraStorageConfig '[blk1, blk2])
-> NP StorageConfig '[blk1, blk2]
-> PerEraStorageConfig '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$
                      (StorageConfig blk1
storageConfig1 StorageConfig blk1
-> NP StorageConfig '[blk2] -> NP StorageConfig '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* StorageConfig blk2
storageConfig2 StorageConfig blk2
-> NP StorageConfig '[] -> NP StorageConfig '[blk2]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP StorageConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil)
              , topLevelConfigCheckpoints :: CheckpointsMap (HardForkBlock '[blk1, blk2])
topLevelConfigCheckpoints = CheckpointsMap (HardForkBlock '[blk1, blk2])
forall blk. CheckpointsMap blk
emptyCheckpointsMap
              }
        , pInfoInitLedger :: ExtLedgerState (HardForkBlock '[blk1, blk2]) ValuesMK
pInfoInitLedger =
            ExtLedgerState
              { ledgerState :: LedgerState (HardForkBlock '[blk1, blk2]) ValuesMK
ledgerState =
                  HardForkState (Flip LedgerState ValuesMK) '[blk1, blk2]
-> LedgerState (HardForkBlock '[blk1, blk2]) ValuesMK
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (HardForkState (Flip LedgerState ValuesMK) '[blk1, blk2]
 -> LedgerState (HardForkBlock '[blk1, blk2]) ValuesMK)
-> HardForkState (Flip LedgerState ValuesMK) '[blk1, blk2]
-> LedgerState (HardForkBlock '[blk1, blk2]) ValuesMK
forall a b. (a -> b) -> a -> b
$
                    Flip LedgerState ValuesMK blk1
-> HardForkState (Flip LedgerState ValuesMK) '[blk1, blk2]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState (LedgerState blk1 ValuesMK -> Flip LedgerState ValuesMK blk1
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip LedgerState blk1 ValuesMK
initLedgerState1)
              , headerState :: HeaderState (HardForkBlock '[blk1, blk2])
headerState =
                  ChainDepState (BlockProtocol (HardForkBlock '[blk1, blk2]))
-> HeaderState (HardForkBlock '[blk1, blk2])
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState (ChainDepState (BlockProtocol (HardForkBlock '[blk1, blk2]))
 -> HeaderState (HardForkBlock '[blk1, blk2]))
-> ChainDepState (BlockProtocol (HardForkBlock '[blk1, blk2]))
-> HeaderState (HardForkBlock '[blk1, blk2])
forall a b. (a -> b) -> a -> b
$
                    WrapChainDepState blk1
-> HardForkState WrapChainDepState '[blk1, blk2]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState (WrapChainDepState blk1
 -> HardForkState WrapChainDepState '[blk1, blk2])
-> WrapChainDepState blk1
-> HardForkState WrapChainDepState '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$
                      ChainDepState (BlockProtocol blk1) -> WrapChainDepState blk1
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState (ChainDepState (BlockProtocol blk1) -> WrapChainDepState blk1)
-> ChainDepState (BlockProtocol blk1) -> WrapChainDepState blk1
forall a b. (a -> b) -> a -> b
$
                        HeaderState blk1 -> ChainDepState (BlockProtocol blk1)
forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep HeaderState blk1
initHeaderState1
              }
        }
    , \Tracer m kesAgentTrace
tr -> (These (MkBlockForging m blk1) (MkBlockForging m blk2)
 -> MkBlockForging m (HardForkBlock '[blk1, blk2]))
-> [MkBlockForging m blk1]
-> [MkBlockForging m blk2]
-> [MkBlockForging m (HardForkBlock '[blk1, blk2])]
forall a b c. (These a b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These (MkBlockForging m blk1) (MkBlockForging m blk2)
-> MkBlockForging m (HardForkBlock '[blk1, blk2])
alignBlockForging ([MkBlockForging m blk1]
 -> [MkBlockForging m blk2]
 -> [MkBlockForging m (HardForkBlock '[blk1, blk2])])
-> m [MkBlockForging m blk1]
-> m ([MkBlockForging m blk2]
      -> [MkBlockForging m (HardForkBlock '[blk1, blk2])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m kesAgentTrace -> m [MkBlockForging m blk1]
blockForging1 Tracer m kesAgentTrace
tr m ([MkBlockForging m blk2]
   -> [MkBlockForging m (HardForkBlock '[blk1, blk2])])
-> m [MkBlockForging m blk2]
-> m [MkBlockForging m (HardForkBlock '[blk1, blk2])]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer m kesAgentTrace -> m [MkBlockForging m blk2]
blockForging2 Tracer m kesAgentTrace
tr
    )
   where
    ProtocolInfo
      { pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig =
        TopLevelConfig
          { topLevelConfigProtocol :: forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigProtocol = ConsensusConfig (BlockProtocol blk1)
consensusConfig1
          , topLevelConfigLedger :: forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigLedger = LedgerConfig blk1
ledgerConfig1
          , topLevelConfigBlock :: forall blk. TopLevelConfig blk -> BlockConfig blk
topLevelConfigBlock = BlockConfig blk1
blockConfig1
          , topLevelConfigCodec :: forall blk. TopLevelConfig blk -> CodecConfig blk
topLevelConfigCodec = CodecConfig blk1
codecConfig1
          , topLevelConfigStorage :: forall blk. TopLevelConfig blk -> StorageConfig blk
topLevelConfigStorage = StorageConfig blk1
storageConfig1
          }
      , pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b ValuesMK
pInfoInitLedger =
        ExtLedgerState
          { ledgerState :: forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState = LedgerState blk1 ValuesMK
initLedgerState1
          , headerState :: forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState = HeaderState blk1
initHeaderState1
          }
      } = ProtocolInfo blk1
protocolInfo1

    ProtocolInfo
      { pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig =
        TopLevelConfig
          { topLevelConfigProtocol :: forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigProtocol = ConsensusConfig (BlockProtocol blk2)
consensusConfig2
          , topLevelConfigLedger :: forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigLedger = LedgerConfig blk2
ledgerConfig2
          , topLevelConfigBlock :: forall blk. TopLevelConfig blk -> BlockConfig blk
topLevelConfigBlock = BlockConfig blk2
blockConfig2
          , topLevelConfigCodec :: forall blk. TopLevelConfig blk -> CodecConfig blk
topLevelConfigCodec = CodecConfig blk2
codecConfig2
          , topLevelConfigStorage :: forall blk. TopLevelConfig blk -> StorageConfig blk
topLevelConfigStorage = StorageConfig blk2
storageConfig2
          }
      } = ProtocolInfo blk2
protocolInfo2

    k1, k2, k :: SecurityParam
    k1 :: SecurityParam
k1 = ConsensusConfig (BlockProtocol blk1) -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam ConsensusConfig (BlockProtocol blk1)
consensusConfig1
    k2 :: SecurityParam
k2 = ConsensusConfig (BlockProtocol blk2) -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam ConsensusConfig (BlockProtocol blk2)
consensusConfig2
    k :: SecurityParam
k = Bool -> SecurityParam -> SecurityParam
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (SecurityParam
k1 SecurityParam -> SecurityParam -> Bool
forall a. Eq a => a -> a -> Bool
== SecurityParam
k2) SecurityParam
k1

    shape :: History.Shape '[blk1, blk2]
    shape :: Shape '[blk1, blk2]
shape = Exactly '[blk1, blk2] EraParams -> Shape '[blk1, blk2]
forall (xs :: [*]). Exactly xs EraParams -> Shape xs
History.Shape (Exactly '[blk1, blk2] EraParams -> Shape '[blk1, blk2])
-> Exactly '[blk1, blk2] EraParams -> Shape '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$ EraParams -> EraParams -> Exactly '[blk1, blk2] EraParams
forall a x y. a -> a -> Exactly '[x, y] a
exactlyTwo EraParams
eraParams1 EraParams
eraParams2

    alignBlockForging ::
      These (MkBlockForging m blk1) (MkBlockForging m blk2) ->
      MkBlockForging m (HardForkBlock '[blk1, blk2])
    alignBlockForging :: These (MkBlockForging m blk1) (MkBlockForging m blk2)
-> MkBlockForging m (HardForkBlock '[blk1, blk2])
alignBlockForging = \case
      This MkBlockForging m blk1
bf1 ->
        (NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text)
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
-> MkBlockForging m (HardForkBlock '[blk1, blk2])
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
(NonEmptyOptNP (BlockForging m) xs -> Text)
-> NonEmptyOptNP (MkBlockForging m) xs
-> MkBlockForging m (HardForkBlock xs)
hardForkBlockForging
          NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text
mkForgeLabel
          (MkBlockForging m blk1
-> OptNP 'True (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons MkBlockForging m blk1
bf1 (OptNP 'True (MkBlockForging m) '[blk2]
 -> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2])
-> OptNP 'True (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$ OptNP 'True (MkBlockForging m) '[]
-> OptNP 'True (MkBlockForging m) '[blk2]
forall {k} (empty :: Bool) (f :: k -> *) (xs1 :: [k]) (x :: k).
OptNP empty f xs1 -> OptNP empty f (x : xs1)
OptSkip OptNP 'True (MkBlockForging m) '[]
forall {k} (f :: k -> *). OptNP 'True f '[]
OptNil)
      That MkBlockForging m blk2
bf2 ->
        (NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text)
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
-> MkBlockForging m (HardForkBlock '[blk1, blk2])
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
(NonEmptyOptNP (BlockForging m) xs -> Text)
-> NonEmptyOptNP (MkBlockForging m) xs
-> MkBlockForging m (HardForkBlock xs)
hardForkBlockForging
          NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text
mkForgeLabel
          (OptNP 'False (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall {k} (empty :: Bool) (f :: k -> *) (xs1 :: [k]) (x :: k).
OptNP empty f xs1 -> OptNP empty f (x : xs1)
OptSkip (OptNP 'False (MkBlockForging m) '[blk2]
 -> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2])
-> OptNP 'False (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$ MkBlockForging m blk2
-> OptNP 'True (MkBlockForging m) '[]
-> OptNP 'False (MkBlockForging m) '[blk2]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons MkBlockForging m blk2
bf2 OptNP 'True (MkBlockForging m) '[]
forall {k} (f :: k -> *). OptNP 'True f '[]
OptNil)
      These MkBlockForging m blk1
bf1 MkBlockForging m blk2
bf2 ->
        (NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text)
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
-> MkBlockForging m (HardForkBlock '[blk1, blk2])
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
(NonEmptyOptNP (BlockForging m) xs -> Text)
-> NonEmptyOptNP (MkBlockForging m) xs
-> MkBlockForging m (HardForkBlock xs)
hardForkBlockForging
          NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text
mkForgeLabel
          (MkBlockForging m blk1
-> OptNP 'False (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons MkBlockForging m blk1
bf1 (OptNP 'False (MkBlockForging m) '[blk2]
 -> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2])
-> OptNP 'False (MkBlockForging m) '[blk2]
-> NonEmptyOptNP (MkBlockForging m) '[blk1, blk2]
forall a b. (a -> b) -> a -> b
$ MkBlockForging m blk2
-> OptNP 'True (MkBlockForging m) '[]
-> OptNP 'False (MkBlockForging m) '[blk2]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons MkBlockForging m blk2
bf2 OptNP 'True (MkBlockForging m) '[]
forall {k} (f :: k -> *). OptNP 'True f '[]
OptNil)

    mkForgeLabel :: NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text
    mkForgeLabel :: NonEmptyOptNP (BlockForging m) '[blk1, blk2] -> Text
mkForgeLabel = \case
      OptCons BlockForging m x
bf1 (OptCons BlockForging m x
bf2 OptNP empty1 (BlockForging m) xs1
OptNil) -> BlockForging m x -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m x
bf1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockForging m x -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m x
bf2
      OptCons BlockForging m x
bf1 (OptSkip OptNP empty1 (BlockForging m) xs1
OptNil) -> BlockForging m x -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m x
bf1
      OptSkip (OptCons BlockForging m x
bf2 OptNP empty1 (BlockForging m) xs1
OptNil) -> BlockForging m x -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m x
bf2