{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.HardFork.Combinator (tests) where

import Cardano.Ledger.BaseTypes (nonZero, unNonZero)
import qualified Data.Map.Strict as Map
import Data.MemPack
import Data.SOP.BasicFunctors
import Data.SOP.Counting
import Data.SOP.Functors (Flip (..))
import Data.SOP.InPairs (RequiringBoth (..))
import qualified Data.SOP.InPairs as InPairs
import Data.SOP.Index (Index (..), hcimap)
import Data.SOP.OptNP (OptNP (..))
import Data.SOP.Strict
import qualified Data.SOP.Tails as Tails
import qualified Data.SOP.Telescope as Telescope
import Data.Void (Void, absurd)
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.Condense ()
import Ouroboros.Consensus.HardFork.Combinator.Serialisation
import Ouroboros.Consensus.HardFork.Combinator.State.Types
import Ouroboros.Consensus.HardFork.History (EraParams (..))
import qualified Ouroboros.Consensus.HardFork.History as History
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.LeaderSchedule
  ( LeaderSchedule (..)
  , leaderScheduleFor
  )
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util.IndexedMemPack
import Ouroboros.Consensus.Util.Orphans ()
import qualified Ouroboros.Network.Mock.Chain as Mock
import Quiet (Quiet (..))
import Test.Consensus.HardFork.Combinator.A
import Test.Consensus.HardFork.Combinator.B
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.ThreadNet.General
import Test.ThreadNet.Network
import Test.ThreadNet.TxGen
import Test.ThreadNet.Util
import Test.ThreadNet.Util.NodeJoinPlan
import Test.ThreadNet.Util.NodeRestarts
import Test.ThreadNet.Util.NodeToNodeVersion
import Test.ThreadNet.Util.NodeTopology
import Test.ThreadNet.Util.Seed
import Test.Util.HardFork.Future
import Test.Util.SanityCheck (prop_sanityChecks)
import Test.Util.Slots (NumSlots (..))
import Test.Util.Time (dawnOfTime)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Consensus"
    [ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simple convergence" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestSetup -> Property
prop_simple_hfc_convergence
    ]

data AB a = AB {forall a. AB a -> a
getA, forall a. AB a -> a
getB :: a}
  deriving ((forall m. Monoid m => AB m -> m)
-> (forall m a. Monoid m => (a -> m) -> AB a -> m)
-> (forall m a. Monoid m => (a -> m) -> AB a -> m)
-> (forall a b. (a -> b -> b) -> b -> AB a -> b)
-> (forall a b. (a -> b -> b) -> b -> AB a -> b)
-> (forall b a. (b -> a -> b) -> b -> AB a -> b)
-> (forall b a. (b -> a -> b) -> b -> AB a -> b)
-> (forall a. (a -> a -> a) -> AB a -> a)
-> (forall a. (a -> a -> a) -> AB a -> a)
-> (forall a. AB a -> [a])
-> (forall a. AB a -> Bool)
-> (forall a. AB a -> Int)
-> (forall a. Eq a => a -> AB a -> Bool)
-> (forall a. Ord a => AB a -> a)
-> (forall a. Ord a => AB a -> a)
-> (forall a. Num a => AB a -> a)
-> (forall a. Num a => AB a -> a)
-> Foldable AB
forall a. Eq a => a -> AB a -> Bool
forall a. Num a => AB a -> a
forall a. Ord a => AB a -> a
forall m. Monoid m => AB m -> m
forall a. AB a -> Bool
forall a. AB a -> Int
forall a. AB a -> [a]
forall a. (a -> a -> a) -> AB a -> a
forall m a. Monoid m => (a -> m) -> AB a -> m
forall b a. (b -> a -> b) -> b -> AB a -> b
forall a b. (a -> b -> b) -> b -> AB a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => AB m -> m
fold :: forall m. Monoid m => AB m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AB a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> AB a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AB a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> AB a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> AB a -> b
foldr :: forall a b. (a -> b -> b) -> b -> AB a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AB a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> AB a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AB a -> b
foldl :: forall b a. (b -> a -> b) -> b -> AB a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AB a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> AB a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> AB a -> a
foldr1 :: forall a. (a -> a -> a) -> AB a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AB a -> a
foldl1 :: forall a. (a -> a -> a) -> AB a -> a
$ctoList :: forall a. AB a -> [a]
toList :: forall a. AB a -> [a]
$cnull :: forall a. AB a -> Bool
null :: forall a. AB a -> Bool
$clength :: forall a. AB a -> Int
length :: forall a. AB a -> Int
$celem :: forall a. Eq a => a -> AB a -> Bool
elem :: forall a. Eq a => a -> AB a -> Bool
$cmaximum :: forall a. Ord a => AB a -> a
maximum :: forall a. Ord a => AB a -> a
$cminimum :: forall a. Ord a => AB a -> a
minimum :: forall a. Ord a => AB a -> a
$csum :: forall a. Num a => AB a -> a
sum :: forall a. Num a => AB a -> a
$cproduct :: forall a. Num a => AB a -> a
product :: forall a. Num a => AB a -> a
Foldable, (forall a b. (a -> b) -> AB a -> AB b)
-> (forall a b. a -> AB b -> AB a) -> Functor AB
forall a b. a -> AB b -> AB a
forall a b. (a -> b) -> AB a -> AB b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AB a -> AB b
fmap :: forall a b. (a -> b) -> AB a -> AB b
$c<$ :: forall a b. a -> AB b -> AB a
<$ :: forall a b. a -> AB b -> AB a
Functor, (forall x. AB a -> Rep (AB a) x)
-> (forall x. Rep (AB a) x -> AB a) -> Generic (AB a)
forall x. Rep (AB a) x -> AB a
forall x. AB a -> Rep (AB a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AB a) x -> AB a
forall a x. AB a -> Rep (AB a) x
$cfrom :: forall a x. AB a -> Rep (AB a) x
from :: forall x. AB a -> Rep (AB a) x
$cto :: forall a x. Rep (AB a) x -> AB a
to :: forall x. Rep (AB a) x -> AB a
Generic, Functor AB
Foldable AB
(Functor AB, Foldable AB) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> AB a -> f (AB b))
-> (forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> AB a -> m (AB b))
-> (forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a))
-> Traversable AB
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
sequenceA :: forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
$cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
$csequence :: forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
sequence :: forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
Traversable)
  deriving Int -> AB a -> ShowS
[AB a] -> ShowS
AB a -> String
(Int -> AB a -> ShowS)
-> (AB a -> String) -> ([AB a] -> ShowS) -> Show (AB a)
forall a. Show a => Int -> AB a -> ShowS
forall a. Show a => [AB a] -> ShowS
forall a. Show a => AB a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AB a -> ShowS
showsPrec :: Int -> AB a -> ShowS
$cshow :: forall a. Show a => AB a -> String
show :: AB a -> String
$cshowList :: forall a. Show a => [AB a] -> ShowS
showList :: [AB a] -> ShowS
Show via (Quiet (AB a))

instance Applicative AB where
  pure :: forall a. a -> AB a
pure a
x = a -> a -> AB a
forall a. a -> a -> AB a
AB a
x a
x
  AB a -> b
af a -> b
bf <*> :: forall a b. AB (a -> b) -> AB a -> AB b
<*> AB a
a a
b = b -> b -> AB b
forall a. a -> a -> AB a
AB (a -> b
af a
a) (a -> b
bf a
b)

data TestSetup = TestSetup
  { TestSetup -> AB EpochSize
testSetupEpochSize :: AB EpochSize
  -- ^ INVARIANT: @> 0@
  , TestSetup -> SecurityParam
testSetupK :: SecurityParam
  , TestSetup -> Seed
testSetupSeed :: Seed
  , TestSetup -> AB SlotLength
testSetupSlotLength :: AB SlotLength
  , TestSetup -> SlotNo
testSetupTxSlot :: SlotNo
  }
  deriving Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> String
(Int -> TestSetup -> ShowS)
-> (TestSetup -> String)
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    testSetupEpochSize <- Gen EpochSize -> Gen (AB EpochSize)
forall (m :: * -> *) a. Monad m => m a -> m (AB a)
abM (Gen EpochSize -> Gen (AB EpochSize))
-> Gen EpochSize -> Gen (AB EpochSize)
forall a b. (a -> b) -> a -> b
$ Word64 -> EpochSize
EpochSize (Word64 -> EpochSize) -> Gen Word64 -> Gen EpochSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10)
    testSetupK <- SecurityParam <$> choose (2, 10) `suchThatMap` nonZero
    -- TODO why does k=1 cause the nodes to only forge in the first epoch?
    testSetupTxSlot <- SlotNo <$> choose (0, 9)

    testSetupSeed <- arbitrary
    testSetupSlotLength <- abM arbitrary
    return TestSetup{..}
   where
    abM :: Monad m => m a -> m (AB a)
    abM :: forall (m :: * -> *) a. Monad m => m a -> m (AB a)
abM = AB (m a) -> m (AB a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
sequence (AB (m a) -> m (AB a)) -> (m a -> AB (m a)) -> m a -> m (AB a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> AB (m a)
forall a. a -> AB a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | The number of epochs in the A era
testSetupEraSizeA :: TestSetup -> EraSize
testSetupEraSizeA :: TestSetup -> EraSize
testSetupEraSizeA TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
  -- This function, as a specification, intentionally independently
  -- reimplements the interpretation of the 'InitiateAtoB' transaction by the
  -- A ledger.
  Word64 -> EraSize
EraSize (Word64 -> EraSize) -> Word64 -> EraSize
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
lastEpochA
 where
  lastEpochA :: Word64
lastEpochA = Word64
lastSlotA Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` EpochSize -> Word64
unEpochSize (AB EpochSize -> EpochSize
forall a. AB a -> a
getA AB EpochSize
testSetupEpochSize)
  lastSlotA :: Word64
lastSlotA =
    SlotNo -> Word64
unSlotNo SlotNo
testSetupTxSlot
      Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ SecurityParam -> Word64
stabilityWindowA SecurityParam
testSetupK
      Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ SecurityParam -> Word64
safeFromTipA SecurityParam
testSetupK

-- | Minimum number of slots needed to include exactly one epoch of the B era
testSetupNumSlots :: TestSetup -> NumSlots
testSetupNumSlots :: TestSetup -> NumSlots
testSetupNumSlots testSetup :: TestSetup
testSetup@TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
  -- this test doesn't need more than one B epoch
  Word64 -> NumSlots
NumSlots (Word64 -> NumSlots) -> Word64 -> NumSlots
forall a b. (a -> b) -> a -> b
$ Word64
eraSizeA Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
epoSizeA Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
epoSizeB
 where
  EraSize Word64
eraSizeA = TestSetup -> EraSize
testSetupEraSizeA TestSetup
testSetup
  AB Word64
epoSizeA Word64
epoSizeB = EpochSize -> Word64
unEpochSize (EpochSize -> Word64) -> AB EpochSize -> AB Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AB EpochSize
testSetupEpochSize

prop_simple_hfc_convergence :: TestSetup -> Property
prop_simple_hfc_convergence :: TestSetup -> Property
prop_simple_hfc_convergence testSetup :: TestSetup
testSetup@TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (TestConfig -> String
forall a. Show a => a -> String
show TestConfig
testConfig) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"eraSizeA: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EraSize -> String
forall a. Show a => a -> String
show EraSize
eraSizeA) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"epochs in era A" [String
labelEraSizeA] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        PropGeneralArgs TestBlock -> TestOutput TestBlock -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general PropGeneralArgs TestBlock
args TestOutput TestBlock
testOutput
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TopLevelConfig TestBlock -> Property
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Property
prop_sanityChecks (CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig (Word64 -> CoreNodeId
CoreNodeId Word64
0))
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
prop_allExpectedBlocks
 where
  k :: SecurityParam
  k :: SecurityParam
k = SecurityParam
testSetupK

  eraParamsA, eraParamsB :: EraParams
  AB EraParams
eraParamsA EraParams
eraParamsB =
    EpochSize -> SlotLength -> SafeZone -> GenesisWindow -> EraParams
EraParams
      (EpochSize -> SlotLength -> SafeZone -> GenesisWindow -> EraParams)
-> AB EpochSize
-> AB (SlotLength -> SafeZone -> GenesisWindow -> EraParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AB EpochSize
testSetupEpochSize
      AB (SlotLength -> SafeZone -> GenesisWindow -> EraParams)
-> AB SlotLength -> AB (SafeZone -> GenesisWindow -> EraParams)
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AB SlotLength
testSetupSlotLength
      AB (SafeZone -> GenesisWindow -> EraParams)
-> AB SafeZone -> AB (GenesisWindow -> EraParams)
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SafeZone -> SafeZone -> AB SafeZone
forall a. a -> a -> AB a
AB
        (Word64 -> SafeZone
History.StandardSafeZone (SecurityParam -> Word64
safeFromTipA SecurityParam
k))
        (SecurityParam -> SafeZone
safeZoneB SecurityParam
k)
      AB (GenesisWindow -> EraParams) -> AB GenesisWindow -> AB EraParams
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenesisWindow -> AB GenesisWindow
forall a. a -> AB a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> GenesisWindow
GenesisWindow ((NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
k) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2))

  shape :: History.Shape '[BlockA, BlockB]
  shape :: Shape '[BlockA, BlockB]
shape = Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB]
forall (xs :: [*]). Exactly xs EraParams -> Shape xs
History.Shape (Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB])
-> Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$ EraParams -> EraParams -> Exactly '[BlockA, BlockB] EraParams
forall a x y. a -> a -> Exactly '[x, y] a
exactlyTwo EraParams
eraParamsA EraParams
eraParamsB

  leaderSchedule :: LeaderSchedule
  leaderSchedule :: LeaderSchedule
leaderSchedule = NumCoreNodes -> NumSlots -> LeaderSchedule
roundRobinLeaderSchedule NumCoreNodes
numCoreNodes NumSlots
numSlots
   where
    TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
numCoreNodes :: NumCoreNodes
numSlots :: NumSlots
initSeed :: Seed
nodeTopology :: NodeTopology
numSlots :: TestConfig -> NumSlots
numCoreNodes :: TestConfig -> NumCoreNodes
nodeTopology :: TestConfig -> NodeTopology
initSeed :: TestConfig -> Seed
..} = TestConfig
testConfig

  args :: PropGeneralArgs TestBlock
  args :: PropGeneralArgs TestBlock
args =
    PropGeneralArgs
      { pgaBlockProperty :: TestBlock -> Property
pgaBlockProperty = Property -> TestBlock -> Property
forall a b. a -> b -> a
const (Property -> TestBlock -> Property)
-> Property -> TestBlock -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      , pgaCountTxs :: TestBlock -> Word64
pgaCountTxs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (TestBlock -> Int) -> TestBlock -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx TestBlock] -> Int)
-> (TestBlock -> [GenTx TestBlock]) -> TestBlock -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> [GenTx TestBlock]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
      , pgaExpectedCannotForge :: SlotNo -> NodeId -> WrapCannotForge TestBlock -> Bool
pgaExpectedCannotForge = SlotNo -> NodeId -> WrapCannotForge TestBlock -> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
      , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo = Word64 -> BlockNo
BlockNo Word64
0
      , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength = Maybe NumBlocks
forall a. Maybe a
Nothing
      , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule = LeaderSchedule -> Maybe LeaderSchedule
forall a. a -> Maybe a
Just LeaderSchedule
leaderSchedule
      , pgaSecurityParam :: SecurityParam
pgaSecurityParam = SecurityParam
k
      , pgaTestConfig :: TestConfig
pgaTestConfig = TestConfig
testConfig
      , pgaTestConfigB :: TestConfigB TestBlock
pgaTestConfigB = TestConfigB TestBlock
testConfigB
      }

  testConfig :: TestConfig
  testConfig :: TestConfig
testConfig =
    TestConfig
      { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
      , numSlots :: NumSlots
numSlots = TestSetup -> NumSlots
testSetupNumSlots TestSetup
testSetup
      , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
      , initSeed :: Seed
initSeed = Seed
testSetupSeed
      }
   where
    ncn :: NumCoreNodes
    ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2

  eraSizeA :: EraSize
  eraSizeA :: EraSize
eraSizeA = TestSetup -> EraSize
testSetupEraSizeA TestSetup
testSetup

  testConfigB :: TestConfigB TestBlock
  testConfigB :: TestConfigB TestBlock
testConfigB =
    TestConfigB
      { forgeEbbEnv :: Maybe (ForgeEbbEnv TestBlock)
forgeEbbEnv = Maybe (ForgeEbbEnv TestBlock)
forall a. Maybe a
Nothing
      , future :: Future
future =
          SlotLength -> EpochSize -> EraSize -> Future -> Future
EraCons
            (EraParams -> SlotLength
eraSlotLength EraParams
eraParamsA)
            (EraParams -> EpochSize
eraEpochSize EraParams
eraParamsA)
            EraSize
eraSizeA
            (Future -> Future) -> Future -> Future
forall a b. (a -> b) -> a -> b
$ SlotLength -> EpochSize -> Future
EraFinal
              (EraParams -> SlotLength
eraSlotLength EraParams
eraParamsB)
              (EraParams -> EpochSize
eraEpochSize EraParams
eraParamsB)
      , messageDelay :: CalcMessageDelay TestBlock
messageDelay = CalcMessageDelay TestBlock
forall blk. CalcMessageDelay blk
noCalcMessageDelay
      , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
      , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
      , txGenExtra :: TxGenExtra TestBlock
txGenExtra = ()
      , version :: (NodeToNodeVersion, BlockNodeToNodeVersion TestBlock)
version = Proxy TestBlock
-> (NodeToNodeVersion, BlockNodeToNodeVersion TestBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
newestVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock)
      }
   where
    TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
numSlots :: TestConfig -> NumSlots
numCoreNodes :: TestConfig -> NumCoreNodes
nodeTopology :: TestConfig -> NodeTopology
initSeed :: TestConfig -> Seed
numCoreNodes :: NumCoreNodes
initSeed :: Seed
nodeTopology :: NodeTopology
numSlots :: NumSlots
..} = TestConfig
testConfig

  testConfigMB :: Monad m => TestConfigMB m TestBlock
  testConfigMB :: forall (m :: * -> *). Monad m => TestConfigMB m TestBlock
testConfigMB =
    TestConfigMB
      { nodeInfo :: CoreNodeId -> TestNodeInitialization m TestBlock
nodeInfo = \CoreNodeId
a ->
          ProtocolInfo TestBlock
-> m [BlockForging m TestBlock]
-> TestNodeInitialization m TestBlock
forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization
            (CoreNodeId -> ProtocolInfo TestBlock
protocolInfo CoreNodeId
a)
            ([BlockForging m TestBlock] -> m [BlockForging m TestBlock]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockForging m TestBlock]
forall (m :: * -> *). Monad m => [BlockForging m TestBlock]
blockForging)
      , mkRekeyM :: Maybe (m (RekeyM m TestBlock))
mkRekeyM = Maybe (m (RekeyM m TestBlock))
forall a. Maybe a
Nothing
      }

  labelEraSizeA :: String
  labelEraSizeA :: String
labelEraSizeA =
    if Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10 then String
">=10" else Word64 -> String
forall a. Show a => a -> String
show Word64
sz
   where
    EraSize Word64
sz = EraSize
eraSizeA

  protocolInfo :: CoreNodeId -> ProtocolInfo TestBlock
  protocolInfo :: CoreNodeId -> ProtocolInfo TestBlock
protocolInfo CoreNodeId
nid =
    ProtocolInfo
      { pInfoConfig :: TopLevelConfig TestBlock
pInfoConfig =
          CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig CoreNodeId
nid
      , pInfoInitLedger :: ExtLedgerState TestBlock ValuesMK
pInfoInitLedger =
          ExtLedgerState
            { ledgerState :: LedgerState TestBlock ValuesMK
ledgerState =
                HardForkState (Flip LedgerState ValuesMK) '[BlockA, BlockB]
-> LedgerState TestBlock ValuesMK
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (HardForkState (Flip LedgerState ValuesMK) '[BlockA, BlockB]
 -> LedgerState TestBlock ValuesMK)
-> HardForkState (Flip LedgerState ValuesMK) '[BlockA, BlockB]
-> LedgerState TestBlock ValuesMK
forall a b. (a -> b) -> a -> b
$
                  Flip LedgerState ValuesMK BlockA
-> HardForkState (Flip LedgerState ValuesMK) '[BlockA, BlockB]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState
                    (LedgerState BlockA ValuesMK -> Flip LedgerState ValuesMK BlockA
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip LedgerState BlockA ValuesMK
initLedgerState)
            , headerState :: HeaderState TestBlock
headerState =
                ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState (ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock)
-> ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock
forall a b. (a -> b) -> a -> b
$
                  WrapChainDepState BlockA
-> HardForkState WrapChainDepState '[BlockA, BlockB]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState
                    (ChainDepState (BlockProtocol BlockA) -> WrapChainDepState BlockA
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState ChainDepState (BlockProtocol BlockA)
ChainDepState ProtocolA
initChainDepState)
            }
      }

  blockForging :: Monad m => [BlockForging m TestBlock]
  blockForging :: forall (m :: * -> *). Monad m => [BlockForging m TestBlock]
blockForging =
    [ Text
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
-> BlockForging m TestBlock
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
Text
-> NonEmptyOptNP (BlockForging m) xs
-> BlockForging m (HardForkBlock xs)
hardForkBlockForging Text
"Test" (NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
 -> BlockForging m TestBlock)
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
-> BlockForging m TestBlock
forall a b. (a -> b) -> a -> b
$
        BlockForging m BlockA
-> OptNP 'False (BlockForging m) '[BlockB]
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons BlockForging m BlockA
forall (m :: * -> *). Monad m => BlockForging m BlockA
blockForgingA (OptNP 'False (BlockForging m) '[BlockB]
 -> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB])
-> OptNP 'False (BlockForging m) '[BlockB]
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
          BlockForging m BlockB
-> OptNP 'True (BlockForging m) '[]
-> OptNP 'False (BlockForging m) '[BlockB]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons BlockForging m BlockB
forall (m :: * -> *). Monad m => BlockForging m BlockB
blockForgingB (OptNP 'True (BlockForging m) '[]
 -> OptNP 'False (BlockForging m) '[BlockB])
-> OptNP 'True (BlockForging m) '[]
-> OptNP 'False (BlockForging m) '[BlockB]
forall a b. (a -> b) -> a -> b
$
            OptNP 'True (BlockForging m) '[]
forall {k} (f :: k -> *). OptNP 'True f '[]
OptNil
    ]

  initLedgerState :: LedgerState BlockA ValuesMK
  initLedgerState :: LedgerState BlockA ValuesMK
initLedgerState =
    LgrA
      { lgrA_tip :: Point BlockA
lgrA_tip = Point BlockA
forall {k} (block :: k). Point block
GenesisPoint
      , lgrA_transition :: Maybe SlotNo
lgrA_transition = Maybe SlotNo
forall a. Maybe a
Nothing
      }

  initChainDepState :: ChainDepState ProtocolA
  initChainDepState :: ChainDepState ProtocolA
initChainDepState = ()

  topLevelConfig :: CoreNodeId -> TopLevelConfig TestBlock
  topLevelConfig :: CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig CoreNodeId
nid =
    TopLevelConfig
      { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol TestBlock)
topLevelConfigProtocol =
          HardForkConsensusConfig
            { hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigK = SecurityParam
k
            , hardForkConsensusConfigShape :: Shape '[BlockA, BlockB]
hardForkConsensusConfigShape = Shape '[BlockA, BlockB]
shape
            , hardForkConsensusConfigPerEra :: PerEraConsensusConfig '[BlockA, BlockB]
hardForkConsensusConfigPerEra =
                NP WrapPartialConsensusConfig '[BlockA, BlockB]
-> PerEraConsensusConfig '[BlockA, BlockB]
forall (xs :: [*]).
NP WrapPartialConsensusConfig xs -> PerEraConsensusConfig xs
PerEraConsensusConfig (NP WrapPartialConsensusConfig '[BlockA, BlockB]
 -> PerEraConsensusConfig '[BlockA, BlockB])
-> NP WrapPartialConsensusConfig '[BlockA, BlockB]
-> PerEraConsensusConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                  (PartialConsensusConfig (BlockProtocol BlockA)
-> WrapPartialConsensusConfig BlockA
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (PartialConsensusConfig (BlockProtocol BlockA)
 -> WrapPartialConsensusConfig BlockA)
-> PartialConsensusConfig (BlockProtocol BlockA)
-> WrapPartialConsensusConfig BlockA
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> ConsensusConfig ProtocolA
consensusConfigA CoreNodeId
nid)
                    WrapPartialConsensusConfig BlockA
-> NP WrapPartialConsensusConfig '[BlockB]
-> NP WrapPartialConsensusConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* (PartialConsensusConfig (BlockProtocol BlockB)
-> WrapPartialConsensusConfig BlockB
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (PartialConsensusConfig (BlockProtocol BlockB)
 -> WrapPartialConsensusConfig BlockB)
-> PartialConsensusConfig (BlockProtocol BlockB)
-> WrapPartialConsensusConfig BlockB
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> ConsensusConfig ProtocolB
consensusConfigB CoreNodeId
nid)
                    WrapPartialConsensusConfig BlockB
-> NP WrapPartialConsensusConfig '[]
-> NP WrapPartialConsensusConfig '[BlockB]
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 TestBlock
topLevelConfigLedger =
          HardForkLedgerConfig
            { hardForkLedgerConfigShape :: Shape '[BlockA, BlockB]
hardForkLedgerConfigShape = Shape '[BlockA, BlockB]
shape
            , hardForkLedgerConfigPerEra :: PerEraLedgerConfig '[BlockA, BlockB]
hardForkLedgerConfigPerEra =
                NP WrapPartialLedgerConfig '[BlockA, BlockB]
-> PerEraLedgerConfig '[BlockA, BlockB]
forall (xs :: [*]).
NP WrapPartialLedgerConfig xs -> PerEraLedgerConfig xs
PerEraLedgerConfig (NP WrapPartialLedgerConfig '[BlockA, BlockB]
 -> PerEraLedgerConfig '[BlockA, BlockB])
-> NP WrapPartialLedgerConfig '[BlockA, BlockB]
-> PerEraLedgerConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                  (PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA)
-> PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> PartialLedgerConfig BlockA
ledgerConfigA CoreNodeId
nid)
                    WrapPartialLedgerConfig BlockA
-> NP WrapPartialLedgerConfig '[BlockB]
-> NP WrapPartialLedgerConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* (PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB)
-> PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> LedgerConfig BlockB
ledgerConfigB CoreNodeId
nid)
                    WrapPartialLedgerConfig BlockB
-> NP WrapPartialLedgerConfig '[]
-> NP WrapPartialLedgerConfig '[BlockB]
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 TestBlock
topLevelConfigBlock =
          HardForkBlockConfig
            { hardForkBlockConfigPerEra :: PerEraBlockConfig '[BlockA, BlockB]
hardForkBlockConfigPerEra =
                NP BlockConfig '[BlockA, BlockB]
-> PerEraBlockConfig '[BlockA, BlockB]
forall (xs :: [*]). NP BlockConfig xs -> PerEraBlockConfig xs
PerEraBlockConfig (NP BlockConfig '[BlockA, BlockB]
 -> PerEraBlockConfig '[BlockA, BlockB])
-> NP BlockConfig '[BlockA, BlockB]
-> PerEraBlockConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                  CoreNodeId -> BlockConfig BlockA
blockConfigA CoreNodeId
nid
                    BlockConfig BlockA
-> NP BlockConfig '[BlockB] -> NP BlockConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* CoreNodeId -> BlockConfig BlockB
blockConfigB CoreNodeId
nid
                    BlockConfig BlockB
-> NP BlockConfig '[] -> NP BlockConfig '[BlockB]
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 TestBlock
topLevelConfigCodec =
          HardForkCodecConfig
            { hardForkCodecConfigPerEra :: PerEraCodecConfig '[BlockA, BlockB]
hardForkCodecConfigPerEra =
                NP CodecConfig '[BlockA, BlockB]
-> PerEraCodecConfig '[BlockA, BlockB]
forall (xs :: [*]). NP CodecConfig xs -> PerEraCodecConfig xs
PerEraCodecConfig (NP CodecConfig '[BlockA, BlockB]
 -> PerEraCodecConfig '[BlockA, BlockB])
-> NP CodecConfig '[BlockA, BlockB]
-> PerEraCodecConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                  CodecConfig BlockA
CCfgA
                    CodecConfig BlockA
-> NP CodecConfig '[BlockB] -> NP CodecConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* CodecConfig BlockB
CCfgB
                    CodecConfig BlockB
-> NP CodecConfig '[] -> NP CodecConfig '[BlockB]
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 TestBlock
topLevelConfigStorage =
          HardForkStorageConfig
            { hardForkStorageConfigPerEra :: PerEraStorageConfig '[BlockA, BlockB]
hardForkStorageConfigPerEra =
                NP StorageConfig '[BlockA, BlockB]
-> PerEraStorageConfig '[BlockA, BlockB]
forall (xs :: [*]). NP StorageConfig xs -> PerEraStorageConfig xs
PerEraStorageConfig (NP StorageConfig '[BlockA, BlockB]
 -> PerEraStorageConfig '[BlockA, BlockB])
-> NP StorageConfig '[BlockA, BlockB]
-> PerEraStorageConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                  StorageConfig BlockA
SCfgA
                    StorageConfig BlockA
-> NP StorageConfig '[BlockB] -> NP StorageConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* StorageConfig BlockB
SCfgB
                    StorageConfig BlockB
-> NP StorageConfig '[] -> NP StorageConfig '[BlockB]
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 TestBlock
topLevelConfigCheckpoints = CheckpointsMap TestBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
      }

  consensusConfigA :: CoreNodeId -> ConsensusConfig ProtocolA
  consensusConfigA :: CoreNodeId -> ConsensusConfig ProtocolA
consensusConfigA CoreNodeId
nid =
    CfgA
      { cfgA_k :: SecurityParam
cfgA_k = SecurityParam
k
      , cfgA_leadInSlots :: Set SlotNo
cfgA_leadInSlots = CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor CoreNodeId
nid LeaderSchedule
leaderSchedule
      }

  consensusConfigB :: CoreNodeId -> ConsensusConfig ProtocolB
  consensusConfigB :: CoreNodeId -> ConsensusConfig ProtocolB
consensusConfigB CoreNodeId
nid =
    CfgB
      { cfgB_k :: SecurityParam
cfgB_k = SecurityParam
k
      , cfgB_leadInSlots :: Set SlotNo
cfgB_leadInSlots = CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor CoreNodeId
nid LeaderSchedule
leaderSchedule
      }

  ledgerConfigA :: CoreNodeId -> PartialLedgerConfig BlockA
  ledgerConfigA :: CoreNodeId -> PartialLedgerConfig BlockA
ledgerConfigA CoreNodeId
_nid =
    LCfgA
      { lcfgA_k :: SecurityParam
lcfgA_k = SecurityParam
k
      , lcfgA_systemStart :: SystemStart
lcfgA_systemStart = UTCTime -> SystemStart
SystemStart UTCTime
dawnOfTime -- required for RunNode
      , lcfgA_forgeTxs :: Map SlotNo [GenTx BlockA]
lcfgA_forgeTxs =
          [(SlotNo, [GenTx BlockA])] -> Map SlotNo [GenTx BlockA]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (SlotNo
testSetupTxSlot, [TxId (GenTx BlockA) -> TxPayloadA -> GenTx BlockA
TxA (Int -> TxId (GenTx BlockA)
TxIdA Int
0) TxPayloadA
InitiateAtoB])
            ]
      }

  ledgerConfigB :: CoreNodeId -> LedgerConfig BlockB
  ledgerConfigB :: CoreNodeId -> LedgerConfig BlockB
ledgerConfigB CoreNodeId
_nid = ()

  blockConfigA :: CoreNodeId -> BlockConfig BlockA
  blockConfigA :: CoreNodeId -> BlockConfig BlockA
blockConfigA CoreNodeId
_ = BlockConfig BlockA
BCfgA

  blockConfigB :: CoreNodeId -> BlockConfig BlockB
  blockConfigB :: CoreNodeId -> BlockConfig BlockB
blockConfigB CoreNodeId
_ = BlockConfig BlockB
BCfgB

  testOutput :: TestOutput TestBlock
  testOutput :: TestOutput TestBlock
testOutput = TestConfig
-> TestConfigB TestBlock
-> (forall (m :: * -> *). IOLike m => TestConfigMB m TestBlock)
-> TestOutput TestBlock
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork TestConfig
testConfig TestConfigB TestBlock
testConfigB TestConfigMB m TestBlock
forall (m :: * -> *). Monad m => TestConfigMB m TestBlock
forall (m :: * -> *). IOLike m => TestConfigMB m TestBlock
testConfigMB

  prop_allExpectedBlocks :: Property
  prop_allExpectedBlocks :: Property
prop_allExpectedBlocks =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"some final chain does not have "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
a
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" blocks from A and "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
b
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" blocks from B"
      )
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(NodeId, (Word64, Word64))] -> String
forall a. Show a => a -> String
show ([(NodeId, (Word64, Word64))] -> String)
-> [(NodeId, (Word64, Word64))] -> String
forall a b. (a -> b) -> a -> b
$ Map NodeId (Word64, Word64) -> [(NodeId, (Word64, Word64))]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeId (Word64, Word64)
counts)
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property
      (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ ((Word64, Word64) -> Bool) -> Map NodeId (Word64, Word64) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Word64, Word64) -> (Word64, Word64) -> Bool
forall a. Eq a => a -> a -> Bool
== (Word64
a, Word64
b)) Map NodeId (Word64, Word64)
counts
   where
    TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
numSlots :: TestConfig -> NumSlots
numCoreNodes :: TestConfig -> NumCoreNodes
nodeTopology :: TestConfig -> NodeTopology
initSeed :: TestConfig -> Seed
initSeed :: Seed
nodeTopology :: NodeTopology
numCoreNodes :: NumCoreNodes
numSlots :: NumSlots
..} = TestConfig
testConfig
    NumSlots Word64
t = NumSlots
numSlots

    -- we expect one epoch from B and the rest from A
    b :: Word64
b = EpochSize -> Word64
unEpochSize (AB EpochSize -> EpochSize
forall a. AB a -> a
getB AB EpochSize
testSetupEpochSize)
    a :: Word64
a = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
b

  -- counts of A blocks and of B blocks for each final chain
  counts :: Map.Map NodeId (Word64, Word64)
  counts :: Map NodeId (Word64, Word64)
counts =
    (\NodeOutput TestBlock
c -> ((TestBlock -> Bool) -> NodeOutput TestBlock -> Word64
forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen TestBlock -> Bool
isA NodeOutput TestBlock
c, (TestBlock -> Bool) -> NodeOutput TestBlock -> Word64
forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen TestBlock -> Bool
isB NodeOutput TestBlock
c)) (NodeOutput TestBlock -> (Word64, Word64))
-> Map NodeId (NodeOutput TestBlock) -> Map NodeId (Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NodeId (NodeOutput TestBlock)
testOutputNodes
   where
    TestOutput{Map SlotNo (Map NodeId (WithOrigin BlockNo))
Map NodeId (NodeOutput TestBlock)
testOutputNodes :: Map NodeId (NodeOutput TestBlock)
testOutputTipBlockNos :: Map SlotNo (Map NodeId (WithOrigin BlockNo))
testOutputTipBlockNos :: forall blk.
TestOutput blk -> Map SlotNo (Map NodeId (WithOrigin BlockNo))
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
..} = TestOutput TestBlock
testOutput

    isA, isB :: TestBlock -> Bool
    isA :: TestBlock -> Bool
isA (HardForkBlock (OneEraBlock NS I '[BlockA, BlockB]
blk)) = NS I '[BlockA, BlockB] -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS NS I '[BlockA, BlockB]
blk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    isB :: TestBlock -> Bool
isB (HardForkBlock (OneEraBlock NS I '[BlockA, BlockB]
blk)) = NS I '[BlockA, BlockB] -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS NS I '[BlockA, BlockB]
blk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

    chainLen :: (a -> Bool) -> NodeOutput a -> Word64
    chainLen :: forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen a -> Bool
p NodeOutput{[LedgerUpdate a]
[TracePipeliningEvent a]
Map SlotNo a
Map SlotNo [(RealPoint a, BlockNo)]
Map SlotNo [CannotForge a]
Map SlotNo (Set (RealPoint a, BlockNo))
Map (RealPoint a) [ExtValidationError a]
LedgerState a EmptyMK
Chain a
NodeDBs MockFS
nodeOutputAdds :: Map SlotNo (Set (RealPoint a, BlockNo))
nodeOutputCannotForges :: Map SlotNo [CannotForge a]
nodeOutputFinalChain :: Chain a
nodeOutputFinalLedger :: LedgerState a EmptyMK
nodeOutputForges :: Map SlotNo a
nodeOutputHeaderAdds :: Map SlotNo [(RealPoint a, BlockNo)]
nodeOutputInvalids :: Map (RealPoint a) [ExtValidationError a]
nodeOutputNodeDBs :: NodeDBs MockFS
nodeOutputSelects :: Map SlotNo [(RealPoint a, BlockNo)]
nodeOutputUpdates :: [LedgerUpdate a]
nodePipeliningEvents :: [TracePipeliningEvent a]
nodePipeliningEvents :: forall blk. NodeOutput blk -> [TracePipeliningEvent blk]
nodeOutputUpdates :: forall blk. NodeOutput blk -> [LedgerUpdate blk]
nodeOutputSelects :: forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputNodeDBs :: forall blk. NodeOutput blk -> NodeDBs MockFS
nodeOutputInvalids :: forall blk.
NodeOutput blk -> Map (RealPoint blk) [ExtValidationError blk]
nodeOutputHeaderAdds :: forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputForges :: forall blk. NodeOutput blk -> Map SlotNo blk
nodeOutputFinalLedger :: forall blk. NodeOutput blk -> LedgerState blk EmptyMK
nodeOutputFinalChain :: forall blk. NodeOutput blk -> Chain blk
nodeOutputCannotForges :: forall blk. NodeOutput blk -> Map SlotNo [CannotForge blk]
nodeOutputAdds :: forall blk.
NodeOutput blk -> Map SlotNo (Set (RealPoint blk, BlockNo))
..} =
      Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        (Int -> Word64) -> ([a] -> Int) -> [a] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
        ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p
        ([a] -> Word64) -> [a] -> Word64
forall a b. (a -> b) -> a -> b
$ Chain a -> [a]
forall block. Chain block -> [block]
Mock.chainToList Chain a
nodeOutputFinalChain

-- We ignore the mempool for these tests
instance TxGen TestBlock where
  testGenTxs :: CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig TestBlock
-> TxGenExtra TestBlock
-> LedgerState TestBlock ValuesMK
-> Gen [GenTx TestBlock]
testGenTxs CoreNodeId
_ NumCoreNodes
_ SlotNo
_ TopLevelConfig TestBlock
_ TxGenExtra TestBlock
_ LedgerState TestBlock ValuesMK
_ = [GenTx TestBlock] -> Gen [GenTx TestBlock]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []

{-------------------------------------------------------------------------------
  Canonical TxIn
-------------------------------------------------------------------------------}

instance HasCanonicalTxIn '[BlockA, BlockB] where
  newtype CanonicalTxIn '[BlockA, BlockB] = BlockABTxIn
    { CanonicalTxIn '[BlockA, BlockB] -> Void
getBlockABTxIn :: Void
    }
    deriving stock (Int -> CanonicalTxIn '[BlockA, BlockB] -> ShowS
[CanonicalTxIn '[BlockA, BlockB]] -> ShowS
CanonicalTxIn '[BlockA, BlockB] -> String
(Int -> CanonicalTxIn '[BlockA, BlockB] -> ShowS)
-> (CanonicalTxIn '[BlockA, BlockB] -> String)
-> ([CanonicalTxIn '[BlockA, BlockB]] -> ShowS)
-> Show (CanonicalTxIn '[BlockA, BlockB])
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CanonicalTxIn '[BlockA, BlockB] -> ShowS
showsPrec :: Int -> CanonicalTxIn '[BlockA, BlockB] -> ShowS
$cshow :: CanonicalTxIn '[BlockA, BlockB] -> String
show :: CanonicalTxIn '[BlockA, BlockB] -> String
$cshowList :: [CanonicalTxIn '[BlockA, BlockB]] -> ShowS
showList :: [CanonicalTxIn '[BlockA, BlockB]] -> ShowS
Show, CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
(CanonicalTxIn '[BlockA, BlockB]
 -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> Eq (CanonicalTxIn '[BlockA, BlockB])
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
== :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
$c/= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
/= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
Eq, Eq (CanonicalTxIn '[BlockA, BlockB])
Eq (CanonicalTxIn '[BlockA, BlockB]) =>
(CanonicalTxIn '[BlockA, BlockB]
 -> CanonicalTxIn '[BlockA, BlockB] -> Ordering)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB] -> Bool)
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB])
-> (CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB]
    -> CanonicalTxIn '[BlockA, BlockB])
-> Ord (CanonicalTxIn '[BlockA, BlockB])
CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Ordering
CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Ordering
compare :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Ordering
$c< :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
< :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
$c<= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
<= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
$c> :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
> :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
$c>= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
>= :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB] -> Bool
$cmax :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
max :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
$cmin :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
min :: CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
-> CanonicalTxIn '[BlockA, BlockB]
Ord)
    deriving newtype ([String] -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo)
Proxy (CanonicalTxIn '[BlockA, BlockB]) -> String
([String]
 -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo))
-> ([String]
    -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo))
-> (Proxy (CanonicalTxIn '[BlockA, BlockB]) -> String)
-> NoThunks (CanonicalTxIn '[BlockA, BlockB])
forall a.
([String] -> a -> IO (Maybe ThunkInfo))
-> ([String] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: [String] -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo)
noThunks :: [String] -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo)
$cwNoThunks :: [String] -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo)
wNoThunks :: [String] -> CanonicalTxIn '[BlockA, BlockB] -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (CanonicalTxIn '[BlockA, BlockB]) -> String
showTypeOf :: Proxy (CanonicalTxIn '[BlockA, BlockB]) -> String
NoThunks, String
String
-> (CanonicalTxIn '[BlockA, BlockB] -> Int)
-> (forall s. CanonicalTxIn '[BlockA, BlockB] -> Pack s ())
-> (forall b.
    Buffer b =>
    Unpack b (CanonicalTxIn '[BlockA, BlockB]))
-> MemPack (CanonicalTxIn '[BlockA, BlockB])
CanonicalTxIn '[BlockA, BlockB] -> Int
forall a.
String
-> (a -> Int)
-> (forall s. a -> Pack s ())
-> (forall b. Buffer b => Unpack b a)
-> MemPack a
forall b. Buffer b => Unpack b (CanonicalTxIn '[BlockA, BlockB])
forall s. CanonicalTxIn '[BlockA, BlockB] -> Pack s ()
$ctypeName :: String
typeName :: String
$cpackedByteCount :: CanonicalTxIn '[BlockA, BlockB] -> Int
packedByteCount :: CanonicalTxIn '[BlockA, BlockB] -> Int
$cpackM :: forall s. CanonicalTxIn '[BlockA, BlockB] -> Pack s ()
packM :: forall s. CanonicalTxIn '[BlockA, BlockB] -> Pack s ()
$cunpackM :: forall b. Buffer b => Unpack b (CanonicalTxIn '[BlockA, BlockB])
unpackM :: forall b. Buffer b => Unpack b (CanonicalTxIn '[BlockA, BlockB])
MemPack)

  injectCanonicalTxIn :: forall x.
Index '[BlockA, BlockB] x
-> TxIn (LedgerState x) -> CanonicalTxIn '[BlockA, BlockB]
injectCanonicalTxIn Index '[BlockA, BlockB] x
IZ TxIn (LedgerState x)
key = Void -> CanonicalTxIn '[BlockA, BlockB]
forall a. Void -> a
absurd Void
TxIn (LedgerState x)
key
  injectCanonicalTxIn (IS Index xs' x
IZ) TxIn (LedgerState x)
key = Void -> CanonicalTxIn '[BlockA, BlockB]
forall a. Void -> a
absurd Void
TxIn (LedgerState x)
key
  injectCanonicalTxIn (IS (IS Index xs' x
idx')) TxIn (LedgerState x)
_ = case Index xs' x
idx' of {}

  ejectCanonicalTxIn :: forall x.
Index '[BlockA, BlockB] x
-> CanonicalTxIn '[BlockA, BlockB] -> TxIn (LedgerState x)
ejectCanonicalTxIn Index '[BlockA, BlockB] x
_ CanonicalTxIn '[BlockA, BlockB]
key = Void -> TxIn (LedgerState x)
forall a. Void -> a
absurd (Void -> TxIn (LedgerState x)) -> Void -> TxIn (LedgerState x)
forall a b. (a -> b) -> a -> b
$ CanonicalTxIn '[BlockA, BlockB] -> Void
getBlockABTxIn CanonicalTxIn '[BlockA, BlockB]
key

instance HasHardForkTxOut '[BlockA, BlockB] where
  type HardForkTxOut '[BlockA, BlockB] = DefaultHardForkTxOut '[BlockA, BlockB]
  injectHardForkTxOut :: forall x.
Index '[BlockA, BlockB] x
-> TxOut (LedgerState x) -> HardForkTxOut '[BlockA, BlockB]
injectHardForkTxOut = Index '[BlockA, BlockB] x
-> TxOut (LedgerState x) -> HardForkTxOut '[BlockA, BlockB]
Index '[BlockA, BlockB] x
-> TxOut (LedgerState x) -> NS WrapTxOut '[BlockA, BlockB]
forall (xs :: [*]) x.
SListI xs =>
Index xs x -> TxOut (LedgerState x) -> DefaultHardForkTxOut xs
injectHardForkTxOutDefault
  ejectHardForkTxOut :: forall x.
Index '[BlockA, BlockB] x
-> HardForkTxOut '[BlockA, BlockB] -> TxOut (LedgerState x)
ejectHardForkTxOut = Index '[BlockA, BlockB] x
-> HardForkTxOut '[BlockA, BlockB] -> TxOut (LedgerState x)
Index '[BlockA, BlockB] x
-> NS WrapTxOut '[BlockA, BlockB] -> TxOut (LedgerState x)
forall (xs :: [*]) x.
(SListI xs, HasHardForkTxOut xs) =>
Index xs x -> DefaultHardForkTxOut xs -> TxOut (LedgerState x)
ejectHardForkTxOutDefault

{-------------------------------------------------------------------------------
  Hard fork
-------------------------------------------------------------------------------}

type TestBlock = HardForkBlock '[BlockA, BlockB]

instance CanHardFork '[BlockA, BlockB] where
  type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32

  hardForkEraTranslation :: EraTranslation '[BlockA, BlockB]
hardForkEraTranslation =
    EraTranslation
      { translateLedgerState :: InPairs
  (RequiringBoth WrapLedgerConfig TranslateLedgerState)
  '[BlockA, BlockB]
translateLedgerState = RequiringBoth WrapLedgerConfig TranslateLedgerState BlockA BlockB
-> InPairs
     (RequiringBoth WrapLedgerConfig TranslateLedgerState) '[BlockB]
-> InPairs
     (RequiringBoth WrapLedgerConfig TranslateLedgerState)
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth WrapLedgerConfig TranslateLedgerState BlockA BlockB
ledgerState_AtoB InPairs
  (RequiringBoth WrapLedgerConfig TranslateLedgerState) '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      , translateLedgerTables :: InPairs TranslateLedgerTables '[BlockA, BlockB]
translateLedgerTables = TranslateLedgerTables BlockA BlockB
-> InPairs TranslateLedgerTables '[BlockB]
-> InPairs TranslateLedgerTables '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons TranslateLedgerTables BlockA BlockB
ledgerTables_AtoB InPairs TranslateLedgerTables '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      , translateChainDepState :: InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[BlockA, BlockB]
translateChainDepState = RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     '[BlockB]
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
chainDepState_AtoB InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      , crossEraForecast :: InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[BlockA, BlockB]
crossEraForecast = RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     '[BlockB]
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
forecast_AtoB InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      }
  hardForkChainSel :: Tails AcrossEraSelection '[BlockA, BlockB]
hardForkChainSel = AcrossEraSelection BlockA BlockB
-> Tails AcrossEraSelection '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k).
f x y -> Tails f '[x, y]
Tails.mk2 AcrossEraSelection BlockA BlockB
forall a b. AcrossEraSelection a b
CompareBlockNo
  hardForkInjectTxs :: InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  '[BlockA, BlockB]
hardForkInjectTxs = RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k).
f x y -> InPairs f '[x, y]
InPairs.mk2 RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
injectTx_AtoB

  hardForkInjTxMeasure :: NS WrapTxMeasure '[BlockA, BlockB]
-> HardForkTxMeasure '[BlockA, BlockB]
hardForkInjTxMeasure = \case
    (Z (WrapTxMeasure TxMeasure x
x)) -> TxMeasure x
HardForkTxMeasure '[BlockA, BlockB]
x
    S (Z (WrapTxMeasure TxMeasure x
x)) -> TxMeasure x
HardForkTxMeasure '[BlockA, BlockB]
x

versionN2N :: BlockNodeToNodeVersion TestBlock
versionN2N :: BlockNodeToNodeVersion TestBlock
versionN2N =
  HardForkSpecificNodeToNodeVersion
-> NP WrapNodeToNodeVersion '[BlockA, BlockB]
-> HardForkNodeToNodeVersion '[BlockA, BlockB]
forall (xs :: [*]).
HardForkSpecificNodeToNodeVersion
-> NP WrapNodeToNodeVersion xs -> HardForkNodeToNodeVersion xs
HardForkNodeToNodeEnabled
    HardForkSpecificNodeToNodeVersion
forall a. Bounded a => a
maxBound
    ( BlockNodeToNodeVersion BlockA -> WrapNodeToNodeVersion BlockA
forall blk. BlockNodeToNodeVersion blk -> WrapNodeToNodeVersion blk
WrapNodeToNodeVersion ()
        WrapNodeToNodeVersion BlockA
-> NP WrapNodeToNodeVersion '[BlockB]
-> NP WrapNodeToNodeVersion '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* BlockNodeToNodeVersion BlockB -> WrapNodeToNodeVersion BlockB
forall blk. BlockNodeToNodeVersion blk -> WrapNodeToNodeVersion blk
WrapNodeToNodeVersion ()
        WrapNodeToNodeVersion BlockB
-> NP WrapNodeToNodeVersion '[]
-> NP WrapNodeToNodeVersion '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapNodeToNodeVersion '[]
forall {k} (f :: k -> *). NP f '[]
Nil
    )

versionN2C :: BlockNodeToClientVersion TestBlock
versionN2C :: BlockNodeToClientVersion TestBlock
versionN2C =
  HardForkSpecificNodeToClientVersion
-> NP EraNodeToClientVersion '[BlockA, BlockB]
-> HardForkNodeToClientVersion '[BlockA, BlockB]
forall (xs :: [*]).
HardForkSpecificNodeToClientVersion
-> NP EraNodeToClientVersion xs -> HardForkNodeToClientVersion xs
HardForkNodeToClientEnabled
    HardForkSpecificNodeToClientVersion
forall a. Bounded a => a
maxBound
    ( BlockNodeToClientVersion BlockA -> EraNodeToClientVersion BlockA
forall blk.
BlockNodeToClientVersion blk -> EraNodeToClientVersion blk
EraNodeToClientEnabled ()
        EraNodeToClientVersion BlockA
-> NP EraNodeToClientVersion '[BlockB]
-> NP EraNodeToClientVersion '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* BlockNodeToClientVersion BlockB -> EraNodeToClientVersion BlockB
forall blk.
BlockNodeToClientVersion blk -> EraNodeToClientVersion blk
EraNodeToClientEnabled ()
        EraNodeToClientVersion BlockB
-> NP EraNodeToClientVersion '[]
-> NP EraNodeToClientVersion '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP EraNodeToClientVersion '[]
forall {k} (f :: k -> *). NP f '[]
Nil
    )

instance SupportedNetworkProtocolVersion TestBlock where
  supportedNodeToNodeVersions :: Proxy TestBlock
-> Map NodeToNodeVersion (BlockNodeToNodeVersion TestBlock)
supportedNodeToNodeVersions Proxy TestBlock
_ = NodeToNodeVersion
-> HardForkNodeToNodeVersion '[BlockA, BlockB]
-> Map
     NodeToNodeVersion (HardForkNodeToNodeVersion '[BlockA, BlockB])
forall k a. k -> a -> Map k a
Map.singleton NodeToNodeVersion
forall a. Bounded a => a
maxBound BlockNodeToNodeVersion TestBlock
HardForkNodeToNodeVersion '[BlockA, BlockB]
versionN2N
  supportedNodeToClientVersions :: Proxy TestBlock
-> Map NodeToClientVersion (BlockNodeToClientVersion TestBlock)
supportedNodeToClientVersions Proxy TestBlock
_ = NodeToClientVersion
-> HardForkNodeToClientVersion '[BlockA, BlockB]
-> Map
     NodeToClientVersion (HardForkNodeToClientVersion '[BlockA, BlockB])
forall k a. k -> a -> Map k a
Map.singleton NodeToClientVersion
forall a. Bounded a => a
maxBound BlockNodeToClientVersion TestBlock
HardForkNodeToClientVersion '[BlockA, BlockB]
versionN2C

  latestReleasedNodeVersion :: Proxy TestBlock
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersion = Proxy TestBlock
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersionDefault

instance SerialiseHFC '[BlockA, BlockB]

-- Use defaults

instance SerializeTablesWithHint (LedgerState (HardForkBlock '[BlockA, BlockB])) where
  encodeTablesWithHint :: SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> Encoding
encodeTablesWithHint = SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> Encoding
forall (l :: LedgerStateKind).
(MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
defaultEncodeTablesWithHint
  decodeTablesWithHint :: forall s.
SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> Decoder s (LedgerTables (LedgerState TestBlock) ValuesMK)
decodeTablesWithHint = SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> Decoder s (LedgerTables (LedgerState TestBlock) ValuesMK)
forall (l :: LedgerStateKind) s.
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint

instance
  IndexedMemPack
    (LedgerState (HardForkBlock '[BlockA, BlockB]) EmptyMK)
    (DefaultHardForkTxOut '[BlockA, BlockB])
  where
  indexedTypeName :: LedgerState TestBlock EmptyMK -> String
indexedTypeName LedgerState TestBlock EmptyMK
_ = forall a. MemPack a => String
typeName @(DefaultHardForkTxOut '[BlockA, BlockB])
  indexedPackedByteCount :: LedgerState TestBlock EmptyMK
-> NS WrapTxOut '[BlockA, BlockB] -> Int
indexedPackedByteCount LedgerState TestBlock EmptyMK
_ NS WrapTxOut '[BlockA, BlockB]
txout =
    NS (K Int) '[BlockA, BlockB] -> CollapseTo NS Int
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K Int) '[BlockA, BlockB] -> CollapseTo NS Int)
-> NS (K Int) '[BlockA, BlockB] -> CollapseTo NS Int
forall a b. (a -> b) -> a -> b
$
      Proxy MemPackTxOut
-> (forall a. MemPackTxOut a => WrapTxOut a -> K Int a)
-> NS WrapTxOut '[BlockA, BlockB]
-> NS (K Int) '[BlockA, BlockB]
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap
        (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @MemPackTxOut)
        (Int -> K Int a
forall k a (b :: k). a -> K a b
K (Int -> K Int a) -> (WrapTxOut a -> Int) -> WrapTxOut a -> K Int a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (LedgerState a) -> Int
forall a. MemPack a => a -> Int
packedByteCount (TxOut (LedgerState a) -> Int)
-> (WrapTxOut a -> TxOut (LedgerState a)) -> WrapTxOut a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTxOut a -> TxOut (LedgerState a)
forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut)
        NS WrapTxOut '[BlockA, BlockB]
txout
  indexedPackM :: forall s.
LedgerState TestBlock EmptyMK
-> NS WrapTxOut '[BlockA, BlockB] -> Pack s ()
indexedPackM LedgerState TestBlock EmptyMK
_ =
    NS (K (Pack s ())) '[BlockA, BlockB] -> CollapseTo NS (Pack s ())
NS (K (Pack s ())) '[BlockA, BlockB] -> Pack s ()
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
      (NS (K (Pack s ())) '[BlockA, BlockB] -> Pack s ())
-> (NS WrapTxOut '[BlockA, BlockB]
    -> NS (K (Pack s ())) '[BlockA, BlockB])
-> NS WrapTxOut '[BlockA, BlockB]
-> Pack s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy MemPackTxOut
-> (forall a.
    MemPackTxOut a =>
    Index '[BlockA, BlockB] a -> WrapTxOut a -> K (Pack s ()) a)
-> NS WrapTxOut '[BlockA, BlockB]
-> NS (K (Pack s ())) '[BlockA, BlockB]
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap
        (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @MemPackTxOut)
        ( \Index '[BlockA, BlockB] a
_ (WrapTxOut TxOut (LedgerState a)
txout) -> Pack s () -> K (Pack s ()) a
forall k a (b :: k). a -> K a b
K (Pack s () -> K (Pack s ()) a) -> Pack s () -> K (Pack s ()) a
forall a b. (a -> b) -> a -> b
$ do
            TxOut (LedgerState a) -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
forall s. TxOut (LedgerState a) -> Pack s ()
packM TxOut (LedgerState a)
txout
        )
  indexedUnpackM :: forall b.
Buffer b =>
LedgerState TestBlock EmptyMK
-> Unpack b (NS WrapTxOut '[BlockA, BlockB])
indexedUnpackM (HardForkLedgerState (HardForkState Telescope
  (K Past) (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
idx)) = do
    NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB]
-> Unpack b (NS WrapTxOut '[BlockA, BlockB])
forall (xs :: [*]) (f :: * -> *) (g :: * -> *).
(SListIN NS xs, Applicative f) =>
NS (f :.: g) xs -> f (NS g xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
hsequence'
      (NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB]
 -> Unpack b (NS WrapTxOut '[BlockA, BlockB]))
-> NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB]
-> Unpack b (NS WrapTxOut '[BlockA, BlockB])
forall a b. (a -> b) -> a -> b
$ Proxy MemPackTxOut
-> (forall a.
    MemPackTxOut a =>
    Current (Flip LedgerState EmptyMK) a
    -> (:.:) (Unpack b) WrapTxOut a)
-> NS (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
-> NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB]
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap
        (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @MemPackTxOut)
        ((:.:) (Unpack b) WrapTxOut a
-> Current (Flip LedgerState EmptyMK) a
-> (:.:) (Unpack b) WrapTxOut a
forall a b. a -> b -> a
const ((:.:) (Unpack b) WrapTxOut a
 -> Current (Flip LedgerState EmptyMK) a
 -> (:.:) (Unpack b) WrapTxOut a)
-> (:.:) (Unpack b) WrapTxOut a
-> Current (Flip LedgerState EmptyMK) a
-> (:.:) (Unpack b) WrapTxOut a
forall a b. (a -> b) -> a -> b
$ Unpack b (WrapTxOut a) -> (:.:) (Unpack b) WrapTxOut a
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Unpack b (WrapTxOut a) -> (:.:) (Unpack b) WrapTxOut a)
-> Unpack b (WrapTxOut a) -> (:.:) (Unpack b) WrapTxOut a
forall a b. (a -> b) -> a -> b
$ TxOut (LedgerState a) -> WrapTxOut a
forall blk. TxOut (LedgerState blk) -> WrapTxOut blk
WrapTxOut (TxOut (LedgerState a) -> WrapTxOut a)
-> Unpack b (TxOut (LedgerState a)) -> Unpack b (WrapTxOut a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unpack b (TxOut (LedgerState a))
forall b. Buffer b => Unpack b (TxOut (LedgerState a))
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM)
      (NS (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
 -> NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB])
-> NS (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
-> NS (Unpack b :.: WrapTxOut) '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$ Telescope
  (K Past) (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
-> NS (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip Telescope
  (K Past) (Current (Flip LedgerState EmptyMK)) '[BlockA, BlockB]
idx

{-------------------------------------------------------------------------------
  Translation
-------------------------------------------------------------------------------}

ledgerState_AtoB ::
  RequiringBoth
    WrapLedgerConfig
    TranslateLedgerState
    BlockA
    BlockB
ledgerState_AtoB :: RequiringBoth WrapLedgerConfig TranslateLedgerState BlockA BlockB
ledgerState_AtoB =
  TranslateLedgerState BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig TranslateLedgerState BlockA BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (TranslateLedgerState BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig TranslateLedgerState BlockA BlockB)
-> TranslateLedgerState BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig TranslateLedgerState BlockA BlockB
forall a b. (a -> b) -> a -> b
$
    TranslateLedgerState
      { translateLedgerStateWith :: EpochNo -> LedgerState BlockA EmptyMK -> LedgerState BlockB DiffMK
translateLedgerStateWith = \EpochNo
_ LgrA{Maybe SlotNo
Point BlockA
lgrA_tip :: forall (mk :: MapKind). LedgerState BlockA mk -> Point BlockA
lgrA_transition :: forall (mk :: MapKind). LedgerState BlockA mk -> Maybe SlotNo
lgrA_tip :: Point BlockA
lgrA_transition :: Maybe SlotNo
..} ->
          LgrB
            { lgrB_tip :: Point BlockB
lgrB_tip = Point BlockA -> Point BlockB
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point BlockA
lgrA_tip
            }
      }

ledgerTables_AtoB :: TranslateLedgerTables BlockA BlockB
ledgerTables_AtoB :: TranslateLedgerTables BlockA BlockB
ledgerTables_AtoB =
  TranslateLedgerTables
    { translateTxInWith :: TxIn (LedgerState BlockA) -> TxIn (LedgerState BlockB)
translateTxInWith = Void -> Void
TxIn (LedgerState BlockA) -> TxIn (LedgerState BlockB)
forall a. a -> a
id
    , translateTxOutWith :: TxOut (LedgerState BlockA) -> TxOut (LedgerState BlockB)
translateTxOutWith = Void -> Void
TxOut (LedgerState BlockA) -> TxOut (LedgerState BlockB)
forall a. a -> a
id
    }

chainDepState_AtoB ::
  RequiringBoth
    WrapConsensusConfig
    (Translate WrapChainDepState)
    BlockA
    BlockB
chainDepState_AtoB :: RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
chainDepState_AtoB = Translate WrapChainDepState BlockA BlockB
-> RequiringBoth
     WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (Translate WrapChainDepState BlockA BlockB
 -> RequiringBoth
      WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB)
-> Translate WrapChainDepState BlockA BlockB
-> RequiringBoth
     WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
forall a b. (a -> b) -> a -> b
$ (EpochNo -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
-> Translate WrapChainDepState BlockA BlockB
forall (f :: * -> *) x y.
(EpochNo -> f x -> f y) -> Translate f x y
Translate ((EpochNo -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
 -> Translate WrapChainDepState BlockA BlockB)
-> (EpochNo
    -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
-> Translate WrapChainDepState BlockA BlockB
forall a b. (a -> b) -> a -> b
$ \EpochNo
_ WrapChainDepState BlockA
_ ->
  ChainDepState (BlockProtocol BlockB) -> WrapChainDepState BlockB
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState ()

forecast_AtoB ::
  RequiringBoth
    WrapLedgerConfig
    (CrossEraForecaster LedgerState WrapLedgerView)
    BlockA
    BlockB
forecast_AtoB :: RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
forecast_AtoB = CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     BlockA
     BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig
      (CrossEraForecaster LedgerState WrapLedgerView)
      BlockA
      BlockB)
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     BlockA
     BlockB
forall a b. (a -> b) -> a -> b
$ (Bound
 -> SlotNo
 -> LedgerState BlockA EmptyMK
 -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
forall (state :: * -> LedgerStateKind) (view :: * -> *) x y.
(Bound
 -> SlotNo
 -> state x EmptyMK
 -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> LedgerState BlockA EmptyMK
  -> Except OutsideForecastRange (WrapLedgerView BlockB))
 -> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB)
-> (Bound
    -> SlotNo
    -> LedgerState BlockA EmptyMK
    -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
forall a b. (a -> b) -> a -> b
$ \Bound
_ SlotNo
_ LedgerState BlockA EmptyMK
_ ->
  WrapLedgerView BlockB
-> Except OutsideForecastRange (WrapLedgerView BlockB)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (WrapLedgerView BlockB
 -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> WrapLedgerView BlockB
-> Except OutsideForecastRange (WrapLedgerView BlockB)
forall a b. (a -> b) -> a -> b
$
    LedgerView (BlockProtocol BlockB) -> WrapLedgerView BlockB
forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk
WrapLedgerView ()

injectTx_AtoB ::
  RequiringBoth
    WrapLedgerConfig
    (Product2 InjectTx InjectValidatedTx)
    BlockA
    BlockB
injectTx_AtoB :: RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
injectTx_AtoB =
  Product2 InjectTx InjectValidatedTx BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (Product2 InjectTx InjectValidatedTx)
     BlockA
     BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (Product2 InjectTx InjectValidatedTx BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig
      (Product2 InjectTx InjectValidatedTx)
      BlockA
      BlockB)
-> Product2 InjectTx InjectValidatedTx BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (Product2 InjectTx InjectValidatedTx)
     BlockA
     BlockB
forall a b. (a -> b) -> a -> b
$ InjectTx BlockA BlockB
-> InjectValidatedTx BlockA BlockB
-> Product2 InjectTx InjectValidatedTx BlockA BlockB
forall (f :: MapKind) (g :: MapKind) x y.
f x y -> g x y -> Product2 f g x y
Pair2 InjectTx BlockA BlockB
forall blk blk'. InjectTx blk blk'
cannotInjectTx InjectValidatedTx BlockA BlockB
forall blk blk'. InjectValidatedTx blk blk'
cannotInjectValidatedTx

{-------------------------------------------------------------------------------
  Query HF
-------------------------------------------------------------------------------}

instance BlockSupportsHFLedgerQuery '[BlockA, BlockB] where
  answerBlockQueryHFLookup :: forall (m :: * -> *) x result.
(All SingleEraBlock '[BlockA, BlockB], Monad m) =>
Index '[BlockA, BlockB] x
-> ExtLedgerCfg x
-> BlockQuery x 'QFLookupTables result
-> ReadOnlyForker' m TestBlock
-> m result
answerBlockQueryHFLookup Index '[BlockA, BlockB] x
IZ ExtLedgerCfg x
_ BlockQuery x 'QFLookupTables result
q = case BlockQuery x 'QFLookupTables result
q of {}
  answerBlockQueryHFLookup (IS Index xs' x
IZ) ExtLedgerCfg x
_cfg BlockQuery x 'QFLookupTables result
q = case BlockQuery x 'QFLookupTables result
q of {}
  answerBlockQueryHFLookup (IS (IS Index xs' x
idx)) ExtLedgerCfg x
_cfg BlockQuery x 'QFLookupTables result
_q = case Index xs' x
idx of {}

  answerBlockQueryHFTraverse :: forall (m :: * -> *) x result.
(All SingleEraBlock '[BlockA, BlockB], Monad m) =>
Index '[BlockA, BlockB] x
-> ExtLedgerCfg x
-> BlockQuery x 'QFTraverseTables result
-> ReadOnlyForker' m TestBlock
-> m result
answerBlockQueryHFTraverse Index '[BlockA, BlockB] x
IZ ExtLedgerCfg x
_cfg BlockQuery x 'QFTraverseTables result
q = case BlockQuery x 'QFTraverseTables result
q of {}
  answerBlockQueryHFTraverse (IS Index xs' x
IZ) ExtLedgerCfg x
_cfg BlockQuery x 'QFTraverseTables result
q = case BlockQuery x 'QFTraverseTables result
q of {}
  answerBlockQueryHFTraverse (IS (IS Index xs' x
idx)) ExtLedgerCfg x
_cfg BlockQuery x 'QFTraverseTables result
_q = case Index xs' x
idx of {}

  queryLedgerGetTraversingFilter :: forall x result.
Index '[BlockA, BlockB] x
-> BlockQuery x 'QFTraverseTables result
-> TxOut (LedgerState TestBlock)
-> Bool
queryLedgerGetTraversingFilter Index '[BlockA, BlockB] x
IZ BlockQuery x 'QFTraverseTables result
q = case BlockQuery x 'QFTraverseTables result
q of {}
  queryLedgerGetTraversingFilter (IS Index xs' x
IZ) BlockQuery x 'QFTraverseTables result
q = case BlockQuery x 'QFTraverseTables result
q of {}
  queryLedgerGetTraversingFilter (IS (IS Index xs' x
idx)) BlockQuery x 'QFTraverseTables result
_q = case Index xs' x
idx of {}