{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (DijkstraUtxoPredFailure (..))
import Cardano.Ledger.Dijkstra.State
import Cardano.Ledger.Mary.Value (
  AssetName,
  MaryValue (..),
  PolicyID (..),
  multiAssetFromList,
 )
import Cardano.Ledger.Plutus
import qualified Cardano.Ledger.Shelley.AdaPots as AdaPots
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts (pattern RequireSignature)
import Cardano.Ledger.Shelley.UTxO (produced)
import Cardano.Ledger.Tools (ensureMinCoinTxOut)
import Cardano.Ledger.TxIn
import Cardano.Ledger.Val
import qualified Data.Map.Strict as Map
import qualified Data.OMap.Strict as OMap
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Lens.Micro
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum)

spec ::
  forall era.
  DijkstraEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Collaterals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1264
    -- TODO: Re-enable after issue is resolved, by removing this override
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Fails to submit a transaction containing a Ptr in collateral return" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Payment -> Credential Payment
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Payment -> Credential Payment)
-> ImpM (LedgerSpec era) (KeyHash Payment)
-> ImpM (LedgerSpec era) (Credential Payment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Payment)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ptr <- arbitrary
      pp <- getsPParams id
      let
        ptrAddr = Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet Credential Payment
cred (Ptr -> StakeReference
StakeRefPtr Ptr
ptr)
        ptrOutput = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
ptrAddr (Value era -> TxOut era)
-> (Coin -> Value era) -> Coin -> TxOut era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100
        tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
SJust TxOut era
ptrOutput
      submitFailingTx tx [injectFailure $ PtrPresentInCollateralReturn ptrOutput]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"value produced by a transaction" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts each new pool deposit at most once across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [poolKh] [[poolKh], [poolKh]]
            -- just the pool deposits are in `produced` because the transaction is not fixed up
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitTx_ =<< genTx
      submitTx_ =<< switchTxToLegacyMode =<< genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts distinct pool deposits in top and sub separately" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
            poolA <- freshKeyHash
            poolB <- freshKeyHash
            tx <- registerPoolTxWithSubTxs [poolB, poolA, poolB] [[poolA, poolA, poolB], [poolA, poolB]]
            expectProduced tx $ inject ((2 :: Int) <×> (pp ^. ppPoolDepositL))
            pure tx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToLegacyMode (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"includes sub-tx cert deposits when top has no certs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [] [[poolKh]]
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitTx_ =<< genTx
      submitTx_ =<< switchTxToLegacyMode =<< genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not count re-registrations of an already-registered pool across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            registerPool poolKh
            tx <- registerPoolTxWithSubTxs [poolKh] [[poolKh]]
            expectProduced tx mempty
            pure tx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToLegacyMode (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dedupes across multiple subtransactions registering the same fresh pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [] [[poolKh], [poolKh]]
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitTx_ =<< genTx
      submitTx_ =<< switchTxToLegacyMode =<< genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sums outputs, fee, treasury donations and deposits across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            let poolDeposit :: Coin
poolDeposit = 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, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL
                dRepDeposit :: Coin
dRepDeposit = 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. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL

            let freshPoolCert :: ImpM (LedgerSpec era) (TxCert era)
freshPoolCert = do
                  poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
                  pps <- freshPoolParams poolKh =<< registerAccountAddress
                  pure $ RegPoolTxCert @era pps
            topPoolCert <- ImpM (LedgerSpec era) (TxCert era)
freshPoolCert
            subPoolCert <- freshPoolCert

            let freshDRepCert = do
                  kh <- ImpM (LedgerSpec era) (KeyHash DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
                  pure $ RegDRepTxCert @era (KeyHashObj kh) dRepDeposit SNothing
            topDRepCert <- freshDRepCert
            subDRepCert <- freshDRepCert

            subDDAccount <- registerAccountAddress
            subDDAmount <- (Coin 1 <>) <$> arbitrary

            topOut <- freshTxOut
            subOut <- freshTxOut
            topTreasury <- arbitrary
            subTreasury <- arbitrary
            -- we are setting the fee manually in order to verify the `produced` value before the fixup.
            topFee <- (Coin 1_000_000 <>) <$> arbitrary

            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
subOut]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxCert era))
TxCert era
subPoolCert, Item (StrictSeq (TxCert era))
TxCert era
subDRepCert]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Coin -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
subTreasury
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> DirectDeposits -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
subDDAccount, Coin
subDDAmount)]
                topTx :: Tx TopTx era
                topTx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
topOut]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topFee
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxCert era))
TxCert era
topPoolCert, Item (StrictSeq (TxCert era))
TxCert era
topDRepCert]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topTreasury
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
                -- we're not adding direct deposits at the top level
                -- in order to be able to submit this transaction when switched to legacy mode
                -- (which doesn't support direct deposits)
                expectedCoin =
                  (TxOut era
topOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> (TxOut era
subOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topFee
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topTreasury
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subTreasury
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
poolDeposit)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
dRepDeposit)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subDDAmount
            expectProduced topTx $ inject expectedCoin
            checkDepositCalculation
              (topTx ^. bodyTxL)
              (((2 :: Int) <×> poolDeposit) <> ((2 :: Int) <×> dRepDeposit))
              (poolDeposit <> dRepDeposit)
            pure topTx

      submitTx_ =<< genTx
      submitTx_ =<< switchTxToLegacyMode =<< genTx

    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"sums assets burned by the top and the sub transaction" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            -- Mint upfront the tokens that the batch is going to burn: one output for the top
            -- transaction to spend and one for the sub transaction.
            policyId <- ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) PolicyID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpM (LedgerSpec era) ScriptHash)
-> (KeyHash Witness -> NativeScript era)
-> KeyHash Witness
-> ImpM (LedgerSpec era) ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (KeyHash Witness -> ImpM (LedgerSpec era) ScriptHash)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) ScriptHash
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash)
            assetName <- arbitrary @AssetName
            topBurnAmount <- getPositive <$> arbitrary
            subBurnAmount <- getPositive <$> arbitrary
            tokenAddr <- freshKeyAddr_
            let tokens Integer
n = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
policyId, AssetName
assetName, Integer
n)]
            mintTx <-
              submitTx $
                mkBasicTx $
                  mkBasicTxBody
                    & mintTxBodyL .~ tokens (topBurnAmount + subBurnAmount)
                    & outputsTxBodyL
                      .~ [ mkBasicTxOut tokenAddr (MaryValue mempty (tokens topBurnAmount))
                         , mkBasicTxOut tokenAddr (MaryValue mempty (tokens subBurnAmount))
                         ]
            topOut <- freshTxOut
            subOut <- freshTxOut
            topFee <- (Coin 1_000_000 <>) <$> arbitrary
            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt (Int
1 :: Int) Tx TopTx era
mintTx]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
subOut]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> MultiAsset -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> MultiAsset
tokens (Integer -> Integer
forall a. Num a => a -> a
negate Integer
subBurnAmount)
                topTx :: Tx TopTx era
                topTx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt (Int
0 :: Int) Tx TopTx era
mintTx]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
topOut]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topFee
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> MultiAsset -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> MultiAsset
tokens (Integer -> Integer
forall a. Num a => a -> a
negate Integer
topBurnAmount)
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
                expected =
                  Coin -> MultiAsset -> MaryValue
MaryValue
                    ((TxOut era
topOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> (TxOut era
subOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topFee)
                    (Integer -> MultiAsset
tokens (Integer
topBurnAmount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
subBurnAmount))
            expectProduced topTx expected
            pure topTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToLegacyMode (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Value preservation" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let mkSubTx :: BatchAmounts -> ImpTestM era (Tx SubTx era)
        mkSubTx :: BatchAmounts -> ImpTestM era (Tx SubTx era)
mkSubTx BatchAmounts {Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
..} = do
          txIn <- Coin -> ImpTestM era TxIn
txInWithFunds Coin
baSubTxIn
          txOut <- mkTxOut baSubTxOut
          account <- registerAccountAddress
          pure $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & outputsTxBodyL .~ [txOut]
                & directDepositsTxBodyL .~ DirectDeposits [(account, baSubDirectDeposit)]

    let mkTopTx :: BatchAmounts -> ImpTestM era (Tx TopTx era)
        mkTopTx :: BatchAmounts -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTopTx amounts :: BatchAmounts
amounts@BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} = do
          txIn <- Coin -> ImpTestM era TxIn
txInWithFunds Coin
baTopTxIn
          txOut <- mkTxOut baTopTxOut
          account <- registerAccountAddress
          fundAccountBalance account baTopWithdrawal
          subTx <- mkSubTx amounts
          pure $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & outputsTxBodyL .~ [txOut]
                & feeTxBodyL .~ baFee
                & withdrawalsTxBodyL .~ Withdrawals [(account, baTopWithdrawal)]
                & subTransactionsTxBodyL .~ OMap.singleton subTx

    let mkTopTxLegacyMode :: BatchAmounts -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
        mkTopTxLegacyMode :: BatchAmounts
-> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTopTxLegacyMode BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} Tx TopTx era
tx = do
          scriptTxIn <- ScriptHash -> Coin -> ImpTestM era TxIn
produceScriptAt (Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV3
SPlutusV3) Coin
baScriptTxIn
          pure $
            tx
              & bodyTxL . inputsTxBodyL <>~ Set.singleton scriptTxIn
              & bodyTxL . feeTxBodyL <>~ baScriptTxIn

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
      topTx <- mkTopTx amounts
      withFixup noBalanceFixup $ submitTx_ topTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      withFixup noBalanceFixup $ submitTx_ topTxLegacy

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and unbalanced at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      withFixup noBalanceFixup $ submitTx_ topTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and unbalanced at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedInLegacyMode
                Mismatch
                  { mismatchSupplied = inject (bbTopConsumed balances)
                  , mismatchExpected = inject (bbTopProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced at the top level and unbalanced across the batch - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTx
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced at the top level and unbalanced across the batch - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx unbalanced across the batch and at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts
      topTx <- mkTopTx amounts
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTx
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx unbalanced across the batch and at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedInLegacyMode
                Mismatch
                  { mismatchSupplied = inject (bbTopConsumed balances)
                  , mismatchExpected = inject (bbTopProduced balances)
                  }
          , injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"fixup function for balancing subtransactions" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"top-only balanced - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
        topTx <- mkTopTx amounts
        balanced <- balanceSubTransactions topTx
        withFixup noBalanceFixup $ submitTx_ balanced

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"top-only balanced - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
        topTx <- mkTopTx amounts
        topTxLegacy <- mkTopTxLegacyMode amounts topTx
        balanced <- balanceSubTransactions topTxLegacy
        withFixup noBalanceFixup $ submitTx_ balanced

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"balanced on both levels keeps it balanced" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
        topTx <- mkTopTx amounts
        balanced <- balanceSubTransactions topTx
        withFixup noBalanceFixup $ submitTx_ balanced
  where
    registerPoolTxWithSubTxs ::
      [KeyHash StakePool] -> -- top's pool certs
      [[KeyHash StakePool]] -> -- one sub-tx per inner list, with one pool cert per key
      ImpTestM era (Tx TopTx era)
    registerPoolTxWithSubTxs :: [KeyHash StakePool]
-> [[KeyHash StakePool]] -> ImpM (LedgerSpec era) (Tx TopTx era)
registerPoolTxWithSubTxs [KeyHash StakePool]
topKhs [[KeyHash StakePool]]
subKhs = do
      top <- forall (l :: TxLevel).
Typeable l =>
[KeyHash StakePool] -> ImpTestM era (Tx l era)
registerPoolTx @TopTx [KeyHash StakePool]
topKhs
      subs <- traverse (registerPoolTx @SubTx) subKhs
      pure $ top & bodyTxL . subTransactionsTxBodyL .~ OMap.fromFoldable subs
    registerPoolTx :: forall l. Typeable l => [KeyHash StakePool] -> ImpTestM era (Tx l era)
    registerPoolTx :: forall (l :: TxLevel).
Typeable l =>
[KeyHash StakePool] -> ImpTestM era (Tx l era)
registerPoolTx [KeyHash StakePool]
khPools = do
      certs <-
        (KeyHash StakePool -> ImpM (LedgerSpec era) (TxCert era))
-> [KeyHash StakePool] -> ImpM (LedgerSpec era) [TxCert era]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          ( \KeyHash StakePool
khPool ->
              forall era. EraTxCert era => StakePoolParams -> TxCert era
RegPoolTxCert @era (StakePoolParams -> TxCert era)
-> ImpTestM era StakePoolParams
-> ImpM (LedgerSpec era) (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KeyHash StakePool -> AccountAddress -> ImpTestM era StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> AccountAddress -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
khPool (AccountAddress -> ImpTestM era StakePoolParams)
-> ImpM (LedgerSpec era) AccountAddress
-> ImpTestM era StakePoolParams
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress)
          )
          [KeyHash StakePool]
khPools
      pure $ mkBasicTx mkBasicTxBody & bodyTxL . certsTxBodyL .~ StrictSeq.fromList certs
    expectProduced :: Tx TopTx era -> Value era -> ImpTestM era ()
    expectProduced :: Tx TopTx era -> Value era -> ImpM (LedgerSpec era) ()
expectProduced Tx TopTx era
tx Value era
expected = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      pState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certPStateL
      produced pp pState (tx ^. bodyTxL) `shouldBe` expected

    -- Check that `certsTotalDepositsTxBody` (used to set deposits in `UTxOState` and `AdaPots` calculations)
    -- returns the batch deposits, while `getTotalDepositsTxBody` returns the top-level deposits
    checkDepositCalculation :: TxBody TopTx era -> Coin -> Coin -> ImpM (LedgerSpec era) ()
checkDepositCalculation TxBody TopTx era
topBody Coin
batchDeposits Coin
topLevelDeposits = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
      AdaPots.proDeposits (AdaPots.producedTxBody topBody pp certState)
        `shouldBe` batchDeposits
      let isPoolReg = (KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (CertState era
certState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL))
      getTotalDepositsTxBody pp isPoolReg topBody `shouldBe` topLevelDeposits
    freshTxOut :: ImpM (LedgerSpec era) (TxOut era)
freshTxOut = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      addr <- freshKeyAddr_
      amount <- arbitrary @Coin
      pure $ ensureMinCoinTxOut pp (mkBasicTxOut addr (inject amount))
    fundAccountBalance :: AccountAddress -> Coin -> ImpTestM era ()
    fundAccountBalance :: AccountAddress -> Coin -> ImpM (LedgerSpec era) ()
fundAccountBalance AccountAddress
account Coin
amount = do
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
          TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> DirectDeposits -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
account, Coin
amount)]
    txInWithFunds :: Coin -> ImpTestM era TxIn
    txInWithFunds :: Coin -> ImpTestM era TxIn
txInWithFunds Coin
amount = ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpTestM era TxIn) -> ImpTestM era TxIn
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
a -> Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
a Coin
amount
    mkTxOut :: Coin -> ImpTestM era (TxOut era)
    mkTxOut :: Coin -> ImpM (LedgerSpec era) (TxOut era)
mkTxOut Coin
amount = ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (TxOut era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
a -> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
a (Coin -> MaryValue
forall t s. Inject t s => t -> s
inject Coin
amount)
    produceScriptAt :: ScriptHash -> Coin -> ImpTestM era TxIn
    produceScriptAt :: ScriptHash -> Coin -> ImpTestM era TxIn
produceScriptAt ScriptHash
scriptHash Coin
amount = do
      let addr :: Addr
addr = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
      let tx :: Tx TopTx era
tx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
amount)]
      Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 (Tx TopTx era -> TxIn)
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpTestM era TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTx Tx TopTx era
tx

noBalanceFixup ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
noBalanceFixup :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
noBalanceFixup =
  Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupSubTransactions
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (m :: * -> *) (l :: TxLevel).
(EraTx era, Applicative m) =>
Tx l era -> m (Tx l era)
fixupAuxDataHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
AlonzoEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInput
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupRedeemerIndices
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(ShelleyEraImp era, HasCallStack) =>
Tx l era -> ImpTestM era (Tx l era)
fixupTxOuts
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupCollateralReturn
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits

-- A template for creating a transaction with exactly one subtransaction,
-- with values for different fields that contribute to consumed and produced.
data BatchAmounts = BatchAmounts
  { BatchAmounts -> Coin
baSubTxIn :: Coin
  , BatchAmounts -> Coin
baSubTxOut :: Coin
  , BatchAmounts -> Coin
baSubDirectDeposit :: Coin
  , BatchAmounts -> Coin
baTopTxIn :: Coin
  , BatchAmounts -> Coin
baTopWithdrawal :: Coin
  , BatchAmounts -> Coin
baTopTxOut :: Coin
  , BatchAmounts -> Coin
baFee :: Coin
  , BatchAmounts -> Coin
baScriptTxIn :: Coin
  }

genBatchOnlyBalancedAmounts :: ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts = do
  -- we are restricted in the lower bound by min utxo size
  -- and in the upper bound by the hardcoded collateral in `makeCollateralInput`
  m <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
1_000_000, Integer
2_000_000)
  pure $ mkAmounts m
  where
    mkAmounts :: Coin -> BatchAmounts
mkAmounts Coin
m =
      -- These values create an unbalanced sub-transaction, with:
      --      consumed = subTxIn   = 1
      --      produced = subTxOut + subDirectDeposit  =  2 + 3
      -- and an unbalanced top transaction, with:
      --      consumed = topTxIn + topWithdrawal = 8 + 5
      --      produced = topTxOut + fee    = 6 + 3
      -- Legacy variant adds scriptTxIn on both sides (input + fee)
      -- On the batch level, the transaction is balancing out.
      let amounts :: BatchAmounts
amounts =
            BatchAmounts
              { baSubTxIn :: Coin
baSubTxIn = (Int
1 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baSubTxOut :: Coin
baSubTxOut = (Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baSubDirectDeposit :: Coin
baSubDirectDeposit = (Int
3 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopTxIn :: Coin
baTopTxIn = (Int
8 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopWithdrawal :: Coin
baTopWithdrawal = (Int
5 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopTxOut :: Coin
baTopTxOut = (Int
6 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baFee :: Coin
baFee = (Int
3 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baScriptTxIn :: Coin
baScriptTxIn = (Int
4 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              }
       in HasCallStack => BatchAmounts -> BatchAmounts
BatchAmounts -> BatchAmounts
assertBatchBalanced BatchAmounts
amounts

-- Amounts for a transaction that balances out both at batch level, and at top level
genFullyBalancedAmounts :: ImpTestM era BatchAmounts
genFullyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts = do
  batchBalanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
  let BatchBalances {..} = batchBalances False batchBalanced
      mismatch = Coin
bbTopConsumed Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
bbTopProduced
      fullyBalanced =
        BatchAmounts
batchBalanced
          { -- because the batch is balanced, we can fix both top and sub balances with the same `mismatch`
            baTopTxOut = baTopTxOut <> mismatch
          , baSubTxIn = baSubTxIn <> mismatch
          }
  pure $
    fullyBalanced
      & assertBatchBalanced
      & assertTopBalanced
      & assertSubBalanced

-- Amounts for a transaction that doesn't balance out - neither at top or batch level
genFullyUnbalancedAmounts :: ImpTestM era BatchAmounts
genFullyUnbalancedAmounts :: forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts = do
  balanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
  extra <- Coin . getPositive <$> arbitrary
  pure $ balanced {baTopTxIn = baTopTxIn <> extra}

genTopOnlyBalancedAmounts :: ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts = do
  balanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
  extra <- Coin . getPositive <$> arbitrary
  pure $ balanced {baSubTxIn = baSubTxIn <> extra}

data BatchBalances = BatchBalances
  { BatchBalances -> Coin
bbSubConsumed :: Coin
  , BatchBalances -> Coin
bbSubProduced :: Coin
  , BatchBalances -> Coin
bbTopConsumed :: Coin
  , BatchBalances -> Coin
bbTopProduced :: Coin
  , BatchBalances -> Coin
bbBatchConsumed :: Coin
  , BatchBalances -> Coin
bbBatchProduced :: Coin
  }

assertBatchBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertBatchBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertBatchBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbBatchConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbBatchProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: batch amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbBatchConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbBatchProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

assertTopBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertTopBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertTopBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbTopConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbTopProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: top transaction amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbTopConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbTopProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

assertSubBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertSubBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertSubBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbSubConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbSubProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: sub-transaction amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbSubConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbSubProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

batchBalances :: Bool -> BatchAmounts -> BatchBalances
batchBalances :: Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
isLegacy BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} =
  let script :: Coin
script = if Bool
isLegacy then Coin
baScriptTxIn else Coin
forall a. Monoid a => a
mempty
      subConsumed :: Coin
subConsumed = Coin
baSubTxIn
      subProduced :: Coin
subProduced = Coin
baSubTxOut Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baSubDirectDeposit
      topConsumed :: Coin
topConsumed = Coin
baTopTxIn Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baTopWithdrawal Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
script
      topProduced :: Coin
topProduced = Coin
baTopTxOut Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baFee Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
script
   in BatchBalances
        { bbSubConsumed :: Coin
bbSubConsumed = Coin
subConsumed
        , bbSubProduced :: Coin
bbSubProduced = Coin
subProduced
        , bbTopConsumed :: Coin
bbTopConsumed = Coin
topConsumed
        , bbTopProduced :: Coin
bbTopProduced = Coin
topProduced
        , bbBatchConsumed :: Coin
bbBatchConsumed = Coin
subConsumed Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topConsumed
        , bbBatchProduced :: Coin
bbBatchProduced = Coin
subProduced Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topProduced
        }