{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Storage.LedgerDB.StateMachine.TestBlock
  ( TestBlock
  , extLedgerDbConfig
  , genBlocks
  , genesis
  ) where

import Cardano.Binary
  ( FromCBOR (..)
  , ToCBOR (..)
  , serialize'
  , unsafeDeserialize'
  )
import Cardano.Ledger.BaseTypes (NonZero (..))
import qualified Cardano.Slotting.Slot as WithOrigin
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as S
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map.Diff.Strict.Internal as DS
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict
import Data.MemPack
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff
import Data.Word
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.LedgerDB.API
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.IndexedMemPack
import Ouroboros.Network.Block (Point (Point))
import Ouroboros.Network.Point (Block (Block))
import qualified Test.QuickCheck as QC
import Test.Tasty.QuickCheck
import Test.Util.Orphans.Arbitrary ()
import Test.Util.TestBlock hiding
  ( TestBlock
  , TestBlockCodecConfig
  , TestBlockStorageConfig
  )
import Test.Util.ToExpr ()
import Prelude hiding (elem)

{-------------------------------------------------------------------------------
  TestBlock
-------------------------------------------------------------------------------}

type TestBlock = TestBlockWith Tx

-- | Mock of a UTxO transaction where exactly one (transaction) input is
-- consumed and exactly one output is produced.
data Tx = Tx
  { Tx -> Token
consumed :: Token
  -- ^ Input that the transaction consumes.
  , Tx -> (Token, TValue)
produced :: (Token, TValue)
  -- ^ Ouptupt that the transaction produces.
  }
  deriving stock (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, 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)
  deriving anyclass ([Tx] -> Encoding
Tx -> Encoding
(Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> ([Tx] -> Encoding)
-> (forall s. Decoder s [Tx])
-> Serialise Tx
forall s. Decoder s [Tx]
forall s. Decoder s Tx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Tx -> Encoding
encode :: Tx -> Encoding
$cdecode :: forall s. Decoder s Tx
decode :: forall s. Decoder s Tx
$cencodeList :: [Tx] -> Encoding
encodeList :: [Tx] -> Encoding
$cdecodeList :: forall s. Decoder s [Tx]
decodeList :: forall s. Decoder s [Tx]
Serialise, 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] -> Expr
Tx -> Expr
(Tx -> Expr) -> ([Tx] -> Expr) -> ToExpr Tx
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Tx -> Expr
toExpr :: Tx -> Expr
$clistToExpr :: [Tx] -> Expr
listToExpr :: [Tx] -> Expr
ToExpr)

-- | A token is an identifier for the values produced and consumed by the
-- 'TestBlock' transactions.
--
-- This is analogous to @TxId@: it's how we identify what's in the table. It's
-- also analogous to @TxIn@, since we trivially only have one output per 'Tx'.
newtype Token = Token {Token -> Point TestBlock
unToken :: Point TestBlock}
  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 ([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, 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, Gen Token
Gen Token -> (Token -> [Token]) -> Arbitrary Token
Token -> [Token]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen Token
arbitrary :: Gen Token
$cshrink :: Token -> [Token]
shrink :: Token -> [Token]
QC.Arbitrary)

instance QC.Arbitrary (Point TestBlock) where
  arbitrary :: Gen (Point TestBlock)
arbitrary = do
    slot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
QC.arbitrary
    hash <- fmap TestHash $ (:|) <$> QC.arbitrary <*> QC.arbitrary
    pure $ Point $ WithOrigin.At $ Block slot hash

-- | Unit of value associated with the output produced by a transaction.
newtype TValue = TValue ()
  deriving stock (Int -> TValue -> ShowS
[TValue] -> ShowS
TValue -> String
(Int -> TValue -> ShowS)
-> (TValue -> String) -> ([TValue] -> ShowS) -> Show TValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TValue -> ShowS
showsPrec :: Int -> TValue -> ShowS
$cshow :: TValue -> String
show :: TValue -> String
$cshowList :: [TValue] -> ShowS
showList :: [TValue] -> ShowS
Show, TValue -> TValue -> Bool
(TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool) -> Eq TValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TValue -> TValue -> Bool
== :: TValue -> TValue -> Bool
$c/= :: TValue -> TValue -> Bool
/= :: TValue -> TValue -> Bool
Eq, Eq TValue
Eq TValue =>
(TValue -> TValue -> Ordering)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> TValue)
-> (TValue -> TValue -> TValue)
-> Ord TValue
TValue -> TValue -> Bool
TValue -> TValue -> Ordering
TValue -> TValue -> TValue
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 :: TValue -> TValue -> Ordering
compare :: TValue -> TValue -> Ordering
$c< :: TValue -> TValue -> Bool
< :: TValue -> TValue -> Bool
$c<= :: TValue -> TValue -> Bool
<= :: TValue -> TValue -> Bool
$c> :: TValue -> TValue -> Bool
> :: TValue -> TValue -> Bool
$c>= :: TValue -> TValue -> Bool
>= :: TValue -> TValue -> Bool
$cmax :: TValue -> TValue -> TValue
max :: TValue -> TValue -> TValue
$cmin :: TValue -> TValue -> TValue
min :: TValue -> TValue -> TValue
Ord, (forall x. TValue -> Rep TValue x)
-> (forall x. Rep TValue x -> TValue) -> Generic TValue
forall x. Rep TValue x -> TValue
forall x. TValue -> Rep TValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TValue -> Rep TValue x
from :: forall x. TValue -> Rep TValue x
$cto :: forall x. Rep TValue x -> TValue
to :: forall x. Rep TValue x -> TValue
Generic)
  deriving newtype ([TValue] -> Encoding
TValue -> Encoding
(TValue -> Encoding)
-> (forall s. Decoder s TValue)
-> ([TValue] -> Encoding)
-> (forall s. Decoder s [TValue])
-> Serialise TValue
forall s. Decoder s [TValue]
forall s. Decoder s TValue
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TValue -> Encoding
encode :: TValue -> Encoding
$cdecode :: forall s. Decoder s TValue
decode :: forall s. Decoder s TValue
$cencodeList :: [TValue] -> Encoding
encodeList :: [TValue] -> Encoding
$cdecodeList :: forall s. Decoder s [TValue]
decodeList :: forall s. Decoder s [TValue]
Serialise, Context -> TValue -> IO (Maybe ThunkInfo)
Proxy TValue -> String
(Context -> TValue -> IO (Maybe ThunkInfo))
-> (Context -> TValue -> IO (Maybe ThunkInfo))
-> (Proxy TValue -> String)
-> NoThunks TValue
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
noThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TValue -> String
showTypeOf :: Proxy TValue -> String
NoThunks, [TValue] -> Expr
TValue -> Expr
(TValue -> Expr) -> ([TValue] -> Expr) -> ToExpr TValue
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TValue -> Expr
toExpr :: TValue -> Expr
$clistToExpr :: [TValue] -> Expr
listToExpr :: [TValue] -> Expr
ToExpr, String
String
-> (TValue -> Int)
-> (forall s. TValue -> Pack s ())
-> (forall b. Buffer b => Unpack b TValue)
-> MemPack TValue
TValue -> Int
forall a.
String
-> (a -> Int)
-> (forall s. a -> Pack s ())
-> (forall b. Buffer b => Unpack b a)
-> MemPack a
forall b. Buffer b => Unpack b TValue
forall s. TValue -> Pack s ()
$ctypeName :: String
typeName :: String
$cpackedByteCount :: TValue -> Int
packedByteCount :: TValue -> Int
$cpackM :: forall s. TValue -> Pack s ()
packM :: forall s. TValue -> Pack s ()
$cunpackM :: forall b. Buffer b => Unpack b TValue
unpackM :: forall b. Buffer b => Unpack b TValue
MemPack)

{-------------------------------------------------------------------------------
  A ledger semantics for TestBlock
-------------------------------------------------------------------------------}

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

instance PayloadSemantics Tx where
  data PayloadDependentState Tx mk
    = UTxTok
    { forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables :: LedgerTables (LedgerState TestBlock) mk
    , -- \| All the tokens that ever existed. We use this to
      -- make sure a token is not created more than once. See
      -- the definition of 'applyPayload' in the
      -- 'PayloadSemantics' of 'Tx'.
      forall (mk :: MapKind). PayloadDependentState Tx mk -> Set Token
utxhist :: Set 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 = TxErr

  -- We need to exercise the HD backend. This requires that we store key-values
  -- ledger tables and the block application semantics satisfy:
  --
  -- \* a key is deleted at most once
  -- \* a key is inserted at most once
  --
  applyPayload :: PayloadDependentState Tx ValuesMK
-> Tx
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
applyPayload PayloadDependentState Tx ValuesMK
st Tx{Token
consumed :: Tx -> Token
consumed :: Token
consumed, (Token, TValue)
produced :: Tx -> (Token, TValue)
produced :: (Token, TValue)
produced} =
    (PayloadDependentState Tx ValuesMK
 -> PayloadDependentState Tx TrackingMK)
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx ValuesMK)
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
forall a b.
(a -> b)
-> Either (PayloadDependentError Tx) a
-> Either (PayloadDependentError Tx) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PayloadDependentState Tx ValuesMK
-> PayloadDependentState Tx TrackingMK
track (Either
   (PayloadDependentError Tx) (PayloadDependentState Tx ValuesMK)
 -> Either
      (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK))
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx ValuesMK)
-> Either
     (PayloadDependentError Tx) (PayloadDependentState Tx TrackingMK)
forall a b. (a -> b) -> a -> b
$ Token
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
delete Token
consumed PayloadDependentState Tx ValuesMK
st Either TxErr (PayloadDependentState Tx ValuesMK)
-> (PayloadDependentState Tx ValuesMK
    -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b.
Either TxErr a -> (a -> Either TxErr b) -> Either TxErr b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Token
 -> TValue
 -> PayloadDependentState Tx ValuesMK
 -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> (Token, TValue)
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Token
-> TValue
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
insert (Token, TValue)
produced
   where
    insert ::
      Token ->
      TValue ->
      PayloadDependentState Tx ValuesMK ->
      Either TxErr (PayloadDependentState Tx ValuesMK)
    insert :: Token
-> TValue
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
insert Token
tok TValue
val st' :: PayloadDependentState Tx ValuesMK
st'@UTxTok{LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables :: forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables :: LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables, Set Token
utxhist :: forall (mk :: MapKind). PayloadDependentState Tx mk -> Set Token
utxhist :: Set Token
utxhist} =
      if Token
tok Token -> Set Token -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Token
utxhist
        then TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. a -> Either a b
Left (TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. (a -> b) -> a -> b
$ Token -> TxErr
TokenWasAlreadyCreated Token
tok
        else
          PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. b -> Either a b
Right (PayloadDependentState Tx ValuesMK
 -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. (a -> b) -> a -> b
$
            PayloadDependentState Tx ValuesMK
st'
              { utxtoktables = Map.insert tok val `onValues` utxtoktables
              , utxhist = Set.insert tok utxhist
              }
    delete ::
      Token ->
      PayloadDependentState Tx ValuesMK ->
      Either TxErr (PayloadDependentState Tx ValuesMK)
    delete :: Token
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
delete Token
tok st' :: PayloadDependentState Tx ValuesMK
st'@UTxTok{LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables :: forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables :: LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables} =
      if Token -> Map Token TValue -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Token
tok (Map Token TValue -> Bool)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> Bool
forall a.
(Map Token TValue -> a)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> a
`queryKeys` LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables
        then
          PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. b -> Either a b
Right (PayloadDependentState Tx ValuesMK
 -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> PayloadDependentState Tx ValuesMK
-> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. (a -> b) -> a -> b
$
            PayloadDependentState Tx ValuesMK
st'
              { utxtoktables = Map.delete tok `onValues` utxtoktables
              }
        else TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. a -> Either a b
Left (TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK))
-> TxErr -> Either TxErr (PayloadDependentState Tx ValuesMK)
forall a b. (a -> b) -> a -> b
$ Token -> TxErr
TokenDoesNotExist Token
tok

    track :: PayloadDependentState Tx ValuesMK -> PayloadDependentState Tx TrackingMK
    track :: PayloadDependentState Tx ValuesMK
-> PayloadDependentState Tx TrackingMK
track PayloadDependentState Tx ValuesMK
stAfter =
      PayloadDependentState Tx ValuesMK
stAfter
        { utxtoktables =
            LedgerTables $ rawCalculateDifference utxtokBefore utxtokAfter
        }
     where
      utxtokBefore :: ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
utxtokBefore = LedgerTables (LedgerState TestBlock) ValuesMK
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall (l :: MapKind -> *) (mk :: MapKind).
LedgerTables l mk -> mk (TxIn l) (TxOut l)
getLedgerTables (LedgerTables (LedgerState TestBlock) ValuesMK
 -> ValuesMK
      (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock)))
-> LedgerTables (LedgerState TestBlock) ValuesMK
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ PayloadDependentState Tx ValuesMK
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables PayloadDependentState Tx ValuesMK
st
      utxtokAfter :: ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
utxtokAfter = LedgerTables (LedgerState TestBlock) ValuesMK
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall (l :: MapKind -> *) (mk :: MapKind).
LedgerTables l mk -> mk (TxIn l) (TxOut l)
getLedgerTables (LedgerTables (LedgerState TestBlock) ValuesMK
 -> ValuesMK
      (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock)))
-> LedgerTables (LedgerState TestBlock) ValuesMK
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ PayloadDependentState Tx ValuesMK
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables PayloadDependentState Tx ValuesMK
stAfter

  getPayloadKeySets :: Tx -> LedgerTables (LedgerState TestBlock) KeysMK
getPayloadKeySets Tx{Token
consumed :: Tx -> Token
consumed :: Token
consumed} =
    KeysMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) KeysMK
forall (l :: MapKind -> *) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (KeysMK
   (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
 -> LedgerTables (LedgerState TestBlock) KeysMK)
-> KeysMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) KeysMK
forall a b. (a -> b) -> a -> b
$ Set (TxIn (LedgerState TestBlock))
-> KeysMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall k v. Set k -> KeysMK k v
KeysMK (Set (TxIn (LedgerState TestBlock))
 -> KeysMK
      (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock)))
-> Set (TxIn (LedgerState TestBlock))
-> KeysMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ Token -> Set Token
forall a. a -> Set a
Set.singleton Token
consumed

deriving instance Eq (LedgerTables (LedgerState TestBlock) mk) => Eq (PayloadDependentState Tx mk)
deriving instance
  NoThunks (LedgerTables (LedgerState TestBlock) mk) => NoThunks (PayloadDependentState Tx mk)
deriving instance
  Show (LedgerTables (LedgerState TestBlock) mk) => Show (PayloadDependentState Tx mk)
deriving instance
  Serialise (LedgerTables (LedgerState TestBlock) mk) => Serialise (PayloadDependentState Tx mk)

onValues ::
  (Map Token TValue -> Map Token TValue) ->
  LedgerTables (LedgerState TestBlock) ValuesMK ->
  LedgerTables (LedgerState TestBlock) ValuesMK
onValues :: (Map Token TValue -> Map Token TValue)
-> LedgerTables (LedgerState TestBlock) ValuesMK
-> LedgerTables (LedgerState TestBlock) ValuesMK
onValues Map Token TValue -> Map Token TValue
f (LedgerTables ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
testUtxtokTable) = ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall (l :: MapKind -> *) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (ValuesMK
   (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
 -> LedgerTables (LedgerState TestBlock) ValuesMK)
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall a b. (a -> b) -> a -> b
$ ValuesMK Token TValue -> ValuesMK Token TValue
updateMap ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
ValuesMK Token TValue
testUtxtokTable
 where
  updateMap :: ValuesMK Token TValue -> ValuesMK Token TValue
  updateMap :: ValuesMK Token TValue -> ValuesMK Token TValue
updateMap (ValuesMK Map Token TValue
utxovals) =
    Map Token TValue -> ValuesMK Token TValue
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map Token TValue -> ValuesMK Token TValue)
-> Map Token TValue -> ValuesMK Token TValue
forall a b. (a -> b) -> a -> b
$ Map Token TValue -> Map Token TValue
f Map Token TValue
utxovals

queryKeys ::
  (Map Token TValue -> a) ->
  LedgerTables (LedgerState TestBlock) ValuesMK ->
  a
queryKeys :: forall a.
(Map Token TValue -> a)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> a
queryKeys Map Token TValue -> a
f (LedgerTables (ValuesMK Map (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
utxovals)) = Map Token TValue -> a
f Map (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
Map Token TValue
utxovals

{-------------------------------------------------------------------------------
  Instances required for on-disk storage of ledger state tables
-------------------------------------------------------------------------------}

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

instance CanUpgradeLedgerTables (LedgerState TestBlock) where
  upgradeTables :: forall (mk1 :: MapKind) (mk2 :: MapKind).
LedgerState TestBlock mk1
-> LedgerState TestBlock mk2
-> LedgerTables (LedgerState TestBlock) ValuesMK
-> LedgerTables (LedgerState TestBlock) ValuesMK
upgradeTables LedgerState TestBlock mk1
_ LedgerState TestBlock mk2
_ = LedgerTables (LedgerState TestBlock) ValuesMK
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall a. a -> a
id

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

instance SerializeTablesWithHint (LedgerState TestBlock) where
  encodeTablesWithHint :: SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> Encoding
encodeTablesWithHint = SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> LedgerTables (LedgerState TestBlock) ValuesMK -> Encoding
forall (l :: MapKind -> *).
(MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
defaultEncodeTablesWithHint
  decodeTablesWithHint :: forall s.
SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> Decoder s (LedgerTables (LedgerState TestBlock) ValuesMK)
decodeTablesWithHint = SerializeTablesHint (LedgerTables (LedgerState TestBlock) ValuesMK)
-> Decoder s (LedgerTables (LedgerState TestBlock) ValuesMK)
forall (l :: MapKind -> *) s.
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint

instance HasLedgerTables (LedgerState TestBlock) where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState TestBlock mk -> LedgerTables (LedgerState TestBlock) mk
projectLedgerTables LedgerState TestBlock mk
st = PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
forall (mk :: MapKind).
PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
utxtoktables (PayloadDependentState Tx mk
 -> LedgerTables (LedgerState TestBlock) mk)
-> PayloadDependentState Tx mk
-> LedgerTables (LedgerState TestBlock) mk
forall a b. (a -> b) -> a -> b
$ LedgerState TestBlock mk -> PayloadDependentState Tx mk
forall ptype (mk :: MapKind).
LedgerState (TestBlockWith ptype) mk
-> PayloadDependentState ptype mk
payloadDependentState LedgerState TestBlock mk
st
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState TestBlock any
-> LedgerTables (LedgerState TestBlock) mk
-> LedgerState TestBlock mk
withLedgerTables LedgerState TestBlock any
st LedgerTables (LedgerState TestBlock) mk
table =
    LedgerState TestBlock any
st
      { payloadDependentState =
          (payloadDependentState st){utxtoktables = table}
      }

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

instance Serialise (LedgerTables (LedgerState TestBlock) EmptyMK) where
  encode :: LedgerTables (LedgerState TestBlock) EmptyMK -> Encoding
encode (LedgerTables (EmptyMK Token TValue
_ :: EmptyMK Token TValue)) =
    Encoding
CBOR.encodeNull
  decode :: forall s. Decoder s (LedgerTables (LedgerState TestBlock) EmptyMK)
decode = EmptyMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) EmptyMK
forall (l :: MapKind -> *) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables EmptyMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
EmptyMK Token TValue
forall k v. EmptyMK k v
EmptyMK LedgerTables (LedgerState TestBlock) EmptyMK
-> Decoder s ()
-> Decoder s (LedgerTables (LedgerState TestBlock) EmptyMK)
forall a b. a -> Decoder s b -> Decoder s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Decoder s ()
forall s. Decoder s ()
CBOR.decodeNull

instance ToCBOR Token where
  toCBOR :: Token -> Encoding
toCBOR (Token Point TestBlock
pt) = Point TestBlock -> Encoding
forall a. Serialise a => a -> Encoding
S.encode Point TestBlock
pt

instance FromCBOR Token where
  fromCBOR :: forall s. Decoder s Token
fromCBOR = (Point TestBlock -> Token)
-> Decoder s (Point TestBlock) -> Decoder s Token
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point TestBlock -> Token
Token Decoder s (Point TestBlock)
forall s. Decoder s (Point TestBlock)
forall a s. Serialise a => Decoder s a
S.decode

instance MemPack Token where
  packM :: forall s. Token -> Pack s ()
packM = ByteString -> Pack s ()
forall s. ByteString -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM (ByteString -> Pack s ())
-> (Token -> ByteString) -> Token -> Pack s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize'
  packedByteCount :: Token -> Int
packedByteCount = ByteString -> Int
forall a. MemPack a => a -> Int
packedByteCount (ByteString -> Int) -> (Token -> ByteString) -> Token -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize'
  unpackM :: forall b. Buffer b => Unpack b Token
unpackM = ByteString -> Token
forall a. FromCBOR a => ByteString -> a
unsafeDeserialize' (ByteString -> Token) -> Unpack b ByteString -> Unpack b Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unpack b ByteString
forall b. Buffer b => Unpack b ByteString
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM

instance CanStowLedgerTables (LedgerState TestBlock) where
  stowLedgerTables :: LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
stowLedgerTables = String
-> LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall a. String -> a
stowErr String
"stowLedgerTables"
  unstowLedgerTables :: LedgerState TestBlock EmptyMK -> LedgerState TestBlock ValuesMK
unstowLedgerTables = String
-> LedgerState TestBlock EmptyMK -> LedgerState TestBlock ValuesMK
forall a. String -> a
stowErr String
"unstowLedgerTables"

stowErr :: String -> a
stowErr :: forall a. String -> a
stowErr String
fname = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Function " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" should not be used in these tests."

deriving anyclass instance ToExpr v => ToExpr (DS.Delta v)
deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Diff k v)
deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.RootMeasure k v)
deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.InternalMeasure k v)
deriving anyclass instance ToExpr v => ToExpr (StrictMaybe v)
deriving anyclass instance (ToExpr k, ToExpr v) => ToExpr (DS.Element k v)
deriving anyclass instance ToExpr DS.Length
deriving anyclass instance ToExpr DS.SlotNoUB
deriving anyclass instance ToExpr DS.SlotNoLB
deriving anyclass instance
  ToExpr (mk Token TValue) => ToExpr (LedgerTables (LedgerState TestBlock) mk)
deriving instance
  ToExpr (LedgerTables (LedgerState TestBlock) mk) => ToExpr (PayloadDependentState Tx mk)

deriving newtype instance ToExpr (ValuesMK Token TValue)

instance ToExpr v => ToExpr (DS.DeltaHistory v) where
  toExpr :: DeltaHistory v -> Expr
toExpr DeltaHistory v
h = String -> [Expr] -> Expr
App String
"DeltaHistory" [[Delta v] -> Expr
forall a. (Generic a, GToExpr (Rep a)) => a -> Expr
genericToExpr ([Delta v] -> Expr)
-> (DeltaHistory v -> [Delta v]) -> DeltaHistory v -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESeq (Delta v) -> [Delta v]
forall a. NESeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NESeq (Delta v) -> [Delta v])
-> (DeltaHistory v -> NESeq (Delta v))
-> DeltaHistory v
-> [Delta v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeltaHistory v -> NESeq (Delta v)
forall v. DeltaHistory v -> NESeq (Delta v)
DS.getDeltaHistory (DeltaHistory v -> Expr) -> DeltaHistory v -> Expr
forall a b. (a -> b) -> a -> b
$ DeltaHistory v
h]

instance ToExpr (ExtLedgerState TestBlock ValuesMK) where
  toExpr :: ExtLedgerState TestBlock ValuesMK -> Expr
toExpr = ExtLedgerState TestBlock ValuesMK -> Expr
forall a. (Generic a, GToExpr (Rep a)) => a -> Expr
genericToExpr

instance ToExpr (LedgerState (TestBlockWith Tx) ValuesMK) where
  toExpr :: LedgerState TestBlock ValuesMK -> Expr
toExpr = LedgerState TestBlock ValuesMK -> Expr
forall a. (Generic a, GToExpr (Rep a)) => a -> Expr
genericToExpr

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

{-------------------------------------------------------------------------------
  TestBlock generation

  When we added support for storing parts of the ledger state on disk we needed
  to exercise this new functionality. Therefore, we modified this test so that
  the ledger state associated to the test block contained tables (key-value
  maps) to be stored on disk. This ledger state needs to follow an evolution
  pattern similar to the UTxO one (see the 'PayloadSemantics' instance for more
  details). As a result, block application might fail on a given payload.

  The tests in this module assume that no invalid blocks are generated. Thus we
  have to satisfy this assumption in the block generators. To keep the
  generators simple, eg independent on the ledger state, we follow this strategy
  to block generation:

  - The block payload consist of a single transaction:
      - input: Point
      - output: (Point, SlotNo)
  - The ledger state is a map from Point to ().
  - We start always in an initial state in which 'GenesisPoint' maps to ().
  - When we generate a block for point p, the payload of the block will be:
      - input: point p - 1
      - ouptput: (point p, ())

  A consequence of adopting the strategy above is that the initial state is
  coupled to the generator's semantics.
 -------------------------------------------------------------------------------}

genesis :: ExtLedgerState TestBlock ValuesMK
genesis :: ExtLedgerState TestBlock ValuesMK
genesis = PayloadDependentState Tx ValuesMK
-> ExtLedgerState TestBlock ValuesMK
forall ptype (mk :: MapKind).
PayloadDependentState ptype mk
-> ExtLedgerState (TestBlockWith ptype) mk
testInitExtLedgerWithState PayloadDependentState Tx ValuesMK
initialTestLedgerState

initialTestLedgerState :: PayloadDependentState Tx ValuesMK
initialTestLedgerState :: PayloadDependentState Tx ValuesMK
initialTestLedgerState =
  UTxTok
    { utxtoktables :: LedgerTables (LedgerState TestBlock) ValuesMK
utxtoktables =
        ValuesMK
  (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall (l :: MapKind -> *) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (ValuesMK
   (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
 -> LedgerTables (LedgerState TestBlock) ValuesMK)
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> LedgerTables (LedgerState TestBlock) ValuesMK
forall a b. (a -> b) -> a -> b
$
          Map (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
 -> ValuesMK
      (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock)))
-> Map
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
-> ValuesMK
     (TxIn (LedgerState TestBlock)) (TxOut (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$
            TxIn (LedgerState TestBlock)
-> TValue -> Map (TxIn (LedgerState TestBlock)) TValue
forall k a. k -> a -> Map k a
Map.singleton TxIn (LedgerState TestBlock)
Token
initialToken (TValue -> Map (TxIn (LedgerState TestBlock)) TValue)
-> TValue -> Map (TxIn (LedgerState TestBlock)) TValue
forall a b. (a -> b) -> a -> b
$
              () -> TValue
TValue ()
    , utxhist :: Set Token
utxhist = Token -> Set Token
forall a. a -> Set a
Set.singleton Token
initialToken
    }
 where
  initialToken :: Token
initialToken = Point TestBlock -> Token
Token Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint

genBlocks ::
  Word64 ->
  Point TestBlock ->
  [TestBlock]
genBlocks :: Word64 -> Point TestBlock -> [TestBlock]
genBlocks Word64
n Point TestBlock
pt0 = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (Point TestBlock -> [TestBlock]
go Point TestBlock
pt0)
 where
  go :: Point TestBlock -> [TestBlock]
go Point TestBlock
pt = let b :: TestBlock
b = Point TestBlock -> TestBlock
genBlock Point TestBlock
pt in TestBlock
b TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: Point TestBlock -> [TestBlock]
go (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b)

genBlock ::
  Point TestBlock -> TestBlock
genBlock :: Point TestBlock -> TestBlock
genBlock Point TestBlock
pt =
  Point TestBlock -> Tx -> TestBlock
forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom
    Point TestBlock
pt
    Tx
      { consumed :: Token
consumed = Point TestBlock -> Token
Token Point TestBlock
pt
      , produced :: (Token, TValue)
produced = (Point TestBlock -> Token
Token Point TestBlock
pt', () -> TValue
TValue ())
      }
 where
  mkBlockFrom :: Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
  mkBlockFrom :: forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom Point (TestBlockWith ptype)
GenesisPoint = Word64 -> ptype -> TestBlockWith ptype
forall ptype. Word64 -> ptype -> TestBlockWith ptype
firstBlockWithPayload Word64
0
  mkBlockFrom (BlockPoint SlotNo
slot HeaderHash (TestBlockWith ptype)
hash) = TestHash -> SlotNo -> ptype -> TestBlockWith ptype
forall ptype. TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload HeaderHash (TestBlockWith ptype)
TestHash
hash SlotNo
slot

  pt' :: Point (TestBlockWith Tx)
  pt' :: Point TestBlock
pt' = Point (TestBlockWith ()) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (TestBlockWith () -> Point (TestBlockWith ())
forall block. HasHeader block => block -> Point block
blockPoint TestBlockWith ()
dummyBlk)
   where
    -- This could be the new block itself; we merely wanted to avoid the loop.
    dummyBlk :: TestBlockWith ()
    dummyBlk :: TestBlockWith ()
dummyBlk = Point (TestBlockWith ()) -> () -> TestBlockWith ()
forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom (Point TestBlock -> Point (TestBlockWith ())
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point TestBlock
pt) ()

extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig SecurityParam
secParam =
  LedgerDbCfg
    { ledgerDbCfgSecParam :: HKD Identity SecurityParam
ledgerDbCfgSecParam = SecurityParam
HKD Identity SecurityParam
secParam
    , ledgerDbCfg :: HKD Identity (LedgerCfg (ExtLedgerState TestBlock))
ledgerDbCfg =
        TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg (TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock)
-> TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock
forall a b. (a -> b) -> a -> b
$
          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
secParam
            (Word64 -> GenesisWindow
GenesisWindow (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
secParam)))
    , ledgerDbCfgComputeLedgerEvents :: ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents = ComputeLedgerEvents
OmitLedgerEvents
    }

-- | TODO: for the time being 'TestBlock' does not have 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)

-- | TODO: for the time being 'TestBlock' does not have 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)