{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Dijkstra.Translation.TranslatableGen (
  genTranslatableTxWithNestedTxs,
) where

import Cardano.Ledger.Allegra.Scripts (invalidBeforeL, invalidHereAfterL)
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo, SupportedLanguage (..))
import Cardano.Ledger.Alonzo.Scripts (toAsIx)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (TxDats), unTxDats)
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.State (EraUTxO (..), UTxO (..))
import Cardano.Ledger.Mary.Value (AssetName, PolicyID (..), multiAssetFromList)
import Cardano.Ledger.Plutus (hashPlutusScript)
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.TxIn (TxIn)
import Control.Monad (forM, (>=>))
import Control.Monad.Trans.Fail.String (errorFail)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (SNothing))
import qualified Data.OMap.Strict as OMap
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Lens.Micro ((%~), (&), (.~), (^.))
import Test.Cardano.Ledger.Babbage.Translation.TranslatableGen (genTxOut)
import Test.Cardano.Ledger.Common (
  Arbitrary,
  Gen,
  arbitrary,
  frequency,
  oneof,
  scale,
  sublistOf,
  vectorOf,
 )
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysSucceedsNoDatum,
  alwaysSucceedsWithDatum,
  evenRedeemerNoDatum,
  evenRedeemerWithDatum,
  purposeIsWellformedNoDatum,
  redeemerSameAsDatum,
 )

-- | Generate a top-level transaction together with its sub-transactions (if any) and
-- a 'UTxO' that makes the whole batch translatable (by functions like 'transGuardingTopTxInfo').
--
-- Some properties of the generated transactions:
--   * every input/reference input across the batch resolves in the 'UTxO',
--   * no output anywhere in the batch carries a 'StakeRefPtr' or a Byron address,
--   * inputs never overlap with reference inputs within the same transaction,
--   * reference inputs, datums, withdrawal and direct deposit account addresses, guard and
--     required top-level guard credentials, and minted asset ids are often shared across the
--     top transaction field and nested transactions, so that their aggregation is exercised; an
--     asset id is sometimes minted in one transaction and burned in another.
--   * sub-transactions often vote again, differently, on some of the @(voter,
--     governance action)@ pairs of the top-level transaction or of other
--     sub-transactions, so that which vote wins across the batch is exercised. It
--     also exercises votes one a new governance action for a known voter, so that
--     votes are merged per voter.
--   * sometimes no transaction of the batch has an upper bound (or, alternatively, a lower
--     bound) in its validity interval, so that a bound absent from the whole batch is exercised,
--   * every redeemer points at a script that its transaction both needs and provides, from a
--     small pool of PlutusV4 scripts, so that the same script is often executed in more than
--     one transaction, and sometimes for two purposes (guarding and minting) in one transaction.
--     Only scripts for guarding and minting purposes are executed; the
--     translation of the other purposes is left to the unit tests of
--     'transPlutusPurposeV4'.
genTranslatableTxWithNestedTxs ::
  forall era.
  ( DijkstraEraTxBody era
  , AlonzoEraTxWits era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusTxInfo PlutusV4 era
  , Arbitrary (Tx TopTx era)
  , Arbitrary (Value era)
  , Arbitrary (Script era)
  ) =>
  Gen (Tx TopTx era, UTxO era)
genTranslatableTxWithNestedTxs :: forall era.
(DijkstraEraTxBody era, AlonzoEraTxWits era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusTxInfo 'PlutusV4 era, Arbitrary (Tx TopTx era),
 Arbitrary (Value era), Arbitrary (Script era)) =>
Gen (Tx TopTx era, UTxO era)
genTranslatableTxWithNestedTxs = do
  -- Sub-transactions are generated at the same size as the top-level transaction, and there
  -- can be up to 4 of them, so scale down to keep the generation of the batch fast.
  topTx <- (Int -> Int) -> Gen (Tx TopTx era) -> Gen (Tx TopTx era)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) Gen (Tx TopTx era)
forall a. Arbitrary a => Gen a
arbitrary
  -- Pools of values for the different tx fields. A subset of those values is
  -- added to the fields in the nested transactions so that the same value often
  -- appears in more than one transaction.
  sharedAccountAddresses <- arbitrary
  sharedGuardCreds <- arbitrary
  sharedDats <- arbitrary
  sharedAssetIds <- arbitrary
  sharedReferenceInputs <- arbitrary
  -- Bounds that are absent from every transaction of the batch. Each bound is otherwise
  -- independently present or absent in every transaction, so a bound is essentially never
  -- absent from the whole batch.
  maybeClearBounds <-
    frequency
      [ (3, pure id)
      , (1, pure $ invalidHereAfterL .~ SNothing)
      , (1, pure $ invalidBeforeL .~ SNothing)
      ]
  let subTxs = OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (OMap TxId (Tx SubTx era) -> [Tx SubTx era])
-> OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
topTx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (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
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (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
      knownVotes =
        Tx TopTx era
topTx Tx TopTx era
-> Getting
     (VotingProcedures era) (Tx TopTx era) (VotingProcedures era)
-> VotingProcedures era
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (VotingProcedures era) (TxBody TopTx era))
-> Tx TopTx era -> Const (VotingProcedures era) (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
  -> Const (VotingProcedures era) (TxBody TopTx era))
 -> Tx TopTx era -> Const (VotingProcedures era) (Tx TopTx era))
-> ((VotingProcedures era
     -> Const (VotingProcedures era) (VotingProcedures era))
    -> TxBody TopTx era
    -> Const (VotingProcedures era) (TxBody TopTx era))
-> Getting
     (VotingProcedures era) (Tx TopTx era) (VotingProcedures era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era
 -> Const (VotingProcedures era) (VotingProcedures era))
-> TxBody TopTx era
-> Const (VotingProcedures era) (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
          VotingProcedures era
-> VotingProcedures era -> VotingProcedures era
forall a. Semigroup a => a -> a -> a
<> (Tx SubTx era -> VotingProcedures era)
-> [Tx SubTx era] -> VotingProcedures era
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Tx SubTx era
tx -> Tx SubTx era
tx Tx SubTx era
-> Getting
     (VotingProcedures era) (Tx SubTx era) (VotingProcedures era)
-> VotingProcedures era
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (VotingProcedures era) (TxBody SubTx era))
-> Tx SubTx era -> Const (VotingProcedures era) (Tx SubTx 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 SubTx era
  -> Const (VotingProcedures era) (TxBody SubTx era))
 -> Tx SubTx era -> Const (VotingProcedures era) (Tx SubTx era))
-> ((VotingProcedures era
     -> Const (VotingProcedures era) (VotingProcedures era))
    -> TxBody SubTx era
    -> Const (VotingProcedures era) (TxBody SubTx era))
-> Getting
     (VotingProcedures era) (Tx SubTx era) (VotingProcedures era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era
 -> Const (VotingProcedures era) (VotingProcedures era))
-> TxBody SubTx era
-> Const (VotingProcedures era) (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL) [Tx SubTx era]
subTxs
      -- Steps applied to top or sub transactions, in order.
      -- 'makeTxTranslatable' must come last.
      fixTx :: Tx l era -> Gen (Tx l era)
      fixTx =
        Tx l era -> Gen (Tx l era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Tx l era) -> Tx l era -> Gen (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody l era -> Identity (TxBody l era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx l era -> Identity (Tx l era))
-> (ValidityInterval -> ValidityInterval) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ValidityInterval -> ValidityInterval
maybeClearBounds)
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [TxIn] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel). [TxIn] -> Tx l era -> Gen (Tx l era)
addKnownReferenceInputs [TxIn]
sharedReferenceInputs
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [(PolicyID, AssetName)] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel).
[(PolicyID, AssetName)] -> Tx l era -> Gen (Tx l era)
addKnownMints [(PolicyID, AssetName)]
sharedAssetIds
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TxDats era -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel). TxDats era -> Tx l era -> Gen (Tx l era)
addKnownDats TxDats era
sharedDats
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Credential Guard] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel).
[Credential Guard] -> Tx l era -> Gen (Tx l era)
addKnownGuards [Credential Guard]
sharedGuardCreds
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Credential Guard] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel).
[Credential Guard] -> Tx l era -> Gen (Tx l era)
addKnownRequiredTopLevelGuards [Credential Guard]
sharedGuardCreds
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [AccountAddress] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel).
[AccountAddress] -> Tx l era -> Gen (Tx l era)
addKnownDirectDeposits [AccountAddress]
sharedAccountAddresses
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [AccountAddress] -> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel).
[AccountAddress] -> Tx l era -> Gen (Tx l era)
addKnownWithdrawals [AccountAddress]
sharedAccountAddresses
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel). Tx l era -> Gen (Tx l era)
addPredefinedScripts
          (Tx l era -> Gen (Tx l era))
-> (Tx l era -> Gen (Tx l era)) -> Tx l era -> Gen (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> Gen (Tx l era)
forall (l :: TxLevel). Tx l era -> Gen (Tx l era)
makeTxTranslatable
  fixedSubTxs <- forM subTxs (revote knownVotes >=> fixTx)
  fixedTopTx <-
    fixTx $ topTx & bodyTxL . subTransactionsTxBodyL .~ OMap.fromFoldable fixedSubTxs
  let allInputs = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
fixedTopTx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (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 -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era. EraTx era => SimpleGetter (TxBody TopTx era) (Set TxIn)
SimpleGetter (TxBody TopTx era) (Set TxIn)
allInputsTxBodyF
  outputs <- vectorOf (length allInputs) $ genTxOut @era $ SupportedLanguage SPlutusV4
  let utxo = Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO ([(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut era)] -> Map TxIn (TxOut era))
-> [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall a b. (a -> b) -> a -> b
$ [TxIn]
allInputs [TxIn] -> [TxOut era] -> [(TxIn, TxOut era)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TxOut era]
outputs)
  subTxsWithRedeemers <-
    forM (OMap.elems $ fixedTopTx ^. bodyTxL . subTransactionsTxBodyL) $
      addRedeemers utxo (Map.keysSet predefinedScripts)
  topTxWithRedeemers <-
    addRedeemers utxo (Map.keysSet predefinedScripts) $
      fixedTopTx & bodyTxL . subTransactionsTxBodyL .~ OMap.fromFoldable subTxsWithRedeemers
  pure (topTxWithRedeemers, utxo)
  where
    -- A small pool of distinct scripts, so that their hashes are often shared across the batch
    predefinedScripts :: Map.Map ScriptHash (Script era)
    predefinedScripts :: Map ScriptHash (Script era)
predefinedScripts =
      [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Plutus 'PlutusV4 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus 'PlutusV4
plutus, PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> Script era) -> PlutusScript era -> Script era
forall a b. (a -> b) -> a -> b
$ Fail (PlutusScript era) -> PlutusScript era
forall a. HasCallStack => Fail a -> a
errorFail (Fail (PlutusScript era) -> PlutusScript era)
-> Fail (PlutusScript era) -> PlutusScript era
forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV4 -> Fail (PlutusScript era)
forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
forall (l :: Language) (m :: * -> *).
(PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript Plutus 'PlutusV4
plutus)
        | Plutus 'PlutusV4
plutus <-
            [ SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV4
SPlutusV4
            , SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV4
SPlutusV4
            , SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV4
SPlutusV4
            , SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerWithDatum SLanguage 'PlutusV4
SPlutusV4
            , SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV4
SPlutusV4
            , SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV4
SPlutusV4
            ]
        ]
    -- Fix the generated transaction by:
    --   * replacing its outputs with freshly generated ones, so they never carry a 'StakeRefPtr' or
    --     a Byron address,
    --   * making its reference inputs disjoint from its inputs.
    makeTxTranslatable :: Tx l era -> Gen (Tx l era)
    makeTxTranslatable :: forall (l :: TxLevel). Tx l era -> Gen (Tx l era)
makeTxTranslatable Tx l era
tx = do
      let txBody :: TxBody l era
txBody = Tx l era
tx Tx l era
-> Getting (TxBody l era) (Tx l era) (TxBody l era) -> TxBody l era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody l era) (Tx l era) (TxBody l 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
      newTxOutputs <-
        Int -> Gen (TxOut era) -> Gen [TxOut era]
forall a. Int -> Gen a -> Gen [a]
vectorOf (StrictSeq (TxOut era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody l era
txBody TxBody l era
-> Getting
     (StrictSeq (TxOut era)) (TxBody l era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody l era) (StrictSeq (TxOut 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)) (Gen (TxOut era) -> Gen [TxOut era])
-> Gen (TxOut era) -> Gen [TxOut era]
forall a b. (a -> b) -> a -> b
$ forall era.
(BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Gen (TxOut era)
genTxOut @era (SupportedLanguage era -> Gen (TxOut era))
-> SupportedLanguage era -> Gen (TxOut era)
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV4 -> SupportedLanguage era
forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> SupportedLanguage era
SupportedLanguage SLanguage 'PlutusV4
SPlutusV4
      let fixedTxBody =
            TxBody l era
txBody
              TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody l era -> Identity (TxBody l 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 l era -> Identity (TxBody l era))
-> StrictSeq (TxOut era) -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxOut era]
newTxOutputs
              TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL
                ((Set TxIn -> Identity (Set TxIn))
 -> TxBody l era -> Identity (TxBody l era))
-> Set TxIn -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL) (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL)
      pure $ tx & bodyTxL .~ fixedTxBody
    -- Provide a sublist of the predefined scripts, and make the transaction need each of them as a
    -- guard and sometimes also as a minting policy, so that a script can be executed for two
    -- purposes in one transaction.
    addPredefinedScripts :: Tx l era -> Gen (Tx l era)
    addPredefinedScripts :: forall (l :: TxLevel). Tx l era -> Gen (Tx l era)
addPredefinedScripts Tx l era
tx = do
      scriptSubset <- [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, Script era)] -> Map ScriptHash (Script era))
-> Gen [(ScriptHash, Script era)]
-> Gen (Map ScriptHash (Script era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ScriptHash, Script era)] -> Gen [(ScriptHash, Script era)]
forall a. [a] -> Gen [a]
sublistOf (Map ScriptHash (Script era) -> [(ScriptHash, Script era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptHash (Script era)
predefinedScripts)
      mintingHashes <- sublistOf (Map.keys scriptSubset)
      addedMintValues <-
        multiAssetFromList
          <$> traverse (\ScriptHash
h -> (ScriptHash -> PolicyID
PolicyID ScriptHash
h,,) (AssetName -> Integer -> (PolicyID, AssetName, Integer))
-> Gen AssetName -> Gen (Integer -> (PolicyID, AssetName, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen AssetName
forall a. Arbitrary a => Gen a
arbitrary Gen (Integer -> (PolicyID, AssetName, Integer))
-> Gen Integer -> Gen (PolicyID, AssetName, Integer)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary) mintingHashes
      pure $
        tx
          & witsTxL . scriptTxWitsL %~ (<> scriptSubset)
          & bodyTxL . guardsTxBodyL %~ (<> OSet.fromList (ScriptHashObj <$> Map.keys scriptSubset))
          & bodyTxL . mintTxBodyL %~ (<> addedMintValues)
    -- Replace the redeemers of the transaction with redeemers for a sublist of
    -- its needed purposes whose script is one of the predefined scripts.
    -- Arbitrary generated redeemers almost never point at a script that is both
    -- needed and provided, which fails the translation with
    -- 'ScriptHashNotFoundForPurpose'.
    addRedeemers :: UTxO era -> Set.Set ScriptHash -> Tx l era -> Gen (Tx l era)
    addRedeemers :: forall (l :: TxLevel).
UTxO era -> Set ScriptHash -> Tx l era -> Gen (Tx l era)
addRedeemers UTxO era
utxo Set ScriptHash
scriptHashes Tx l era
tx = do
      let AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash)]
needed = UTxO era -> TxBody l era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (Tx l era
tx Tx l era
-> Getting (TxBody l era) (Tx l era) (TxBody l era) -> TxBody l era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody l era) (Tx l era) (TxBody l 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)
      purposes <-
        [PlutusPurpose AsIx era] -> Gen [PlutusPurpose AsIx era]
forall a. [a] -> Gen [a]
sublistOf
          [(forall ix it. AsIxItem ix it -> AsIx ix it)
-> PlutusPurpose AsIxItem era -> PlutusPurpose AsIx era
forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose AsIxItem ix it -> AsIx ix it
forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
purpose | (PlutusPurpose AsIxItem era
purpose, ScriptHash
sh) <- [(PlutusPurpose AsIxItem era, ScriptHash)]
needed, ScriptHash
sh ScriptHash -> Set ScriptHash -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ScriptHash
scriptHashes]
      redeemers <- traverse (\PlutusPurpose AsIx era
purpose -> (PlutusPurpose AsIx era
purpose,) ((Data era, ExUnits)
 -> (PlutusPurpose AsIx era, (Data era, ExUnits)))
-> Gen (Data era, ExUnits)
-> Gen (PlutusPurpose AsIx era, (Data era, ExUnits))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Data era, ExUnits)
forall a. Arbitrary a => Gen a
arbitrary) purposes
      pure $ tx & witsTxL . rdmrsTxWitsL .~ Redeemers (Map.fromList redeemers)
    -- Half of the time, make the sub-transaction vote (with freshly generated votes) on:
    --   * a sublist of the (voter, governance action) pairs voted on by the top-level
    --     transaction or by any sub-transaction, so that which vote wins is exercised, between
    --     the top-level transaction and a sub-transaction, and between two sub-transactions;
    --   * a new governance action for a sublist of the known voters, so that votes are merged
    --     per voter, and not only per @(voter, governance action)@ pair.
    -- Independently generated votes essentially never share a voter.
    revote :: VotingProcedures era -> Tx SubTx era -> Gen (Tx SubTx era)
    revote :: VotingProcedures era -> Tx SubTx era -> Gen (Tx SubTx era)
revote VotingProcedures era
knownVotes Tx SubTx era
subTx =
      [Gen (Tx SubTx era)] -> Gen (Tx SubTx era)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ Tx SubTx era -> Gen (Tx SubTx era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx SubTx era
subTx
        , do
            revotedPairs <-
              [(Voter, GovActionId)] -> Gen [(Voter, GovActionId)]
forall a. [a] -> Gen [a]
sublistOf
                [ (Voter
voter, GovActionId
gaid)
                | (Voter
voter, Map GovActionId (VotingProcedure era)
gaids) <- Map Voter (Map GovActionId (VotingProcedure era))
-> [(Voter, Map GovActionId (VotingProcedure era))]
forall k a. Map k a -> [(k, a)]
Map.toList (VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures VotingProcedures era
knownVotes)
                , GovActionId
gaid <- Map GovActionId (VotingProcedure era) -> [GovActionId]
forall k a. Map k a -> [k]
Map.keys Map GovActionId (VotingProcedure era)
gaids
                ]
            newGovActionPairs <-
              sublistOf (Map.keys $ unVotingProcedures knownVotes)
                >>= traverse (\Voter
voter -> (Voter
voter,) (GovActionId -> (Voter, GovActionId))
-> Gen GovActionId -> Gen (Voter, GovActionId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen GovActionId
forall a. Arbitrary a => Gen a
arbitrary)
            votes <- traverse (\(Voter, GovActionId)
key -> ((Voter, GovActionId)
key,) (VotingProcedure era
 -> ((Voter, GovActionId), VotingProcedure era))
-> Gen (VotingProcedure era)
-> Gen ((Voter, GovActionId), VotingProcedure era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VotingProcedure era)
forall a. Arbitrary a => Gen a
arbitrary) (revotedPairs <> newGovActionPairs)
            let addedVotes =
                  Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures (Map Voter (Map GovActionId (VotingProcedure era))
 -> VotingProcedures era)
-> Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall a b. (a -> b) -> a -> b
$
                    (Map GovActionId (VotingProcedure era)
 -> Map GovActionId (VotingProcedure era)
 -> Map GovActionId (VotingProcedure era))
-> [(Voter, Map GovActionId (VotingProcedure era))]
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
                      Map GovActionId (VotingProcedure era)
-> Map GovActionId (VotingProcedure era)
-> Map GovActionId (VotingProcedure era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
                      [(Voter
voter, GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
gaid VotingProcedure era
vp) | ((Voter
voter, GovActionId
gaid), VotingProcedure era
vp) <- [((Voter, GovActionId), VotingProcedure era)]
votes]
            pure $ subTx & bodyTxL . votingProceduresTxBodyL %~ (<> addedVotes)
        ]

    addKnownWithdrawals :: [AccountAddress] -> Tx l era -> Gen (Tx l era)
    addKnownWithdrawals :: forall (l :: TxLevel).
[AccountAddress] -> Tx l era -> Gen (Tx l era)
addKnownWithdrawals [AccountAddress]
accountAddressPool Tx l era
tx = do
      aas <- [AccountAddress] -> Gen [AccountAddress]
forall a. [a] -> Gen [a]
sublistOf [AccountAddress]
accountAddressPool
      addedWithdrawals <-
        Withdrawals . Map.fromList
          <$> traverse (\AccountAddress
aa -> (AccountAddress
aa,) (Coin -> (AccountAddress, Coin))
-> Gen Coin -> Gen (AccountAddress, Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Coin
forall a. Arbitrary a => Gen a
arbitrary) aas
      pure $ tx & bodyTxL . withdrawalsTxBodyL %~ (<> addedWithdrawals)

    addKnownDirectDeposits :: [AccountAddress] -> Tx l era -> Gen (Tx l era)
    addKnownDirectDeposits :: forall (l :: TxLevel).
[AccountAddress] -> Tx l era -> Gen (Tx l era)
addKnownDirectDeposits [AccountAddress]
accountAddressPool Tx l era
tx = do
      aas <- [AccountAddress] -> Gen [AccountAddress]
forall a. [a] -> Gen [a]
sublistOf [AccountAddress]
accountAddressPool
      addedDirectDeposits <-
        DirectDeposits . Map.fromList
          <$> traverse (\AccountAddress
aa -> (AccountAddress
aa,) (Coin -> (AccountAddress, Coin))
-> Gen Coin -> Gen (AccountAddress, Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Coin
forall a. Arbitrary a => Gen a
arbitrary) aas
      pure $ tx & bodyTxL . directDepositsTxBodyL %~ (<> addedDirectDeposits)

    addKnownGuards :: [Credential Guard] -> Tx l era -> Gen (Tx l era)
    addKnownGuards :: forall (l :: TxLevel).
[Credential Guard] -> Tx l era -> Gen (Tx l era)
addKnownGuards [Credential Guard]
guardCredPool Tx l era
tx = do
      creds <- [Credential Guard] -> Gen [Credential Guard]
forall a. [a] -> Gen [a]
sublistOf [Credential Guard]
guardCredPool
      let addedGuards = [Credential Guard] -> OSet (Credential Guard)
forall a. Ord a => [a] -> OSet a
OSet.fromList [Credential Guard]
creds
      pure $ tx & bodyTxL . guardsTxBodyL %~ (<> addedGuards)

    addKnownRequiredTopLevelGuards :: [Credential Guard] -> Tx l era -> Gen (Tx l era)
    addKnownRequiredTopLevelGuards :: forall (l :: TxLevel).
[Credential Guard] -> Tx l era -> Gen (Tx l era)
addKnownRequiredTopLevelGuards [Credential Guard]
guardCredPool Tx l era
tx = do
      creds <- [Credential Guard] -> Gen [Credential Guard]
forall a. [a] -> Gen [a]
sublistOf [Credential Guard]
guardCredPool
      addedRequiredTopLevelGuards <-
        Map.fromList
          <$> traverse (\Credential Guard
cred -> (Credential Guard
cred,) (StrictMaybe (Data era)
 -> (Credential Guard, StrictMaybe (Data era)))
-> Gen (StrictMaybe (Data era))
-> Gen (Credential Guard, StrictMaybe (Data era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StrictMaybe (Data era))
forall a. Arbitrary a => Gen a
arbitrary) creds
      pure $ tx & bodyTxL . requiredTopLevelGuardsTxBodyL %~ (<> addedRequiredTopLevelGuards)

    addKnownReferenceInputs :: [TxIn] -> Tx l era -> Gen (Tx l era)
    addKnownReferenceInputs :: forall (l :: TxLevel). [TxIn] -> Tx l era -> Gen (Tx l era)
addKnownReferenceInputs [TxIn]
referenceInputPool Tx l era
tx = do
      addedReferenceInputs <- [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> Gen [TxIn] -> Gen (Set TxIn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn] -> Gen [TxIn]
forall a. [a] -> Gen [a]
sublistOf [TxIn]
referenceInputPool
      pure $ tx & bodyTxL . referenceInputsTxBodyL %~ (<> addedReferenceInputs)

    addKnownDats :: TxDats era -> Tx l era -> Gen (Tx l era)
    addKnownDats :: forall (l :: TxLevel). TxDats era -> Tx l era -> Gen (Tx l era)
addKnownDats TxDats era
datPool Tx l era
tx = do
      addedDats <- Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (Map DataHash (Data era) -> TxDats era)
-> ([(DataHash, Data era)] -> Map DataHash (Data era))
-> [(DataHash, Data era)]
-> TxDats era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DataHash, Data era)] -> Map DataHash (Data era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(DataHash, Data era)] -> TxDats era)
-> Gen [(DataHash, Data era)] -> Gen (TxDats era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DataHash, Data era)] -> Gen [(DataHash, Data era)]
forall a. [a] -> Gen [a]
sublistOf (Map DataHash (Data era) -> [(DataHash, Data era)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map DataHash (Data era) -> [(DataHash, Data era)])
-> Map DataHash (Data era) -> [(DataHash, Data era)]
forall a b. (a -> b) -> a -> b
$ TxDats era -> Map DataHash (Data era)
forall era. TxDats era -> Map DataHash (Data era)
unTxDats TxDats era
datPool)
      pure $ tx & witsTxL . datsTxWitsL %~ (<> addedDats)

    addKnownMints :: [(PolicyID, AssetName)] -> Tx l era -> Gen (Tx l era)
    addKnownMints :: forall (l :: TxLevel).
[(PolicyID, AssetName)] -> Tx l era -> Gen (Tx l era)
addKnownMints [(PolicyID, AssetName)]
assetIdPool Tx l era
tx = do
      mas <- [(PolicyID, AssetName)] -> Gen [(PolicyID, AssetName)]
forall a. [a] -> Gen [a]
sublistOf [(PolicyID, AssetName)]
assetIdPool
      addedMints <- multiAssetFromList <$> traverse (\(PolicyID
pid, AssetName
an) -> (PolicyID
pid,AssetName
an,) (Integer -> (PolicyID, AssetName, Integer))
-> Gen Integer -> Gen (PolicyID, AssetName, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary) mas
      pure $ tx & bodyTxL . mintTxBodyL %~ (<> addedMints)