{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Api.Tx.Body (spec) where

import Cardano.Ledger.Api.Era
import Cardano.Ledger.Api.Tx.Body
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible
import Cardano.Ledger.PoolParams
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.UTxO hiding (consumed, produced)
import Cardano.Ledger.State hiding (consumed)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val
import Data.Foldable
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Common

totalTxDeposits ::
  (EraTxBody era, EraCertState era) =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Coin
totalTxDeposits :: forall era.
(EraTxBody era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Coin
totalTxDeposits PParams era
pp CertState era
dpstate TxBody era
txb =
  Int
numKeys Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Map (KeyHash 'StakePool) PoolParams, Coin) -> Coin
forall a b. (a, b) -> b
snd (((Map (KeyHash 'StakePool) PoolParams, Coin)
 -> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin))
-> (Map (KeyHash 'StakePool) PoolParams, Coin)
-> [TxCert era]
-> (Map (KeyHash 'StakePool) PoolParams, Coin)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map (KeyHash 'StakePool) PoolParams, Coin)
-> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxCert era) =>
(Map (KeyHash 'StakePool) PoolParams, Coin)
-> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin)
accum (Map (KeyHash 'StakePool) PoolParams
regpools, Integer -> Coin
Coin Integer
0) [TxCert era]
certs)
  where
    certs :: [TxCert era]
certs = StrictSeq (TxCert era) -> [TxCert era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txb TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
    numKeys :: Int
numKeys = [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxCert era] -> Int) -> [TxCert era] -> Int
forall a b. (a -> b) -> a -> b
$ (TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert [TxCert era]
certs
    regpools :: Map (KeyHash 'StakePool) PoolParams
regpools = PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (CertState era
dpstate CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
    accum :: (Map (KeyHash 'StakePool) PoolParams, Coin)
-> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin)
accum (!Map (KeyHash 'StakePool) PoolParams
pools, !Coin
ans) (RegPoolTxCert PoolParams
poolparam) =
      -- We don't pay a deposit on a pool that is already registered
      if KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolparam) Map (KeyHash 'StakePool) PoolParams
pools
        then (Map (KeyHash 'StakePool) PoolParams
pools, Coin
ans)
        else (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolparam) PoolParams
poolparam Map (KeyHash 'StakePool) PoolParams
pools, Coin
ans Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL)
    accum (Map (KeyHash 'StakePool) PoolParams, Coin)
ans TxCert era
_ = (Map (KeyHash 'StakePool) PoolParams, Coin)
ans

keyTxRefunds ::
  (EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Coin
keyTxRefunds :: forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody era
tx = (UView (Credential 'Staking) RDPair, Coin) -> Coin
forall a b. (a, b) -> b
snd (((UView (Credential 'Staking) RDPair, Coin)
 -> TxCert era -> (UView (Credential 'Staking) RDPair, Coin))
-> (UView (Credential 'Staking) RDPair, Coin)
-> StrictSeq (TxCert era)
-> (UView (Credential 'Staking) RDPair, Coin)
forall b a. (b -> a -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UView (Credential 'Staking) RDPair, Coin)
-> TxCert era -> (UView (Credential 'Staking) RDPair, Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraTxCert era) =>
(UView (Credential 'Staking) RDPair, Coin)
-> TxCert era -> (UView (Credential 'Staking) RDPair, Coin)
accum (UView (Credential 'Staking) RDPair
initialKeys, Integer -> Coin
Coin Integer
0) StrictSeq (TxCert era)
certs)
  where
    certs :: StrictSeq (TxCert era)
certs = TxBody era
tx TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
    initialKeys :: UView (Credential 'Staking) RDPair
initialKeys = UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView (UMap -> UView (Credential 'Staking) RDPair)
-> UMap -> UView (Credential 'Staking) RDPair
forall a b. (a -> b) -> a -> b
$ CertState era
dpstate CertState era -> Getting UMap (CertState era) UMap -> UMap
forall s a. s -> Getting a s a -> a
^. (DState era -> Const UMap (DState era))
-> CertState era -> Const UMap (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const UMap (DState era))
 -> CertState era -> Const UMap (CertState era))
-> ((UMap -> Const UMap UMap)
    -> DState era -> Const UMap (DState era))
-> Getting UMap (CertState era) UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const UMap UMap) -> DState era -> Const UMap (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL
    keyDeposit :: CompactForm Coin
keyDeposit = HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
    accum :: (UView (Credential 'Staking) RDPair, Coin)
-> TxCert era -> (UView (Credential 'Staking) RDPair, Coin)
accum (!UView (Credential 'Staking) RDPair
keys, !Coin
ans) (RegTxCert Credential 'Staking
k) =
      -- Deposit is added locally to the growing 'keys'
      (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView (UMap -> UView (Credential 'Staking) RDPair)
-> UMap -> UView (Credential 'Staking) RDPair
forall a b. (a -> b) -> a -> b
$ Credential 'Staking
-> RDPair -> UView (Credential 'Staking) RDPair -> UMap
forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
k (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair CompactForm Coin
forall a. Monoid a => a
mempty CompactForm Coin
keyDeposit) UView (Credential 'Staking) RDPair
keys, Coin
ans)
    accum (!UView (Credential 'Staking) RDPair
keys, !Coin
ans) (UnRegTxCert Credential 'Staking
k) =
      -- If the key is registered, lookup the deposit in the locally growing 'keys'
      -- if it is not registered, then just return ans
      case Credential 'Staking
-> UView (Credential 'Staking) RDPair -> Maybe RDPair
forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
k UView (Credential 'Staking) RDPair
keys of
        Just (UM.RDPair CompactForm Coin
_ CompactForm Coin
deposit) -> (UView (Credential 'Staking) RDPair
keys, Coin
ans Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
deposit)
        Maybe RDPair
Nothing -> (UView (Credential 'Staking) RDPair
keys, Coin
ans)
    accum (UView (Credential 'Staking) RDPair, Coin)
ans TxCert era
_ = (UView (Credential 'Staking) RDPair, Coin)
ans

-- | This is the old implementation of `evalBodyTxBody`. We keep it around to ensure that
-- the produced result hasn't changed
evaluateTransactionBalance ::
  (MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
evaluateTransactionBalance :: forall era.
(MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalance PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody =
  PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> (TxBody era
txBody TxBody era
-> Getting (Value era) (TxBody era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxBody era) (Value era)
forall era.
MaryEraTxBody era =>
SimpleGetter (TxBody era) (Value era)
SimpleGetter (TxBody era) (Value era)
mintValueTxBodyF)

evaluateTransactionBalanceShelley ::
  (EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
evaluateTransactionBalanceShelley :: forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody = Value era
consumed Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<-> Value era
produced
  where
    produced :: Value era
produced =
      UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO (TxBody era -> UTxO era
forall era. EraTxBody era => TxBody era -> UTxO era
txouts TxBody era
txBody)
        Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t s. Inject t s => t -> s
inject (TxBody era
txBody TxBody era -> Getting Coin (TxBody era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxBody era) Coin
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> PParams era -> CertState era -> TxBody era -> Coin
forall era.
(EraTxBody era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Coin
totalTxDeposits PParams era
pp CertState era
dpstate TxBody era
txBody)
    consumed :: Value era
consumed =
      UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO (UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
        Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin
refunds Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
    refunds :: Coin
refunds = PParams era -> CertState era -> TxBody era -> Coin
forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody era
txBody
    withdrawals :: Coin
withdrawals = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map RewardAccount Coin -> Coin)
-> (Withdrawals -> Map RewardAccount Coin) -> Withdrawals -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals (Withdrawals -> Coin) -> Withdrawals -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL

-- | Randomly lookup pool params and staking credentials to add them as unregistration and
-- undelegation certificates respectively.
genTxBodyFrom ::
  (EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) =>
  CertState era ->
  UTxO era ->
  Gen (TxBody era)
genTxBodyFrom :: forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState era
certState (UTxO Map TxIn (TxOut era)
u) = do
  TxBody era
txBody <- Gen (TxBody era)
forall a. Arbitrary a => Gen a
arbitrary
  [TxIn]
inputs <- [TxIn] -> Gen [TxIn]
forall a. [a] -> Gen [a]
sublistOf (Map TxIn (TxOut era) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut era)
u)
  [Credential 'Staking]
unDelegCreds <-
    [Credential 'Staking] -> Gen [Credential 'Staking]
forall a. [a] -> Gen [a]
sublistOf (Set (Credential 'Staking) -> [Credential 'Staking]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (UView (Credential 'Staking) RDPair -> Set (Credential 'Staking)
forall k v. UView k v -> Set k
UM.domain (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView (UMap -> UView (Credential 'Staking) RDPair)
-> UMap -> UView (Credential 'Staking) RDPair
forall a b. (a -> b) -> a -> b
$ CertState era
certState CertState era -> Getting UMap (CertState era) UMap -> UMap
forall s a. s -> Getting a s a -> a
^. (DState era -> Const UMap (DState era))
-> CertState era -> Const UMap (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const UMap (DState era))
 -> CertState era -> Const UMap (CertState era))
-> ((UMap -> Const UMap UMap)
    -> DState era -> Const UMap (DState era))
-> Getting UMap (CertState era) UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const UMap UMap) -> DState era -> Const UMap (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL)))
  [PoolParams]
deRegKeys <- [PoolParams] -> Gen [PoolParams]
forall a. [a] -> Gen [a]
sublistOf (Map (KeyHash 'StakePool) PoolParams -> [PoolParams]
forall k a. Map k a -> [a]
Map.elems (CertState era
certState CertState era
-> Getting
     (Map (KeyHash 'StakePool) PoolParams)
     (CertState era)
     (Map (KeyHash 'StakePool) PoolParams)
-> Map (KeyHash 'StakePool) PoolParams
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
-> CertState era
-> Const (Map (KeyHash 'StakePool) PoolParams) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
 -> CertState era
 -> Const (Map (KeyHash 'StakePool) PoolParams) (CertState era))
-> ((Map (KeyHash 'StakePool) PoolParams
     -> Const
          (Map (KeyHash 'StakePool) PoolParams)
          (Map (KeyHash 'StakePool) PoolParams))
    -> PState era
    -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
-> Getting
     (Map (KeyHash 'StakePool) PoolParams)
     (CertState era)
     (Map (KeyHash 'StakePool) PoolParams)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool) PoolParams
 -> Const
      (Map (KeyHash 'StakePool) PoolParams)
      (Map (KeyHash 'StakePool) PoolParams))
-> PState era
-> Const (Map (KeyHash 'StakePool) PoolParams) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) PoolParams
 -> f (Map (KeyHash 'StakePool) PoolParams))
-> PState era -> f (PState era)
psStakePoolParamsL))
  [TxCert era]
certs <-
    [TxCert era] -> Gen [TxCert era]
forall a. [a] -> Gen [a]
shuffle ([TxCert era] -> Gen [TxCert era])
-> [TxCert era] -> Gen [TxCert era]
forall a b. (a -> b) -> a -> b
$
      StrictSeq (TxCert era) -> [TxCert era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
        [TxCert era] -> [TxCert era] -> [TxCert era]
forall a. Semigroup a => a -> a -> a
<> (Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
UnRegTxCert (Credential 'Staking -> TxCert era)
-> [Credential 'Staking] -> [TxCert era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Credential 'Staking]
unDelegCreds)
        [TxCert era] -> [TxCert era] -> [TxCert era]
forall a. Semigroup a => a -> a -> a
<> (PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert (PoolParams -> TxCert era) -> [PoolParams] -> [TxCert era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolParams]
deRegKeys)
  TxBody era -> Gen (TxBody era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( TxBody era
txBody
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputs
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxCert era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxCert era]
certs
    )

propEvalBalanceTxBody ::
  (EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceTxBody :: forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody PParams era
pp CertState era
certState UTxO era
utxo =
  Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (TxBody era) -> (TxBody era -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (CertState era -> UTxO era -> Gen (TxBody era)
forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState era
certState UTxO era
utxo) ((TxBody era -> Expectation) -> Property)
-> (TxBody era -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \TxBody era
txBody ->
      PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
forall era.
EraUTxO era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
evalBalanceTxBody PParams era
pp Credential 'Staking -> Maybe Coin
lookupKeyDeposit (Maybe Coin -> Credential 'DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) KeyHash 'StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody era
txBody
        Value era -> Value era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
forall era.
(MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalance PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody
  where
    lookupKeyDeposit :: Credential 'Staking -> Maybe Coin
lookupKeyDeposit = DState era -> Credential 'Staking -> Maybe Coin
forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    isRegPoolId :: KeyHash 'StakePool -> Bool
isRegPoolId = (KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL))

propEvalBalanceShelleyTxBody ::
  (EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceShelleyTxBody :: forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody PParams era
pp CertState era
certState UTxO era
utxo =
  Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (TxBody era) -> (TxBody era -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (CertState era -> UTxO era -> Gen (TxBody era)
forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState era
certState UTxO era
utxo) ((TxBody era -> Expectation) -> Property)
-> (TxBody era -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \TxBody era
txBody ->
      PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
forall era.
EraUTxO era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
evalBalanceTxBody PParams era
pp Credential 'Staking -> Maybe Coin
lookupKeyDeposit (Maybe Coin -> Credential 'DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) KeyHash 'StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody era
txBody
        Value era -> Value era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody
  where
    lookupKeyDeposit :: Credential 'Staking -> Maybe Coin
lookupKeyDeposit = DState era -> Credential 'Staking -> Maybe Coin
forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    isRegPoolId :: KeyHash 'StakePool -> Bool
isRegPoolId = (KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL))

-- | NOTE: We cannot have this property pass for Conway and beyond because Conway changes this calculation.
-- This property test only exists to confirm that the old and new implementations for the evalBalanceTxBody` API matched,
-- and this can be ascertained only until Babbage.
spec :: Spec
spec :: Spec
spec =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxBody" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ShelleyEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams ShelleyEra
    -> CertState ShelleyEra -> UTxO ShelleyEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams ShelleyEra
  -> CertState ShelleyEra -> UTxO ShelleyEra -> Property)
 -> Spec)
-> (PParams ShelleyEra
    -> CertState ShelleyEra -> UTxO ShelleyEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @ShelleyEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AllegraEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams AllegraEra
    -> CertState AllegraEra -> UTxO AllegraEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams AllegraEra
  -> CertState AllegraEra -> UTxO AllegraEra -> Property)
 -> Spec)
-> (PParams AllegraEra
    -> CertState AllegraEra -> UTxO AllegraEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era),
 EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @AllegraEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"MaryEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams MaryEra
    -> CertState MaryEra -> UTxO MaryEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams MaryEra -> CertState MaryEra -> UTxO MaryEra -> Property)
 -> Spec)
-> (PParams MaryEra
    -> CertState MaryEra -> UTxO MaryEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @MaryEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AlonzoEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams AlonzoEra
    -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams AlonzoEra
  -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
 -> Spec)
-> (PParams AlonzoEra
    -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @AlonzoEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BabbageEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams BabbageEra
    -> CertState BabbageEra -> UTxO BabbageEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams BabbageEra
  -> CertState BabbageEra -> UTxO BabbageEra -> Property)
 -> Spec)
-> (PParams BabbageEra
    -> CertState BabbageEra -> UTxO BabbageEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @BabbageEra