{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Bench.Consensus.Mempool.TestBlock
  ( -- * Test block
    TestBlock

    -- * Initial parameters
  , initialLedgerState
  , mkInitialLedgerState
  , advanceTip
  , sampleLedgerConfig

    -- * Transactions
  , Token (Token)
  , Tx (Tx)
  , mkTx
  , txSize
  ) where

import Cardano.Ledger.BaseTypes (knownNonZeroBounded)
import qualified Cardano.Slotting.Time as Time
import Codec.Serialise (Serialise (..))
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Except (except)
import qualified Data.Map.Strict as Map
import Data.MemPack
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff (ToExpr)
import Data.Word (Word64)
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import qualified Ouroboros.Consensus.Block as Block
import Ouroboros.Consensus.Block.SupportsPeras (pattern PerasEnabled)
import Ouroboros.Consensus.Config.SecurityParam as Consensus
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger
import Ouroboros.Consensus.Ledger.Tables
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
import qualified Ouroboros.Consensus.Ledger.Tables.Utils as Ledger
import Ouroboros.Consensus.Util.IndexedMemPack (IndexedMemPack (..))
import System.Environment (lookupEnv)
import System.IO.Unsafe (unsafePerformIO)
import Test.Util.TestBlock hiding (TestBlock)
import Text.Read (readMaybe)

{-------------------------------------------------------------------------------
  MempoolTestBlock
-------------------------------------------------------------------------------}

type TestBlock = TestBlockWith Tx

data Tx = Tx
  { Tx -> Set Token
consumed :: !(Set Token)
  , Tx -> Set Token
produced :: !(Set Token)
  }
  deriving stock (Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
/= :: Tx -> Tx -> Bool
Eq, Eq Tx
Eq Tx =>
(Tx -> Tx -> Ordering)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Tx)
-> (Tx -> Tx -> Tx)
-> Ord Tx
Tx -> Tx -> Bool
Tx -> Tx -> Ordering
Tx -> Tx -> Tx
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 :: Tx -> Tx -> Ordering
compare :: Tx -> Tx -> Ordering
$c< :: Tx -> Tx -> Bool
< :: Tx -> Tx -> Bool
$c<= :: Tx -> Tx -> Bool
<= :: Tx -> Tx -> Bool
$c> :: Tx -> Tx -> Bool
> :: Tx -> Tx -> Bool
$c>= :: Tx -> Tx -> Bool
>= :: Tx -> Tx -> Bool
$cmax :: Tx -> Tx -> Tx
max :: Tx -> Tx -> Tx
$cmin :: Tx -> Tx -> Tx
min :: Tx -> Tx -> Tx
Ord, (forall x. Tx -> Rep Tx x)
-> (forall x. Rep Tx x -> Tx) -> Generic Tx
forall x. Rep Tx x -> Tx
forall x. Tx -> Rep Tx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tx -> Rep Tx x
from :: forall x. Tx -> Rep Tx x
$cto :: forall x. Rep Tx x -> Tx
to :: forall x. Rep Tx x -> Tx
Generic, Int -> Tx -> ShowS
[Tx] -> ShowS
Tx -> String
(Int -> Tx -> ShowS)
-> (Tx -> String) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tx -> ShowS
showsPrec :: Int -> Tx -> ShowS
$cshow :: Tx -> String
show :: Tx -> String
$cshowList :: [Tx] -> ShowS
showList :: [Tx] -> ShowS
Show)
  deriving anyclass (Context -> Tx -> IO (Maybe ThunkInfo)
Proxy Tx -> String
(Context -> Tx -> IO (Maybe ThunkInfo))
-> (Context -> Tx -> IO (Maybe ThunkInfo))
-> (Proxy Tx -> String)
-> NoThunks Tx
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Tx -> String
showTypeOf :: Proxy Tx -> String
NoThunks, Tx -> ()
(Tx -> ()) -> NFData Tx
forall a. (a -> ()) -> NFData a
$crnf :: Tx -> ()
rnf :: Tx -> ()
NFData)

newtype Token = Token {Token -> Int
unToken :: Int}
  deriving stock (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
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 :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$c< :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord, (forall x. Token -> Rep Token x)
-> (forall x. Rep Token x -> Token) -> Generic Token
forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Token -> Rep Token x
from :: forall x. Token -> Rep Token x
$cto :: forall x. Rep Token x -> Token
to :: forall x. Rep Token x -> Token
Generic)
  deriving newtype (String
String
-> (Token -> Int)
-> (forall s. Token -> Pack s ())
-> (forall b s. Buffer b => Unpack s b Token)
-> MemPack Token
Token -> Int
forall a.
String
-> (a -> Int)
-> (forall s. a -> Pack s ())
-> (forall b s. Buffer b => Unpack s b a)
-> MemPack a
forall s. Token -> Pack s ()
forall b s. Buffer b => Unpack s b Token
$ctypeName :: String
typeName :: String
$cpackedByteCount :: Token -> Int
packedByteCount :: Token -> Int
$cpackM :: forall s. Token -> Pack s ()
packM :: forall s. Token -> Pack s ()
$cunpackM :: forall b s. Buffer b => Unpack s b Token
unpackM :: forall b s. Buffer b => Unpack s b Token
MemPack, Integer -> Token
Token -> Token
Token -> Token -> Token
(Token -> Token -> Token)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> (Token -> Token)
-> (Token -> Token)
-> (Token -> Token)
-> (Integer -> Token)
-> Num Token
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Token -> Token -> Token
+ :: Token -> Token -> Token
$c- :: Token -> Token -> Token
- :: Token -> Token -> Token
$c* :: Token -> Token -> Token
* :: Token -> Token -> Token
$cnegate :: Token -> Token
negate :: Token -> Token
$cabs :: Token -> Token
abs :: Token -> Token
$csignum :: Token -> Token
signum :: Token -> Token
$cfromInteger :: Integer -> Token
fromInteger :: Integer -> Token
Num, Int -> Token
Token -> Int
Token -> [Token]
Token -> Token
Token -> Token -> [Token]
Token -> Token -> Token -> [Token]
(Token -> Token)
-> (Token -> Token)
-> (Int -> Token)
-> (Token -> Int)
-> (Token -> [Token])
-> (Token -> Token -> [Token])
-> (Token -> Token -> [Token])
-> (Token -> Token -> Token -> [Token])
-> Enum Token
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 :: Token -> Token
succ :: Token -> Token
$cpred :: Token -> Token
pred :: Token -> Token
$ctoEnum :: Int -> Token
toEnum :: Int -> Token
$cfromEnum :: Token -> Int
fromEnum :: Token -> Int
$cenumFrom :: Token -> [Token]
enumFrom :: Token -> [Token]
$cenumFromThen :: Token -> Token -> [Token]
enumFromThen :: Token -> Token -> [Token]
$cenumFromTo :: Token -> Token -> [Token]
enumFromTo :: Token -> Token -> [Token]
$cenumFromThenTo :: Token -> Token -> Token -> [Token]
enumFromThenTo :: Token -> Token -> Token -> [Token]
Enum)
  deriving anyclass (Context -> Token -> IO (Maybe ThunkInfo)
Proxy Token -> String
(Context -> Token -> IO (Maybe ThunkInfo))
-> (Context -> Token -> IO (Maybe ThunkInfo))
-> (Proxy Token -> String)
-> NoThunks Token
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
noThunks :: Context -> Token -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Token -> String
showTypeOf :: Proxy Token -> String
NoThunks, [Token] -> Expr
Token -> Expr
(Token -> Expr) -> ([Token] -> Expr) -> ToExpr Token
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Token -> Expr
toExpr :: Token -> Expr
$clistToExpr :: [Token] -> Expr
listToExpr :: [Token] -> Expr
ToExpr, [Token] -> Encoding
Token -> Encoding
(Token -> Encoding)
-> (forall s. Decoder s Token)
-> ([Token] -> Encoding)
-> (forall s. Decoder s [Token])
-> Serialise Token
forall s. Decoder s [Token]
forall s. Decoder s Token
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Token -> Encoding
encode :: Token -> Encoding
$cdecode :: forall s. Decoder s Token
decode :: forall s. Decoder s Token
$cencodeList :: [Token] -> Encoding
encodeList :: [Token] -> Encoding
$cdecodeList :: forall s. Decoder s [Token]
decodeList :: forall s. Decoder s [Token]
Serialise, Token -> ()
(Token -> ()) -> NFData Token
forall a. (a -> ()) -> NFData a
$crnf :: Token -> ()
rnf :: Token -> ()
NFData)

mkTx ::
  -- | Consumed
  [Token] ->
  -- | Produced
  [Token] ->
  Ledger.GenTx TestBlock
mkTx :: [Token] -> [Token] -> GenTx (TestBlockWith Tx)
mkTx [Token]
cons [Token]
prod =
  Tx -> GenTx (TestBlockWith Tx)
TestBlockGenTx (Tx -> GenTx (TestBlockWith Tx)) -> Tx -> GenTx (TestBlockWith Tx)
forall a b. (a -> b) -> a -> b
$
    Tx
      { consumed :: Set Token
consumed = [Token] -> Set Token
forall a. Ord a => [a] -> Set a
Set.fromList [Token]
cons
      , produced :: Set Token
produced = [Token] -> Set Token
forall a. Ord a => [a] -> Set a
Set.fromList [Token]
prod
      }

{-------------------------------------------------------------------------------
  Initial parameters
-------------------------------------------------------------------------------}

initialLedgerState :: LedgerState (TestBlockWith Tx) ValuesMK
initialLedgerState :: LedgerState (TestBlockWith Tx) ValuesMK
initialLedgerState = [Token] -> LedgerState (TestBlockWith Tx) ValuesMK
mkInitialLedgerState []

-- | Like 'initialLedgerState' but seeded with a set of available tokens (the
-- UTxO). Chains of transactions can then be built by consuming a seed token and
-- producing the next one.
mkInitialLedgerState :: [Token] -> LedgerState (TestBlockWith Tx) ValuesMK
mkInitialLedgerState :: [Token] -> LedgerState (TestBlockWith Tx) ValuesMK
mkInitialLedgerState [Token]
toks =
  TestLedger
    { lastAppliedPoint :: Point (TestBlockWith Tx)
lastAppliedPoint = Point (TestBlockWith Tx)
forall {k} (block :: k). Point block
Block.GenesisPoint
    , payloadDependentState :: PayloadDependentState Tx ValuesMK
payloadDependentState =
        TestPLDS
          { getTestPLDS :: ValuesMK Token ()
getTestPLDS = Map Token () -> ValuesMK Token ()
forall k v. Map k v -> ValuesMK k v
ValuesMK ([(Token, ())] -> Map Token ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Token
t, ()) | Token
t <- [Token]
toks])
          }
    }

-- | Move the tip to a fresh point (distinct per @n@) while keeping the ledger
-- tables unchanged. Used to force the mempool to resync/revalidate against a
-- "new" tip without invalidating any of its transactions.
advanceTip ::
  Word64 -> LedgerState (TestBlockWith Tx) ValuesMK -> LedgerState (TestBlockWith Tx) ValuesMK
advanceTip :: Word64
-> LedgerState (TestBlockWith Tx) ValuesMK
-> LedgerState (TestBlockWith Tx) ValuesMK
advanceTip Word64
n LedgerState (TestBlockWith Tx) ValuesMK
st =
  LedgerState (TestBlockWith Tx) ValuesMK
st{lastAppliedPoint = Block.blockPoint (firstBlockWithPayload n (Tx Set.empty Set.empty))}

sampleLedgerConfig :: Ledger.LedgerConfig TestBlock
sampleLedgerConfig :: LedgerConfig (TestBlockWith Tx)
sampleLedgerConfig =
  EraParams -> TestBlockLedgerConfig
testBlockLedgerConfigFrom (EraParams -> TestBlockLedgerConfig)
-> EraParams -> TestBlockLedgerConfig
forall a b. (a -> b) -> a -> b
$
    SecurityParam -> SlotLength -> PerasEnabled () -> EraParams
HardFork.defaultEraParams
      (NonZero Word64 -> SecurityParam
Consensus.SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @10)
      (Integer -> SlotLength
Time.slotLengthFromSec Integer
2)
      (() -> PerasEnabled ()
forall a. a -> PerasEnabled a
PerasEnabled ())

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

data TestLedgerState = TestLedgerState
  { TestLedgerState -> Set Token
availableTokens :: !(Set Token)
  }
  deriving stock ((forall x. TestLedgerState -> Rep TestLedgerState x)
-> (forall x. Rep TestLedgerState x -> TestLedgerState)
-> Generic TestLedgerState
forall x. Rep TestLedgerState x -> TestLedgerState
forall x. TestLedgerState -> Rep TestLedgerState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestLedgerState -> Rep TestLedgerState x
from :: forall x. TestLedgerState -> Rep TestLedgerState x
$cto :: forall x. Rep TestLedgerState x -> TestLedgerState
to :: forall x. Rep TestLedgerState x -> TestLedgerState
Generic, TestLedgerState -> TestLedgerState -> Bool
(TestLedgerState -> TestLedgerState -> Bool)
-> (TestLedgerState -> TestLedgerState -> Bool)
-> Eq TestLedgerState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestLedgerState -> TestLedgerState -> Bool
== :: TestLedgerState -> TestLedgerState -> Bool
$c/= :: TestLedgerState -> TestLedgerState -> Bool
/= :: TestLedgerState -> TestLedgerState -> Bool
Eq, Int -> TestLedgerState -> ShowS
[TestLedgerState] -> ShowS
TestLedgerState -> String
(Int -> TestLedgerState -> ShowS)
-> (TestLedgerState -> String)
-> ([TestLedgerState] -> ShowS)
-> Show TestLedgerState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestLedgerState -> ShowS
showsPrec :: Int -> TestLedgerState -> ShowS
$cshow :: TestLedgerState -> String
show :: TestLedgerState -> String
$cshowList :: [TestLedgerState] -> ShowS
showList :: [TestLedgerState] -> ShowS
Show)
  deriving anyclass (Context -> TestLedgerState -> IO (Maybe ThunkInfo)
Proxy TestLedgerState -> String
(Context -> TestLedgerState -> IO (Maybe ThunkInfo))
-> (Context -> TestLedgerState -> IO (Maybe ThunkInfo))
-> (Proxy TestLedgerState -> String)
-> NoThunks TestLedgerState
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestLedgerState -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestLedgerState -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestLedgerState -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestLedgerState -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestLedgerState -> String
showTypeOf :: Proxy TestLedgerState -> String
NoThunks, [TestLedgerState] -> Expr
TestLedgerState -> Expr
(TestLedgerState -> Expr)
-> ([TestLedgerState] -> Expr) -> ToExpr TestLedgerState
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TestLedgerState -> Expr
toExpr :: TestLedgerState -> Expr
$clistToExpr :: [TestLedgerState] -> Expr
listToExpr :: [TestLedgerState] -> Expr
ToExpr, [TestLedgerState] -> Encoding
TestLedgerState -> Encoding
(TestLedgerState -> Encoding)
-> (forall s. Decoder s TestLedgerState)
-> ([TestLedgerState] -> Encoding)
-> (forall s. Decoder s [TestLedgerState])
-> Serialise TestLedgerState
forall s. Decoder s [TestLedgerState]
forall s. Decoder s TestLedgerState
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestLedgerState -> Encoding
encode :: TestLedgerState -> Encoding
$cdecode :: forall s. Decoder s TestLedgerState
decode :: forall s. Decoder s TestLedgerState
$cencodeList :: [TestLedgerState] -> Encoding
encodeList :: [TestLedgerState] -> Encoding
$cdecodeList :: forall s. Decoder s [TestLedgerState]
decodeList :: forall s. Decoder s [TestLedgerState]
Serialise)

data TxApplicationError
  = -- | The transaction could not be applied due to the given unavailable tokens.
    TxApplicationError {TxApplicationError -> Set Token
unavailable :: Set Token}
  deriving stock ((forall x. TxApplicationError -> Rep TxApplicationError x)
-> (forall x. Rep TxApplicationError x -> TxApplicationError)
-> Generic TxApplicationError
forall x. Rep TxApplicationError x -> TxApplicationError
forall x. TxApplicationError -> Rep TxApplicationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TxApplicationError -> Rep TxApplicationError x
from :: forall x. TxApplicationError -> Rep TxApplicationError x
$cto :: forall x. Rep TxApplicationError x -> TxApplicationError
to :: forall x. Rep TxApplicationError x -> TxApplicationError
Generic, TxApplicationError -> TxApplicationError -> Bool
(TxApplicationError -> TxApplicationError -> Bool)
-> (TxApplicationError -> TxApplicationError -> Bool)
-> Eq TxApplicationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxApplicationError -> TxApplicationError -> Bool
== :: TxApplicationError -> TxApplicationError -> Bool
$c/= :: TxApplicationError -> TxApplicationError -> Bool
/= :: TxApplicationError -> TxApplicationError -> Bool
Eq, Int -> TxApplicationError -> ShowS
[TxApplicationError] -> ShowS
TxApplicationError -> String
(Int -> TxApplicationError -> ShowS)
-> (TxApplicationError -> String)
-> ([TxApplicationError] -> ShowS)
-> Show TxApplicationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxApplicationError -> ShowS
showsPrec :: Int -> TxApplicationError -> ShowS
$cshow :: TxApplicationError -> String
show :: TxApplicationError -> String
$cshowList :: [TxApplicationError] -> ShowS
showList :: [TxApplicationError] -> ShowS
Show)
  deriving anyclass (Context -> TxApplicationError -> IO (Maybe ThunkInfo)
Proxy TxApplicationError -> String
(Context -> TxApplicationError -> IO (Maybe ThunkInfo))
-> (Context -> TxApplicationError -> IO (Maybe ThunkInfo))
-> (Proxy TxApplicationError -> String)
-> NoThunks TxApplicationError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TxApplicationError -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxApplicationError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxApplicationError -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TxApplicationError -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TxApplicationError -> String
showTypeOf :: Proxy TxApplicationError -> String
NoThunks, [TxApplicationError] -> Expr
TxApplicationError -> Expr
(TxApplicationError -> Expr)
-> ([TxApplicationError] -> Expr) -> ToExpr TxApplicationError
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TxApplicationError -> Expr
toExpr :: TxApplicationError -> Expr
$clistToExpr :: [TxApplicationError] -> Expr
listToExpr :: [TxApplicationError] -> Expr
ToExpr, [TxApplicationError] -> Encoding
TxApplicationError -> Encoding
(TxApplicationError -> Encoding)
-> (forall s. Decoder s TxApplicationError)
-> ([TxApplicationError] -> Encoding)
-> (forall s. Decoder s [TxApplicationError])
-> Serialise TxApplicationError
forall s. Decoder s [TxApplicationError]
forall s. Decoder s TxApplicationError
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TxApplicationError -> Encoding
encode :: TxApplicationError -> Encoding
$cdecode :: forall s. Decoder s TxApplicationError
decode :: forall s. Decoder s TxApplicationError
$cencodeList :: [TxApplicationError] -> Encoding
encodeList :: [TxApplicationError] -> Encoding
$cdecodeList :: forall s. Decoder s [TxApplicationError]
decodeList :: forall s. Decoder s [TxApplicationError]
Serialise)

instance PayloadSemantics Tx where
  newtype PayloadDependentState Tx mk = TestPLDS
    { forall (mk :: MapKind). PayloadDependentState Tx mk -> mk Token ()
getTestPLDS :: mk Token ()
    }
    deriving stock (forall x.
 PayloadDependentState Tx mk -> Rep (PayloadDependentState Tx mk) x)
-> (forall x.
    Rep (PayloadDependentState Tx mk) x -> PayloadDependentState Tx mk)
-> Generic (PayloadDependentState Tx mk)
forall x.
Rep (PayloadDependentState Tx mk) x -> PayloadDependentState Tx mk
forall x.
PayloadDependentState Tx mk -> Rep (PayloadDependentState Tx mk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (mk :: MapKind) x.
Rep (PayloadDependentState Tx mk) x -> PayloadDependentState Tx mk
forall (mk :: MapKind) x.
PayloadDependentState Tx mk -> Rep (PayloadDependentState Tx mk) x
$cfrom :: forall (mk :: MapKind) x.
PayloadDependentState Tx mk -> Rep (PayloadDependentState Tx mk) x
from :: forall x.
PayloadDependentState Tx mk -> Rep (PayloadDependentState Tx mk) x
$cto :: forall (mk :: MapKind) x.
Rep (PayloadDependentState Tx mk) x -> PayloadDependentState Tx mk
to :: forall x.
Rep (PayloadDependentState Tx mk) x -> PayloadDependentState Tx mk
Generic

  type PayloadDependentError Tx = TxApplicationError

  applyPayload :: PayloadDependentState Tx ValuesMK
-> Tx
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
applyPayload PayloadDependentState Tx ValuesMK
plds Tx
tx =
    let
      notFound :: Set Token
notFound = (Token -> Bool) -> Set Token -> Set Token
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Map Token () -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Token ()
tokMap)) Set Token
consumed
     in
      if Set Token -> Bool
forall a. Set a -> Bool
Set.null Set Token
notFound
        then PayloadDependentState Tx TrackingMK
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
forall a b. b -> Either a b
Right (PayloadDependentState Tx TrackingMK
 -> Either
      (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK))
-> PayloadDependentState Tx TrackingMK
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
forall a b. (a -> b) -> a -> b
$ TrackingMK Token () -> PayloadDependentState Tx TrackingMK
forall (mk :: MapKind). mk Token () -> PayloadDependentState Tx mk
TestPLDS (ValuesMK Token () -> DiffMK Token () -> TrackingMK Token ()
forall k v. Ord k => ValuesMK k v -> DiffMK k v -> TrackingMK k v
Ledger.rawAttachAndApplyDiffs ValuesMK Token ()
toks DiffMK Token ()
fullDiff)
        else TxApplicationError
-> Either TxApplicationError (PayloadDependentState Tx TrackingMK)
forall a b. a -> Either a b
Left (TxApplicationError
 -> Either TxApplicationError (PayloadDependentState Tx TrackingMK))
-> TxApplicationError
-> Either TxApplicationError (PayloadDependentState Tx TrackingMK)
forall a b. (a -> b) -> a -> b
$ Set Token -> TxApplicationError
TxApplicationError Set Token
notFound
   where
    TestPLDS toks :: ValuesMK Token ()
toks@(ValuesMK Map Token ()
tokMap) = PayloadDependentState Tx ValuesMK
plds
    Tx{Set Token
consumed :: Tx -> Set Token
consumed :: Set Token
consumed, Set Token
produced :: Tx -> Set Token
produced :: Set Token
produced} = Tx
tx

    consumedDiff, producedDiff :: Diff.Diff Token ()
    consumedDiff :: Diff Token ()
consumedDiff = [(Token, ())] -> Diff Token ()
forall k v. Ord k => [(k, v)] -> Diff k v
Diff.fromListDeletes [(Token
t, ()) | Token
t <- Set Token -> [Token]
forall a. Set a -> [a]
Set.toList Set Token
consumed]
    producedDiff :: Diff Token ()
producedDiff = [(Token, ())] -> Diff Token ()
forall k v. Ord k => [(k, v)] -> Diff k v
Diff.fromListInserts [(Token
t, ()) | Token
t <- Set Token -> [Token]
forall a. Set a -> [a]
Set.toList Set Token
produced]

    fullDiff :: DiffMK Token ()
    fullDiff :: DiffMK Token ()
fullDiff = Diff Token () -> DiffMK Token ()
forall k v. Diff k v -> DiffMK k v
DiffMK (Diff Token () -> DiffMK Token ())
-> Diff Token () -> DiffMK Token ()
forall a b. (a -> b) -> a -> b
$ Diff Token ()
consumedDiff Diff Token () -> Diff Token () -> Diff Token ()
forall a. Semigroup a => a -> a -> a
<> Diff Token ()
producedDiff

  getPayloadKeySets :: Tx -> LedgerTables (TestBlockWith Tx) KeysMK
getPayloadKeySets Tx
tx = KeysMK (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
-> LedgerTables (TestBlockWith Tx) KeysMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables (KeysMK (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
 -> LedgerTables (TestBlockWith Tx) KeysMK)
-> KeysMK (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
-> LedgerTables (TestBlockWith Tx) KeysMK
forall a b. (a -> b) -> a -> b
$ Set (TxIn (TestBlockWith Tx))
-> KeysMK (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
forall k v. Set k -> KeysMK k v
KeysMK Set (TxIn (TestBlockWith Tx))
Set Token
consumed
   where
    Tx{Set Token
consumed :: Tx -> Set Token
consumed :: Set Token
consumed} = Tx
tx

deriving stock instance
  EqMK mk =>
  Eq (PayloadDependentState Tx mk)
deriving stock instance
  ShowMK mk =>
  Show (PayloadDependentState Tx mk)
deriving anyclass instance
  NoThunksMK mk =>
  NoThunks (PayloadDependentState Tx mk)

instance Serialise (PayloadDependentState Tx EmptyMK) where
  encode :: PayloadDependentState Tx EmptyMK -> Encoding
encode = String -> PayloadDependentState Tx EmptyMK -> Encoding
forall a. HasCallStack => String -> a
error String
"Mempool bench TestBlock unused: encode"
  decode :: forall s. Decoder s (PayloadDependentState Tx EmptyMK)
decode = String -> Decoder s (PayloadDependentState Tx EmptyMK)
forall a. HasCallStack => String -> a
error String
"Mempool bench TestBlock unused: decode"

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

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

{-------------------------------------------------------------------------------
  Ledger tables
-------------------------------------------------------------------------------}

type instance TxIn TestBlock = Token
type instance TxOut TestBlock = ()

instance HasLedgerTables LedgerState TestBlock where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (TestBlockWith Tx) mk
-> LedgerTables (TestBlockWith Tx) mk
projectLedgerTables LedgerState (TestBlockWith Tx) mk
st =
    mk (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
-> LedgerTables (TestBlockWith Tx) mk
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables (mk (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
 -> LedgerTables (TestBlockWith Tx) mk)
-> mk (TxIn (TestBlockWith Tx)) (TxOut (TestBlockWith Tx))
-> LedgerTables (TestBlockWith Tx) mk
forall a b. (a -> b) -> a -> b
$ PayloadDependentState Tx mk -> mk Token ()
forall (mk :: MapKind). PayloadDependentState Tx mk -> mk Token ()
getTestPLDS (PayloadDependentState Tx mk -> mk Token ())
-> PayloadDependentState Tx mk -> mk Token ()
forall a b. (a -> b) -> a -> b
$ LedgerState (TestBlockWith Tx) mk -> PayloadDependentState Tx mk
forall ptype (mk :: MapKind).
LedgerState (TestBlockWith ptype) mk
-> PayloadDependentState ptype mk
payloadDependentState LedgerState (TestBlockWith Tx) mk
st
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (TestBlockWith Tx) any
-> LedgerTables (TestBlockWith Tx) mk
-> LedgerState (TestBlockWith Tx) mk
withLedgerTables LedgerState (TestBlockWith Tx) any
st LedgerTables (TestBlockWith Tx) mk
table =
    LedgerState (TestBlockWith Tx) any
st
      { payloadDependentState =
          plds
            { getTestPLDS = Ledger.getLedgerTables table
            }
      }
   where
    TestLedger{payloadDependentState :: forall ptype (mk :: MapKind).
LedgerState (TestBlockWith ptype) mk
-> PayloadDependentState ptype mk
payloadDependentState = PayloadDependentState Tx any
plds} = LedgerState (TestBlockWith Tx) any
st

instance HasLedgerTables (Ticked LedgerState) TestBlock where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked LedgerState (TestBlockWith Tx) mk
-> LedgerTables (TestBlockWith Tx) mk
projectLedgerTables (TickedTestLedger LedgerState (TestBlockWith Tx) mk
st) =
    LedgerState (TestBlockWith Tx) mk
-> LedgerTables (TestBlockWith Tx) mk
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (TestBlockWith Tx) mk
-> LedgerTables (TestBlockWith Tx) mk
forall (l :: * -> MapKind -> *) blk (mk :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
Ledger.projectLedgerTables LedgerState (TestBlockWith Tx) mk
st
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked LedgerState (TestBlockWith Tx) any
-> LedgerTables (TestBlockWith Tx) mk
-> Ticked LedgerState (TestBlockWith Tx) mk
withLedgerTables (TickedTestLedger LedgerState (TestBlockWith Tx) any
st) LedgerTables (TestBlockWith Tx) mk
tables =
    LedgerState (TestBlockWith Tx) mk
-> Ticked LedgerState (TestBlockWith Tx) mk
forall ptype (mk :: MapKind).
LedgerState (TestBlockWith ptype) mk
-> Ticked LedgerState (TestBlockWith ptype) mk
TickedTestLedger (LedgerState (TestBlockWith Tx) mk
 -> Ticked LedgerState (TestBlockWith Tx) mk)
-> LedgerState (TestBlockWith Tx) mk
-> Ticked LedgerState (TestBlockWith Tx) mk
forall a b. (a -> b) -> a -> b
$ LedgerState (TestBlockWith Tx) any
-> LedgerTables (TestBlockWith Tx) mk
-> LedgerState (TestBlockWith Tx) mk
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (TestBlockWith Tx) any
-> LedgerTables (TestBlockWith Tx) mk
-> LedgerState (TestBlockWith Tx) mk
forall (l :: * -> MapKind -> *) blk (mk :: MapKind)
       (any :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk any -> LedgerTables blk mk -> l blk mk
Ledger.withLedgerTables LedgerState (TestBlockWith Tx) any
st LedgerTables (TestBlockWith Tx) mk
tables

instance CanStowLedgerTables (LedgerState TestBlock) where
  stowLedgerTables :: LedgerState (TestBlockWith Tx) ValuesMK
-> LedgerState (TestBlockWith Tx) EmptyMK
stowLedgerTables = String
-> LedgerState (TestBlockWith Tx) ValuesMK
-> LedgerState (TestBlockWith Tx) EmptyMK
forall a. HasCallStack => String -> a
error String
"Mempool bench TestBlock unused: stowLedgerTables"
  unstowLedgerTables :: LedgerState (TestBlockWith Tx) EmptyMK
-> LedgerState (TestBlockWith Tx) ValuesMK
unstowLedgerTables = String
-> LedgerState (TestBlockWith Tx) EmptyMK
-> LedgerState (TestBlockWith Tx) ValuesMK
forall a. HasCallStack => String -> a
error String
"Mempool bench TestBlock unused: unstowLedgerTables"

instance IndexedMemPack LedgerState TestBlock () where
  indexedTypeName :: Proxy () -> LedgerState (TestBlockWith Tx) EmptyMK -> String
indexedTypeName Proxy ()
_ LedgerState (TestBlockWith Tx) EmptyMK
_ = forall a. MemPack a => String
typeName @()
  indexedPackedByteCount :: LedgerState (TestBlockWith Tx) EmptyMK -> () -> Int
indexedPackedByteCount LedgerState (TestBlockWith Tx) EmptyMK
_ = () -> Int
forall a. MemPack a => a -> Int
packedByteCount
  indexedPackM :: forall s. LedgerState (TestBlockWith Tx) EmptyMK -> () -> Pack s ()
indexedPackM LedgerState (TestBlockWith Tx) EmptyMK
_ = () -> Pack s ()
forall s. () -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM
  indexedUnpackM :: forall b s.
Buffer b =>
LedgerState (TestBlockWith Tx) EmptyMK -> Unpack s b ()
indexedUnpackM LedgerState (TestBlockWith Tx) EmptyMK
_ = Unpack s b ()
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b ()
unpackM

{-------------------------------------------------------------------------------
  Mempool support
-------------------------------------------------------------------------------}

newtype instance Ledger.GenTx TestBlock = TestBlockGenTx {GenTx (TestBlockWith Tx) -> Tx
unGenTx :: Tx}
  deriving stock (forall x.
 GenTx (TestBlockWith Tx) -> Rep (GenTx (TestBlockWith Tx)) x)
-> (forall x.
    Rep (GenTx (TestBlockWith Tx)) x -> GenTx (TestBlockWith Tx))
-> Generic (GenTx (TestBlockWith Tx))
forall x.
Rep (GenTx (TestBlockWith Tx)) x -> GenTx (TestBlockWith Tx)
forall x.
GenTx (TestBlockWith Tx) -> Rep (GenTx (TestBlockWith Tx)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
GenTx (TestBlockWith Tx) -> Rep (GenTx (TestBlockWith Tx)) x
from :: forall x.
GenTx (TestBlockWith Tx) -> Rep (GenTx (TestBlockWith Tx)) x
$cto :: forall x.
Rep (GenTx (TestBlockWith Tx)) x -> GenTx (TestBlockWith Tx)
to :: forall x.
Rep (GenTx (TestBlockWith Tx)) x -> GenTx (TestBlockWith Tx)
Generic
  deriving newtype (Int -> GenTx (TestBlockWith Tx) -> ShowS
[GenTx (TestBlockWith Tx)] -> ShowS
GenTx (TestBlockWith Tx) -> String
(Int -> GenTx (TestBlockWith Tx) -> ShowS)
-> (GenTx (TestBlockWith Tx) -> String)
-> ([GenTx (TestBlockWith Tx)] -> ShowS)
-> Show (GenTx (TestBlockWith Tx))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenTx (TestBlockWith Tx) -> ShowS
showsPrec :: Int -> GenTx (TestBlockWith Tx) -> ShowS
$cshow :: GenTx (TestBlockWith Tx) -> String
show :: GenTx (TestBlockWith Tx) -> String
$cshowList :: [GenTx (TestBlockWith Tx)] -> ShowS
showList :: [GenTx (TestBlockWith Tx)] -> ShowS
Show, Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo)
Proxy (GenTx (TestBlockWith Tx)) -> String
(Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo))
-> (Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo))
-> (Proxy (GenTx (TestBlockWith Tx)) -> String)
-> NoThunks (GenTx (TestBlockWith Tx))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GenTx (TestBlockWith Tx) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (GenTx (TestBlockWith Tx)) -> String
showTypeOf :: Proxy (GenTx (TestBlockWith Tx)) -> String
NoThunks, GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
(GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> (GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> Eq (GenTx (TestBlockWith Tx))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
== :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
$c/= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
/= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
Eq, Eq (GenTx (TestBlockWith Tx))
Eq (GenTx (TestBlockWith Tx)) =>
(GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Ordering)
-> (GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> (GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> (GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> (GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool)
-> (GenTx (TestBlockWith Tx)
    -> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx))
-> (GenTx (TestBlockWith Tx)
    -> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx))
-> Ord (GenTx (TestBlockWith Tx))
GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Ordering
GenTx (TestBlockWith Tx)
-> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx)
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 :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Ordering
compare :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Ordering
$c< :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
< :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
$c<= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
<= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
$c> :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
> :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
$c>= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
>= :: GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx) -> Bool
$cmax :: GenTx (TestBlockWith Tx)
-> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx)
max :: GenTx (TestBlockWith Tx)
-> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx)
$cmin :: GenTx (TestBlockWith Tx)
-> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx)
min :: GenTx (TestBlockWith Tx)
-> GenTx (TestBlockWith Tx) -> GenTx (TestBlockWith Tx)
Ord, GenTx (TestBlockWith Tx) -> ()
(GenTx (TestBlockWith Tx) -> ())
-> NFData (GenTx (TestBlockWith Tx))
forall a. (a -> ()) -> NFData a
$crnf :: GenTx (TestBlockWith Tx) -> ()
rnf :: GenTx (TestBlockWith Tx) -> ()
NFData)

-- | For the mempool tests and benchmarks it is not imporant that we calculate
-- the actual size of the transaction in bytes.
txSize :: Ledger.GenTx TestBlock -> Ledger.ByteSize32
txSize :: GenTx (TestBlockWith Tx) -> ByteSize32
txSize (TestBlockGenTx Tx
tx) =
  Word32 -> ByteSize32
Ledger.ByteSize32 (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$
    Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$
      Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set Token -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> Set Token
consumed Tx
tx) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set Token -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> Set Token
produced Tx
tx)

-- | Simulated CPU cost, in microseconds, of /fully/ validating a transaction
-- (the script and signature checks a real ledger performs in 'applyTx'). Set via
-- @MEMPOOL_APPLY_CPU_US@; defaults to @0@ (no injected cost) so this shared
-- 'TestBlock' does not slow down the criterion @mempool-bench@ that CI
-- regression-gates. The @mempool-state-bench@ opts in — it sets the env var from
-- its @--apply-us@ flag (default 128us, the measured median applyBlock cost on
-- an nvme SSD, see input-output-hk/ouroboros-leios#553) before this CAF is
-- forced.
--
-- Together with 'reapplyCpuMicros' this lets a benchmark reproduce the
-- real-node relationship @reapply ≪ apply@: reapplication skips the expensive
-- checks, so a mempool sync (which only reapplies) is strictly cheaper per tx
-- than ingestion (which fully validates). The mempool-state-bench relies on
-- this for its sync-vs-ingest convergence to be faithful.
{-# NOINLINE applyCpuMicros #-}
applyCpuMicros :: Int
applyCpuMicros :: Int
applyCpuMicros = String -> Int -> Int
envInt String
"MEMPOOL_APPLY_CPU_US" Int
0

-- | Simulated CPU cost, in microseconds, of /reapplying/ an already-validated
-- transaction. Set via @MEMPOOL_REAPPLY_CPU_US@; defaults to @0@ (see
-- 'applyCpuMicros'). The @mempool-state-bench@ sets it from its @--reapply-us@
-- flag (default 20us, an estimate kept well below @--apply-us@ to model
-- @reapply ≪ apply@, as reapply skips the expensive script/signature checks).
{-# NOINLINE reapplyCpuMicros #-}
reapplyCpuMicros :: Int
reapplyCpuMicros :: Int
reapplyCpuMicros = String -> Int -> Int
envInt String
"MEMPOOL_REAPPLY_CPU_US" Int
0

{-# NOINLINE envInt #-}
envInt :: String -> Int -> Int
envInt :: String -> Int -> Int
envInt String
k Int
d = IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
d Int -> Int
forall a. a -> a
id (Maybe Int -> Int)
-> (Maybe String -> Maybe Int) -> Maybe String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> (String -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe) (Maybe String -> Int) -> IO (Maybe String) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
k

-- | Busy-wait (burning CPU, /not/ sleeping — validation contends for cores)
-- for @us@ microseconds, then return @tx@. The result is @tx@ itself and the
-- caller feeds it into the ledger transition, so the spin depends on the tx
-- and cannot be shared across calls or optimised away.
{-# NOINLINE burnCpuMicros #-}
burnCpuMicros :: Int -> Tx -> Tx
burnCpuMicros :: Int -> Tx -> Tx
burnCpuMicros Int
us Tx
tx
  | Int
us Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Tx
tx
  | Bool
otherwise = IO Tx -> Tx
forall a. IO a -> a
unsafePerformIO (IO Tx -> Tx) -> IO Tx -> Tx
forall a b. (a -> b) -> a -> b
$ do
      let targetNs :: Word64
targetNs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000 :: Word64
      start <- IO Word64
getMonotonicTimeNSec
      let go = do
            now <- IO Word64
getMonotonicTimeNSec
            if now - start >= targetNs then pure tx else go
      go

instance Ledger.LedgerSupportsMempool TestBlock where
  applyTx :: LedgerConfig (TestBlockWith Tx)
-> WhetherToIntervene
-> SlotNo
-> GenTx (TestBlockWith Tx)
-> TickedLedgerState (TestBlockWith Tx) ValuesMK
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
applyTx LedgerConfig (TestBlockWith Tx)
_cfg WhetherToIntervene
_shouldIntervene SlotNo
_slot (TestBlockGenTx Tx
tx) TickedLedgerState (TestBlockWith Tx) ValuesMK
tickedSt =
    Either
  (ApplyTxErr (TestBlockWith Tx))
  (TickedLedgerState (TestBlockWith Tx) DiffMK,
   Validated (GenTx (TestBlockWith Tx)))
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   (ApplyTxErr (TestBlockWith Tx))
   (TickedLedgerState (TestBlockWith Tx) DiffMK,
    Validated (GenTx (TestBlockWith Tx)))
 -> Except
      (ApplyTxErr (TestBlockWith Tx))
      (TickedLedgerState (TestBlockWith Tx) DiffMK,
       Validated (GenTx (TestBlockWith Tx))))
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
forall a b. (a -> b) -> a -> b
$
      (Ticked LedgerState (TestBlockWith Tx) TrackingMK
 -> (TickedLedgerState (TestBlockWith Tx) DiffMK,
     Validated (GenTx (TestBlockWith Tx))))
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
forall a b.
(a -> b)
-> Either (ApplyTxErr (TestBlockWith Tx)) a
-> Either (ApplyTxErr (TestBlockWith Tx)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,GenTx (TestBlockWith Tx) -> Validated (GenTx (TestBlockWith Tx))
ValidatedGenTx (Tx -> GenTx (TestBlockWith Tx)
TestBlockGenTx Tx
tx)) (TickedLedgerState (TestBlockWith Tx) DiffMK
 -> (TickedLedgerState (TestBlockWith Tx) DiffMK,
     Validated (GenTx (TestBlockWith Tx))))
-> (Ticked LedgerState (TestBlockWith Tx) TrackingMK
    -> TickedLedgerState (TestBlockWith Tx) DiffMK)
-> Ticked LedgerState (TestBlockWith Tx) TrackingMK
-> (TickedLedgerState (TestBlockWith Tx) DiffMK,
    Validated (GenTx (TestBlockWith Tx)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked LedgerState (TestBlockWith Tx) TrackingMK
-> TickedLedgerState (TestBlockWith Tx) DiffMK
forall (l :: * -> MapKind -> *) blk.
HasLedgerTables l blk =>
l blk TrackingMK -> l blk DiffMK
Ledger.trackingToDiffs) (Either
   (ApplyTxErr (TestBlockWith Tx))
   (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
 -> Either
      (ApplyTxErr (TestBlockWith Tx))
      (TickedLedgerState (TestBlockWith Tx) DiffMK,
       Validated (GenTx (TestBlockWith Tx))))
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) DiffMK,
      Validated (GenTx (TestBlockWith Tx)))
forall a b. (a -> b) -> a -> b
$
        -- Pay the (simulated) full-validation cost. 'burnCpuMicros' returns the
        -- tx we then apply, so it is forced as part of producing the result.
        TickedLedgerState (TestBlockWith Tx) ValuesMK
-> Tx
-> Either
     (PayloadDependentError Tx)
     (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
forall ptype.
PayloadSemantics ptype =>
Ticked LedgerState (TestBlockWith ptype) ValuesMK
-> ptype
-> Either
     (PayloadDependentError ptype)
     (Ticked LedgerState (TestBlockWith ptype) TrackingMK)
applyDirectlyToPayloadDependentState TickedLedgerState (TestBlockWith Tx) ValuesMK
tickedSt (Int -> Tx -> Tx
burnCpuMicros Int
applyCpuMicros Tx
tx)

  -- Reapplication does /not/ route through 'applyTx' (which would pay the full
  -- validation cost); it runs the ledger transition directly, paying only the
  -- much cheaper 'reapplyCpuMicros'.
  reapplyTx :: HasCallStack =>
LedgerConfig (TestBlockWith Tx)
-> SlotNo
-> Validated (GenTx (TestBlockWith Tx))
-> TickedLedgerState (TestBlockWith Tx) ValuesMK
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) ValuesMK)
reapplyTx LedgerConfig (TestBlockWith Tx)
_cfg SlotNo
_slot (ValidatedGenTx (TestBlockGenTx Tx
tx)) TickedLedgerState (TestBlockWith Tx) ValuesMK
tickedSt =
    Either
  (ApplyTxErr (TestBlockWith Tx))
  (TickedLedgerState (TestBlockWith Tx) ValuesMK)
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) ValuesMK)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   (ApplyTxErr (TestBlockWith Tx))
   (TickedLedgerState (TestBlockWith Tx) ValuesMK)
 -> Except
      (ApplyTxErr (TestBlockWith Tx))
      (TickedLedgerState (TestBlockWith Tx) ValuesMK))
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) ValuesMK)
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) ValuesMK)
forall a b. (a -> b) -> a -> b
$
      TickedLedgerState (TestBlockWith Tx) ValuesMK
-> TickedLedgerState (TestBlockWith Tx) DiffMK
-> TickedLedgerState (TestBlockWith Tx) ValuesMK
forall (l :: * -> MapKind -> *) blk (l' :: * -> MapKind -> *).
(HasLedgerTables l blk, HasLedgerTables l' blk) =>
l blk ValuesMK -> l' blk DiffMK -> l' blk ValuesMK
Ledger.applyDiffs TickedLedgerState (TestBlockWith Tx) ValuesMK
tickedSt (TickedLedgerState (TestBlockWith Tx) DiffMK
 -> TickedLedgerState (TestBlockWith Tx) ValuesMK)
-> (Ticked LedgerState (TestBlockWith Tx) TrackingMK
    -> TickedLedgerState (TestBlockWith Tx) DiffMK)
-> Ticked LedgerState (TestBlockWith Tx) TrackingMK
-> TickedLedgerState (TestBlockWith Tx) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked LedgerState (TestBlockWith Tx) TrackingMK
-> TickedLedgerState (TestBlockWith Tx) DiffMK
forall (l :: * -> MapKind -> *) blk.
HasLedgerTables l blk =>
l blk TrackingMK -> l blk DiffMK
Ledger.trackingToDiffs
        (Ticked LedgerState (TestBlockWith Tx) TrackingMK
 -> TickedLedgerState (TestBlockWith Tx) ValuesMK)
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
-> Either
     (ApplyTxErr (TestBlockWith Tx))
     (TickedLedgerState (TestBlockWith Tx) ValuesMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TickedLedgerState (TestBlockWith Tx) ValuesMK
-> Tx
-> Either
     (PayloadDependentError Tx)
     (Ticked LedgerState (TestBlockWith Tx) TrackingMK)
forall ptype.
PayloadSemantics ptype =>
Ticked LedgerState (TestBlockWith ptype) ValuesMK
-> ptype
-> Either
     (PayloadDependentError ptype)
     (Ticked LedgerState (TestBlockWith ptype) TrackingMK)
applyDirectlyToPayloadDependentState TickedLedgerState (TestBlockWith Tx) ValuesMK
tickedSt (Int -> Tx -> Tx
burnCpuMicros Int
reapplyCpuMicros Tx
tx)

  txForgetValidated :: Validated (GenTx (TestBlockWith Tx)) -> GenTx (TestBlockWith Tx)
txForgetValidated (ValidatedGenTx GenTx (TestBlockWith Tx)
tx) = GenTx (TestBlockWith Tx)
tx

  getTransactionKeySets :: GenTx (TestBlockWith Tx) -> LedgerTables (TestBlockWith Tx) KeysMK
getTransactionKeySets (TestBlockGenTx Tx
tx) = Tx -> LedgerTables (TestBlockWith Tx) KeysMK
forall ptype.
PayloadSemantics ptype =>
ptype -> LedgerTables (TestBlockWith ptype) KeysMK
getPayloadKeySets Tx
tx

  mkMempoolApplyTxError :: forall (mk :: MapKind).
TickedLedgerState (TestBlockWith Tx) mk
-> Text -> Maybe (ApplyTxErr (TestBlockWith Tx))
mkMempoolApplyTxError = TickedLedgerState (TestBlockWith Tx) mk
-> Text -> Maybe (ApplyTxErr (TestBlockWith Tx))
forall blk (mk :: MapKind).
TickedLedgerState blk mk -> Text -> Maybe (ApplyTxErr blk)
Ledger.nothingMkMempoolApplyTxError

instance Ledger.TxLimits TestBlock where
  type TxMeasurePhase1 TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32
  type TxMeasurePhase2 TestBlock = Ledger.TrivialTxMeasurePhase2

  txWireSize :: GenTx (TestBlockWith Tx) -> SizeInBytes
txWireSize = Word32 -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> SizeInBytes)
-> (GenTx (TestBlockWith Tx) -> Word32)
-> GenTx (TestBlockWith Tx)
-> SizeInBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteSize32 -> Word32
Ledger.unByteSize32 (ByteSize32 -> Word32)
-> (GenTx (TestBlockWith Tx) -> ByteSize32)
-> GenTx (TestBlockWith Tx)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (TestBlockWith Tx) -> ByteSize32
txSize

  -- We tweaked this in such a way that we test the case in which we exceed the
  -- maximum mempool capacity. The value used here depends on 'txInBlockSize'.
  blockCapacityTxMeasure :: forall (mk :: MapKind).
LedgerConfig (TestBlockWith Tx)
-> TickedLedgerState (TestBlockWith Tx) mk
-> TxMeasure (TestBlockWith Tx)
blockCapacityTxMeasure LedgerConfig (TestBlockWith Tx)
_cfg TickedLedgerState (TestBlockWith Tx) mk
_st =
    TxMeasurePhase1 (TestBlockWith Tx)
-> TxMeasurePhase2 (TestBlockWith Tx)
-> TxMeasure (TestBlockWith Tx)
forall blk.
TxMeasurePhase1 blk -> TxMeasurePhase2 blk -> TxMeasure blk
Ledger.TxMeasure (ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
Ledger.IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
Ledger.ByteSize32 Word32
20) TrivialTxMeasurePhase2
TxMeasurePhase2 (TestBlockWith Tx)
Ledger.TrivialTxMeasurePhase2

  txMeasurePhase1 :: LedgerConfig (TestBlockWith Tx)
-> TickedLedgerState (TestBlockWith Tx) EmptyMK
-> GenTx (TestBlockWith Tx)
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TxMeasurePhase1 (TestBlockWith Tx))
txMeasurePhase1 LedgerConfig (TestBlockWith Tx)
_cfg TickedLedgerState (TestBlockWith Tx) EmptyMK
_st = IgnoringOverflow ByteSize32
-> ExceptT
     TxApplicationError Identity (IgnoringOverflow ByteSize32)
forall a. a -> ExceptT TxApplicationError Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IgnoringOverflow ByteSize32
 -> ExceptT
      TxApplicationError Identity (IgnoringOverflow ByteSize32))
-> (GenTx (TestBlockWith Tx) -> IgnoringOverflow ByteSize32)
-> GenTx (TestBlockWith Tx)
-> ExceptT
     TxApplicationError Identity (IgnoringOverflow ByteSize32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
Ledger.IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> (GenTx (TestBlockWith Tx) -> ByteSize32)
-> GenTx (TestBlockWith Tx)
-> IgnoringOverflow ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (TestBlockWith Tx) -> ByteSize32
txSize
  txMeasurePhase2 :: LedgerConfig (TestBlockWith Tx)
-> TickedLedgerState (TestBlockWith Tx) ValuesMK
-> GenTx (TestBlockWith Tx)
-> Except
     (ApplyTxErr (TestBlockWith Tx))
     (TxMeasurePhase2 (TestBlockWith Tx))
txMeasurePhase2 LedgerConfig (TestBlockWith Tx)
_cfg TickedLedgerState (TestBlockWith Tx) ValuesMK
_st GenTx (TestBlockWith Tx)
_tx = TrivialTxMeasurePhase2
-> ExceptT TxApplicationError Identity TrivialTxMeasurePhase2
forall a. a -> ExceptT TxApplicationError Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TrivialTxMeasurePhase2
Ledger.TrivialTxMeasurePhase2

newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx
  deriving stock (forall x.
 TxId (GenTx (TestBlockWith Tx))
 -> Rep (TxId (GenTx (TestBlockWith Tx))) x)
-> (forall x.
    Rep (TxId (GenTx (TestBlockWith Tx))) x
    -> TxId (GenTx (TestBlockWith Tx)))
-> Generic (TxId (GenTx (TestBlockWith Tx)))
forall x.
Rep (TxId (GenTx (TestBlockWith Tx))) x
-> TxId (GenTx (TestBlockWith Tx))
forall x.
TxId (GenTx (TestBlockWith Tx))
-> Rep (TxId (GenTx (TestBlockWith Tx))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TxId (GenTx (TestBlockWith Tx))
-> Rep (TxId (GenTx (TestBlockWith Tx))) x
from :: forall x.
TxId (GenTx (TestBlockWith Tx))
-> Rep (TxId (GenTx (TestBlockWith Tx))) x
$cto :: forall x.
Rep (TxId (GenTx (TestBlockWith Tx))) x
-> TxId (GenTx (TestBlockWith Tx))
to :: forall x.
Rep (TxId (GenTx (TestBlockWith Tx))) x
-> TxId (GenTx (TestBlockWith Tx))
Generic
  deriving newtype (Int -> TxId (GenTx (TestBlockWith Tx)) -> ShowS
[TxId (GenTx (TestBlockWith Tx))] -> ShowS
TxId (GenTx (TestBlockWith Tx)) -> String
(Int -> TxId (GenTx (TestBlockWith Tx)) -> ShowS)
-> (TxId (GenTx (TestBlockWith Tx)) -> String)
-> ([TxId (GenTx (TestBlockWith Tx))] -> ShowS)
-> Show (TxId (GenTx (TestBlockWith Tx)))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxId (GenTx (TestBlockWith Tx)) -> ShowS
showsPrec :: Int -> TxId (GenTx (TestBlockWith Tx)) -> ShowS
$cshow :: TxId (GenTx (TestBlockWith Tx)) -> String
show :: TxId (GenTx (TestBlockWith Tx)) -> String
$cshowList :: [TxId (GenTx (TestBlockWith Tx))] -> ShowS
showList :: [TxId (GenTx (TestBlockWith Tx))] -> ShowS
Show, Eq (TxId (GenTx (TestBlockWith Tx)))
Eq (TxId (GenTx (TestBlockWith Tx))) =>
(TxId (GenTx (TestBlockWith Tx))
 -> TxId (GenTx (TestBlockWith Tx)) -> Ordering)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)))
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)))
-> Ord (TxId (GenTx (TestBlockWith Tx)))
TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Ordering
TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
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 :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Ordering
compare :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Ordering
$c< :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
< :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
$c<= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
<= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
$c> :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
> :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
$c>= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
>= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
$cmax :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
max :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
$cmin :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
min :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx))
Ord, TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
(TxId (GenTx (TestBlockWith Tx))
 -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> (TxId (GenTx (TestBlockWith Tx))
    -> TxId (GenTx (TestBlockWith Tx)) -> Bool)
-> Eq (TxId (GenTx (TestBlockWith Tx)))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
== :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
$c/= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
/= :: TxId (GenTx (TestBlockWith Tx))
-> TxId (GenTx (TestBlockWith Tx)) -> Bool
Eq)
  deriving anyclass Context -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx (TestBlockWith Tx))) -> String
(Context
 -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo))
-> (Context
    -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx (TestBlockWith Tx))) -> String)
-> NoThunks (TxId (GenTx (TestBlockWith Tx)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TxId (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (TxId (GenTx (TestBlockWith Tx))) -> String
showTypeOf :: Proxy (TxId (GenTx (TestBlockWith Tx))) -> String
NoThunks

instance Ledger.HasTxId (Ledger.GenTx TestBlock) where
  txId :: GenTx (TestBlockWith Tx) -> TxId (GenTx (TestBlockWith Tx))
txId (TestBlockGenTx Tx
tx) = Tx -> TxId (GenTx (TestBlockWith Tx))
TestBlockTxId Tx
tx

newtype instance Ledger.Validated (Ledger.GenTx TestBlock)
  = ValidatedGenTx (Ledger.GenTx TestBlock)
  deriving stock (forall x.
 Validated (GenTx (TestBlockWith Tx))
 -> Rep (Validated (GenTx (TestBlockWith Tx))) x)
-> (forall x.
    Rep (Validated (GenTx (TestBlockWith Tx))) x
    -> Validated (GenTx (TestBlockWith Tx)))
-> Generic (Validated (GenTx (TestBlockWith Tx)))
forall x.
Rep (Validated (GenTx (TestBlockWith Tx))) x
-> Validated (GenTx (TestBlockWith Tx))
forall x.
Validated (GenTx (TestBlockWith Tx))
-> Rep (Validated (GenTx (TestBlockWith Tx))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
Validated (GenTx (TestBlockWith Tx))
-> Rep (Validated (GenTx (TestBlockWith Tx))) x
from :: forall x.
Validated (GenTx (TestBlockWith Tx))
-> Rep (Validated (GenTx (TestBlockWith Tx))) x
$cto :: forall x.
Rep (Validated (GenTx (TestBlockWith Tx))) x
-> Validated (GenTx (TestBlockWith Tx))
to :: forall x.
Rep (Validated (GenTx (TestBlockWith Tx))) x
-> Validated (GenTx (TestBlockWith Tx))
Generic
  deriving newtype (Int -> Validated (GenTx (TestBlockWith Tx)) -> ShowS
[Validated (GenTx (TestBlockWith Tx))] -> ShowS
Validated (GenTx (TestBlockWith Tx)) -> String
(Int -> Validated (GenTx (TestBlockWith Tx)) -> ShowS)
-> (Validated (GenTx (TestBlockWith Tx)) -> String)
-> ([Validated (GenTx (TestBlockWith Tx))] -> ShowS)
-> Show (Validated (GenTx (TestBlockWith Tx)))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validated (GenTx (TestBlockWith Tx)) -> ShowS
showsPrec :: Int -> Validated (GenTx (TestBlockWith Tx)) -> ShowS
$cshow :: Validated (GenTx (TestBlockWith Tx)) -> String
show :: Validated (GenTx (TestBlockWith Tx)) -> String
$cshowList :: [Validated (GenTx (TestBlockWith Tx))] -> ShowS
showList :: [Validated (GenTx (TestBlockWith Tx))] -> ShowS
Show, Context
-> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
Proxy (Validated (GenTx (TestBlockWith Tx))) -> String
(Context
 -> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo))
-> (Context
    -> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo))
-> (Proxy (Validated (GenTx (TestBlockWith Tx))) -> String)
-> NoThunks (Validated (GenTx (TestBlockWith Tx)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context
-> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context
-> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Validated (GenTx (TestBlockWith Tx)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Validated (GenTx (TestBlockWith Tx))) -> String
showTypeOf :: Proxy (Validated (GenTx (TestBlockWith Tx))) -> String
NoThunks)

type instance Ledger.ApplyTxErr TestBlock = TxApplicationError