{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 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 s. Buffer b => Unpack s b TValue)
-> MemPack TValue
TValue -> Int
forall a.
String
-> (a -> Int)
-> (forall s. a -> Pack s ())
-> (forall b s. Buffer b => Unpack s b a)
-> MemPack a
forall s. TValue -> Pack s ()
forall b s. Buffer b => Unpack s b TValue
$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 s. Buffer b => Unpack s b TValue
unpackM :: forall b s. Buffer b => Unpack s 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 TestBlock mk
utxtoktables :: LedgerTables 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 TestBlock ValuesMK
utxtoktables :: forall (mk :: MapKind).
PayloadDependentState Tx mk -> LedgerTables TestBlock mk
utxtoktables :: LedgerTables 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 TestBlock ValuesMK
utxtoktables :: forall (mk :: MapKind).
PayloadDependentState Tx mk -> LedgerTables TestBlock mk
utxtoktables :: LedgerTables 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 TestBlock ValuesMK -> Bool
forall a.
(Map Token TValue -> a) -> LedgerTables TestBlock ValuesMK -> a
`queryKeys` LedgerTables 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 TestBlock) (TxOut TestBlock)
utxtokBefore = LedgerTables TestBlock ValuesMK
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall blk (mk :: MapKind).
LedgerTables blk mk -> mk (TxIn blk) (TxOut blk)
getLedgerTables (LedgerTables TestBlock ValuesMK
 -> ValuesMK (TxIn TestBlock) (TxOut TestBlock))
-> LedgerTables TestBlock ValuesMK
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall a b. (a -> b) -> a -> b
$ PayloadDependentState Tx ValuesMK
-> LedgerTables TestBlock ValuesMK
forall (mk :: MapKind).
PayloadDependentState Tx mk -> LedgerTables TestBlock mk
utxtoktables PayloadDependentState Tx ValuesMK
st
      utxtokAfter :: ValuesMK (TxIn TestBlock) (TxOut TestBlock)
utxtokAfter = LedgerTables TestBlock ValuesMK
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall blk (mk :: MapKind).
LedgerTables blk mk -> mk (TxIn blk) (TxOut blk)
getLedgerTables (LedgerTables TestBlock ValuesMK
 -> ValuesMK (TxIn TestBlock) (TxOut TestBlock))
-> LedgerTables TestBlock ValuesMK
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall a b. (a -> b) -> a -> b
$ PayloadDependentState Tx ValuesMK
-> LedgerTables TestBlock ValuesMK
forall (mk :: MapKind).
PayloadDependentState Tx mk -> LedgerTables TestBlock mk
utxtoktables PayloadDependentState Tx ValuesMK
stAfter

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

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

onValues ::
  (Map Token TValue -> Map Token TValue) ->
  LedgerTables TestBlock ValuesMK ->
  LedgerTables TestBlock ValuesMK
onValues :: (Map Token TValue -> Map Token TValue)
-> LedgerTables TestBlock ValuesMK
-> LedgerTables TestBlock ValuesMK
onValues Map Token TValue -> Map Token TValue
f (LedgerTables ValuesMK (TxIn TestBlock) (TxOut TestBlock)
testUtxtokTable) = ValuesMK (TxIn TestBlock) (TxOut TestBlock)
-> LedgerTables TestBlock ValuesMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables (ValuesMK (TxIn TestBlock) (TxOut TestBlock)
 -> LedgerTables TestBlock ValuesMK)
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
-> LedgerTables TestBlock ValuesMK
forall a b. (a -> b) -> a -> b
$ ValuesMK Token TValue -> ValuesMK Token TValue
updateMap ValuesMK (TxIn TestBlock) (TxOut 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 TestBlock ValuesMK ->
  a
queryKeys :: forall a.
(Map Token TValue -> a) -> LedgerTables TestBlock ValuesMK -> a
queryKeys Map Token TValue -> a
f (LedgerTables (ValuesMK Map (TxIn TestBlock) (TxOut TestBlock)
utxovals)) = Map Token TValue -> a
f Map (TxIn TestBlock) (TxOut TestBlock)
Map Token TValue
utxovals

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

type instance TxIn TestBlock = Token
type instance TxOut TestBlock = TValue

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

instance IndexedMemPack LedgerState TestBlock TValue where
  indexedTypeName :: Proxy TValue -> LedgerState TestBlock EmptyMK -> String
indexedTypeName Proxy TValue
_ 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 s.
Buffer b =>
LedgerState TestBlock EmptyMK -> Unpack s b TValue
indexedUnpackM LedgerState TestBlock EmptyMK
_ = Unpack s b TValue
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b TValue
unpackM

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

instance HasLedgerTables LedgerState TestBlock where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState TestBlock mk -> LedgerTables TestBlock mk
projectLedgerTables LedgerState TestBlock mk
st = PayloadDependentState Tx mk -> LedgerTables TestBlock mk
forall (mk :: MapKind).
PayloadDependentState Tx mk -> LedgerTables TestBlock mk
utxtoktables (PayloadDependentState Tx mk -> LedgerTables TestBlock mk)
-> PayloadDependentState Tx mk -> LedgerTables 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 TestBlock mk -> LedgerState TestBlock mk
withLedgerTables LedgerState TestBlock any
st LedgerTables 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 TestBlock mk
projectLedgerTables (TickedTestLedger LedgerState TestBlock mk
st) = LedgerState TestBlock mk -> LedgerTables TestBlock mk
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState TestBlock mk -> LedgerTables TestBlock mk
forall (l :: * -> MapKind -> *) blk (mk :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
projectLedgerTables LedgerState TestBlock mk
st
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked LedgerState TestBlock any
-> LedgerTables TestBlock mk -> Ticked LedgerState TestBlock mk
withLedgerTables (TickedTestLedger LedgerState TestBlock any
st) LedgerTables 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 TestBlock mk -> LedgerState TestBlock mk
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState TestBlock any
-> LedgerTables TestBlock mk -> LedgerState TestBlock 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
withLedgerTables LedgerState TestBlock any
st LedgerTables TestBlock mk
tables

instance Serialise (LedgerTables TestBlock EmptyMK) where
  encode :: LedgerTables TestBlock EmptyMK -> Encoding
encode (LedgerTables (EmptyMK Token TValue
_ :: EmptyMK Token TValue)) =
    Encoding
CBOR.encodeNull
  decode :: forall s. Decoder s (LedgerTables TestBlock EmptyMK)
decode = EmptyMK (TxIn TestBlock) (TxOut TestBlock)
-> LedgerTables TestBlock EmptyMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables EmptyMK (TxIn TestBlock) (TxOut TestBlock)
EmptyMK Token TValue
forall k v. EmptyMK k v
EmptyMK LedgerTables TestBlock EmptyMK
-> Decoder s () -> Decoder s (LedgerTables 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 s. Buffer b => Unpack s b Token
unpackM = ByteString -> Token
forall a. FromCBOR a => ByteString -> a
unsafeDeserialize' (ByteString -> Token) -> Unpack s b ByteString -> Unpack s b Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unpack s b ByteString
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b ByteString
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 v => ToExpr (StrictMaybe v)
deriving anyclass instance
  ToExpr (mk Token TValue) => ToExpr (LedgerTables TestBlock mk)
deriving instance
  ToExpr (LedgerTables 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 TestBlock ValuesMK
utxtoktables =
        ValuesMK (TxIn TestBlock) (TxOut TestBlock)
-> LedgerTables TestBlock ValuesMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables (ValuesMK (TxIn TestBlock) (TxOut TestBlock)
 -> LedgerTables TestBlock ValuesMK)
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
-> LedgerTables TestBlock ValuesMK
forall a b. (a -> b) -> a -> b
$
          Map (TxIn TestBlock) (TxOut TestBlock)
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map (TxIn TestBlock) (TxOut TestBlock)
 -> ValuesMK (TxIn TestBlock) (TxOut TestBlock))
-> Map (TxIn TestBlock) (TxOut TestBlock)
-> ValuesMK (TxIn TestBlock) (TxOut TestBlock)
forall a b. (a -> b) -> a -> b
$
            TxIn TestBlock -> TValue -> Map (TxIn TestBlock) TValue
forall k a. k -> a -> Map k a
Map.singleton TxIn TestBlock
Token
initialToken (TValue -> Map (TxIn TestBlock) TValue)
-> TValue -> Map (TxIn 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 = HKD Identity SecurityParam
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)