{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Minimal instantiation of the consensus layer to be able to run the ChainDB
module Test.Util.TestBlock (
    -- * Blocks
    BlockConfig (..)
  , BlockQuery (..)
  , CodecConfig (..)
  , Header (..)
  , StorageConfig (..)
  , TestBlockError (..)
  , TestBlockWith (tbPayload, tbSlot, tbValid)
  , TestHash (TestHash)
  , Validity (..)
  , firstBlockWithPayload
  , forkBlock
  , modifyFork
  , successorBlockWithPayload
  , testHashFromList
  , unTestHash
    -- ** Test block without payload
  , TestBlock
  , firstBlock
  , successorBlock
    -- ** Payload semantics
  , PayloadSemantics (..)
  , applyDirectlyToPayloadDependentState
    -- * LedgerState
  , LedgerState (TestLedger)
  , Ticked (TickedTestLedger)
  , lastAppliedPoint
  , payloadDependentState
    -- * Chain
  , BlockChain (..)
  , blockChain
  , chainToBlocks
    -- * Tree
  , BlockTree (..)
  , blockTree
  , treePreferredChain
  , treeToBlocks
  , treeToChains
    -- * Ledger infrastructure
  , singleNodeTestConfig
  , singleNodeTestConfigWith
  , singleNodeTestConfigWithK
  , testInitExtLedger
  , testInitExtLedgerWithState
  , testInitLedger
  , testInitLedgerWithState
    -- * Support for tests
  , Permutation (..)
  , TestBlockLedgerConfig (..)
  , isAncestorOf
  , isDescendentOf
  , isStrictAncestorOf
  , isStrictDescendentOf
  , permute
  , testBlockLedgerConfigFrom
  , unsafeTestBlockWithPayload
  , updateToNextNumeral
  ) where

import           Cardano.Crypto.DSIGN
import           Codec.Serialise (Serialise (..), serialise)
import           Control.DeepSeq (force)
import           Control.Monad (guard, replicateM, replicateM_)
import           Control.Monad.Except (throwError)
import qualified Data.Binary.Get as Get
import qualified Data.Binary.Put as Put
import qualified Data.ByteString.Lazy as BL
import           Data.Foldable (for_)
import           Data.Int
import           Data.Kind (Type)
import           Data.List (isSuffixOf, transpose)
import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe)
import           Data.Proxy
import           Data.Time.Calendar (fromGregorian)
import           Data.Time.Clock (UTCTime (..))
import           Data.Tree (Tree (..))
import qualified Data.Tree as Tree
import           Data.TreeDiff (ToExpr)
import           Data.Typeable (Typeable)
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.Forecast
import           Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.BFT
import           Ouroboros.Consensus.Protocol.MockChainSel
import           Ouroboros.Consensus.Protocol.Signed
import           Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints)
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.Magic (NetworkMagic (..))
import           Ouroboros.Network.Mock.Chain (Chain (..))
import qualified Ouroboros.Network.Mock.Chain as Chain
import qualified System.Random as R
import           Test.QuickCheck hiding (Result)
import           Test.Util.Orphans.SignableRepresentation ()
import           Test.Util.Orphans.ToExpr ()

{-------------------------------------------------------------------------------
  Test infrastructure: test block
-------------------------------------------------------------------------------}

-- The hash represents a path through a tree (of forks) as a list of
-- 'Word64's: @[0, 1, 0]@ means we forked off at the first block.
--
-- The following tree is just a small subset of the actual tree, which allows
-- multiple forks at /each/ node:
--
-- > G--A--B--C
-- > \  \--B"-C"
-- >  \-A'-B'-C'
--
-- Some examples:
--
-- > []      = G = Genesis
-- > [0]     = A
-- > [1]     = A'
-- > [0,0]   = B
-- > [0,0,0] = C
-- > [0,1]   = B"
-- > [0,1,0] = C"
-- > [1,0]   = B'
-- > [1,0,0] = C'
-- > ...
--
-- Since the empty list represents Genesis, which does not correspond to an
-- actual block, we use a NonEmpty list.
--
-- As it is easier to prepend to and access the front of a (NonEmpty) list, we
-- store the list in reverse order, e.g., @C'@ is stored as @[0,0,1]@, but we
-- print ('Show' and 'Condense') it as @[1,0,0]@.
--
-- The predecessor (parent in the tree) can be obtained by dropping the last
-- (in the printed representation) element in the list (or the head in the
-- in-memory representation).
--
-- The 'BlockNo' of the corresponding block is just the length of the list.
newtype TestHash = UnsafeTestHash {
      TestHash -> NonEmpty Word64
unTestHash :: NonEmpty Word64
    }
  deriving stock    ((forall x. TestHash -> Rep TestHash x)
-> (forall x. Rep TestHash x -> TestHash) -> Generic TestHash
forall x. Rep TestHash x -> TestHash
forall x. TestHash -> Rep TestHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestHash -> Rep TestHash x
from :: forall x. TestHash -> Rep TestHash x
$cto :: forall x. Rep TestHash x -> TestHash
to :: forall x. Rep TestHash x -> TestHash
Generic, Typeable)
  deriving newtype  (TestHash -> TestHash -> Bool
(TestHash -> TestHash -> Bool)
-> (TestHash -> TestHash -> Bool) -> Eq TestHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestHash -> TestHash -> Bool
== :: TestHash -> TestHash -> Bool
$c/= :: TestHash -> TestHash -> Bool
/= :: TestHash -> TestHash -> Bool
Eq, Eq TestHash
Eq TestHash =>
(TestHash -> TestHash -> Ordering)
-> (TestHash -> TestHash -> Bool)
-> (TestHash -> TestHash -> Bool)
-> (TestHash -> TestHash -> Bool)
-> (TestHash -> TestHash -> Bool)
-> (TestHash -> TestHash -> TestHash)
-> (TestHash -> TestHash -> TestHash)
-> Ord TestHash
TestHash -> TestHash -> Bool
TestHash -> TestHash -> Ordering
TestHash -> TestHash -> TestHash
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 :: TestHash -> TestHash -> Ordering
compare :: TestHash -> TestHash -> Ordering
$c< :: TestHash -> TestHash -> Bool
< :: TestHash -> TestHash -> Bool
$c<= :: TestHash -> TestHash -> Bool
<= :: TestHash -> TestHash -> Bool
$c> :: TestHash -> TestHash -> Bool
> :: TestHash -> TestHash -> Bool
$c>= :: TestHash -> TestHash -> Bool
>= :: TestHash -> TestHash -> Bool
$cmax :: TestHash -> TestHash -> TestHash
max :: TestHash -> TestHash -> TestHash
$cmin :: TestHash -> TestHash -> TestHash
min :: TestHash -> TestHash -> TestHash
Ord, [TestHash] -> Encoding
TestHash -> Encoding
(TestHash -> Encoding)
-> (forall s. Decoder s TestHash)
-> ([TestHash] -> Encoding)
-> (forall s. Decoder s [TestHash])
-> Serialise TestHash
forall s. Decoder s [TestHash]
forall s. Decoder s TestHash
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestHash -> Encoding
encode :: TestHash -> Encoding
$cdecode :: forall s. Decoder s TestHash
decode :: forall s. Decoder s TestHash
$cencodeList :: [TestHash] -> Encoding
encodeList :: [TestHash] -> Encoding
$cdecodeList :: forall s. Decoder s [TestHash]
decodeList :: forall s. Decoder s [TestHash]
Serialise, [TestHash] -> Expr
TestHash -> Expr
(TestHash -> Expr) -> ([TestHash] -> Expr) -> ToExpr TestHash
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TestHash -> Expr
toExpr :: TestHash -> Expr
$clistToExpr :: [TestHash] -> Expr
listToExpr :: [TestHash] -> Expr
ToExpr)
  deriving anyclass (Context -> TestHash -> IO (Maybe ThunkInfo)
Proxy TestHash -> String
(Context -> TestHash -> IO (Maybe ThunkInfo))
-> (Context -> TestHash -> IO (Maybe ThunkInfo))
-> (Proxy TestHash -> String)
-> NoThunks TestHash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestHash -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestHash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestHash -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestHash -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestHash -> String
showTypeOf :: Proxy TestHash -> String
NoThunks)

pattern TestHash :: NonEmpty Word64 -> TestHash
pattern $mTestHash :: forall {r}. TestHash -> (NonEmpty Word64 -> r) -> ((# #) -> r) -> r
$bTestHash :: NonEmpty Word64 -> TestHash
TestHash path <- UnsafeTestHash path where
  TestHash NonEmpty Word64
path = NonEmpty Word64 -> TestHash
UnsafeTestHash (NonEmpty Word64 -> NonEmpty Word64
forall a. NFData a => a -> a
force NonEmpty Word64
path)

{-# COMPLETE TestHash #-}

testHashFromList :: [Word64] -> TestHash
testHashFromList :: [Word64] -> TestHash
testHashFromList = NonEmpty Word64 -> TestHash
TestHash (NonEmpty Word64 -> TestHash)
-> ([Word64] -> NonEmpty Word64) -> [Word64] -> TestHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> NonEmpty Word64
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([Word64] -> NonEmpty Word64)
-> ([Word64] -> [Word64]) -> [Word64] -> NonEmpty Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> [Word64]
forall a. [a] -> [a]
reverse

instance Show TestHash where
  show :: TestHash -> String
show (TestHash NonEmpty Word64
h) = String
"(testHashFromList " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word64] -> String
forall a. Show a => a -> String
show ([Word64] -> [Word64]
forall a. [a] -> [a]
reverse (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Word64
h)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

instance Condense TestHash where
  condense :: TestHash -> String
condense = [Word64] -> String
forall a. Condense a => a -> String
condense ([Word64] -> String)
-> (TestHash -> [Word64]) -> TestHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> [Word64]
forall a. [a] -> [a]
reverse ([Word64] -> [Word64])
-> (TestHash -> [Word64]) -> TestHash -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Word64 -> [Word64])
-> (TestHash -> NonEmpty Word64) -> TestHash -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHash -> NonEmpty Word64
unTestHash

data Validity = Valid | Invalid
  deriving stock    (Int -> Validity -> ShowS
[Validity] -> ShowS
Validity -> String
(Int -> Validity -> ShowS)
-> (Validity -> String) -> ([Validity] -> ShowS) -> Show Validity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validity -> ShowS
showsPrec :: Int -> Validity -> ShowS
$cshow :: Validity -> String
show :: Validity -> String
$cshowList :: [Validity] -> ShowS
showList :: [Validity] -> ShowS
Show, Validity -> Validity -> Bool
(Validity -> Validity -> Bool)
-> (Validity -> Validity -> Bool) -> Eq Validity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Validity -> Validity -> Bool
== :: Validity -> Validity -> Bool
$c/= :: Validity -> Validity -> Bool
/= :: Validity -> Validity -> Bool
Eq, Eq Validity
Eq Validity =>
(Validity -> Validity -> Ordering)
-> (Validity -> Validity -> Bool)
-> (Validity -> Validity -> Bool)
-> (Validity -> Validity -> Bool)
-> (Validity -> Validity -> Bool)
-> (Validity -> Validity -> Validity)
-> (Validity -> Validity -> Validity)
-> Ord Validity
Validity -> Validity -> Bool
Validity -> Validity -> Ordering
Validity -> Validity -> Validity
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 :: Validity -> Validity -> Ordering
compare :: Validity -> Validity -> Ordering
$c< :: Validity -> Validity -> Bool
< :: Validity -> Validity -> Bool
$c<= :: Validity -> Validity -> Bool
<= :: Validity -> Validity -> Bool
$c> :: Validity -> Validity -> Bool
> :: Validity -> Validity -> Bool
$c>= :: Validity -> Validity -> Bool
>= :: Validity -> Validity -> Bool
$cmax :: Validity -> Validity -> Validity
max :: Validity -> Validity -> Validity
$cmin :: Validity -> Validity -> Validity
min :: Validity -> Validity -> Validity
Ord, Int -> Validity
Validity -> Int
Validity -> [Validity]
Validity -> Validity
Validity -> Validity -> [Validity]
Validity -> Validity -> Validity -> [Validity]
(Validity -> Validity)
-> (Validity -> Validity)
-> (Int -> Validity)
-> (Validity -> Int)
-> (Validity -> [Validity])
-> (Validity -> Validity -> [Validity])
-> (Validity -> Validity -> [Validity])
-> (Validity -> Validity -> Validity -> [Validity])
-> Enum Validity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Validity -> Validity
succ :: Validity -> Validity
$cpred :: Validity -> Validity
pred :: Validity -> Validity
$ctoEnum :: Int -> Validity
toEnum :: Int -> Validity
$cfromEnum :: Validity -> Int
fromEnum :: Validity -> Int
$cenumFrom :: Validity -> [Validity]
enumFrom :: Validity -> [Validity]
$cenumFromThen :: Validity -> Validity -> [Validity]
enumFromThen :: Validity -> Validity -> [Validity]
$cenumFromTo :: Validity -> Validity -> [Validity]
enumFromTo :: Validity -> Validity -> [Validity]
$cenumFromThenTo :: Validity -> Validity -> Validity -> [Validity]
enumFromThenTo :: Validity -> Validity -> Validity -> [Validity]
Enum, Validity
Validity -> Validity -> Bounded Validity
forall a. a -> a -> Bounded a
$cminBound :: Validity
minBound :: Validity
$cmaxBound :: Validity
maxBound :: Validity
Bounded, (forall x. Validity -> Rep Validity x)
-> (forall x. Rep Validity x -> Validity) -> Generic Validity
forall x. Rep Validity x -> Validity
forall x. Validity -> Rep Validity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Validity -> Rep Validity x
from :: forall x. Validity -> Rep Validity x
$cto :: forall x. Rep Validity x -> Validity
to :: forall x. Rep Validity x -> Validity
Generic)
  deriving anyclass ([Validity] -> Encoding
Validity -> Encoding
(Validity -> Encoding)
-> (forall s. Decoder s Validity)
-> ([Validity] -> Encoding)
-> (forall s. Decoder s [Validity])
-> Serialise Validity
forall s. Decoder s [Validity]
forall s. Decoder s Validity
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Validity -> Encoding
encode :: Validity -> Encoding
$cdecode :: forall s. Decoder s Validity
decode :: forall s. Decoder s Validity
$cencodeList :: [Validity] -> Encoding
encodeList :: [Validity] -> Encoding
$cdecodeList :: forall s. Decoder s [Validity]
decodeList :: forall s. Decoder s [Validity]
Serialise, Context -> Validity -> IO (Maybe ThunkInfo)
Proxy Validity -> String
(Context -> Validity -> IO (Maybe ThunkInfo))
-> (Context -> Validity -> IO (Maybe ThunkInfo))
-> (Proxy Validity -> String)
-> NoThunks Validity
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Validity -> IO (Maybe ThunkInfo)
noThunks :: Context -> Validity -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Validity -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Validity -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Validity -> String
showTypeOf :: Proxy Validity -> String
NoThunks, [Validity] -> Expr
Validity -> Expr
(Validity -> Expr) -> ([Validity] -> Expr) -> ToExpr Validity
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Validity -> Expr
toExpr :: Validity -> Expr
$clistToExpr :: [Validity] -> Expr
listToExpr :: [Validity] -> Expr
ToExpr)

-- | Test block parametrized on the payload type
--
-- For blocks without payload see the 'TestBlock' type alias.
--
-- By defining a 'PayloadSemantics' it is possible to obtain an 'ApplyBlock'
-- instance. See the former class for more details.
--
data TestBlockWith ptype = TestBlockWith {
      forall ptype. TestBlockWith ptype -> TestHash
tbHash    :: !TestHash
    , forall ptype. TestBlockWith ptype -> SlotNo
tbSlot    :: !SlotNo
      -- ^ We store a separate 'Block.SlotNo', as slots can have gaps between
      -- them, unlike block numbers.
      --
      -- Note that when generating a 'TestBlock', you must make sure that
      -- blocks with the same 'TestHash' have the same slot number.
    , forall ptype. TestBlockWith ptype -> Validity
tbValid   :: !Validity
      -- ^ Note that when generating a 'TestBlock', you must make sure that
      -- blocks with the same 'TestHash' have the same value for 'tbValid'.
    , forall ptype. TestBlockWith ptype -> ptype
tbPayload :: !ptype
    }
  deriving stock    (Int -> TestBlockWith ptype -> ShowS
[TestBlockWith ptype] -> ShowS
TestBlockWith ptype -> String
(Int -> TestBlockWith ptype -> ShowS)
-> (TestBlockWith ptype -> String)
-> ([TestBlockWith ptype] -> ShowS)
-> Show (TestBlockWith ptype)
forall ptype. Show ptype => Int -> TestBlockWith ptype -> ShowS
forall ptype. Show ptype => [TestBlockWith ptype] -> ShowS
forall ptype. Show ptype => TestBlockWith ptype -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ptype. Show ptype => Int -> TestBlockWith ptype -> ShowS
showsPrec :: Int -> TestBlockWith ptype -> ShowS
$cshow :: forall ptype. Show ptype => TestBlockWith ptype -> String
show :: TestBlockWith ptype -> String
$cshowList :: forall ptype. Show ptype => [TestBlockWith ptype] -> ShowS
showList :: [TestBlockWith ptype] -> ShowS
Show, TestBlockWith ptype -> TestBlockWith ptype -> Bool
(TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> (TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> Eq (TestBlockWith ptype)
forall ptype.
Eq ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ptype.
Eq ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
== :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
$c/= :: forall ptype.
Eq ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
/= :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
Eq, Eq (TestBlockWith ptype)
Eq (TestBlockWith ptype) =>
(TestBlockWith ptype -> TestBlockWith ptype -> Ordering)
-> (TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> (TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> (TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> (TestBlockWith ptype -> TestBlockWith ptype -> Bool)
-> (TestBlockWith ptype
    -> TestBlockWith ptype -> TestBlockWith ptype)
-> (TestBlockWith ptype
    -> TestBlockWith ptype -> TestBlockWith ptype)
-> Ord (TestBlockWith ptype)
TestBlockWith ptype -> TestBlockWith ptype -> Bool
TestBlockWith ptype -> TestBlockWith ptype -> Ordering
TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
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
forall ptype. Ord ptype => Eq (TestBlockWith ptype)
forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Ordering
forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
$ccompare :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Ordering
compare :: TestBlockWith ptype -> TestBlockWith ptype -> Ordering
$c< :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
< :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
$c<= :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
<= :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
$c> :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
> :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
$c>= :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> Bool
>= :: TestBlockWith ptype -> TestBlockWith ptype -> Bool
$cmax :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
max :: TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
$cmin :: forall ptype.
Ord ptype =>
TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
min :: TestBlockWith ptype -> TestBlockWith ptype -> TestBlockWith ptype
Ord, (forall x. TestBlockWith ptype -> Rep (TestBlockWith ptype) x)
-> (forall x. Rep (TestBlockWith ptype) x -> TestBlockWith ptype)
-> Generic (TestBlockWith ptype)
forall x. Rep (TestBlockWith ptype) x -> TestBlockWith ptype
forall x. TestBlockWith ptype -> Rep (TestBlockWith ptype) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ptype x. Rep (TestBlockWith ptype) x -> TestBlockWith ptype
forall ptype x. TestBlockWith ptype -> Rep (TestBlockWith ptype) x
$cfrom :: forall ptype x. TestBlockWith ptype -> Rep (TestBlockWith ptype) x
from :: forall x. TestBlockWith ptype -> Rep (TestBlockWith ptype) x
$cto :: forall ptype x. Rep (TestBlockWith ptype) x -> TestBlockWith ptype
to :: forall x. Rep (TestBlockWith ptype) x -> TestBlockWith ptype
Generic)
  deriving anyclass ([TestBlockWith ptype] -> Encoding
TestBlockWith ptype -> Encoding
(TestBlockWith ptype -> Encoding)
-> (forall s. Decoder s (TestBlockWith ptype))
-> ([TestBlockWith ptype] -> Encoding)
-> (forall s. Decoder s [TestBlockWith ptype])
-> Serialise (TestBlockWith ptype)
forall s. Decoder s [TestBlockWith ptype]
forall s. Decoder s (TestBlockWith ptype)
forall ptype. Serialise ptype => [TestBlockWith ptype] -> Encoding
forall ptype. Serialise ptype => TestBlockWith ptype -> Encoding
forall ptype s. Serialise ptype => Decoder s [TestBlockWith ptype]
forall ptype s. Serialise ptype => Decoder s (TestBlockWith ptype)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: forall ptype. Serialise ptype => TestBlockWith ptype -> Encoding
encode :: TestBlockWith ptype -> Encoding
$cdecode :: forall ptype s. Serialise ptype => Decoder s (TestBlockWith ptype)
decode :: forall s. Decoder s (TestBlockWith ptype)
$cencodeList :: forall ptype. Serialise ptype => [TestBlockWith ptype] -> Encoding
encodeList :: [TestBlockWith ptype] -> Encoding
$cdecodeList :: forall ptype s. Serialise ptype => Decoder s [TestBlockWith ptype]
decodeList :: forall s. Decoder s [TestBlockWith ptype]
Serialise, Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
Proxy (TestBlockWith ptype) -> String
(Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo))
-> (Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo))
-> (Proxy (TestBlockWith ptype) -> String)
-> NoThunks (TestBlockWith ptype)
forall ptype.
NoThunks ptype =>
Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
forall ptype.
NoThunks ptype =>
Proxy (TestBlockWith ptype) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall ptype.
NoThunks ptype =>
Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall ptype.
NoThunks ptype =>
Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBlockWith ptype -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall ptype.
NoThunks ptype =>
Proxy (TestBlockWith ptype) -> String
showTypeOf :: Proxy (TestBlockWith ptype) -> String
NoThunks, [TestBlockWith ptype] -> Expr
TestBlockWith ptype -> Expr
(TestBlockWith ptype -> Expr)
-> ([TestBlockWith ptype] -> Expr) -> ToExpr (TestBlockWith ptype)
forall ptype. ToExpr ptype => [TestBlockWith ptype] -> Expr
forall ptype. ToExpr ptype => TestBlockWith ptype -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: forall ptype. ToExpr ptype => TestBlockWith ptype -> Expr
toExpr :: TestBlockWith ptype -> Expr
$clistToExpr :: forall ptype. ToExpr ptype => [TestBlockWith ptype] -> Expr
listToExpr :: [TestBlockWith ptype] -> Expr
ToExpr)

-- | Create a block directly with the given parameters. This allows creating
-- inconsistent blocks; prefer 'firstBlockWithPayload' or 'successorBlockWithPayload'.
unsafeTestBlockWithPayload :: TestHash -> SlotNo -> Validity -> ptype -> TestBlockWith ptype
unsafeTestBlockWithPayload :: forall ptype.
TestHash -> SlotNo -> Validity -> ptype -> TestBlockWith ptype
unsafeTestBlockWithPayload TestHash
tbHash SlotNo
tbSlot Validity
tbValid ptype
tbPayload =
  TestBlockWith{TestHash
tbHash :: TestHash
tbHash :: TestHash
tbHash, SlotNo
tbSlot :: SlotNo
tbSlot :: SlotNo
tbSlot, Validity
tbValid :: Validity
tbValid :: Validity
tbValid, ptype
tbPayload :: ptype
tbPayload :: ptype
tbPayload}

-- | Create the first block in the given fork, @[fork]@, with the given payload.
-- The 'SlotNo' will be 1.
firstBlockWithPayload :: Word64 -> ptype -> TestBlockWith ptype
firstBlockWithPayload :: forall ptype. Word64 -> ptype -> TestBlockWith ptype
firstBlockWithPayload Word64
forkNo ptype
payload = TestBlockWith
    { tbHash :: TestHash
tbHash    = NonEmpty Word64 -> TestHash
TestHash (Word64
forkNo Word64 -> [Word64] -> NonEmpty Word64
forall a. a -> [a] -> NonEmpty a
NE.:| [])
    , tbSlot :: SlotNo
tbSlot    = SlotNo
1
    , tbValid :: Validity
tbValid   = Validity
Valid
    , tbPayload :: ptype
tbPayload = ptype
payload
    }

-- | Create the successor of the given block without forking: @b -> b ++ [0]@ (in
-- the printed representation) The 'SlotNo' is increased by 1.
--
-- In Zipper parlance, this corresponds to going down in a tree.
successorBlockWithPayload ::
  TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload :: forall ptype. TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload TestHash
hash SlotNo
slot ptype
payload = TestBlockWith
    { tbHash :: TestHash
tbHash    = NonEmpty Word64 -> TestHash
TestHash (Word64 -> NonEmpty Word64 -> NonEmpty Word64
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Word64
0 (TestHash -> NonEmpty Word64
unTestHash TestHash
hash))
    , tbSlot :: SlotNo
tbSlot    = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
slot
    , tbValid :: Validity
tbValid   = Validity
Valid
    , tbPayload :: ptype
tbPayload = ptype
payload
    }

-- | A block @b1@ is the ancestor of another block @b2@ if there exists a chain
-- of blocks from @b1@ to @b2@. For test blocks in particular, this can be seen
-- in the hash: the hash of @b1@ should be a prefix of the hash of @b2@.
--
-- Note that this is a partial comparison function. In particular, it does hold
-- that for all @b1@ and @b2@, @b1 `isDescendentOf` b2 === b2 `isAncestorOf` b1@
-- but it does not hold that for all @b1@ and @b2@, @b1 `isDescendentOf` b2 ===
-- not (b1 `isAncestorOf` b2) || b1 == b2@.
isAncestorOf :: TestBlock -> TestBlock -> Bool
isAncestorOf :: TestBlock -> TestBlock -> Bool
isAncestorOf TestBlock
b1 TestBlock
b2 =
  -- NOTE: 'unTestHash' returns the list of hash components _in reverse
  -- order_ so we need to test that one hash is the _suffix_ of the other.
  NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NE.toList (TestHash -> NonEmpty Word64
unTestHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b1))
    [Word64] -> [Word64] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`
  NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NE.toList (TestHash -> NonEmpty Word64
unTestHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b2))

-- | Variant of 'isAncestorOf' that returns @False@ when the two blocks are
-- equal.
isStrictAncestorOf :: TestBlock -> TestBlock -> Bool
isStrictAncestorOf :: TestBlock -> TestBlock -> Bool
isStrictAncestorOf TestBlock
b1 TestBlock
b2 = TestBlock
b1 TestBlock -> TestBlock -> Bool
`isAncestorOf` TestBlock
b2 Bool -> Bool -> Bool
&& TestBlock
b1 TestBlock -> TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= TestBlock
b2

-- | A block @b1@ is the descendent of another block @b2@ if there exists a
-- chain of blocks from @b2@ to @b1@. For test blocks in particular, this can be
-- seen in the hash: the hash of @b2@ should be a prefix of the hash of @b1@.
--
-- Note that this is a partial comparison function. In particular, it does hold
-- that for all @b1@ and @b2@, @b1 `isDescendentOf` b2 === b2 `isAncestorOf` b1@
-- but it does not hold that for all @b1@ and @b2@, @b1 `isDescendentOf` b2 ===
-- not (b1 `isAncestorOf` b2) || b1 == b2@.
isDescendentOf :: TestBlock -> TestBlock -> Bool
isDescendentOf :: TestBlock -> TestBlock -> Bool
isDescendentOf = (TestBlock -> TestBlock -> Bool) -> TestBlock -> TestBlock -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip TestBlock -> TestBlock -> Bool
isAncestorOf

-- | Variant of 'isDescendentOf' that returns @False@ when the two blocks are
-- equal.
isStrictDescendentOf :: TestBlock -> TestBlock -> Bool
isStrictDescendentOf :: TestBlock -> TestBlock -> Bool
isStrictDescendentOf TestBlock
b1 TestBlock
b2 = TestBlock
b1 TestBlock -> TestBlock -> Bool
`isDescendentOf` TestBlock
b2 Bool -> Bool -> Bool
&& TestBlock
b1 TestBlock -> TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= TestBlock
b2

instance ShowProxy TestBlock where

newtype instance Header (TestBlockWith ptype) =
    TestHeader { forall ptype. Header (TestBlockWith ptype) -> TestBlockWith ptype
testHeader :: TestBlockWith ptype }
  deriving stock (Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
(Header (TestBlockWith ptype)
 -> Header (TestBlockWith ptype) -> Bool)
-> (Header (TestBlockWith ptype)
    -> Header (TestBlockWith ptype) -> Bool)
-> Eq (Header (TestBlockWith ptype))
forall ptype.
Eq ptype =>
Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ptype.
Eq ptype =>
Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
== :: Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
$c/= :: forall ptype.
Eq ptype =>
Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
/= :: Header (TestBlockWith ptype)
-> Header (TestBlockWith ptype) -> Bool
Eq, Int -> Header (TestBlockWith ptype) -> ShowS
[Header (TestBlockWith ptype)] -> ShowS
Header (TestBlockWith ptype) -> String
(Int -> Header (TestBlockWith ptype) -> ShowS)
-> (Header (TestBlockWith ptype) -> String)
-> ([Header (TestBlockWith ptype)] -> ShowS)
-> Show (Header (TestBlockWith ptype))
forall ptype.
Show ptype =>
Int -> Header (TestBlockWith ptype) -> ShowS
forall ptype. Show ptype => [Header (TestBlockWith ptype)] -> ShowS
forall ptype. Show ptype => Header (TestBlockWith ptype) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ptype.
Show ptype =>
Int -> Header (TestBlockWith ptype) -> ShowS
showsPrec :: Int -> Header (TestBlockWith ptype) -> ShowS
$cshow :: forall ptype. Show ptype => Header (TestBlockWith ptype) -> String
show :: Header (TestBlockWith ptype) -> String
$cshowList :: forall ptype. Show ptype => [Header (TestBlockWith ptype)] -> ShowS
showList :: [Header (TestBlockWith ptype)] -> ShowS
Show)
  deriving newtype (Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
Proxy (Header (TestBlockWith ptype)) -> String
(Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo))
-> (Context
    -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo))
-> (Proxy (Header (TestBlockWith ptype)) -> String)
-> NoThunks (Header (TestBlockWith ptype))
forall ptype.
NoThunks ptype =>
Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
forall ptype.
NoThunks ptype =>
Proxy (Header (TestBlockWith ptype)) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall ptype.
NoThunks ptype =>
Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall ptype.
NoThunks ptype =>
Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Header (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall ptype.
NoThunks ptype =>
Proxy (Header (TestBlockWith ptype)) -> String
showTypeOf :: Proxy (Header (TestBlockWith ptype)) -> String
NoThunks, [Header (TestBlockWith ptype)] -> Encoding
Header (TestBlockWith ptype) -> Encoding
(Header (TestBlockWith ptype) -> Encoding)
-> (forall s. Decoder s (Header (TestBlockWith ptype)))
-> ([Header (TestBlockWith ptype)] -> Encoding)
-> (forall s. Decoder s [Header (TestBlockWith ptype)])
-> Serialise (Header (TestBlockWith ptype))
forall s. Decoder s [Header (TestBlockWith ptype)]
forall s. Decoder s (Header (TestBlockWith ptype))
forall ptype.
Serialise ptype =>
[Header (TestBlockWith ptype)] -> Encoding
forall ptype.
Serialise ptype =>
Header (TestBlockWith ptype) -> Encoding
forall ptype s.
Serialise ptype =>
Decoder s [Header (TestBlockWith ptype)]
forall ptype s.
Serialise ptype =>
Decoder s (Header (TestBlockWith ptype))
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: forall ptype.
Serialise ptype =>
Header (TestBlockWith ptype) -> Encoding
encode :: Header (TestBlockWith ptype) -> Encoding
$cdecode :: forall ptype s.
Serialise ptype =>
Decoder s (Header (TestBlockWith ptype))
decode :: forall s. Decoder s (Header (TestBlockWith ptype))
$cencodeList :: forall ptype.
Serialise ptype =>
[Header (TestBlockWith ptype)] -> Encoding
encodeList :: [Header (TestBlockWith ptype)] -> Encoding
$cdecodeList :: forall ptype s.
Serialise ptype =>
Decoder s [Header (TestBlockWith ptype)]
decodeList :: forall s. Decoder s [Header (TestBlockWith ptype)]
Serialise)

instance Typeable ptype => ShowProxy (Header (TestBlockWith ptype)) where

instance (Typeable ptype, Eq ptype) => HasHeader (Header (TestBlockWith ptype)) where
  getHeaderFields :: Header (TestBlockWith ptype)
-> HeaderFields (Header (TestBlockWith ptype))
getHeaderFields (TestHeader TestBlockWith{ptype
SlotNo
Validity
TestHash
tbPayload :: forall ptype. TestBlockWith ptype -> ptype
tbSlot :: forall ptype. TestBlockWith ptype -> SlotNo
tbValid :: forall ptype. TestBlockWith ptype -> Validity
tbHash :: forall ptype. TestBlockWith ptype -> TestHash
tbHash :: TestHash
tbSlot :: SlotNo
tbValid :: Validity
tbPayload :: ptype
..}) = HeaderFields {
        headerFieldHash :: HeaderHash (Header (TestBlockWith ptype))
headerFieldHash    = HeaderHash (Header (TestBlockWith ptype))
TestHash
tbHash
      , headerFieldSlot :: SlotNo
headerFieldSlot    = SlotNo
tbSlot
      , headerFieldBlockNo :: BlockNo
headerFieldBlockNo = Int -> BlockNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> BlockNo) -> (TestHash -> Int) -> TestHash -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Word64 -> Int
forall a. NonEmpty a -> Int
NE.length (NonEmpty Word64 -> Int)
-> (TestHash -> NonEmpty Word64) -> TestHash -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHash -> NonEmpty Word64
unTestHash (TestHash -> BlockNo) -> TestHash -> BlockNo
forall a b. (a -> b) -> a -> b
$ TestHash
tbHash
      }

instance (Typeable ptype, Eq ptype) => GetHeader (TestBlockWith ptype) where
  getHeader :: TestBlockWith ptype -> Header (TestBlockWith ptype)
getHeader = TestBlockWith ptype -> Header (TestBlockWith ptype)
forall ptype. TestBlockWith ptype -> Header (TestBlockWith ptype)
TestHeader
  blockMatchesHeader :: Header (TestBlockWith ptype) -> TestBlockWith ptype -> Bool
blockMatchesHeader (TestHeader TestBlockWith ptype
blk') TestBlockWith ptype
blk = TestBlockWith ptype
blk TestBlockWith ptype -> TestBlockWith ptype -> Bool
forall a. Eq a => a -> a -> Bool
== TestBlockWith ptype
blk'
  headerIsEBB :: Header (TestBlockWith ptype) -> Maybe EpochNo
headerIsEBB = Maybe EpochNo -> Header (TestBlockWith ptype) -> Maybe EpochNo
forall a b. a -> b -> a
const Maybe EpochNo
forall a. Maybe a
Nothing

type instance HeaderHash (TestBlockWith ptype) = TestHash

instance (Typeable ptype, Eq ptype) => HasHeader (TestBlockWith ptype) where
  getHeaderFields :: TestBlockWith ptype -> HeaderFields (TestBlockWith ptype)
getHeaderFields = TestBlockWith ptype -> HeaderFields (TestBlockWith ptype)
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields

instance (Typeable ptype, Eq ptype) => GetPrevHash (TestBlockWith ptype) where
  headerPrevHash :: Header (TestBlockWith ptype) -> ChainHash (TestBlockWith ptype)
headerPrevHash (TestHeader TestBlockWith ptype
b) =
      case [Word64] -> Maybe (NonEmpty Word64)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Word64] -> Maybe (NonEmpty Word64))
-> (TestBlockWith ptype -> [Word64])
-> TestBlockWith ptype
-> Maybe (NonEmpty Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NE.tail (NonEmpty Word64 -> [Word64])
-> (TestBlockWith ptype -> NonEmpty Word64)
-> TestBlockWith ptype
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHash -> NonEmpty Word64
unTestHash (TestHash -> NonEmpty Word64)
-> (TestBlockWith ptype -> TestHash)
-> TestBlockWith ptype
-> NonEmpty Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlockWith ptype -> TestHash
forall ptype. TestBlockWith ptype -> TestHash
tbHash (TestBlockWith ptype -> Maybe (NonEmpty Word64))
-> TestBlockWith ptype -> Maybe (NonEmpty Word64)
forall a b. (a -> b) -> a -> b
$ TestBlockWith ptype
b of
        Maybe (NonEmpty Word64)
Nothing       -> ChainHash (TestBlockWith ptype)
forall {k} (b :: k). ChainHash b
GenesisHash
        Just NonEmpty Word64
prevHash -> HeaderHash (TestBlockWith ptype) -> ChainHash (TestBlockWith ptype)
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (NonEmpty Word64 -> TestHash
TestHash NonEmpty Word64
prevHash)

instance StandardHash (TestBlockWith ptype)

instance (Typeable ptype, Eq ptype) => Condense (TestBlockWith ptype) where
  condense :: TestBlockWith ptype -> String
condense TestBlockWith ptype
b = Context -> String
forall a. Monoid a => [a] -> a
mconcat [
        String
"(H:"
      , TestHash -> String
forall a. Condense a => a -> String
condense (TestBlockWith ptype -> HeaderHash (TestBlockWith ptype)
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlockWith ptype
b)
      , String
",S:"
      , SlotNo -> String
forall a. Condense a => a -> String
condense (TestBlockWith ptype -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlockWith ptype
b)
      , String
",B:"
      , Word64 -> String
forall a. Condense a => a -> String
condense (BlockNo -> Word64
unBlockNo (TestBlockWith ptype -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo TestBlockWith ptype
b))
      , String
")"
      ]

instance (Typeable ptype, Eq ptype) => Condense (Header (TestBlockWith ptype)) where
  condense :: Header (TestBlockWith ptype) -> String
condense = TestBlockWith ptype -> String
forall a. Condense a => a -> String
condense (TestBlockWith ptype -> String)
-> (Header (TestBlockWith ptype) -> TestBlockWith ptype)
-> Header (TestBlockWith ptype)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (TestBlockWith ptype) -> TestBlockWith ptype
forall ptype. Header (TestBlockWith ptype) -> TestBlockWith ptype
testHeader

instance Condense (ChainHash (TestBlockWith ptype)) where
  condense :: ChainHash (TestBlockWith ptype) -> String
condense ChainHash (TestBlockWith ptype)
GenesisHash   = String
"genesis"
  condense (BlockHash HeaderHash (TestBlockWith ptype)
h) = TestHash -> String
forall a. Show a => a -> String
show HeaderHash (TestBlockWith ptype)
TestHash
h

data instance BlockConfig (TestBlockWith ptype) = TestBlockConfig {
      -- | Number of core nodes
      --
      -- We need this in order to compute the 'ValidateView', which must
      -- conjure up a validation key out of thin air
      forall ptype. BlockConfig (TestBlockWith ptype) -> NumCoreNodes
testBlockNumCoreNodes :: !NumCoreNodes
    }
  deriving (Int -> BlockConfig (TestBlockWith ptype) -> ShowS
[BlockConfig (TestBlockWith ptype)] -> ShowS
BlockConfig (TestBlockWith ptype) -> String
(Int -> BlockConfig (TestBlockWith ptype) -> ShowS)
-> (BlockConfig (TestBlockWith ptype) -> String)
-> ([BlockConfig (TestBlockWith ptype)] -> ShowS)
-> Show (BlockConfig (TestBlockWith ptype))
forall ptype. Int -> BlockConfig (TestBlockWith ptype) -> ShowS
forall ptype. [BlockConfig (TestBlockWith ptype)] -> ShowS
forall ptype. BlockConfig (TestBlockWith ptype) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ptype. Int -> BlockConfig (TestBlockWith ptype) -> ShowS
showsPrec :: Int -> BlockConfig (TestBlockWith ptype) -> ShowS
$cshow :: forall ptype. BlockConfig (TestBlockWith ptype) -> String
show :: BlockConfig (TestBlockWith ptype) -> String
$cshowList :: forall ptype. [BlockConfig (TestBlockWith ptype)] -> ShowS
showList :: [BlockConfig (TestBlockWith ptype)] -> ShowS
Show, (forall x.
 BlockConfig (TestBlockWith ptype)
 -> Rep (BlockConfig (TestBlockWith ptype)) x)
-> (forall x.
    Rep (BlockConfig (TestBlockWith ptype)) x
    -> BlockConfig (TestBlockWith ptype))
-> Generic (BlockConfig (TestBlockWith ptype))
forall x.
Rep (BlockConfig (TestBlockWith ptype)) x
-> BlockConfig (TestBlockWith ptype)
forall x.
BlockConfig (TestBlockWith ptype)
-> Rep (BlockConfig (TestBlockWith ptype)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ptype x.
Rep (BlockConfig (TestBlockWith ptype)) x
-> BlockConfig (TestBlockWith ptype)
forall ptype x.
BlockConfig (TestBlockWith ptype)
-> Rep (BlockConfig (TestBlockWith ptype)) x
$cfrom :: forall ptype x.
BlockConfig (TestBlockWith ptype)
-> Rep (BlockConfig (TestBlockWith ptype)) x
from :: forall x.
BlockConfig (TestBlockWith ptype)
-> Rep (BlockConfig (TestBlockWith ptype)) x
$cto :: forall ptype x.
Rep (BlockConfig (TestBlockWith ptype)) x
-> BlockConfig (TestBlockWith ptype)
to :: forall x.
Rep (BlockConfig (TestBlockWith ptype)) x
-> BlockConfig (TestBlockWith ptype)
Generic, Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
Proxy (BlockConfig (TestBlockWith ptype)) -> String
(Context
 -> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo))
-> (Context
    -> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo))
-> (Proxy (BlockConfig (TestBlockWith ptype)) -> String)
-> NoThunks (BlockConfig (TestBlockWith ptype))
forall ptype.
Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
forall ptype. Proxy (BlockConfig (TestBlockWith ptype)) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall ptype.
Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall ptype.
Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> BlockConfig (TestBlockWith ptype) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall ptype. Proxy (BlockConfig (TestBlockWith ptype)) -> String
showTypeOf :: Proxy (BlockConfig (TestBlockWith ptype)) -> String
NoThunks)

instance HasNetworkProtocolVersion (TestBlockWith ptype) where
  -- Use defaults

instance ConfigSupportsNode (TestBlockWith ptype) where
  getSystemStart :: BlockConfig (TestBlockWith ptype) -> SystemStart
getSystemStart = SystemStart -> BlockConfig (TestBlockWith ptype) -> SystemStart
forall a b. a -> b -> a
const (UTCTime -> SystemStart
SystemStart UTCTime
dummyDate)
    where
      --  This doesn't matter much
      dummyDate :: UTCTime
dummyDate = Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
2019 Int
8 Int
13) DiffTime
0

  getNetworkMagic :: BlockConfig (TestBlockWith ptype) -> NetworkMagic
getNetworkMagic = NetworkMagic -> BlockConfig (TestBlockWith ptype) -> NetworkMagic
forall a b. a -> b -> a
const (Word32 -> NetworkMagic
NetworkMagic Word32
42)

{-------------------------------------------------------------------------------
  Payload semantics
-------------------------------------------------------------------------------}

class ( Typeable ptype
      , Eq       ptype
      , NoThunks ptype

      , Eq        (PayloadDependentState ptype)
      , Show      (PayloadDependentState ptype)
      , Generic   (PayloadDependentState ptype)
      , ToExpr    (PayloadDependentState ptype)
      , Serialise (PayloadDependentState ptype)
      , NoThunks  (PayloadDependentState ptype)

      , Eq        (PayloadDependentError ptype)
      , Show      (PayloadDependentError ptype)
      , Generic   (PayloadDependentError ptype)
      , ToExpr    (PayloadDependentError ptype)
      , Serialise (PayloadDependentError ptype)
      , NoThunks  (PayloadDependentError ptype)

      , NoThunks (CodecConfig (TestBlockWith ptype))
      , NoThunks (StorageConfig (TestBlockWith ptype))
      ) => PayloadSemantics ptype where

  type PayloadDependentState ptype :: Type

  type PayloadDependentError ptype :: Type

  applyPayload ::
       PayloadDependentState ptype
    -> ptype
    -> Either (PayloadDependentError ptype) (PayloadDependentState ptype)

instance PayloadSemantics () where
  type PayloadDependentState () = ()

  type PayloadDependentError () = ()

  applyPayload :: PayloadDependentState ()
-> ()
-> Either (PayloadDependentError ()) (PayloadDependentState ())
applyPayload PayloadDependentState ()
_ ()
_ = () -> Either () ()
forall a b. b -> Either a b
Right ()

-- | Apply the payload directly to the payload dependent state portion of a
-- ticked state, leaving the rest of the input ticked state unaltered.
applyDirectlyToPayloadDependentState ::
     PayloadSemantics ptype
  => Ticked (LedgerState (TestBlockWith ptype))
  -> ptype
  -> Either (PayloadDependentError ptype)
            (Ticked (LedgerState (TestBlockWith ptype)))
applyDirectlyToPayloadDependentState :: forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype))
-> ptype
-> Either
     (PayloadDependentError ptype)
     (Ticked (LedgerState (TestBlockWith ptype)))
applyDirectlyToPayloadDependentState (TickedTestLedger LedgerState (TestBlockWith ptype)
st) ptype
tx = do
    PayloadDependentState ptype
payloadDepSt' <- PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
forall ptype.
PayloadSemantics ptype =>
PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
applyPayload (LedgerState (TestBlockWith ptype) -> PayloadDependentState ptype
forall ptype.
LedgerState (TestBlockWith ptype) -> PayloadDependentState ptype
payloadDependentState LedgerState (TestBlockWith ptype)
st) ptype
tx
    Ticked (LedgerState (TestBlockWith ptype))
-> Either
     (PayloadDependentError ptype)
     (Ticked (LedgerState (TestBlockWith ptype)))
forall a. a -> Either (PayloadDependentError ptype) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticked (LedgerState (TestBlockWith ptype))
 -> Either
      (PayloadDependentError ptype)
      (Ticked (LedgerState (TestBlockWith ptype))))
-> Ticked (LedgerState (TestBlockWith ptype))
-> Either
     (PayloadDependentError ptype)
     (Ticked (LedgerState (TestBlockWith ptype)))
forall a b. (a -> b) -> a -> b
$ LedgerState (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
forall ptype.
LedgerState (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
TickedTestLedger (LedgerState (TestBlockWith ptype)
 -> Ticked (LedgerState (TestBlockWith ptype)))
-> LedgerState (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
forall a b. (a -> b) -> a -> b
$ LedgerState (TestBlockWith ptype)
st { payloadDependentState = payloadDepSt' }

{-------------------------------------------------------------------------------
  NestedCtxt
-------------------------------------------------------------------------------}

data instance NestedCtxt_ (TestBlockWith ptype) f a where
  CtxtTestBlock :: NestedCtxt_ (TestBlockWith ptype) f (f (TestBlockWith ptype))

deriving instance Show (NestedCtxt_ (TestBlockWith ptype) f a)

instance TrivialDependency (NestedCtxt_ (TestBlockWith ptype) f) where
  type TrivialIndex (NestedCtxt_ (TestBlockWith ptype) f) = f (TestBlockWith ptype)
  hasSingleIndex :: forall a b.
NestedCtxt_ (TestBlockWith ptype) f a
-> NestedCtxt_ (TestBlockWith ptype) f b -> a :~: b
hasSingleIndex NestedCtxt_ (TestBlockWith ptype) f a
R:NestedCtxt_TestBlockWithfa ptype f a
CtxtTestBlock NestedCtxt_ (TestBlockWith ptype) f b
R:NestedCtxt_TestBlockWithfa ptype f b
CtxtTestBlock = a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  indexIsTrivial :: NestedCtxt_
  (TestBlockWith ptype)
  f
  (TrivialIndex (NestedCtxt_ (TestBlockWith ptype) f))
indexIsTrivial = NestedCtxt_ (TestBlockWith ptype) f (f (TestBlockWith ptype))
NestedCtxt_
  (TestBlockWith ptype)
  f
  (TrivialIndex (NestedCtxt_ (TestBlockWith ptype) f))
forall ptype (f :: * -> *).
NestedCtxt_ (TestBlockWith ptype) f (f (TestBlockWith ptype))
CtxtTestBlock

instance SameDepIndex (NestedCtxt_ (TestBlockWith ptype) f)
instance HasNestedContent f (TestBlockWith ptype)

{-------------------------------------------------------------------------------
  Test infrastructure: ledger state
-------------------------------------------------------------------------------}

type instance BlockProtocol (TestBlockWith ptype) = Bft BftMockCrypto

type instance Signed (Header (TestBlockWith ptype)) = ()
instance SignedHeader (Header (TestBlockWith ptype)) where
  headerSigned :: Header (TestBlockWith ptype)
-> Signed (Header (TestBlockWith ptype))
headerSigned Header (TestBlockWith ptype)
_ = ()

data TestBlockError ptype =
    -- | The hashes don't line up
    InvalidHash
      (ChainHash (TestBlockWith ptype))  -- ^ Expected hash
      (ChainHash (TestBlockWith ptype))  -- ^ Invalid hash

    -- | The block itself is invalid
  | InvalidBlock
  | InvalidPayload (PayloadDependentError ptype)

deriving stock instance Eq (PayloadDependentError ptype) => Eq (TestBlockError ptype)
deriving stock instance Show (PayloadDependentError ptype) => Show (TestBlockError ptype)
deriving stock instance Generic (TestBlockError ptype)

deriving anyclass instance
  ( Typeable ptype
  , Generic (PayloadDependentError ptype)
  , NoThunks (PayloadDependentError ptype)) => NoThunks (TestBlockError ptype)

instance ( Typeable ptype
         , Eq       ptype
         , NoThunks ptype
         , NoThunks (CodecConfig (TestBlockWith ptype))
         , NoThunks (StorageConfig (TestBlockWith ptype))
         ) => BlockSupportsProtocol (TestBlockWith ptype) where
  validateView :: BlockConfig (TestBlockWith ptype)
-> Header (TestBlockWith ptype)
-> ValidateView (BlockProtocol (TestBlockWith ptype))
validateView TestBlockConfig{NumCoreNodes
testBlockNumCoreNodes :: forall ptype. BlockConfig (TestBlockWith ptype) -> NumCoreNodes
testBlockNumCoreNodes :: NumCoreNodes
..} =
      (Header (TestBlockWith ptype)
 -> BftFields BftMockCrypto (Signed (Header (TestBlockWith ptype))))
-> Header (TestBlockWith ptype) -> BftValidateView BftMockCrypto
forall hdr c.
(SignedHeader hdr, Signable (BftDSIGN c) (Signed hdr)) =>
(hdr -> BftFields c (Signed hdr)) -> hdr -> BftValidateView c
bftValidateView Header (TestBlockWith ptype) -> BftFields BftMockCrypto ()
Header (TestBlockWith ptype)
-> BftFields BftMockCrypto (Signed (Header (TestBlockWith ptype)))
bftFields
    where
      NumCoreNodes Word64
numCore = NumCoreNodes
testBlockNumCoreNodes

      bftFields :: Header (TestBlockWith ptype) -> BftFields BftMockCrypto ()
      bftFields :: Header (TestBlockWith ptype) -> BftFields BftMockCrypto ()
bftFields (TestHeader TestBlockWith ptype
tb) = BftFields {
            bftSignature :: SignedDSIGN (BftDSIGN BftMockCrypto) ()
bftSignature = SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ()
forall v a. SigDSIGN v -> SignedDSIGN v a
SignedDSIGN (SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ())
-> SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ()
forall a b. (a -> b) -> a -> b
$ () -> SignKeyDSIGN MockDSIGN -> SigDSIGN MockDSIGN
forall a.
SignableRepresentation a =>
a -> SignKeyDSIGN MockDSIGN -> SigDSIGN MockDSIGN
mockSign () (SlotNo -> SignKeyDSIGN MockDSIGN
signKey (TestBlockWith ptype -> SlotNo
forall ptype. TestBlockWith ptype -> SlotNo
tbSlot TestBlockWith ptype
tb))
          }

      -- We don't want /our/ signing key, but rather the signing key of the
      -- node that produced the block
      signKey :: SlotNo -> SignKeyDSIGN MockDSIGN
      signKey :: SlotNo -> SignKeyDSIGN MockDSIGN
signKey (SlotNo Word64
n) = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN (Word64 -> SignKeyDSIGN MockDSIGN)
-> Word64 -> SignKeyDSIGN MockDSIGN
forall a b. (a -> b) -> a -> b
$ Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
numCore

instance PayloadSemantics ptype
         => ApplyBlock (LedgerState (TestBlockWith ptype)) (TestBlockWith ptype) where
  applyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (TestBlockWith ptype))
-> TestBlockWith ptype
-> Ticked (LedgerState (TestBlockWith ptype))
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
applyBlockLedgerResult LedgerCfg (LedgerState (TestBlockWith ptype))
_ tb :: TestBlockWith ptype
tb@TestBlockWith{ptype
SlotNo
Validity
TestHash
tbPayload :: forall ptype. TestBlockWith ptype -> ptype
tbSlot :: forall ptype. TestBlockWith ptype -> SlotNo
tbValid :: forall ptype. TestBlockWith ptype -> Validity
tbHash :: forall ptype. TestBlockWith ptype -> TestHash
tbHash :: TestHash
tbSlot :: SlotNo
tbValid :: Validity
tbPayload :: ptype
..} (TickedTestLedger TestLedger{Point (TestBlockWith ptype)
PayloadDependentState ptype
lastAppliedPoint :: forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
payloadDependentState :: forall ptype.
LedgerState (TestBlockWith ptype) -> PayloadDependentState ptype
lastAppliedPoint :: Point (TestBlockWith ptype)
payloadDependentState :: PayloadDependentState ptype
..})
    | TestBlockWith ptype -> ChainHash (TestBlockWith ptype)
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash TestBlockWith ptype
tb ChainHash (TestBlockWith ptype)
-> ChainHash (TestBlockWith ptype) -> Bool
forall a. Eq a => a -> a -> Bool
/= Point (TestBlockWith ptype) -> ChainHash (TestBlockWith ptype)
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point (TestBlockWith ptype)
lastAppliedPoint
    = TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a.
TestBlockError ptype
-> ExceptT
     (LedgerErr (LedgerState (TestBlockWith ptype))) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockError ptype
 -> Except
      (LedgerErr (LedgerState (TestBlockWith ptype)))
      (LedgerResult
         (LedgerState (TestBlockWith ptype))
         (LedgerState (TestBlockWith ptype))))
-> TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a b. (a -> b) -> a -> b
$ ChainHash (TestBlockWith ptype)
-> ChainHash (TestBlockWith ptype) -> TestBlockError ptype
forall ptype.
ChainHash (TestBlockWith ptype)
-> ChainHash (TestBlockWith ptype) -> TestBlockError ptype
InvalidHash (Point (TestBlockWith ptype) -> ChainHash (TestBlockWith ptype)
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point (TestBlockWith ptype)
lastAppliedPoint) (TestBlockWith ptype -> ChainHash (TestBlockWith ptype)
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash TestBlockWith ptype
tb)
    | Validity
tbValid Validity -> Validity -> Bool
forall a. Eq a => a -> a -> Bool
== Validity
Invalid
    = TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a.
TestBlockError ptype
-> ExceptT
     (LedgerErr (LedgerState (TestBlockWith ptype))) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockError ptype
 -> Except
      (LedgerErr (LedgerState (TestBlockWith ptype)))
      (LedgerResult
         (LedgerState (TestBlockWith ptype))
         (LedgerState (TestBlockWith ptype))))
-> TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a b. (a -> b) -> a -> b
$ TestBlockError ptype
forall ptype. TestBlockError ptype
InvalidBlock
    | Bool
otherwise
    = case PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
forall ptype.
PayloadSemantics ptype =>
PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
applyPayload PayloadDependentState ptype
payloadDependentState ptype
tbPayload of
        Left PayloadDependentError ptype
err  -> TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a.
TestBlockError ptype
-> ExceptT
     (LedgerErr (LedgerState (TestBlockWith ptype))) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockError ptype
 -> Except
      (LedgerErr (LedgerState (TestBlockWith ptype)))
      (LedgerResult
         (LedgerState (TestBlockWith ptype))
         (LedgerState (TestBlockWith ptype))))
-> TestBlockError ptype
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a b. (a -> b) -> a -> b
$ PayloadDependentError ptype -> TestBlockError ptype
forall ptype. PayloadDependentError ptype -> TestBlockError ptype
InvalidPayload PayloadDependentError ptype
err
        Right PayloadDependentState ptype
st' -> LedgerResult
  (LedgerState (TestBlockWith ptype))
  (LedgerState (TestBlockWith ptype))
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a.
a
-> ExceptT
     (LedgerErr (LedgerState (TestBlockWith ptype))) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return     (LedgerResult
   (LedgerState (TestBlockWith ptype))
   (LedgerState (TestBlockWith ptype))
 -> Except
      (LedgerErr (LedgerState (TestBlockWith ptype)))
      (LedgerResult
         (LedgerState (TestBlockWith ptype))
         (LedgerState (TestBlockWith ptype))))
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
-> Except
     (LedgerErr (LedgerState (TestBlockWith ptype)))
     (LedgerResult
        (LedgerState (TestBlockWith ptype))
        (LedgerState (TestBlockWith ptype)))
forall a b. (a -> b) -> a -> b
$ LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a l. a -> LedgerResult l a
pureLedgerResult
                                (LedgerState (TestBlockWith ptype)
 -> LedgerResult
      (LedgerState (TestBlockWith ptype))
      (LedgerState (TestBlockWith ptype)))
-> LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a b. (a -> b) -> a -> b
$ TestLedger {
                                    lastAppliedPoint :: Point (TestBlockWith ptype)
lastAppliedPoint      = TestBlockWith ptype -> Point (TestBlockWith ptype)
forall block. HasHeader block => block -> Point block
Chain.blockPoint TestBlockWith ptype
tb
                                  , payloadDependentState :: PayloadDependentState ptype
payloadDependentState = PayloadDependentState ptype
st'
                                  }

  reapplyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (TestBlockWith ptype))
-> TestBlockWith ptype
-> Ticked (LedgerState (TestBlockWith ptype))
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
reapplyBlockLedgerResult LedgerCfg (LedgerState (TestBlockWith ptype))
_ tb :: TestBlockWith ptype
tb@TestBlockWith{ptype
SlotNo
Validity
TestHash
tbPayload :: forall ptype. TestBlockWith ptype -> ptype
tbSlot :: forall ptype. TestBlockWith ptype -> SlotNo
tbValid :: forall ptype. TestBlockWith ptype -> Validity
tbHash :: forall ptype. TestBlockWith ptype -> TestHash
tbHash :: TestHash
tbSlot :: SlotNo
tbValid :: Validity
tbPayload :: ptype
..} (TickedTestLedger TestLedger{Point (TestBlockWith ptype)
PayloadDependentState ptype
lastAppliedPoint :: forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
payloadDependentState :: forall ptype.
LedgerState (TestBlockWith ptype) -> PayloadDependentState ptype
lastAppliedPoint :: Point (TestBlockWith ptype)
payloadDependentState :: PayloadDependentState ptype
..}) =
    case PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
forall ptype.
PayloadSemantics ptype =>
PayloadDependentState ptype
-> ptype
-> Either
     (PayloadDependentError ptype) (PayloadDependentState ptype)
applyPayload PayloadDependentState ptype
payloadDependentState ptype
tbPayload of
        Left PayloadDependentError ptype
err  -> String
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a. HasCallStack => String -> a
error (String
 -> LedgerResult
      (LedgerState (TestBlockWith ptype))
      (LedgerState (TestBlockWith ptype)))
-> String
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a b. (a -> b) -> a -> b
$ String
"Found an error when reapplying a block: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PayloadDependentError ptype -> String
forall a. Show a => a -> String
show PayloadDependentError ptype
err
        Right PayloadDependentState ptype
st' ->              LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a l. a -> LedgerResult l a
pureLedgerResult
                                (LedgerState (TestBlockWith ptype)
 -> LedgerResult
      (LedgerState (TestBlockWith ptype))
      (LedgerState (TestBlockWith ptype)))
-> LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (LedgerState (TestBlockWith ptype))
forall a b. (a -> b) -> a -> b
$ TestLedger {
                                    lastAppliedPoint :: Point (TestBlockWith ptype)
lastAppliedPoint      = TestBlockWith ptype -> Point (TestBlockWith ptype)
forall block. HasHeader block => block -> Point block
Chain.blockPoint TestBlockWith ptype
tb
                                  , payloadDependentState :: PayloadDependentState ptype
payloadDependentState = PayloadDependentState ptype
st'
                                  }


data instance LedgerState (TestBlockWith ptype) =
    TestLedger {
        -- | The ledger state simply consists of the last applied block
        forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint      :: Point (TestBlockWith ptype)
        -- | State that depends on the application of the block payload to the
        -- state.
      , forall ptype.
LedgerState (TestBlockWith ptype) -> PayloadDependentState ptype
payloadDependentState :: PayloadDependentState ptype
      }

deriving stock instance PayloadSemantics ptype => Show    (LedgerState (TestBlockWith ptype))
deriving stock instance PayloadSemantics ptype => Eq      (LedgerState (TestBlockWith ptype))
deriving stock instance Generic (LedgerState (TestBlockWith ptype))

deriving anyclass instance PayloadSemantics ptype => Serialise (LedgerState (TestBlockWith ptype))
deriving anyclass instance PayloadSemantics ptype => NoThunks  (LedgerState (TestBlockWith ptype))
deriving anyclass instance PayloadSemantics ptype => ToExpr    (LedgerState (TestBlockWith ptype))

testInitLedgerWithState :: PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
testInitLedgerWithState :: forall ptype.
PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
testInitLedgerWithState = Point (TestBlockWith ptype)
-> PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
forall ptype.
Point (TestBlockWith ptype)
-> PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
TestLedger Point (TestBlockWith ptype)
forall {k} (block :: k). Point block
GenesisPoint

-- Ticking has no effect
newtype instance Ticked (LedgerState (TestBlockWith ptype)) = TickedTestLedger {
      forall ptype.
Ticked (LedgerState (TestBlockWith ptype))
-> LedgerState (TestBlockWith ptype)
getTickedTestLedger :: LedgerState (TestBlockWith ptype)
    }
  deriving stock ((forall x.
 Ticked (LedgerState (TestBlockWith ptype))
 -> Rep (Ticked (LedgerState (TestBlockWith ptype))) x)
-> (forall x.
    Rep (Ticked (LedgerState (TestBlockWith ptype))) x
    -> Ticked (LedgerState (TestBlockWith ptype)))
-> Generic (Ticked (LedgerState (TestBlockWith ptype)))
forall x.
Rep (Ticked (LedgerState (TestBlockWith ptype))) x
-> Ticked (LedgerState (TestBlockWith ptype))
forall x.
Ticked (LedgerState (TestBlockWith ptype))
-> Rep (Ticked (LedgerState (TestBlockWith ptype))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ptype x.
Rep (Ticked (LedgerState (TestBlockWith ptype))) x
-> Ticked (LedgerState (TestBlockWith ptype))
forall ptype x.
Ticked (LedgerState (TestBlockWith ptype))
-> Rep (Ticked (LedgerState (TestBlockWith ptype))) x
$cfrom :: forall ptype x.
Ticked (LedgerState (TestBlockWith ptype))
-> Rep (Ticked (LedgerState (TestBlockWith ptype))) x
from :: forall x.
Ticked (LedgerState (TestBlockWith ptype))
-> Rep (Ticked (LedgerState (TestBlockWith ptype))) x
$cto :: forall ptype x.
Rep (Ticked (LedgerState (TestBlockWith ptype))) x
-> Ticked (LedgerState (TestBlockWith ptype))
to :: forall x.
Rep (Ticked (LedgerState (TestBlockWith ptype))) x
-> Ticked (LedgerState (TestBlockWith ptype))
Generic, Int -> Ticked (LedgerState (TestBlockWith ptype)) -> ShowS
[Ticked (LedgerState (TestBlockWith ptype))] -> ShowS
Ticked (LedgerState (TestBlockWith ptype)) -> String
(Int -> Ticked (LedgerState (TestBlockWith ptype)) -> ShowS)
-> (Ticked (LedgerState (TestBlockWith ptype)) -> String)
-> ([Ticked (LedgerState (TestBlockWith ptype))] -> ShowS)
-> Show (Ticked (LedgerState (TestBlockWith ptype)))
forall ptype.
PayloadSemantics ptype =>
Int -> Ticked (LedgerState (TestBlockWith ptype)) -> ShowS
forall ptype.
PayloadSemantics ptype =>
[Ticked (LedgerState (TestBlockWith ptype))] -> ShowS
forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype)) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ptype.
PayloadSemantics ptype =>
Int -> Ticked (LedgerState (TestBlockWith ptype)) -> ShowS
showsPrec :: Int -> Ticked (LedgerState (TestBlockWith ptype)) -> ShowS
$cshow :: forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype)) -> String
show :: Ticked (LedgerState (TestBlockWith ptype)) -> String
$cshowList :: forall ptype.
PayloadSemantics ptype =>
[Ticked (LedgerState (TestBlockWith ptype))] -> ShowS
showList :: [Ticked (LedgerState (TestBlockWith ptype))] -> ShowS
Show)
  deriving newtype (Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
Proxy (Ticked (LedgerState (TestBlockWith ptype))) -> String
(Context
 -> Ticked (LedgerState (TestBlockWith ptype))
 -> IO (Maybe ThunkInfo))
-> (Context
    -> Ticked (LedgerState (TestBlockWith ptype))
    -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked (LedgerState (TestBlockWith ptype))) -> String)
-> NoThunks (Ticked (LedgerState (TestBlockWith ptype)))
forall ptype.
PayloadSemantics ptype =>
Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
forall ptype.
PayloadSemantics ptype =>
Proxy (Ticked (LedgerState (TestBlockWith ptype))) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall ptype.
PayloadSemantics ptype =>
Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
noThunks :: Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
$cwNoThunks :: forall ptype.
PayloadSemantics ptype =>
Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Ticked (LedgerState (TestBlockWith ptype))
-> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall ptype.
PayloadSemantics ptype =>
Proxy (Ticked (LedgerState (TestBlockWith ptype))) -> String
showTypeOf :: Proxy (Ticked (LedgerState (TestBlockWith ptype))) -> String
NoThunks, [Ticked (LedgerState (TestBlockWith ptype))] -> Expr
Ticked (LedgerState (TestBlockWith ptype)) -> Expr
(Ticked (LedgerState (TestBlockWith ptype)) -> Expr)
-> ([Ticked (LedgerState (TestBlockWith ptype))] -> Expr)
-> ToExpr (Ticked (LedgerState (TestBlockWith ptype)))
forall ptype.
PayloadSemantics ptype =>
[Ticked (LedgerState (TestBlockWith ptype))] -> Expr
forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype)) -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype)) -> Expr
toExpr :: Ticked (LedgerState (TestBlockWith ptype)) -> Expr
$clistToExpr :: forall ptype.
PayloadSemantics ptype =>
[Ticked (LedgerState (TestBlockWith ptype))] -> Expr
listToExpr :: [Ticked (LedgerState (TestBlockWith ptype))] -> Expr
ToExpr, Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
(Ticked (LedgerState (TestBlockWith ptype))
 -> Ticked (LedgerState (TestBlockWith ptype)) -> Bool)
-> (Ticked (LedgerState (TestBlockWith ptype))
    -> Ticked (LedgerState (TestBlockWith ptype)) -> Bool)
-> Eq (Ticked (LedgerState (TestBlockWith ptype)))
forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
== :: Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
$c/= :: forall ptype.
PayloadSemantics ptype =>
Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
/= :: Ticked (LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype)) -> Bool
Eq)

testInitExtLedgerWithState :: PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState :: forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState PayloadDependentState ptype
st = ExtLedgerState {
      ledgerState :: LedgerState (TestBlockWith ptype)
ledgerState = PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
forall ptype.
PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
testInitLedgerWithState PayloadDependentState ptype
st
    , headerState :: HeaderState (TestBlockWith ptype)
headerState = ChainDepState (BlockProtocol (TestBlockWith ptype))
-> HeaderState (TestBlockWith ptype)
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ()
    }

data TestBlockLedgerConfig = TestBlockLedgerConfig {
  TestBlockLedgerConfig -> EraParams
tblcHardForkParams :: !HardFork.EraParams,
  -- | `Nothing` means an infinite forecast range.
  -- Instead of SlotNo, it should be something like "SlotRange"
  TestBlockLedgerConfig -> StrictMaybe SlotNo
tblcForecastRange  :: !(StrictMaybe SlotNo)
}
  deriving (Int -> TestBlockLedgerConfig -> ShowS
[TestBlockLedgerConfig] -> ShowS
TestBlockLedgerConfig -> String
(Int -> TestBlockLedgerConfig -> ShowS)
-> (TestBlockLedgerConfig -> String)
-> ([TestBlockLedgerConfig] -> ShowS)
-> Show TestBlockLedgerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlockLedgerConfig -> ShowS
showsPrec :: Int -> TestBlockLedgerConfig -> ShowS
$cshow :: TestBlockLedgerConfig -> String
show :: TestBlockLedgerConfig -> String
$cshowList :: [TestBlockLedgerConfig] -> ShowS
showList :: [TestBlockLedgerConfig] -> ShowS
Show, TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool
(TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool)
-> (TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool)
-> Eq TestBlockLedgerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool
== :: TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool
$c/= :: TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool
/= :: TestBlockLedgerConfig -> TestBlockLedgerConfig -> Bool
Eq, (forall x. TestBlockLedgerConfig -> Rep TestBlockLedgerConfig x)
-> (forall x. Rep TestBlockLedgerConfig x -> TestBlockLedgerConfig)
-> Generic TestBlockLedgerConfig
forall x. Rep TestBlockLedgerConfig x -> TestBlockLedgerConfig
forall x. TestBlockLedgerConfig -> Rep TestBlockLedgerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestBlockLedgerConfig -> Rep TestBlockLedgerConfig x
from :: forall x. TestBlockLedgerConfig -> Rep TestBlockLedgerConfig x
$cto :: forall x. Rep TestBlockLedgerConfig x -> TestBlockLedgerConfig
to :: forall x. Rep TestBlockLedgerConfig x -> TestBlockLedgerConfig
Generic)
  deriving anyclass (Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo)
Proxy TestBlockLedgerConfig -> String
(Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo))
-> (Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo))
-> (Proxy TestBlockLedgerConfig -> String)
-> NoThunks TestBlockLedgerConfig
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBlockLedgerConfig -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBlockLedgerConfig -> String
showTypeOf :: Proxy TestBlockLedgerConfig -> String
NoThunks)

testBlockLedgerConfigFrom :: HardFork.EraParams -> TestBlockLedgerConfig
testBlockLedgerConfigFrom :: EraParams -> TestBlockLedgerConfig
testBlockLedgerConfigFrom EraParams
eraParams = EraParams -> StrictMaybe SlotNo -> TestBlockLedgerConfig
TestBlockLedgerConfig EraParams
eraParams StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing

type instance LedgerCfg (LedgerState (TestBlockWith ptype)) = TestBlockLedgerConfig

instance GetTip (LedgerState (TestBlockWith ptype)) where
  getTip :: LedgerState (TestBlockWith ptype)
-> Point (LedgerState (TestBlockWith ptype))
getTip = Point (TestBlockWith ptype)
-> Point (LedgerState (TestBlockWith ptype))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (TestBlockWith ptype)
 -> Point (LedgerState (TestBlockWith ptype)))
-> (LedgerState (TestBlockWith ptype)
    -> Point (TestBlockWith ptype))
-> LedgerState (TestBlockWith ptype)
-> Point (LedgerState (TestBlockWith ptype))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint

instance GetTip (Ticked (LedgerState (TestBlockWith ptype))) where
  getTip :: Ticked (LedgerState (TestBlockWith ptype))
-> Point (Ticked (LedgerState (TestBlockWith ptype)))
getTip = Point (TestBlockWith ptype)
-> Point (Ticked (LedgerState (TestBlockWith ptype)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (TestBlockWith ptype)
 -> Point (Ticked (LedgerState (TestBlockWith ptype))))
-> (Ticked (LedgerState (TestBlockWith ptype))
    -> Point (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype))
-> Point (Ticked (LedgerState (TestBlockWith ptype)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint (LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype))
-> (Ticked (LedgerState (TestBlockWith ptype))
    -> LedgerState (TestBlockWith ptype))
-> Ticked (LedgerState (TestBlockWith ptype))
-> Point (TestBlockWith ptype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (TestBlockWith ptype))
-> LedgerState (TestBlockWith ptype)
forall ptype.
Ticked (LedgerState (TestBlockWith ptype))
-> LedgerState (TestBlockWith ptype)
getTickedTestLedger

instance PayloadSemantics ptype => IsLedger (LedgerState (TestBlockWith ptype)) where
  type LedgerErr (LedgerState (TestBlockWith ptype)) = TestBlockError ptype

  type AuxLedgerEvent (LedgerState (TestBlockWith ptype)) =
    VoidLedgerEvent (LedgerState (TestBlockWith ptype))

  applyChainTickLedgerResult :: LedgerCfg (LedgerState (TestBlockWith ptype))
-> SlotNo
-> LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (Ticked (LedgerState (TestBlockWith ptype)))
applyChainTickLedgerResult LedgerCfg (LedgerState (TestBlockWith ptype))
_ SlotNo
_ = Ticked (LedgerState (TestBlockWith ptype))
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (Ticked (LedgerState (TestBlockWith ptype)))
forall a l. a -> LedgerResult l a
pureLedgerResult (Ticked (LedgerState (TestBlockWith ptype))
 -> LedgerResult
      (LedgerState (TestBlockWith ptype))
      (Ticked (LedgerState (TestBlockWith ptype))))
-> (LedgerState (TestBlockWith ptype)
    -> Ticked (LedgerState (TestBlockWith ptype)))
-> LedgerState (TestBlockWith ptype)
-> LedgerResult
     (LedgerState (TestBlockWith ptype))
     (Ticked (LedgerState (TestBlockWith ptype)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
forall ptype.
LedgerState (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
TickedTestLedger

instance PayloadSemantics ptype => UpdateLedger (TestBlockWith ptype)

instance InspectLedger (TestBlockWith ptype) where
  -- Defaults are fine

instance (PayloadSemantics ptype) => HasAnnTip (TestBlockWith ptype) where
  -- Use defaults

instance (PayloadSemantics ptype) => BasicEnvelopeValidation (TestBlockWith ptype) where
  -- The block number of a test block is derived from the length of the hash
  expectedFirstBlockNo :: forall (proxy :: * -> *). proxy (TestBlockWith ptype) -> BlockNo
expectedFirstBlockNo proxy (TestBlockWith ptype)
_ = Word64 -> BlockNo
BlockNo Word64
1

instance (PayloadSemantics ptype) => ValidateEnvelope (TestBlockWith ptype) where
  -- Use defaults

instance (PayloadSemantics ptype) => LedgerSupportsProtocol (TestBlockWith ptype) where
  protocolLedgerView :: LedgerConfig (TestBlockWith ptype)
-> Ticked (LedgerState (TestBlockWith ptype))
-> LedgerView (BlockProtocol (TestBlockWith ptype))
protocolLedgerView   LedgerConfig (TestBlockWith ptype)
_ Ticked (LedgerState (TestBlockWith ptype))
_  = ()
  ledgerViewForecastAt :: HasCallStack =>
LedgerConfig (TestBlockWith ptype)
-> LedgerState (TestBlockWith ptype)
-> Forecast (LedgerView (BlockProtocol (TestBlockWith ptype)))
ledgerViewForecastAt LedgerConfig (TestBlockWith ptype)
cfg LedgerState (TestBlockWith ptype)
state =
    Maybe SlotNo -> () -> WithOrigin SlotNo -> Forecast ()
forall a. Maybe SlotNo -> a -> WithOrigin SlotNo -> Forecast a
constantForecastInRange (StrictMaybe SlotNo -> Maybe SlotNo
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TestBlockLedgerConfig -> StrictMaybe SlotNo
tblcForecastRange LedgerConfig (TestBlockWith ptype)
TestBlockLedgerConfig
cfg)) () (LedgerState (TestBlockWith ptype) -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot LedgerState (TestBlockWith ptype)
state)

singleNodeTestConfigWith ::
     CodecConfig (TestBlockWith ptype)
  -> StorageConfig (TestBlockWith ptype)
  -> SecurityParam
  -> GenesisWindow
  -> TopLevelConfig (TestBlockWith ptype)
singleNodeTestConfigWith :: forall ptype.
CodecConfig (TestBlockWith ptype)
-> StorageConfig (TestBlockWith ptype)
-> SecurityParam
-> GenesisWindow
-> TopLevelConfig (TestBlockWith ptype)
singleNodeTestConfigWith CodecConfig (TestBlockWith ptype)
codecConfig StorageConfig (TestBlockWith ptype)
storageConfig SecurityParam
k GenesisWindow
genesisWindow = TopLevelConfig {
      topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (TestBlockWith ptype))
topLevelConfigProtocol = BftConfig {
          bftParams :: BftParams
bftParams  = BftParams { bftSecurityParam :: SecurityParam
bftSecurityParam = SecurityParam
k
                                 , bftNumNodes :: NumCoreNodes
bftNumNodes      = NumCoreNodes
numCoreNodes
                                 }
        , bftSignKey :: SignKeyDSIGN (BftDSIGN BftMockCrypto)
bftSignKey = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN Word64
0
        , bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN BftMockCrypto))
bftVerKeys = NodeId
-> VerKeyDSIGN MockDSIGN -> Map NodeId (VerKeyDSIGN MockDSIGN)
forall k a. k -> a -> Map k a
Map.singleton (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
0)) (Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
0)
        }
    , topLevelConfigLedger :: LedgerConfig (TestBlockWith ptype)
topLevelConfigLedger      = LedgerConfig (TestBlockWith ptype)
TestBlockLedgerConfig
ledgerCfgParams
    , topLevelConfigBlock :: BlockConfig (TestBlockWith ptype)
topLevelConfigBlock       = NumCoreNodes -> BlockConfig (TestBlockWith ptype)
forall ptype. NumCoreNodes -> BlockConfig (TestBlockWith ptype)
TestBlockConfig NumCoreNodes
numCoreNodes
    , topLevelConfigCodec :: CodecConfig (TestBlockWith ptype)
topLevelConfigCodec       = CodecConfig (TestBlockWith ptype)
codecConfig
    , topLevelConfigStorage :: StorageConfig (TestBlockWith ptype)
topLevelConfigStorage     = StorageConfig (TestBlockWith ptype)
storageConfig
    , topLevelConfigCheckpoints :: CheckpointsMap (TestBlockWith ptype)
topLevelConfigCheckpoints = CheckpointsMap (TestBlockWith ptype)
forall blk. CheckpointsMap blk
emptyCheckpointsMap
    }
  where
    slotLength :: SlotLength
    slotLength :: SlotLength
slotLength = Year -> SlotLength
slotLengthFromSec Year
20

    numCoreNodes :: NumCoreNodes
    numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
1

    ledgerCfgParams :: TestBlockLedgerConfig
    ledgerCfgParams :: TestBlockLedgerConfig
ledgerCfgParams = TestBlockLedgerConfig {
      tblcHardForkParams :: EraParams
tblcHardForkParams = SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
k SlotLength
slotLength,
      tblcForecastRange :: StrictMaybe SlotNo
tblcForecastRange = StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
    }

    _eraParams :: HardFork.EraParams
    _eraParams :: EraParams
_eraParams = (SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
k SlotLength
slotLength) {HardFork.eraGenesisWin = genesisWindow}


{-------------------------------------------------------------------------------
  Test blocks without payload
-------------------------------------------------------------------------------}

-- | Block without payload
type TestBlock = TestBlockWith ()

-- | The 'TestBlock' does not need any codec config
data instance CodecConfig TestBlock = TestBlockCodecConfig
  deriving (Int -> CodecConfig TestBlock -> ShowS
[CodecConfig TestBlock] -> ShowS
CodecConfig TestBlock -> String
(Int -> CodecConfig TestBlock -> ShowS)
-> (CodecConfig TestBlock -> String)
-> ([CodecConfig TestBlock] -> ShowS)
-> Show (CodecConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodecConfig TestBlock -> ShowS
showsPrec :: Int -> CodecConfig TestBlock -> ShowS
$cshow :: CodecConfig TestBlock -> String
show :: CodecConfig TestBlock -> String
$cshowList :: [CodecConfig TestBlock] -> ShowS
showList :: [CodecConfig TestBlock] -> ShowS
Show, (forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x)
-> (forall x.
    Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock)
-> Generic (CodecConfig TestBlock)
forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
from :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
$cto :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
to :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
Generic, Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (CodecConfig TestBlock) -> String
(Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig TestBlock) -> String)
-> NoThunks (CodecConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (CodecConfig TestBlock) -> String
showTypeOf :: Proxy (CodecConfig TestBlock) -> String
NoThunks)

-- | The 'TestBlock' does not need any storage config
data instance StorageConfig TestBlock = TestBlockStorageConfig
  deriving (Int -> StorageConfig TestBlock -> ShowS
[StorageConfig TestBlock] -> ShowS
StorageConfig TestBlock -> String
(Int -> StorageConfig TestBlock -> ShowS)
-> (StorageConfig TestBlock -> String)
-> ([StorageConfig TestBlock] -> ShowS)
-> Show (StorageConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StorageConfig TestBlock -> ShowS
showsPrec :: Int -> StorageConfig TestBlock -> ShowS
$cshow :: StorageConfig TestBlock -> String
show :: StorageConfig TestBlock -> String
$cshowList :: [StorageConfig TestBlock] -> ShowS
showList :: [StorageConfig TestBlock] -> ShowS
Show, (forall x.
 StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x)
-> (forall x.
    Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock)
-> Generic (StorageConfig TestBlock)
forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
from :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
$cto :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
to :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
Generic, Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (StorageConfig TestBlock) -> String
(Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig TestBlock) -> String)
-> NoThunks (StorageConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (StorageConfig TestBlock) -> String
showTypeOf :: Proxy (StorageConfig TestBlock) -> String
NoThunks)

instance HasHardForkHistory TestBlock where
  type HardForkIndices TestBlock = '[TestBlock]
  hardForkSummary :: LedgerConfig TestBlock
-> LedgerState TestBlock -> Summary (HardForkIndices TestBlock)
hardForkSummary = (LedgerConfig TestBlock -> EraParams)
-> LedgerConfig TestBlock
-> LedgerState TestBlock
-> Summary '[TestBlock]
forall blk.
(LedgerConfig blk -> EraParams)
-> LedgerConfig blk -> LedgerState blk -> Summary '[blk]
neverForksHardForkSummary LedgerConfig TestBlock -> EraParams
TestBlockLedgerConfig -> EraParams
tblcHardForkParams

data instance BlockQuery TestBlock result where
  QueryLedgerTip :: BlockQuery TestBlock (Point TestBlock)

instance BlockSupportsLedgerQuery TestBlock where
  answerBlockQuery :: forall result.
ExtLedgerCfg TestBlock
-> BlockQuery TestBlock result
-> ExtLedgerState TestBlock
-> result
answerBlockQuery ExtLedgerCfg TestBlock
_cfg BlockQuery TestBlock result
R:BlockQueryTestBlockWithresult result
QueryLedgerTip (ExtLedgerState TestLedger { Point TestBlock
lastAppliedPoint :: forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint :: Point TestBlock
lastAppliedPoint } HeaderState TestBlock
_) =
    result
Point TestBlock
lastAppliedPoint

instance SameDepIndex (BlockQuery TestBlock) where
  sameDepIndex :: forall a b.
BlockQuery TestBlock a -> BlockQuery TestBlock b -> Maybe (a :~: b)
sameDepIndex BlockQuery TestBlock a
R:BlockQueryTestBlockWithresult a
QueryLedgerTip BlockQuery TestBlock b
R:BlockQueryTestBlockWithresult b
QueryLedgerTip = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl

deriving instance Eq (BlockQuery TestBlock result)
deriving instance Show (BlockQuery TestBlock result)

instance ShowQuery (BlockQuery TestBlock) where
  showResult :: forall result. BlockQuery TestBlock result -> result -> String
showResult BlockQuery TestBlock result
R:BlockQueryTestBlockWithresult result
QueryLedgerTip = result -> String
forall a. Show a => a -> String
show

testInitLedger :: LedgerState TestBlock
testInitLedger :: LedgerState TestBlock
testInitLedger = PayloadDependentState () -> LedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> LedgerState (TestBlockWith ptype)
testInitLedgerWithState ()

testInitExtLedger :: ExtLedgerState TestBlock
testInitExtLedger :: ExtLedgerState TestBlock
testInitExtLedger = PayloadDependentState () -> ExtLedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState ()

-- | Trivial test configuration with a single core node
singleNodeTestConfig :: TopLevelConfig TestBlock
singleNodeTestConfig :: TopLevelConfig TestBlock
singleNodeTestConfig = SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK (Word64 -> SecurityParam
SecurityParam Word64
4)

singleNodeTestConfigWithK :: SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK :: SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK SecurityParam
k =
  CodecConfig TestBlock
-> StorageConfig TestBlock
-> SecurityParam
-> GenesisWindow
-> TopLevelConfig TestBlock
forall ptype.
CodecConfig (TestBlockWith ptype)
-> StorageConfig (TestBlockWith ptype)
-> SecurityParam
-> GenesisWindow
-> TopLevelConfig (TestBlockWith ptype)
singleNodeTestConfigWith CodecConfig TestBlock
TestBlockCodecConfig StorageConfig TestBlock
TestBlockStorageConfig SecurityParam
k (Word64 -> GenesisWindow
GenesisWindow (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* SecurityParam -> Word64
maxRollbacks SecurityParam
k))

{-------------------------------------------------------------------------------
  Chain of blocks (without payload)
-------------------------------------------------------------------------------}

newtype BlockChain = BlockChain Word64
  deriving (Int -> BlockChain -> ShowS
[BlockChain] -> ShowS
BlockChain -> String
(Int -> BlockChain -> ShowS)
-> (BlockChain -> String)
-> ([BlockChain] -> ShowS)
-> Show BlockChain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockChain -> ShowS
showsPrec :: Int -> BlockChain -> ShowS
$cshow :: BlockChain -> String
show :: BlockChain -> String
$cshowList :: [BlockChain] -> ShowS
showList :: [BlockChain] -> ShowS
Show)

blockChain :: BlockChain -> Chain TestBlock
blockChain :: BlockChain -> Chain TestBlock
blockChain = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst ([TestBlock] -> Chain TestBlock)
-> (BlockChain -> [TestBlock]) -> BlockChain -> Chain TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockChain -> [TestBlock]
chainToBlocks

chainToBlocks :: BlockChain -> [TestBlock]
chainToBlocks :: BlockChain -> [TestBlock]
chainToBlocks (BlockChain Word64
c) =
    Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
c) ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$ (TestBlock -> TestBlock) -> TestBlock -> [TestBlock]
forall a. (a -> a) -> a -> [a]
iterate TestBlock -> TestBlock
successorBlock (Word64 -> TestBlock
firstBlock Word64
0)

instance Arbitrary BlockChain where
  arbitrary :: Gen BlockChain
arbitrary = Word64 -> BlockChain
BlockChain (Word64 -> BlockChain) -> Gen Word64 -> Gen BlockChain
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
0, Word64
30)
  shrink :: BlockChain -> [BlockChain]
shrink (BlockChain Word64
c) = Word64 -> BlockChain
BlockChain (Word64 -> BlockChain) -> [Word64] -> [BlockChain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
c

-- | See 'firstBlockWithPayload'.
firstBlock :: Word64 -> TestBlock
firstBlock :: Word64 -> TestBlock
firstBlock Word64
forkNo = Word64 -> () -> TestBlock
forall ptype. Word64 -> ptype -> TestBlockWith ptype
firstBlockWithPayload Word64
forkNo ()

-- | See 'successorBlockWithPayload'.
successorBlock :: TestBlock -> TestBlock
successorBlock :: TestBlock -> TestBlock
successorBlock TestBlockWith{TestHash
tbHash :: forall ptype. TestBlockWith ptype -> TestHash
tbHash :: TestHash
tbHash, SlotNo
tbSlot :: forall ptype. TestBlockWith ptype -> SlotNo
tbSlot :: SlotNo
tbSlot} = TestHash -> SlotNo -> () -> TestBlock
forall ptype. TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload TestHash
tbHash SlotNo
tbSlot ()

-- Modify the (last) fork number of the given block:
-- @g@ -> @[.., f]@ -> @[.., g f]@
-- The 'SlotNo' is left unchanged.
modifyFork :: (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork :: (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork Word64 -> Word64
g tb :: TestBlock
tb@TestBlockWith{ tbHash :: forall ptype. TestBlockWith ptype -> TestHash
tbHash = UnsafeTestHash (Word64
f NE.:| [Word64]
h) } = TestBlock
tb
    { tbHash = let !gf = Word64 -> Word64
g Word64
f in UnsafeTestHash (gf NE.:| h)
    }

-- Increase the fork number of the given block:
-- @[.., f]@ -> @[.., f+1]@
-- The 'SlotNo' is left unchanged.
--
-- In Zipper parlance, this corresponds to going right in a tree.
forkBlock :: TestBlock -> TestBlock
forkBlock :: TestBlock -> TestBlock
forkBlock = (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork Word64 -> Word64
forall a. Enum a => a -> a
succ

{-------------------------------------------------------------------------------
  Tree of blocks (without payload)
-------------------------------------------------------------------------------}

newtype BlockTree = BlockTree (Tree ())

blockTree :: BlockTree -> Tree TestBlock
blockTree :: BlockTree -> Tree TestBlock
blockTree (BlockTree Tree ()
t) = TestBlock -> Tree () -> Tree TestBlock
go (Word64 -> TestBlock
firstBlock Word64
0) Tree ()
t
  where
    go :: TestBlock -> Tree () -> Tree TestBlock
    go :: TestBlock -> Tree () -> Tree TestBlock
go TestBlock
b (Node () [Tree ()]
ts) = TestBlock -> [Tree TestBlock] -> Tree TestBlock
forall a. a -> [Tree a] -> Tree a
Node TestBlock
b ((TestBlock -> Tree () -> Tree TestBlock)
-> [TestBlock] -> [Tree ()] -> [Tree TestBlock]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TestBlock -> Tree () -> Tree TestBlock
go [TestBlock]
bs [Tree ()]
ts)
      where
        -- The first child of a node is the sucessor of b ("go down"), each
        -- subsequent child is a "fork" ("go right")
        bs :: [TestBlock]
bs = (TestBlock -> TestBlock) -> TestBlock -> [TestBlock]
forall a. (a -> a) -> a -> [a]
iterate TestBlock -> TestBlock
forkBlock (TestBlock -> TestBlock
successorBlock TestBlock
b)

treeToBlocks :: BlockTree -> [TestBlock]
treeToBlocks :: BlockTree -> [TestBlock]
treeToBlocks = Tree TestBlock -> [TestBlock]
forall a. Tree a -> [a]
Tree.flatten (Tree TestBlock -> [TestBlock])
-> (BlockTree -> Tree TestBlock) -> BlockTree -> [TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree -> Tree TestBlock
blockTree

treeToChains :: BlockTree -> [Chain TestBlock]
treeToChains :: BlockTree -> [Chain TestBlock]
treeToChains = ([TestBlock] -> Chain TestBlock)
-> [[TestBlock]] -> [Chain TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst ([[TestBlock]] -> [Chain TestBlock])
-> (BlockTree -> [[TestBlock]]) -> BlockTree -> [Chain TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree TestBlock -> [[TestBlock]]
forall a. Tree a -> [[a]]
allPaths (Tree TestBlock -> [[TestBlock]])
-> (BlockTree -> Tree TestBlock) -> BlockTree -> [[TestBlock]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree -> Tree TestBlock
blockTree

treePreferredChain :: BlockTree -> Chain TestBlock
treePreferredChain :: BlockTree -> Chain TestBlock
treePreferredChain =
      Chain TestBlock -> Maybe (Chain TestBlock) -> Chain TestBlock
forall a. a -> Maybe a -> a
fromMaybe Chain TestBlock
forall block. Chain block
Genesis
    (Maybe (Chain TestBlock) -> Chain TestBlock)
-> (BlockTree -> Maybe (Chain TestBlock))
-> BlockTree
-> Chain TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Bft BftMockCrypto)
-> ChainOrderConfig (SelectView (Bft BftMockCrypto))
-> (TestBlock -> SelectView (Bft BftMockCrypto))
-> Chain TestBlock
-> [Chain TestBlock]
-> Maybe (Chain TestBlock)
forall p (proxy :: * -> *) hdr.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [Chain hdr]
-> Maybe (Chain hdr)
selectUnvalidatedChain
        (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol TestBlock))
        (() :: ChainOrderConfig (SelectView (BlockProtocol TestBlock)))
        TestBlock -> BlockNo
TestBlock -> SelectView (Bft BftMockCrypto)
forall b. HasHeader b => b -> BlockNo
blockNo
        Chain TestBlock
forall block. Chain block
Genesis
    ([Chain TestBlock] -> Maybe (Chain TestBlock))
-> (BlockTree -> [Chain TestBlock])
-> BlockTree
-> Maybe (Chain TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree -> [Chain TestBlock]
treeToChains

instance Show BlockTree where
  show :: BlockTree -> String
show (BlockTree Tree ()
t) = Tree String -> String
Tree.drawTree ((() -> String) -> Tree () -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> String
forall a. Show a => a -> String
show Tree ()
t)

instance Arbitrary BlockTree where
  arbitrary :: Gen BlockTree
arbitrary = (Int -> Gen BlockTree) -> Gen BlockTree
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen BlockTree) -> Gen BlockTree)
-> (Int -> Gen BlockTree) -> Gen BlockTree
forall a b. (a -> b) -> a -> b
$ \Int
n ->
      Tree () -> BlockTree
BlockTree (Tree () -> BlockTree) -> Gen (Tree ()) -> Gen BlockTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> [()] -> Gen (Tree ())
forall a. Double -> [a] -> Gen (Tree a)
mkTree Double
0.2 (Int -> () -> [()]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n) ())
  shrink :: BlockTree -> [BlockTree]
shrink (BlockTree Tree ()
t) =
      Tree () -> BlockTree
BlockTree (Tree () -> BlockTree) -> [Tree ()] -> [BlockTree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree () -> [Tree ()]
forall a. Tree a -> [Tree a]
shrinkTree Tree ()
t

{-------------------------------------------------------------------------------
  Generic auxiliary
-------------------------------------------------------------------------------}

-- | Construct random binary tree from given set of elements
mkTree :: forall a.
          Double -- ^ Likelyhood of branching at any point
       -> [a] -> Gen (Tree a)
mkTree :: forall a. Double -> [a] -> Gen (Tree a)
mkTree Double
threshold = [a] -> Gen (Tree a)
go
  where
    go :: [a] -> Gen (Tree a)
    go :: [a] -> Gen (Tree a)
go []     = String -> Gen (Tree a)
forall a. HasCallStack => String -> a
error String
"go: no elements"
    go [a
a]    = Tree a -> Gen (Tree a)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree a -> Gen (Tree a)) -> Tree a -> Gen (Tree a)
forall a b. (a -> b) -> a -> b
$ a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a []
    go (a
a:[a]
as) = do Double
n <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
1)
                   if Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
threshold Bool -> Bool -> Bool
|| [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right
                     then (\Tree a
t   -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a [Tree a
t])    (Tree a -> Tree a) -> Gen (Tree a) -> Gen (Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Gen (Tree a)
go [a]
as
                     else (\Tree a
l Tree a
r -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a [Tree a
l, Tree a
r]) (Tree a -> Tree a -> Tree a)
-> Gen (Tree a) -> Gen (Tree a -> Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Gen (Tree a)
go [a]
left Gen (Tree a -> Tree a) -> Gen (Tree a) -> Gen (Tree a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> Gen (Tree a)
go [a]
right
      where
        ([a]
left, [a]
right) = [a] -> ([a], [a])
forall a. [a] -> ([a], [a])
split [a]
as

-- | Shrink tree (without shrinking any elements)
shrinkTree :: Tree a -> [Tree a]
shrinkTree :: forall a. Tree a -> [Tree a]
shrinkTree (Node a
a [Tree a]
ts) = ([Tree a] -> Tree a) -> [[Tree a]] -> [Tree a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a) ((Tree a -> [Tree a]) -> [Tree a] -> [[Tree a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList Tree a -> [Tree a]
forall a. Tree a -> [Tree a]
shrinkTree [Tree a]
ts)
                         -- Also try shrinking all subtrees at once
                      [Tree a] -> [Tree a] -> [Tree a]
forall a. [a] -> [a] -> [a]
++ ([Tree a] -> Tree a) -> [[Tree a]] -> [Tree a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a) ([[Tree a]] -> [[Tree a]]
forall a. [[a]] -> [[a]]
transpose ((Tree a -> [Tree a]) -> [Tree a] -> [[Tree a]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [Tree a]
forall a. Tree a -> [Tree a]
shrinkTree [Tree a]
ts))


-- | Split list into two
--
-- > split [1..6] == ([1,3,5],[2,4,6])
-- > take 5 (fst (split [1..])) == [1,3,5,7,9]
-- > take 5 (snd (split [1..])) == [2,4,6,8,10]
split :: [a] -> ([a], [a])
split :: forall a. [a] -> ([a], [a])
split []     = ([], [])
split (a
a:[a]
as) = let ([a]
xs, [a]
ys) = [a] -> ([a], [a])
forall a. [a] -> ([a], [a])
split [a]
as in (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, [a]
xs)

-- | All paths through a tree
allPaths :: Tree a -> [[a]]
allPaths :: forall a. Tree a -> [[a]]
allPaths Tree a
t = [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Tree a -> [[a]]
forall a. Tree a -> [[a]]
nonEmptyPaths Tree a
t

nonEmptyPaths :: Tree a -> [[a]]
nonEmptyPaths :: forall a. Tree a -> [[a]]
nonEmptyPaths (Node a
a [Tree a]
ts) = [a
a] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((Tree a -> [[a]]) -> [Tree a] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [[a]]
forall a. Tree a -> [[a]]
nonEmptyPaths [Tree a]
ts)

{-------------------------------------------------------------------------------
  Test auxiliary
-------------------------------------------------------------------------------}

newtype Permutation = Permutation Int
  deriving (Int -> Permutation -> ShowS
[Permutation] -> ShowS
Permutation -> String
(Int -> Permutation -> ShowS)
-> (Permutation -> String)
-> ([Permutation] -> ShowS)
-> Show Permutation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Permutation -> ShowS
showsPrec :: Int -> Permutation -> ShowS
$cshow :: Permutation -> String
show :: Permutation -> String
$cshowList :: [Permutation] -> ShowS
showList :: [Permutation] -> ShowS
Show)

instance Arbitrary Permutation where
  arbitrary :: Gen Permutation
arbitrary = Int -> Permutation
Permutation (Int -> Permutation) -> (Int64 -> Int) -> Int64 -> Permutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
cast (Int64 -> Permutation) -> Gen Int64 -> Gen Permutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int64
forall a. Arbitrary a => Gen a
arbitrary
    where
      -- Use the generator for 'Int64' (rather than 'Int') as it is not biased
      -- towards small values
      cast :: Int64 -> Int
      cast :: Int64 -> Int
cast = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

  -- Doesn't make sense to shrink PRNG seed
  shrink :: Permutation -> [Permutation]
shrink Permutation
_ = []

permute :: Permutation -> [a] -> [a]
permute :: forall a. Permutation -> [a] -> [a]
permute (Permutation Int
n) = StdGen -> [a] -> [a]
forall a. StdGen -> [a] -> [a]
go (Int -> StdGen
R.mkStdGen Int
n)
  where
    go :: R.StdGen -> [a] -> [a]
    go :: forall a. StdGen -> [a] -> [a]
go StdGen
_ [] = []
    go StdGen
g [a]
as = let (Int
i, StdGen
g')           = (Int, Int) -> StdGen -> (Int, StdGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
R.randomR (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StdGen
g
                  ([a]
before, a
a:[a]
after) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
as
              in a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: StdGen -> [a] -> [a]
forall a. StdGen -> [a] -> [a]
go StdGen
g' ([a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
after)

{-------------------------------------------------------------------------------
  Additional serialisation instances
-------------------------------------------------------------------------------}

instance Serialise (AnnTip (TestBlockWith ptype)) where
  encode :: AnnTip (TestBlockWith ptype) -> Encoding
encode = (HeaderHash (TestBlockWith ptype) -> Encoding)
-> AnnTip (TestBlockWith ptype) -> Encoding
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
defaultEncodeAnnTip HeaderHash (TestBlockWith ptype) -> Encoding
TestHash -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: forall s. Decoder s (AnnTip (TestBlockWith ptype))
decode = (forall s. Decoder s (HeaderHash (TestBlockWith ptype)))
-> forall s. Decoder s (AnnTip (TestBlockWith ptype))
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
defaultDecodeAnnTip Decoder s (HeaderHash (TestBlockWith ptype))
Decoder s TestHash
forall s. Decoder s (HeaderHash (TestBlockWith ptype))
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode

instance PayloadSemantics ptype => Serialise (ExtLedgerState (TestBlockWith ptype)) where
  encode :: ExtLedgerState (TestBlockWith ptype) -> Encoding
encode = (LedgerState (TestBlockWith ptype) -> Encoding)
-> (ChainDepState (BlockProtocol (TestBlockWith ptype))
    -> Encoding)
-> (AnnTip (TestBlockWith ptype) -> Encoding)
-> ExtLedgerState (TestBlockWith ptype)
-> Encoding
forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState LedgerState (TestBlockWith ptype) -> Encoding
forall a. Serialise a => a -> Encoding
encode () -> Encoding
ChainDepState (BlockProtocol (TestBlockWith ptype)) -> Encoding
forall a. Serialise a => a -> Encoding
encode AnnTip (TestBlockWith ptype) -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: forall s. Decoder s (ExtLedgerState (TestBlockWith ptype))
decode = (forall s. Decoder s (LedgerState (TestBlockWith ptype)))
-> (forall s.
    Decoder s (ChainDepState (BlockProtocol (TestBlockWith ptype))))
-> (forall s. Decoder s (AnnTip (TestBlockWith ptype)))
-> forall s. Decoder s (ExtLedgerState (TestBlockWith ptype))
forall blk.
(forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState Decoder s (LedgerState (TestBlockWith ptype))
forall s. Decoder s (LedgerState (TestBlockWith ptype))
forall a s. Serialise a => Decoder s a
decode Decoder s ()
Decoder s (ChainDepState (BlockProtocol (TestBlockWith ptype)))
forall s. Decoder s ()
forall s.
Decoder s (ChainDepState (BlockProtocol (TestBlockWith ptype)))
forall a s. Serialise a => Decoder s a
decode Decoder s (AnnTip (TestBlockWith ptype))
forall s. Decoder s (AnnTip (TestBlockWith ptype))
forall a s. Serialise a => Decoder s a
decode

instance Serialise (RealPoint (TestBlockWith ptype)) where
  encode :: RealPoint (TestBlockWith ptype) -> Encoding
encode = (HeaderHash (TestBlockWith ptype) -> Encoding)
-> RealPoint (TestBlockWith ptype) -> Encoding
forall blk.
(HeaderHash blk -> Encoding) -> RealPoint blk -> Encoding
encodeRealPoint HeaderHash (TestBlockWith ptype) -> Encoding
TestHash -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: forall s. Decoder s (RealPoint (TestBlockWith ptype))
decode = (forall s. Decoder s (HeaderHash (TestBlockWith ptype)))
-> forall s. Decoder s (RealPoint (TestBlockWith ptype))
forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint Decoder s (HeaderHash (TestBlockWith ptype))
Decoder s TestHash
forall s. Decoder s (HeaderHash (TestBlockWith ptype))
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode

-- 'ConvertRawHash' expects a constant-size hash. As a compromise, we allow to
-- encode hashes with a block length of up to 100.
instance ConvertRawHash (TestBlockWith ptype) where
  -- 8 + 100 * 8: size of the list, and its elements, one Word64 each
  hashSize :: forall (proxy :: * -> *). proxy (TestBlockWith ptype) -> Word32
hashSize proxy (TestBlockWith ptype)
_ = Word32
808
  toRawHash :: forall (proxy :: * -> *).
proxy (TestBlockWith ptype)
-> HeaderHash (TestBlockWith ptype) -> ByteString
toRawHash proxy (TestBlockWith ptype)
_ (TestHash NonEmpty Word64
h)
      | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100 = String -> ByteString
forall a. HasCallStack => String -> a
error String
"hash too long"
      | Bool
otherwise      = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
          Word64 -> Put
Put.putWord64le (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
          NonEmpty Word64 -> (Word64 -> Put) -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty Word64
h Word64 -> Put
Put.putWord64le
          Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ Word64 -> Put
Put.putWord64le Word64
0
    where
      len :: Int
len = NonEmpty Word64 -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Word64
h
  fromRawHash :: forall (proxy :: * -> *).
proxy (TestBlockWith ptype)
-> ByteString -> HeaderHash (TestBlockWith ptype)
fromRawHash proxy (TestBlockWith ptype)
_ ByteString
bs = (Get TestHash -> ByteString -> HeaderHash (TestBlockWith ptype))
-> ByteString -> Get TestHash -> HeaderHash (TestBlockWith ptype)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get TestHash -> ByteString -> HeaderHash (TestBlockWith ptype)
Get TestHash -> ByteString -> TestHash
forall a. Get a -> ByteString -> a
Get.runGet (ByteString -> ByteString
BL.fromStrict ByteString
bs) (Get TestHash -> HeaderHash (TestBlockWith ptype))
-> Get TestHash -> HeaderHash (TestBlockWith ptype)
forall a b. (a -> b) -> a -> b
$ do
      Int
len <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
Get.getWord64le
      ([Word64] -> Maybe (NonEmpty Word64)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty -> Just NonEmpty Word64
h, [Word64]
rs) <-
        Int -> [Word64] -> ([Word64], [Word64])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len ([Word64] -> ([Word64], [Word64]))
-> Get [Word64] -> Get ([Word64], [Word64])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
100 Get Word64
Get.getWord64le
      Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> Bool -> Get ()
forall a b. (a -> b) -> a -> b
$ (Word64 -> Bool) -> [Word64] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word64
0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
==) [Word64]
rs
      TestHash -> Get TestHash
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestHash -> Get TestHash) -> TestHash -> Get TestHash
forall a b. (a -> b) -> a -> b
$ NonEmpty Word64 -> TestHash
TestHash NonEmpty Word64
h

instance Serialise ptype => EncodeDisk (TestBlockWith ptype) (TestBlockWith ptype)
instance Serialise ptype => DecodeDisk (TestBlockWith ptype) (BL.ByteString -> TestBlockWith ptype) where
  decodeDisk :: CodecConfig (TestBlockWith ptype)
-> forall s. Decoder s (ByteString -> TestBlockWith ptype)
decodeDisk CodecConfig (TestBlockWith ptype)
_ = TestBlockWith ptype -> ByteString -> TestBlockWith ptype
forall a b. a -> b -> a
const (TestBlockWith ptype -> ByteString -> TestBlockWith ptype)
-> Decoder s (TestBlockWith ptype)
-> Decoder s (ByteString -> TestBlockWith ptype)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (TestBlockWith ptype)
forall s. Decoder s (TestBlockWith ptype)
forall a s. Serialise a => Decoder s a
decode

instance Serialise ptype => EncodeDisk (TestBlockWith ptype) (Header (TestBlockWith ptype))
instance Serialise ptype => DecodeDisk (TestBlockWith ptype) (BL.ByteString -> Header (TestBlockWith ptype)) where
  decodeDisk :: CodecConfig (TestBlockWith ptype)
-> forall s. Decoder s (ByteString -> Header (TestBlockWith ptype))
decodeDisk CodecConfig (TestBlockWith ptype)
_ = Header (TestBlockWith ptype)
-> ByteString -> Header (TestBlockWith ptype)
forall a b. a -> b -> a
const (Header (TestBlockWith ptype)
 -> ByteString -> Header (TestBlockWith ptype))
-> Decoder s (Header (TestBlockWith ptype))
-> Decoder s (ByteString -> Header (TestBlockWith ptype))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Header (TestBlockWith ptype))
forall s. Decoder s (Header (TestBlockWith ptype))
forall a s. Serialise a => Decoder s a
decode

instance EncodeDisk (TestBlockWith ptype) (AnnTip (TestBlockWith ptype))
instance DecodeDisk (TestBlockWith ptype) (AnnTip (TestBlockWith ptype))

instance ReconstructNestedCtxt Header (TestBlockWith ptype)

instance PayloadSemantics ptype => EncodeDisk (TestBlockWith ptype) (LedgerState (TestBlockWith ptype))
instance PayloadSemantics ptype => DecodeDisk (TestBlockWith ptype) (LedgerState (TestBlockWith ptype))

instance Serialise ptype => EncodeDiskDep (NestedCtxt Header) (TestBlockWith ptype)
instance Serialise ptype => DecodeDiskDep (NestedCtxt Header) (TestBlockWith ptype)

-- ChainDepState (BlockProtocol (TestBlockWith ptype)) ~ ()
instance EncodeDisk (TestBlockWith ptype) ()
instance DecodeDisk (TestBlockWith ptype) ()

-- Header (TestBlockWith ptype) is a newtype around TestBlockWith ptype
instance Serialise ptype => HasBinaryBlockInfo (TestBlockWith ptype) where
  getBinaryBlockInfo :: TestBlockWith ptype -> BinaryBlockInfo
getBinaryBlockInfo TestBlockWith ptype
blk = BinaryBlockInfo {
        headerOffset :: Word16
headerOffset = Word16
0
      , headerSize :: Word16
headerSize   = Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16)
-> (TestBlockWith ptype -> Int64) -> TestBlockWith ptype -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Int64)
-> (TestBlockWith ptype -> ByteString)
-> TestBlockWith ptype
-> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlockWith ptype -> ByteString
forall a. Serialise a => a -> ByteString
serialise (TestBlockWith ptype -> Word16) -> TestBlockWith ptype -> Word16
forall a b. (a -> b) -> a -> b
$ TestBlockWith ptype
blk
      }

instance (Serialise ptype, PayloadSemantics ptype) => SerialiseDiskConstraints (TestBlockWith ptype)

-----

deriving via SelectViewDiffusionPipelining (TestBlockWith ptype)
  instance BlockSupportsProtocol (TestBlockWith ptype)
  => BlockSupportsDiffusionPipelining (TestBlockWith ptype)

-----

-- | Given a point to a chain of length L, generates a 'SwitchFork' that
-- switches to the "next" block of length L, where "next" is determined by
-- interpreting the "forks" in the 'TestHash' as binary digits (except the
-- deepest, which is a simple counter).
--
-- For example, the following are input and outputs for a chains of length 3,
-- where the 'TestHash'es and 'Point's are denoted by numerals (the 'SlotNo' is
-- merely the number of digits).
--
-- @
-- 000 :-> [RollBack 00, AddBlock 001]
-- 001 :-> [RollBack 0 , AddBlock 01 , AddBlock 010]
-- 010 :-> [RollBack 01, AddBlock 011]
-- 011 :-> [RollBack G , AddBlock 1  , AddBlock 10 , AddBlock 100]
--
-- 100 :-> [RollBack 10, AddBlock 101]
-- 101 :-> [RollBack 1 , AddBlock 11 , AddBlock 110]
-- 110 :-> [RollBack 11, AddBlock 111]
-- 111 :-> [RollBack G , AddBlock 2  , AddBlock 20 , AddBlock 200]
--
-- 200 :-> [RollBack 20, AddBlock 201]
-- 201 :-> [RollBack 2 , AddBlock 21 , AddBlock 210]
-- 210 :-> [RollBack 21, AddBlock 211]
-- 211 :-> [RollBack G , AddBlock 3  , AddBlock 30 , AddBlock 300]
--
-- etc
-- @
updateToNextNumeral :: RealPoint TestBlock -> (Point TestBlock, NonEmpty TestBlock)
updateToNextNumeral :: RealPoint TestBlock -> (Point TestBlock, NonEmpty TestBlock)
updateToNextNumeral RealPoint TestBlock
rp0 =
    let TestHash (Word64
fork :| [Word64]
forks) = HeaderHash TestBlock
hash0 in Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
go (Int
0 :: Int) Word64
fork [Word64]
forks
  where
    RealPoint SlotNo
slot0 HeaderHash TestBlock
hash0 = RealPoint TestBlock
rp0

    go :: Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
go !Int
depth Word64
fork = \case
        []            -> Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
rebuild Int
depth (Word64
fork Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) []
        Word64
fork2 : [Word64]
forks ->
            if Word64
0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
fork then Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
rebuild Int
depth Word64
1 (Word64
fork2 Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: [Word64]
forks) else
                Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word64
fork2 [Word64]
forks

    rebuild :: Int -> Word64 -> [Word64] -> (Point TestBlock, NonEmpty TestBlock)
rebuild Int
depth Word64
fork' [Word64]
forks =
        let islot :: SlotNo
islot  = SlotNo
slot0 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- Int -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1
            ipoint :: Point TestBlock
ipoint = case [Word64] -> Maybe (NonEmpty Word64)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Word64]
forks of
                Maybe (NonEmpty Word64)
Nothing -> Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint
                Just NonEmpty Word64
ne -> SlotNo -> HeaderHash TestBlock -> Point TestBlock
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
islot (NonEmpty Word64 -> TestHash
TestHash NonEmpty Word64
ne)

            next :: TestBlock
next = TestBlockWith {
                tbHash :: TestHash
tbHash    = NonEmpty Word64 -> TestHash
TestHash (Word64
fork' Word64 -> [Word64] -> NonEmpty Word64
forall a. a -> [a] -> NonEmpty a
:| [Word64]
forks)
              , tbSlot :: SlotNo
tbSlot    = SlotNo
islot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
              , tbValid :: Validity
tbValid   = Validity
Valid
              , tbPayload :: ()
tbPayload = ()
              }
        in
        (Point TestBlock
ipoint, NonEmpty TestBlock -> Int -> NonEmpty TestBlock
forall {t}.
(Eq t, Num t) =>
NonEmpty TestBlock -> t -> NonEmpty TestBlock
go' (TestBlock
next TestBlock -> [TestBlock] -> NonEmpty TestBlock
forall a. a -> [a] -> NonEmpty a
:| []) Int
depth)

    go' :: NonEmpty TestBlock -> t -> NonEmpty TestBlock
go' NonEmpty TestBlock
ne = \case
        t
0     -> NonEmpty TestBlock -> NonEmpty TestBlock
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty TestBlock
ne
        t
depth ->
            NonEmpty TestBlock -> t -> NonEmpty TestBlock
go'
                (TestBlock -> TestBlock
successorBlock (NonEmpty TestBlock -> TestBlock
forall a. NonEmpty a -> a
NE.head NonEmpty TestBlock
ne) TestBlock -> NonEmpty TestBlock -> NonEmpty TestBlock
forall a. a -> NonEmpty a -> NonEmpty a
`NE.cons` NonEmpty TestBlock
ne)
                (t
depth t -> t -> t
forall a. Num a => a -> a -> a
- t
1)