{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Generic.TxGen (
  alonzoMkRedeemers,
  alonzoMkRedeemersFromTags,
  mkAlonzoPlutusPurposePointer,
  mkConwayPlutusPurposePointer,
  genAlonzoTx,
  runSTSWithContext,
  genUTxO,
) where

import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Scripts hiding (Script)
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..))
import Cardano.Ledger.Alonzo.TxWits (
  Redeemers (..),
  TxDats (..),
 )
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), Network (..), ShelleyBase, mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayTxCert (..))
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.Data (Data, Datum (..), dataToBinaryData, hashData)
import Cardano.Ledger.Shelley.API (
  Addr (..),
  Credential (..),
  RewardAccount (..),
  ShelleyDelegCert (..),
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert (..))
import Cardano.Ledger.Slot (EpochNo (EpochNo))
import Cardano.Ledger.State hiding (balance)
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.Val
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (forM, replicateM)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (asks, get, gets, modify)
import Control.State.Transition.Extended hiding (Assertion)
import Data.Bifunctor (first)
import qualified Data.Foldable as F
import Data.Functor ((<&>))
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Monoid (All (..))
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as SSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word16, Word32)
import GHC.Stack
import Lens.Micro ((%~), (&), (.~), (<>~), (^.))
import qualified Lens.Micro.Extras as L
import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessVKey)
import Test.Cardano.Ledger.Examples.STSTestUtils (EraModel (..))
import Test.Cardano.Ledger.Generic.ApplyTx (
  mkAlonzoPlutusPurposePointer,
  mkConwayPlutusPurposePointer,
 )
import Test.Cardano.Ledger.Generic.Functions
import Test.Cardano.Ledger.Generic.GenState (
  EraGenericGen (..),
  GenEnv (..),
  GenRS,
  GenSize (..),
  GenState (..),
  PlutusPurposeTag (..),
  elementsT,
  frequencyT,
  genCredential,
  genDatumWithHash,
  genFreshRegCred,
  genKeyHash,
  genNewPool,
  genPool,
  genPositiveVal,
  genRetirementHash,
  genRewards,
  genScript,
  genValidityInterval,
  getCertificateMax,
  getOldUtxoPercent,
  getRefInputsMax,
  getSpendInputsMax,
  getUtxoChoicesMax,
  getUtxoElem,
  getUtxoTest,
  modifyGenStateInitialUtxo,
  modifyModelCount,
  modifyModelIndex,
  modifyModelMutFee,
  modifyModelUTxO,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  MUtxo,
  ModelNewEpochState (..),
  UtxoEntry,
 )
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo, runShelleyBase)
import Test.QuickCheck

alonzoMkRedeemersFromTags ::
  (AlonzoEraScript era, EraModel era) =>
  [((PlutusPurposeTag, Word32), (Data era, ExUnits))] -> Redeemers era
alonzoMkRedeemersFromTags :: forall era.
(AlonzoEraScript era, EraModel era) =>
[((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
alonzoMkRedeemersFromTags [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
redeemerPointers =
  [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
AlonzoEraScript era =>
[(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
alonzoMkRedeemers [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs
  where
    redeemerAssocs :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs =
      [ (PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
forall era.
EraModel era =>
PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
mkPlutusPurposePointer PlutusPurposeTag
tag Word32
i, (Data era, ExUnits)
redeemer)
      | ((PlutusPurposeTag
tag, Word32
i), (Data era, ExUnits)
redeemer) <- [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
redeemerPointers
      ]

alonzoMkRedeemers ::
  forall era.
  AlonzoEraScript era =>
  [(PlutusPurpose AsIx era, (Data era, ExUnits))] ->
  Redeemers era
alonzoMkRedeemers :: forall era.
AlonzoEraScript era =>
[(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
alonzoMkRedeemers = Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era)
-> ([(PlutusPurpose AsIx era, (Data era, ExUnits))]
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Redeemers era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

genTxOut :: Reflect era => Value era -> GenRS era (TxOut era)
genTxOut :: forall era. Reflect era => Value era -> GenRS era (TxOut era)
genTxOut Value era
val = do
  Addr
addr <- GenRS era Addr
forall era. Reflect era => GenRS era Addr
genRecipient
  Credential 'Payment
cred <- RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment)
-> (Credential 'Payment
    -> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment))
-> Maybe (Credential 'Payment)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char]
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment)
forall a. HasCallStack => [Char] -> a
error [Char]
"BootstrapAddress encountered") Credential 'Payment
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Credential 'Payment)
 -> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment))
-> Maybe (Credential 'Payment)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Payment)
forall a b. (a -> b) -> a -> b
$ Addr -> Maybe (Credential 'Payment)
paymentCredAddr Addr
addr
  TxOut era -> TxOut era
dataHashFields <-
    case Credential 'Payment
cred of
      KeyHashObj KeyHash 'Payment
_ -> (TxOut era -> TxOut era)
-> RWST (GenEnv era) () (GenState era) Gen (TxOut era -> TxOut era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era -> TxOut era
forall a. a -> a
id
      ScriptHashObj ScriptHash
scriptHash -> do
        Maybe (Script era)
maybeCoreScript <- ScriptHash
-> Maybe PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era))
forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scriptHash (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
        Maybe (Script era)
-> RWST (GenEnv era) () (GenState era) Gen (TxOut era -> TxOut era)
forall era.
Reflect era =>
Maybe (Script era) -> GenRS era (TxOut era -> TxOut era)
genDataHashField Maybe (Script era)
maybeCoreScript
  TxOut era -> GenRS era (TxOut era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> GenRS era (TxOut era))
-> (TxOut era -> TxOut era) -> TxOut era -> GenRS era (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut era -> TxOut era
dataHashFields (TxOut era -> GenRS era (TxOut era))
-> TxOut era -> GenRS 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
addr Value era
val

-- ====================================================================

lookupByKeyM ::
  (Ord k, Show k, HasCallStack) => String -> k -> (GenState era -> Map.Map k v) -> GenRS era v
lookupByKeyM :: forall k era v.
(Ord k, Show k, HasCallStack) =>
[Char] -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM [Char]
name k
k GenState era -> Map k v
getMap = do
  Map k v
m <- (GenState era -> Map k v)
-> RWST (GenEnv era) () (GenState era) Gen (Map k v)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map k v
getMap
  case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
m of
    Maybe v
Nothing ->
      [Char] -> GenRS era v
forall a. HasCallStack => [Char] -> a
error ([Char] -> GenRS era v) -> [Char] -> GenRS era v
forall a b. (a -> b) -> a -> b
$
        [Char]
"Can't find " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in the test enviroment: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k
    Just v
val -> v -> GenRS era v
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
val

lookupScript ::
  forall era.
  ScriptHash ->
  Maybe PlutusPurposeTag ->
  GenRS era (Maybe (Script era))
lookupScript :: forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scriptHash Maybe PlutusPurposeTag
mTag = do
  Map ScriptHash (Script era)
m <- GenState era -> Map ScriptHash (Script era)
forall era. GenState era -> Map ScriptHash (Script era)
gsScripts (GenState era -> Map ScriptHash (Script era))
-> RWST (GenEnv era) () (GenState era) Gen (GenState era)
-> RWST
     (GenEnv era) () (GenState era) Gen (Map ScriptHash (Script era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (GenState era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
  case ScriptHash -> Map ScriptHash (Script era) -> Maybe (Script era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
scriptHash Map ScriptHash (Script era)
m of
    Just Script era
script -> Maybe (Script era) -> GenRS era (Maybe (Script era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Script era) -> GenRS era (Maybe (Script era)))
-> Maybe (Script era) -> GenRS era (Maybe (Script era))
forall a b. (a -> b) -> a -> b
$ Script era -> Maybe (Script era)
forall a. a -> Maybe a
Just Script era
script
    Maybe (Script era)
Nothing
      | Just PlutusPurposeTag
tag <- Maybe PlutusPurposeTag
mTag ->
          Script era -> Maybe (Script era)
forall a. a -> Maybe a
Just (Script era -> Maybe (Script era))
-> ((IsValid, Script era) -> Script era)
-> (IsValid, Script era)
-> Maybe (Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsValid, Script era) -> Script era
forall a b. (a, b) -> b
snd ((IsValid, Script era) -> Maybe (Script era))
-> RWST (GenEnv era) () (GenState era) Gen (IsValid, Script era)
-> GenRS era (Maybe (Script era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> (ScriptHash, PlutusPurposeTag)
-> (GenState era
    -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> RWST (GenEnv era) () (GenState era) Gen (IsValid, Script era)
forall k era v.
(Ord k, Show k, HasCallStack) =>
[Char] -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM [Char]
"plutusScript" (ScriptHash
scriptHash, PlutusPurposeTag
tag) GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts
    Maybe (Script era)
_ -> Maybe (Script era) -> GenRS era (Maybe (Script era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Script era)
forall a. Maybe a
Nothing

-- =====================================

genGenericScriptWitness ::
  forall era.
  Reflect era =>
  Maybe PlutusPurposeTag ->
  Script era ->
  GenRS era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genGenericScriptWitness :: forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genGenericScriptWitness Maybe PlutusPurposeTag
mTag Script era
script =
  case forall era. Reflect era => Proof era
reify @era of
    Proof era
Shelley -> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit Maybe PlutusPurposeTag
mTag Script era
MultiSig era
script
    Proof era
Allegra -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag Timelock era
Script era
script
    Proof era
Mary -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag Timelock era
Script era
script
    Proof era
Alonzo -> case Script era
script of
      TimelockScript Timelock era
timelock -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript AlonzoEra
_ -> (SafeHash EraIndependentTxBody
 -> AlonzoTxWits AlonzoEra -> AlonzoTxWits AlonzoEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody
      -> AlonzoTxWits AlonzoEra -> AlonzoTxWits AlonzoEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AlonzoTxWits AlonzoEra -> AlonzoTxWits AlonzoEra)
-> SafeHash EraIndependentTxBody
-> AlonzoTxWits AlonzoEra
-> AlonzoTxWits AlonzoEra
forall a b. a -> b -> a
const AlonzoTxWits AlonzoEra -> AlonzoTxWits AlonzoEra
forall a. a -> a
id)
    Proof era
Babbage -> case Script era
script of
      TimelockScript Timelock era
timelock -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript BabbageEra
_ -> (SafeHash EraIndependentTxBody
 -> AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody
      -> AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
-> SafeHash EraIndependentTxBody
-> AlonzoTxWits BabbageEra
-> AlonzoTxWits BabbageEra
forall a b. a -> b -> a
const AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra
forall a. a -> a
id)
    Proof era
Conway -> case Script era
script of
      TimelockScript Timelock era
timelock -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript ConwayEra
_ -> (SafeHash EraIndependentTxBody
 -> AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody
      -> AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
-> SafeHash EraIndependentTxBody
-> AlonzoTxWits ConwayEra
-> AlonzoTxWits ConwayEra
forall a b. a -> b -> a
const AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra
forall a. a -> a
id)

-- | Generate a TxWits producing function. We handle TxWits come from Keys and Scripts
--   Because scripts vary be Era, we need some Era specific code here: genGenericScriptWitness
mkWitVKey ::
  forall era kr.
  Reflect era =>
  Maybe PlutusPurposeTag ->
  Credential kr ->
  GenRS era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey :: forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey Maybe PlutusPurposeTag
_mTag (KeyHashObj KeyHash kr
keyHash) = do
  KeyPair 'Witness
keyPair <- [Char]
-> KeyHash 'Witness
-> (GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era (KeyPair 'Witness)
forall k era v.
(Ord k, Show k, HasCallStack) =>
[Char] -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM [Char]
"credential" (KeyHash kr -> KeyHash 'Witness
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash kr
keyHash) GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys
  (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a b. (a -> b) -> a -> b
$ \SafeHash EraIndependentTxBody
bodyHash -> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> TxWits era -> Identity (TxWits era))
-> Set (WitVKey 'Witness) -> TxWits era -> TxWits era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [SafeHash EraIndependentTxBody
-> KeyPair 'Witness -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
bodyHash KeyPair 'Witness
keyPair]
mkWitVKey Maybe PlutusPurposeTag
mTag (ScriptHashObj ScriptHash
scriptHash) =
  forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript @era ScriptHash
scriptHash Maybe PlutusPurposeTag
mTag RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era))
-> (Maybe (Script era)
    -> GenRS
         era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Script era)
Nothing -> [Char]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Char]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Cannot find script with hash " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ScriptHash -> [Char]
forall a. Show a => a -> [Char]
show ScriptHash
scriptHash
    Just Script era
script -> do
      let scriptWit :: TxWits era -> TxWits era
scriptWit = (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> TxWits era -> Identity (TxWits era))
-> Map ScriptHash (Script era) -> TxWits era -> TxWits era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [(Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
script, Script era
script)]
      SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
otherWit <- Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genGenericScriptWitness Maybe PlutusPurposeTag
mTag Script era
script
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
hash -> TxWits era -> TxWits era
scriptWit (TxWits era -> TxWits era)
-> (TxWits era -> TxWits era) -> TxWits era -> TxWits era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
otherWit SafeHash EraIndependentTxBody
hash)

-- ========================================================================
-- Generating TxWits, here we are not adding anything to the GenState
-- only looking up things already added, and assembling the right pieces to
-- make TxWits.

-- | Used in Shelley Eras
mkMultiSigWit ::
  forall era.
  (ShelleyEraScript era, NativeScript era ~ MultiSig era, Reflect era) =>
  Maybe PlutusPurposeTag ->
  MultiSig era ->
  GenRS era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit Maybe PlutusPurposeTag
mTag (RequireSignature KeyHash 'Witness
keyHash) = Maybe PlutusPurposeTag
-> Credential 'Witness
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey Maybe PlutusPurposeTag
mTag (KeyHash 'Witness -> Credential 'Witness
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
mkMultiSigWit Maybe PlutusPurposeTag
mTag (RequireAllOf StrictSeq (NativeScript era)
timelocks) = [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. [a -> b -> b] -> a -> b -> b
foldFn' ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
 -> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MultiSig era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [MultiSig era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> MultiSig era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit Maybe PlutusPurposeTag
mTag) (StrictSeq (MultiSig era) -> [MultiSig era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks)
mkMultiSigWit Maybe PlutusPurposeTag
mTag (RequireAnyOf StrictSeq (NativeScript era)
timelocks)
  | StrictSeq (MultiSig era) -> Bool
forall a. StrictSeq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks = (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. a -> b -> a
const TxWits era -> TxWits era
forall a. a -> a
id)
  | Bool
otherwise = Maybe PlutusPurposeTag
-> MultiSig era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit Maybe PlutusPurposeTag
mTag (MultiSig era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([MultiSig era] -> Gen (MultiSig era)
forall a. HasCallStack => [a] -> Gen a
elements (StrictSeq (MultiSig era) -> [MultiSig era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks))
mkMultiSigWit Maybe PlutusPurposeTag
mTag (RequireMOf Int
m StrictSeq (NativeScript era)
timelocks) = do
  [MultiSig era]
ts <- Int -> [MultiSig era] -> [MultiSig era]
forall a. Int -> [a] -> [a]
take Int
m ([MultiSig era] -> [MultiSig era])
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([MultiSig era] -> Gen [MultiSig era]
forall a. [a] -> Gen [a]
shuffle (StrictSeq (MultiSig era) -> [MultiSig era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks))
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. [a -> b -> b] -> a -> b -> b
foldFn' ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
 -> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MultiSig era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [MultiSig era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> MultiSig era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkMultiSigWit Maybe PlutusPurposeTag
mTag) [MultiSig era]
ts
mkMultiSigWit Maybe PlutusPurposeTag
_ MultiSig era
_ = [Char]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: All NativeScripts should have been accounted for"

-- | Timeock scripts are used in Mary and subsequent Eras.
mkTimelockWit ::
  forall era.
  (AllegraEraScript era, NativeScript era ~ Timelock era, Reflect era) =>
  Maybe PlutusPurposeTag ->
  Timelock era ->
  GenRS era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag =
  \case
    RequireSignature KeyHash 'Witness
keyHash -> Maybe PlutusPurposeTag
-> Credential 'Witness
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey Maybe PlutusPurposeTag
mTag (KeyHash 'Witness -> Credential 'Witness
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
    RequireAllOf StrictSeq (NativeScript era)
timelocks -> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. [a -> b -> b] -> a -> b -> b
foldFn' ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
 -> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Timelock era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag) (StrictSeq (Timelock era) -> [Timelock era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks)
    RequireAnyOf StrictSeq (NativeScript era)
timelocks
      | StrictSeq (Timelock era) -> Bool
forall a. StrictSeq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks -> (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. a -> b -> a
const TxWits era -> TxWits era
forall a. a -> a
id)
      | Bool
otherwise -> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Timelock era] -> Gen (Timelock era)
forall a. HasCallStack => [a] -> Gen a
elements (StrictSeq (Timelock era) -> [Timelock era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks))
    RequireMOf Int
m StrictSeq (NativeScript era)
timelocks -> do
      [Timelock era]
ts <- Int -> [Timelock era] -> [Timelock era]
forall a. Int -> [a] -> [a]
take Int
m ([Timelock era] -> [Timelock era])
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Timelock era] -> Gen [Timelock era]
forall a. [a] -> Gen [a]
shuffle (StrictSeq (Timelock era) -> [Timelock era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks))
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. [a -> b -> b] -> a -> b -> b
foldFn' ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
 -> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Timelock era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkTimelockWit Maybe PlutusPurposeTag
mTag) [Timelock era]
ts
    RequireTimeStart SlotNo
_ -> (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. a -> b -> a
const TxWits era -> TxWits era
forall a. a -> a
id)
    RequireTimeExpire SlotNo
_ -> (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. a -> b -> a
const TxWits era -> TxWits era
forall a. a -> a
id)
    Timelock era
_ -> [Char]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: All NativeScripts should have been accounted for"

-- | Same as `genCredKeyWit`, but for `TxOuts`
genTxOutKeyWitness ::
  forall era.
  Reflect era =>
  Maybe PlutusPurposeTag ->
  TxOut era ->
  GenRS era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genTxOutKeyWitness :: forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genTxOutKeyWitness Maybe PlutusPurposeTag
mTag TxOut era
txOut =
  case TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
    AddrBootstrap BootstrapAddress
baddr ->
      [Char]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> GenRS
      era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Char]
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a b. (a -> b) -> a -> b
$ [Char]
"Can't authorize bootstrap address: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BootstrapAddress -> [Char]
forall a. Show a => a -> [Char]
show BootstrapAddress
baddr
    Addr Network
_ Credential 'Payment
payCred StakeReference
_ ->
      case Proof era -> TxOut era -> StrictMaybe (Script era)
forall era. Proof era -> TxOut era -> StrictMaybe (Script era)
getTxOutRefScript Proof era
forall era. Reflect era => Proof era
reify TxOut era
txOut of
        StrictMaybe (Script era)
SNothing -> Maybe PlutusPurposeTag
-> Credential 'Payment
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey Maybe PlutusPurposeTag
mTag Credential 'Payment
payCred
        SJust Script era
script -> do
          SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
f1 <- Maybe PlutusPurposeTag
-> Credential 'Payment
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey Maybe PlutusPurposeTag
mTag Credential 'Payment
payCred
          SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
f2 <- Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genGenericScriptWitness (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending) Script era
script
          (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
safehash -> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
f1 SafeHash EraIndependentTxBody
safehash (TxWits era -> TxWits era)
-> (TxWits era -> TxWits era) -> TxWits era -> TxWits era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
f2 SafeHash EraIndependentTxBody
safehash)

makeDatumWitness :: forall era. Reflect era => TxOut era -> GenRS era (TxWits era -> TxWits era)
makeDatumWitness :: forall era.
Reflect era =>
TxOut era -> GenRS era (TxWits era -> TxWits era)
makeDatumWitness TxOut era
txout =
  let proof :: Proof era
proof = forall era. Reflect era => Proof era
reify @era
   in case (Proof era
proof, TxOut era
txout) of
        (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ (DatumHash DataHash
h) StrictMaybe (Script BabbageEra)
_) -> StrictMaybe DataHash -> GenRS era (TxWits era -> TxWits era)
forall era'.
AlonzoEraTxWits era' =>
StrictMaybe DataHash -> GenRS era' (TxWits era' -> TxWits era')
mkDatumWit (DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
h)
        (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ (Datum BinaryData BabbageEra
_) StrictMaybe (Script BabbageEra)
_) -> (AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra
forall a. a -> a
id
        (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ Datum BabbageEra
NoDatum StrictMaybe (Script BabbageEra)
_) -> (AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlonzoTxWits BabbageEra -> AlonzoTxWits BabbageEra
forall a. a -> a
id
        (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ (DatumHash DataHash
h) StrictMaybe (Script ConwayEra)
_) -> StrictMaybe DataHash -> GenRS era (TxWits era -> TxWits era)
forall era'.
AlonzoEraTxWits era' =>
StrictMaybe DataHash -> GenRS era' (TxWits era' -> TxWits era')
mkDatumWit (DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
h)
        (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ (Datum BinaryData ConwayEra
_) StrictMaybe (Script ConwayEra)
_) -> (AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra
forall a. a -> a
id
        (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ Datum ConwayEra
NoDatum StrictMaybe (Script ConwayEra)
_) -> (AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlonzoTxWits ConwayEra -> AlonzoTxWits ConwayEra
forall a. a -> a
id
        (Proof era
Alonzo, AlonzoTxOut Addr
_ Value AlonzoEra
_ StrictMaybe DataHash
mDatum) -> StrictMaybe DataHash -> GenRS era (TxWits era -> TxWits era)
forall era'.
AlonzoEraTxWits era' =>
StrictMaybe DataHash -> GenRS era' (TxWits era' -> TxWits era')
mkDatumWit StrictMaybe DataHash
mDatum
        (Proof era, TxOut era)
_ -> (TxWits era -> TxWits era) -> GenRS era (TxWits era -> TxWits era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxWits era -> TxWits era
forall a. a -> a
id -- No other era has data witnesses
  where
    mkDatumWit ::
      forall era'. AlonzoEraTxWits era' => StrictMaybe DataHash -> GenRS era' (TxWits era' -> TxWits era')
    mkDatumWit :: forall era'.
AlonzoEraTxWits era' =>
StrictMaybe DataHash -> GenRS era' (TxWits era' -> TxWits era')
mkDatumWit StrictMaybe DataHash
SNothing = (TxWits era' -> TxWits era')
-> RWST
     (GenEnv era') () (GenState era') Gen (TxWits era' -> TxWits era')
forall a. a -> RWST (GenEnv era') () (GenState era') Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxWits era' -> TxWits era'
forall a. a -> a
id
    mkDatumWit (SJust DataHash
datumHash) = do
      Data era'
datum <- [Char]
-> DataHash
-> (GenState era' -> Map DataHash (Data era'))
-> GenRS era' (Data era')
forall k era v.
(Ord k, Show k, HasCallStack) =>
[Char] -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM [Char]
"datum" DataHash
datumHash GenState era' -> Map DataHash (Data era')
forall era. GenState era -> Map DataHash (Data era)
gsDatums
      (TxWits era' -> TxWits era')
-> RWST
     (GenEnv era') () (GenState era') Gen (TxWits era' -> TxWits era')
forall a. a -> RWST (GenEnv era') () (GenState era') Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxWits era' -> TxWits era')
 -> RWST
      (GenEnv era') () (GenState era') Gen (TxWits era' -> TxWits era'))
-> (TxWits era' -> TxWits era')
-> RWST
     (GenEnv era') () (GenState era') Gen (TxWits era' -> TxWits era')
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL @era' ((TxDats era' -> Identity (TxDats era'))
 -> TxWits era' -> Identity (TxWits era'))
-> TxDats era' -> TxWits era' -> TxWits era'
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Map DataHash (Data era') -> TxDats era'
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats [(Data era' -> DataHash
forall era. Data era -> DataHash
hashData Data era'
datum, Data era'
datum)]

-- | Does the current Credential point to a PlutusScript? If so return its IsValid and Hash
plutusScriptHashFromTag ::
  Credential k ->
  PlutusPurposeTag ->
  GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag :: forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag (KeyHashObj KeyHash k
_) PlutusPurposeTag
_ = Maybe (IsValid, ScriptHash)
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IsValid, ScriptHash)
forall a. Maybe a
Nothing
plutusScriptHashFromTag (ScriptHashObj ScriptHash
scriptHash) PlutusPurposeTag
tag =
  (GenState era -> Maybe (IsValid, Script era))
-> RWST (GenEnv era) () (GenState era) Gen (GenState era)
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, Script era))
forall a b.
(a -> b)
-> RWST (GenEnv era) () (GenState era) Gen a
-> RWST (GenEnv era) () (GenState era) Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ScriptHash, PlutusPurposeTag)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Maybe (IsValid, Script era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScriptHash
scriptHash, PlutusPurposeTag
tag) (Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Maybe (IsValid, Script era))
-> (GenState era
    -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenState era
-> Maybe (IsValid, Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts) RWST (GenEnv era) () (GenState era) Gen (GenState era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get RWST
  (GenEnv era) () (GenState era) Gen (Maybe (IsValid, Script era))
-> (Maybe (IsValid, Script era) -> Maybe (IsValid, ScriptHash))
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe (IsValid, Script era)
Nothing -> Maybe (IsValid, ScriptHash)
forall a. Maybe a
Nothing
    Just (IsValid
isValid, Script era
_) -> (IsValid, ScriptHash) -> Maybe (IsValid, ScriptHash)
forall a. a -> Maybe a
Just (IsValid
isValid, ScriptHash
scriptHash)

-- | Make RdmrWits WitnessesField only if the Credential is for a Plutus Script
--  And it is in the spending inputs, not the reference inputs
redeemerWitnessMaker ::
  forall era k.
  EraGenericGen era =>
  PlutusPurposeTag ->
  [Maybe (GenRS era (Data era), Credential k)] ->
  GenRS era (IsValid, [ExUnits -> TxWits era -> TxWits era])
redeemerWitnessMaker :: forall era (k :: KeyRole).
EraGenericGen era =>
PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> TxWits era -> TxWits era])
redeemerWitnessMaker PlutusPurposeTag
tag [Maybe
   (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)]
listWithCred =
  let creds :: [(Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
  Credential k)]
creds =
        [ (Word32
ix, RWST (GenEnv era) () (GenState era) Gen (Data era)
genDat, Credential k
cred)
        | (Word32
ix, Maybe
  (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)
mCred) <- [Word32]
-> [Maybe
      (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)]
-> [(Word32,
     Maybe
       (RWST (GenEnv era) () (GenState era) Gen (Data era),
        Credential k))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
Item [Word32]
0 ..] [Maybe
   (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)]
listWithCred
        , Just (RWST (GenEnv era) () (GenState era) Gen (Data era)
genDat, Credential k
cred) <- [Maybe
  (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)
Item
  [Maybe
     (RWST (GenEnv era) () (GenState era) Gen (Data era), Credential k)]
mCred]
        ]
      allValid :: [IsValid] -> IsValid
      allValid :: [IsValid] -> IsValid
allValid = Bool -> IsValid
IsValid (Bool -> IsValid) -> ([IsValid] -> Bool) -> [IsValid] -> IsValid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll (All -> Bool) -> ([IsValid] -> All) -> [IsValid] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsValid -> All) -> [IsValid] -> All
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(IsValid Bool
v) -> Bool -> All
All Bool
v)
   in ([Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
 -> (IsValid, [ExUnits -> TxWits era -> TxWits era]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall a b.
(a -> b)
-> RWST (GenEnv era) () (GenState era) Gen a
-> RWST (GenEnv era) () (GenState era) Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([IsValid] -> IsValid)
-> ([IsValid], [ExUnits -> TxWits era -> TxWits era])
-> (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [IsValid] -> IsValid
allValid (([IsValid], [ExUnits -> TxWits era -> TxWits era])
 -> (IsValid, [ExUnits -> TxWits era -> TxWits era]))
-> ([Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
    -> ([IsValid], [ExUnits -> TxWits era -> TxWits era]))
-> [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
-> (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IsValid, ExUnits -> TxWits era -> TxWits era)]
-> ([IsValid], [ExUnits -> TxWits era -> TxWits era])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(IsValid, ExUnits -> TxWits era -> TxWits era)]
 -> ([IsValid], [ExUnits -> TxWits era -> TxWits era]))
-> ([Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
    -> [(IsValid, ExUnits -> TxWits era -> TxWits era)])
-> [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
-> ([IsValid], [ExUnits -> TxWits era -> TxWits era])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
-> [(IsValid, ExUnits -> TxWits era -> TxWits era)]
forall a. [Maybe a] -> [a]
catMaybes) (RWST
   (GenEnv era)
   ()
   (GenState era)
   Gen
   [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (IsValid, [ExUnits -> TxWits era -> TxWits era]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall a b. (a -> b) -> a -> b
$
        [(Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
  Credential k)]
-> ((Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
     Credential k)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
  Credential k)]
creds (((Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
   Credential k)
  -> RWST
       (GenEnv era)
       ()
       (GenState era)
       Gen
       (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)))
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)])
-> ((Word32, RWST (GenEnv era) () (GenState era) Gen (Data era),
     Credential k)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)]
forall a b. (a -> b) -> a -> b
$ \(Word32
ix, RWST (GenEnv era) () (GenState era) Gen (Data era)
genDat, Credential k
cred) ->
          Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag Credential k
cred PlutusPurposeTag
tag GenRS era (Maybe (IsValid, ScriptHash))
-> (Maybe (IsValid, ScriptHash)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era))
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (IsValid, ScriptHash)
Nothing -> Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
forall a. Maybe a
Nothing
            Just (IsValid
isValid, ScriptHash
_) -> do
              Data era
datum <- RWST (GenEnv era) () (GenState era) Gen (Data era)
genDat
              let mkWit3 :: ExUnits -> TxWits era -> TxWits era
mkWit3 ExUnits
exUnits =
                    Redeemers era -> TxWits era -> TxWits era
forall era.
EraGenericGen era =>
Redeemers era -> TxWits era -> TxWits era
addRedeemers (Redeemers era -> TxWits era -> TxWits era)
-> Redeemers era -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$ forall era.
EraModel era =>
[((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags @era [((PlutusPurposeTag
tag, Word32
ix), (Data era
datum, ExUnits
exUnits))]
              -- we should not add this if the tx turns out to be in the reference inputs.
              -- we accomplish this by not calling this function on referenceInputs
              Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)))
-> Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> TxWits era -> TxWits era))
forall a b. (a -> b) -> a -> b
$ (IsValid, ExUnits -> TxWits era -> TxWits era)
-> Maybe (IsValid, ExUnits -> TxWits era -> TxWits era)
forall a. a -> Maybe a
Just (IsValid
isValid, ExUnits -> TxWits era -> TxWits era
mkWit3)

-- ===================================================================================
-- Now we start actual generators that create things and enter them into
-- the GenState, and sometimes into the Model.

-- | Collaterals can't have scripts, this is where this generator is needed.
--   As we generate this we add to the gsKeys field of the GenState.
genNoScriptRecipient :: GenRS era Addr
genNoScriptRecipient :: forall era. GenRS era Addr
genNoScriptRecipient = do
  KeyHash 'Payment
paymentCred <- forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash @'Payment
  KeyHash 'Staking
stakeCred <- forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash @'Staking
  Addr -> GenRS era Addr
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'Payment -> KeyHash 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
paymentCred KeyHash 'Staking
stakeCred)

-- | Sometimes generates new Credentials, and some times reuses old ones
genRecipient :: Reflect era => GenRS era Addr
genRecipient :: forall era. Reflect era => GenRS era Addr
genRecipient = do
  Credential 'Payment
paymentCred <- forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential @'Payment PlutusPurposeTag
Spending
  Credential 'Staking
stakeCred <- forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential @'Staking PlutusPurposeTag
Rewarding
  Addr -> GenRS era Addr
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential 'Payment -> Credential 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr Credential 'Payment
paymentCred Credential 'Staking
stakeCred)

genDatum :: Era era => GenRS era (Data era)
genDatum :: forall era. Era era => GenRS era (Data era)
genDatum = (DataHash, Data era) -> Data era
forall a b. (a, b) -> b
snd ((DataHash, Data era) -> Data era)
-> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
-> RWST (GenEnv era) () (GenState era) Gen (Data era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash

-- | Generate a Babbage Datum witness to use as a redeemer for a Plutus Script.
--   TxWits can be a ScriptHash, or an inline Datum
genBabbageDatum :: forall era. Era era => GenRS era (Datum era)
genBabbageDatum :: forall era. Era era => GenRS era (Datum era)
genBabbageDatum =
  [(Int, RWST (GenEnv era) () (GenState era) Gen (Datum era))]
-> RWST (GenEnv era) () (GenState era) Gen (Datum era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
1, DataHash -> Datum era
forall era. DataHash -> Datum era
DatumHash (DataHash -> Datum era)
-> ((DataHash, Data era) -> DataHash)
-> (DataHash, Data era)
-> Datum era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataHash, Data era) -> DataHash
forall a b. (a, b) -> a
fst ((DataHash, Data era) -> Datum era)
-> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
-> RWST (GenEnv era) () (GenState era) Gen (Datum era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash)
    , (Int
4, BinaryData era -> Datum era
forall era. BinaryData era -> Datum era
Datum (BinaryData era -> Datum era)
-> ((DataHash, Data era) -> BinaryData era)
-> (DataHash, Data era)
-> Datum era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data era -> BinaryData era
forall era. Data era -> BinaryData era
dataToBinaryData (Data era -> BinaryData era)
-> ((DataHash, Data era) -> Data era)
-> (DataHash, Data era)
-> BinaryData era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataHash, Data era) -> Data era
forall a b. (a, b) -> b
snd ((DataHash, Data era) -> Datum era)
-> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
-> RWST (GenEnv era) () (GenState era) Gen (Datum era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash)
    ]

genRefScript :: Reflect era => GenRS era (StrictMaybe (Script era))
genRefScript :: forall era. Reflect era => GenRS era (StrictMaybe (Script era))
genRefScript = do
  ScriptHash
scripthash <- PlutusPurposeTag -> GenRS era ScriptHash
forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript PlutusPurposeTag
Spending
  Maybe (Script era)
mscript <- ScriptHash
-> Maybe PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era))
forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scripthash (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
  case Maybe (Script era)
mscript of
    Maybe (Script era)
Nothing -> StrictMaybe (Script era) -> GenRS era (StrictMaybe (Script era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (Script era)
forall a. StrictMaybe a
SNothing
    Just Script era
script -> StrictMaybe (Script era) -> GenRS era (StrictMaybe (Script era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
SJust Script era
script)

-- | Gen the Datum and RefScript fields of a TxOut by Analyzing the payment credential's script
genDataHashField ::
  forall era. Reflect era => Maybe (Script era) -> GenRS era (TxOut era -> TxOut era)
genDataHashField :: forall era.
Reflect era =>
Maybe (Script era) -> GenRS era (TxOut era -> TxOut era)
genDataHashField Maybe (Script era)
maybeCoreScript =
  case forall era. Reflect era => Proof era
reify @era of
    Proof era
Conway -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript ConwayEra
_) -> do
        Datum era
datum <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript ConwayEra)
script <- GenRS era (StrictMaybe (Script era))
RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (StrictMaybe (AlonzoScript ConwayEra))
forall era. Reflect era => GenRS era (StrictMaybe (Script era))
genRefScript
        (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra))
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
forall a b. (a -> b) -> a -> b
$ \BabbageTxOut ConwayEra
x ->
          BabbageTxOut ConwayEra
x
            BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Datum era -> Identity (Datum era))
-> TxOut era -> Identity (TxOut era)
(Datum era -> Identity (Datum era))
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut era) (Datum era)
datumTxOutL ((Datum era -> Identity (Datum era))
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Datum era -> BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Datum era
datum
            BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script ConwayEra)
 -> Identity (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(StrictMaybe (Script ConwayEra)
 -> Identity (StrictMaybe (AlonzoScript ConwayEra)))
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL ((StrictMaybe (Script ConwayEra)
  -> Identity (StrictMaybe (AlonzoScript ConwayEra)))
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> StrictMaybe (AlonzoScript ConwayEra)
-> BabbageTxOut ConwayEra
-> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (AlonzoScript ConwayEra)
script
      Maybe (Script era)
_ -> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra
forall a. a -> a
id
    Proof era
Babbage -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript BabbageEra
_) -> do
        Datum era
datum <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript BabbageEra)
script <- GenRS era (StrictMaybe (Script era))
RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (StrictMaybe (AlonzoScript BabbageEra))
forall era. Reflect era => GenRS era (StrictMaybe (Script era))
genRefScript
        (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra))
-> (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
forall a b. (a -> b) -> a -> b
$ \BabbageTxOut BabbageEra
x ->
          BabbageTxOut BabbageEra
x
            BabbageTxOut BabbageEra
-> (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
-> BabbageTxOut BabbageEra
forall a b. a -> (a -> b) -> b
& (Datum era -> Identity (Datum era))
-> TxOut era -> Identity (TxOut era)
(Datum era -> Identity (Datum era))
-> BabbageTxOut BabbageEra -> Identity (BabbageTxOut BabbageEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut era) (Datum era)
datumTxOutL ((Datum era -> Identity (Datum era))
 -> BabbageTxOut BabbageEra -> Identity (BabbageTxOut BabbageEra))
-> Datum era -> BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Datum era
datum
            BabbageTxOut BabbageEra
-> (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
-> BabbageTxOut BabbageEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script BabbageEra)
 -> Identity (StrictMaybe (Script BabbageEra)))
-> TxOut BabbageEra -> Identity (TxOut BabbageEra)
(StrictMaybe (Script BabbageEra)
 -> Identity (StrictMaybe (AlonzoScript BabbageEra)))
-> BabbageTxOut BabbageEra -> Identity (BabbageTxOut BabbageEra)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut BabbageEra) (StrictMaybe (Script BabbageEra))
referenceScriptTxOutL ((StrictMaybe (Script BabbageEra)
  -> Identity (StrictMaybe (AlonzoScript BabbageEra)))
 -> BabbageTxOut BabbageEra -> Identity (BabbageTxOut BabbageEra))
-> StrictMaybe (AlonzoScript BabbageEra)
-> BabbageTxOut BabbageEra
-> BabbageTxOut BabbageEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (AlonzoScript BabbageEra)
script
      Maybe (Script era)
_ -> (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BabbageTxOut BabbageEra -> BabbageTxOut BabbageEra
forall a. a -> a
id
    Proof era
Alonzo -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript AlonzoEra
_) -> do
        (DataHash
datahash, Data era
_data) <- GenRS era (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash
        (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra))
-> (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
forall a b. (a -> b) -> a -> b
$ \AlonzoTxOut AlonzoEra
x ->
          AlonzoTxOut AlonzoEra
x
            AlonzoTxOut AlonzoEra
-> (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
-> AlonzoTxOut AlonzoEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut AlonzoEra -> Identity (TxOut AlonzoEra)
(StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> AlonzoTxOut AlonzoEra -> Identity (AlonzoTxOut AlonzoEra)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut AlonzoEra) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> AlonzoTxOut AlonzoEra -> Identity (AlonzoTxOut AlonzoEra))
-> StrictMaybe DataHash
-> AlonzoTxOut AlonzoEra
-> AlonzoTxOut AlonzoEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
datahash
      Maybe (Script era)
_ -> (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlonzoTxOut AlonzoEra -> AlonzoTxOut AlonzoEra
forall a. a -> a
id
    Proof era
_ -> (TxOut era -> TxOut era) -> GenRS era (TxOut era -> TxOut era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era -> TxOut era
forall a. a -> a
id -- No other Era has any datum in the TxOut

-- ================================================================================

-- | Generate a TxIn whose TxIx will never clash with an Input created from a TxOut
genTxIn :: forall era. Proof era -> Int -> Gen TxIn
genTxIn :: forall era. Proof era -> Int -> Gen TxIn
genTxIn Proof era
_proof Int
numChoices = do
  TxId
txId <- Int -> Gen TxId -> Gen TxId
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
40 Gen TxId
forall a. Arbitrary a => Gen a
arbitrary
  -- The TxIx for Inputs created from outputs of a TxBody, will only range from (1..numChoices)
  -- TxIx for these arbitrary Inputs range from (n+1..n+100). This makes the TxIx ranges
  -- incommensurate.
  TxIx
txIx <- HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Integer -> TxIx) -> (Int -> Integer) -> Int -> TxIx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> TxIx) -> Gen Int -> Gen TxIx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
numChoices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
numChoices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100)
  TxIn -> Gen TxIn
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxId -> TxIx -> TxIn
TxIn TxId
txId TxIx
txIx)

-- | Generate a non-empty List of fresh TxIn. By fresh we mean TxIn's that
--   we have not generated previously. We use the current InitialUtxo to test this.
genFreshTxIn :: forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn :: forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn Int
tries | Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> GenRS era [TxIn]
forall a. HasCallStack => [Char] -> a
error [Char]
"Could not generate a fresh TxIn after many tries."
genFreshTxIn Int
tries = do
  Map TxIn (TxOut era)
entriesInUse <- (GenState era -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (Map TxIn (TxOut era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map TxIn (TxOut era)
forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo
  -- Max number of choices. So the UTxO will never be larger than this
  Int
numChoicesMax <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Int
forall era. GenState era -> Int
getUtxoChoicesMax
  Int
n <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
numChoicesMax Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
  [TxIn]
ins <- Gen [TxIn] -> GenRS era [TxIn]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen [TxIn] -> GenRS era [TxIn]) -> Gen [TxIn] -> GenRS era [TxIn]
forall a b. (a -> b) -> a -> b
$ Int -> Gen TxIn -> Gen [TxIn]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (forall era. Proof era -> Int -> Gen TxIn
genTxIn @era Proof era
forall era. Reflect era => Proof era
reify Int
numChoicesMax)
  case (TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map TxIn (TxOut era)
entriesInUse) [TxIn]
ins of
    [] -> Int -> GenRS era [TxIn]
forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    [TxIn]
freshTxIns -> [TxIn] -> GenRS era [TxIn]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [TxIn] -> [TxIn]
forall a. Int -> [a] -> [a]
take Int
numChoicesMax [TxIn]
freshTxIns)

-- ====================================================================
-- Generating UTxO and associated Inputs (Set (TxIn era))

-- | Generate a somewhat arbitrary MUtxo.  Occasionally add a bit of
--   the MUtxo in the Model to the one generated.  This way the Tx we generate may
--   spend some of the old UTxo. The result has at most 1 entry from the
--   old MUtxo, and If it has only one entry, that entry is not from the old MUtxo
genUTxO :: EraGenericGen era => GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO :: forall era.
EraGenericGen era =>
GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO = do
  [TxIn]
ins <- Int -> GenRS era [TxIn]
forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn Int
100
  [(TxIn, TxOut era)]
pairs <- [RWST (GenEnv era) () (GenState era) Gen (TxIn, TxOut era)]
-> RWST (GenEnv era) () (GenState era) Gen [(TxIn, TxOut era)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((TxIn -> RWST (GenEnv era) () (GenState era) Gen (TxIn, TxOut era))
-> [TxIn]
-> [RWST (GenEnv era) () (GenState era) Gen (TxIn, TxOut era)]
forall a b. (a -> b) -> [a] -> [b]
map (\TxIn
x -> (TxIn
x,) (TxOut era -> (TxIn, TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
-> RWST (GenEnv era) () (GenState era) Gen (TxIn, TxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
genOut) [TxIn]
ins)
  Int
percent <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Int
forall era. GenState era -> Int
getOldUtxoPercent
  -- Choose a pair from the oldUTxO
  Maybe (TxIn, TxOut era)
maybepair <- [(Int,
  RWST (GenEnv era) () (GenState era) Gen (Maybe (TxIn, TxOut era)))]
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (TxIn, TxOut era))
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
percent, RWST (GenEnv era) () (GenState era) Gen (Maybe (TxIn, TxOut era))
forall era. EraModel era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem), (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
percent, Maybe (TxIn, TxOut era)
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (TxIn, TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxIn, TxOut era)
forall a. Maybe a
Nothing)]
  (MUtxo era, Maybe (TxIn, TxOut era))
-> GenRS era (MUtxo era, Maybe (TxIn, TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxIn, TxOut era)] -> MUtxo era
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Maybe (TxIn, TxOut era)
-> [(TxIn, TxOut era)] -> [(TxIn, TxOut era)]
forall {a}. Maybe a -> [a] -> [a]
maybeCons Maybe (TxIn, TxOut era)
maybepair [(TxIn, TxOut era)]
pairs), Maybe (TxIn, TxOut era)
maybepair)
  where
    -- Note: Never add an old pair unless there are more than 1 new pairs
    maybeCons :: Maybe a -> [a] -> [a]
maybeCons (Just a
pair) [a]
xs | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = a
pair a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
    maybeCons Maybe a
_ [a]
xs = [a]
xs
    genOut :: RWST (GenEnv era) () (GenState era) Gen (TxOut era)
genOut = do
      Value era
val <- Gen (Value era)
-> RWST (GenEnv era) () (GenState era) Gen (Value era)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (Value era)
forall v. Val v => Gen v
genPositiveVal
      Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
forall era. Reflect era => Value era -> GenRS era (TxOut era)
genTxOut Value era
val

-- | Generate both the spending and reference inputs and a key from the spending
--   inputs we can use to pay the fee. That key is never from the oldUTxO
genSpendReferenceInputs ::
  Map TxIn (TxOut era) ->
  GenRS
    era
    ( UtxoEntry era -- The fee key, used to pay the fee.
    , Map TxIn (TxOut era)
    , Map TxIn (TxOut era)
    , Map TxIn (TxOut era)
    )
genSpendReferenceInputs :: forall era.
Map TxIn (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
genSpendReferenceInputs Map TxIn (TxOut era)
newUTxO = do
  let pairs :: [UtxoEntry era]
pairs = Map TxIn (TxOut era) -> [UtxoEntry era]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut era)
newUTxO
  Int
maxInputs <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Int
forall era. GenState era -> Int
getSpendInputsMax
  Int
maxRef <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Int
forall era. GenState era -> Int
getRefInputsMax
  Int
numInputs <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Map TxIn (TxOut era) -> Int
forall k a. Map k a -> Int
Map.size Map TxIn (TxOut era)
newUTxO) Int
maxInputs)
  Int
numRefInputs <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxRef)
  TxIn -> Bool
badTest <- GenRS era (TxIn -> Bool)
forall era. GenRS era (TxIn -> Bool)
getUtxoTest
  (feepair :: UtxoEntry era
feepair@(TxIn
txin, TxOut era
txout), [UtxoEntry era]
inputPairs) <- Gen (UtxoEntry era, [UtxoEntry era])
-> RWST
     (GenEnv era) () (GenState era) Gen (UtxoEntry era, [UtxoEntry era])
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (UtxoEntry era, [UtxoEntry era])
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (UtxoEntry era, [UtxoEntry era]))
-> Gen (UtxoEntry era, [UtxoEntry era])
-> RWST
     (GenEnv era) () (GenState era) Gen (UtxoEntry era, [UtxoEntry era])
forall a b. (a -> b) -> a -> b
$ (UtxoEntry era -> Bool)
-> Int -> [UtxoEntry era] -> Gen (UtxoEntry era, [UtxoEntry era])
forall a. (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood (TxIn -> Bool
badTest (TxIn -> Bool) -> (UtxoEntry era -> TxIn) -> UtxoEntry era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoEntry era -> TxIn
forall a b. (a, b) -> a
fst) Int
numInputs [UtxoEntry era]
pairs
  [UtxoEntry era]
refInputPairs <- Int -> [UtxoEntry era] -> [UtxoEntry era]
forall a. Int -> [a] -> [a]
take Int
numRefInputs ([UtxoEntry era] -> [UtxoEntry era])
-> RWST (GenEnv era) () (GenState era) Gen [UtxoEntry era]
-> RWST (GenEnv era) () (GenState era) Gen [UtxoEntry era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [UtxoEntry era]
-> RWST (GenEnv era) () (GenState era) Gen [UtxoEntry era]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([UtxoEntry era] -> Gen [UtxoEntry era]
forall a. [a] -> Gen [a]
shuffle [UtxoEntry era]
pairs)
  let inputs :: Map TxIn (TxOut era)
inputs = [UtxoEntry era] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
inputPairs
      refInputs :: Map TxIn (TxOut era)
refInputs = [UtxoEntry era] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
refInputPairs
  -- The feepair is added to the mMutFee field
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelMutFee (TxIn -> TxOut era -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txin TxOut era
txout)
  let filtered :: Map TxIn (TxOut era)
filtered = Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
newUTxO (Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
inputs) (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputs))
  (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
 Map TxIn (TxOut era))
-> GenRS
     era
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UtxoEntry era
feepair, Map TxIn (TxOut era)
inputs, Map TxIn (TxOut era)
refInputs, Map TxIn (TxOut era)
filtered)

-- | The invariant is:
--
-- * 'xs' is a non empty list.
-- * 'xs' has at most one 'bad' element
-- * if 'xs' has length 1, then the element is guaranteed to be good.
-- * 'n' is a positive `Int`, ranging between (1 .. length xs).
-- Return a pair (good,ys) where
-- > (bad good)==False,
-- > (good `elem` ys),
-- > (length ys) == n, and
-- > all (`elem` xs) ys.
--
-- This is used to generate the spending inputs, which always contain on
-- Input we can use to pay the fee, that does not come from the oldUTxO.
chooseGood :: (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood :: forall a. (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood a -> Bool
bad Int
n [a]
xs = do
  let (a
good, [a]
others) =
        case [a]
xs of
          [] ->
            [Char] -> (a, [a])
forall a. HasCallStack => [Char] -> a
error ([Char] -> (a, [a])) -> [Char] -> (a, [a])
forall a b. (a -> b) -> a -> b
$
              [Char]
"empty list in chooseGood, should never happen. n = "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", length xs = "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)
          [Item [a]
x] -> (a
Item [a]
x, [])
          (a
x : a
y : [a]
more) -> if a -> Bool
bad a
x then (a
y, a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
more) else (a
x, a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
more)
  [a]
tailx <- Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([a] -> [a]) -> Gen [a] -> Gen [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Gen [a]
forall a. [a] -> Gen [a]
shuffle [a]
others
  [a]
result <- [a] -> Gen [a]
forall a. [a] -> Gen [a]
shuffle (a
good a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tailx)
  (a, [a]) -> Gen (a, [a])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
good, [a]
result)

-- ==================================================
-- Generating Certificates, May add to the Model

genShelleyDelegCert :: forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert :: forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert = do
  Int
regCertFreq <- (GenEnv era -> Int) -> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks ((GenEnv era -> Int)
 -> RWST (GenEnv era) () (GenState era) Gen Int)
-> (GenEnv era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ GenSize -> Int
regCertFreq (GenSize -> Int) -> (GenEnv era -> GenSize) -> GenEnv era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> GenSize
forall era. GenEnv era -> GenSize
geSize
  Int
delegCertFreq <- (GenEnv era -> Int) -> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks ((GenEnv era -> Int)
 -> RWST (GenEnv era) () (GenState era) Gen Int)
-> (GenEnv era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ GenSize -> Int
delegCertFreq (GenSize -> Int) -> (GenEnv era -> GenSize) -> GenEnv era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> GenSize
forall era. GenEnv era -> GenSize
geSize
  [(Int, RWST (GenEnv era) () (GenState era) Gen (TxCert era))]
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
regCertFreq, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyRegCert)
    , (Int
25, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyUnRegCert)
    , (Int
delegCertFreq, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genDelegation)
    ]
  where
    genShelleyRegCert :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyRegCert = Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert (Credential 'Staking -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred @era PlutusPurposeTag
Certifying
    genShelleyUnRegCert :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyUnRegCert = Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
UnRegTxCert (Credential 'Staking -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
Certifying
    genDelegation :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genDelegation = do
      Credential 'Staking
rewardAccount <- PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred PlutusPurposeTag
Certifying
      (KeyHash 'StakePool
poolId, PoolParams
_) <- GenRS era (KeyHash 'StakePool, PoolParams)
forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams)
genPool
      TxCert era -> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
 -> RWST (GenEnv era) () (GenState era) Gen (TxCert era))
-> TxCert era
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall a b. (a -> b) -> a -> b
$ Credential 'Staking -> KeyHash 'StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert Credential 'Staking
rewardAccount KeyHash 'StakePool
poolId

genTxCertDeleg :: forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg :: forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Mary -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Allegra -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Alonzo -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Babbage -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Conway -> GenRS era (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert

genTxCert :: forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert :: forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert SlotNo
slot =
  [RWST (GenEnv era) () (GenState era) Gen (TxCert era)]
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT
    [ Item [RWST (GenEnv era) () (GenState era) Gen (TxCert era)]
RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg
    , [(Int, RWST (GenEnv era) () (GenState era) Gen (TxCert era))]
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
        [ (Int
75, PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert (PoolParams -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen PoolParams
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen PoolParams
genFreshPool)
        , (Int
25, KeyHash 'StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert (KeyHash 'StakePool -> EpochNo -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
-> RWST (GenEnv era) () (GenState era) Gen (EpochNo -> TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
forall era. Reflect era => GenRS era (KeyHash 'StakePool)
genRetirementHash RWST (GenEnv era) () (GenState era) Gen (EpochNo -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen EpochNo
-> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall a b.
RWST (GenEnv era) () (GenState era) Gen (a -> b)
-> RWST (GenEnv era) () (GenState era) Gen a
-> RWST (GenEnv era) () (GenState era) Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch)
        ]
    ]
  where
    genFreshPool :: RWST (GenEnv era) () (GenState era) Gen PoolParams
genFreshPool = do
      (KeyHash 'StakePool
_kh, PoolParams
pp, IndividualPoolStake
_) <- GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
      PoolParams -> RWST (GenEnv era) () (GenState era) Gen PoolParams
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return PoolParams
pp
    genEpoch :: RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch = do
      let EpochNo Word64
txEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
      EpochNo Word64
curEpoch <- (GenState era -> EpochNo)
-> RWST (GenEnv era) () (GenState era) Gen EpochNo
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets ((GenState era -> EpochNo)
 -> RWST (GenEnv era) () (GenState era) Gen EpochNo)
-> (GenState era -> EpochNo)
-> RWST (GenEnv era) () (GenState era) Gen EpochNo
forall a b. (a -> b) -> a -> b
$ ModelNewEpochState era -> EpochNo
forall era. ModelNewEpochState era -> EpochNo
mEL (ModelNewEpochState era -> EpochNo)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel
      EpochInterval Word32
maxEpoch <- (GenEnv era -> EpochInterval)
-> RWST (GenEnv era) () (GenState era) Gen EpochInterval
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks ((GenEnv era -> EpochInterval)
 -> RWST (GenEnv era) () (GenState era) Gen EpochInterval)
-> (GenEnv era -> EpochInterval)
-> RWST (GenEnv era) () (GenState era) Gen EpochInterval
forall a b. (a -> b) -> a -> b
$ Getting EpochInterval (PParams era) EpochInterval
-> PParams era -> EpochInterval
forall a s. Getting a s a -> s -> a
L.view Getting EpochInterval (PParams era) EpochInterval
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL (PParams era -> EpochInterval)
-> (GenEnv era -> PParams era) -> GenEnv era -> EpochInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> PParams era
forall era. GenEnv era -> PParams era
gePParams
      let nextEpoch :: Word64
nextEpoch = Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
txEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
curEpoch) -- This will be either 1 or 2. It is 2 if the Tx is at the epoch boundary
      Word64
delta <- Gen Word64 -> RWST (GenEnv era) () (GenState era) Gen Word64
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Word64 -> RWST (GenEnv era) () (GenState era) Gen Word64)
-> Gen Word64 -> RWST (GenEnv era) () (GenState era) Gen Word64
forall a b. (a -> b) -> a -> b
$ (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
nextEpoch, Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxEpoch)
      EpochNo -> RWST (GenEnv era) () (GenState era) Gen EpochNo
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpochNo -> RWST (GenEnv era) () (GenState era) Gen EpochNo)
-> (Word64 -> EpochNo)
-> Word64
-> RWST (GenEnv era) () (GenState era) Gen EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochNo
EpochNo (Word64 -> RWST (GenEnv era) () (GenState era) Gen EpochNo)
-> Word64 -> RWST (GenEnv era) () (GenState era) Gen EpochNo
forall a b. (a -> b) -> a -> b
$ (Word64
curEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
delta)

genTxCerts :: forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts :: forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts SlotNo
slot = do
  let genUniqueScript :: ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
genUniqueScript (![TxCert era]
dcs, !Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, !Map (Credential 'Staking) Coin
regCreds) Int
_ = do
        Set (Credential 'Staking)
honest <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (Credential 'Staking)
forall era. GenState era -> Set (Credential 'Staking)
gsStableDelegators
        TxCert era
dc <- SlotNo -> RWST (GenEnv era) () (GenState era) Gen (TxCert era)
forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert SlotNo
slot
        -- Workaround a misfeature where duplicate plutus scripts in TxCert are ignored
        -- so if a duplicate might be generated, we don't do that generation
        let insertIfNotPresent :: [TxCert era]
-> Map (Credential 'Staking) Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map (Credential 'Staking) Coin)
insertIfNotPresent [TxCert era]
dcs' Map (Credential 'Staking) Coin
regCreds' Maybe (KeyHash 'StakePool)
mKey Maybe (IsValid, ScriptHash)
mScriptHash
              | Just (IsValid
_, ScriptHash
scriptHash) <- Maybe (IsValid, ScriptHash)
mScriptHash =
                  if (ScriptHash
scriptHash, Maybe (KeyHash 'StakePool)
mKey) (ScriptHash, Maybe (KeyHash 'StakePool))
-> Set (ScriptHash, Maybe (KeyHash 'StakePool)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss
                    then ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
                    else (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs', (ScriptHash, Maybe (KeyHash 'StakePool))
-> Set (ScriptHash, Maybe (KeyHash 'StakePool))
-> Set (ScriptHash, Maybe (KeyHash 'StakePool))
forall a. Ord a => a -> Set a -> Set a
Set.insert (ScriptHash
scriptHash, Maybe (KeyHash 'StakePool)
mKey) Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds')
              | Bool
otherwise = (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs', Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds')
        -- Generate registration and de-registration delegation certificates,
        -- while ensuring the proper registered/unregistered state in DState
        case TxCert era
dc of
          RegPoolTxCert PoolParams
_ -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
          RetirePoolTxCert KeyHash 'StakePool
kh EpochNo
_ -> do
            -- We need to make sure that the pool is registered before
            -- we try to retire it
            Map (KeyHash 'StakePool) StakePoolState
modelPools <- (GenState era -> Map (KeyHash 'StakePool) StakePoolState)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash 'StakePool) StakePoolState)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets ((GenState era -> Map (KeyHash 'StakePool) StakePoolState)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (Map (KeyHash 'StakePool) StakePoolState))
-> (GenState era -> Map (KeyHash 'StakePool) StakePoolState)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash 'StakePool) StakePoolState)
forall a b. (a -> b) -> a -> b
$ ModelNewEpochState era -> Map (KeyHash 'StakePool) StakePoolState
forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) StakePoolState
mStakePools (ModelNewEpochState era -> Map (KeyHash 'StakePool) StakePoolState)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash 'StakePool) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel
            case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
kh Map (KeyHash 'StakePool) StakePoolState
modelPools of
              Just StakePoolState
_ -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
              Maybe StakePoolState
Nothing -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
          RegTxCert Credential 'Staking
regCred ->
            if Credential 'Staking
regCred Credential 'Staking -> Map (Credential 'Staking) Coin -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Credential 'Staking) Coin
regCreds -- Can't register if it is already registered
              then ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
              else ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Credential 'Staking
-> Coin
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
regCred (Integer -> Coin
Coin Integer
99) Map (Credential 'Staking) Coin
regCreds) -- 99 is a NonZero Value
          UnRegTxCert Credential 'Staking
deregCred ->
            -- We can't make ShelleyUnRegCert certificate if deregCred is not already registered
            -- or if the Rewards balance for deregCred is not 0,
            -- or if the credential is one of the StableDelegators (which are never de-registered)
            case Credential 'Staking -> Map (Credential 'Staking) Coin -> Maybe Coin
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
deregCred Map (Credential 'Staking) Coin
regCreds of
              Maybe Coin
Nothing -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
              -- No credential, skip making certificate
              Just (Coin Integer
0) ->
                -- Ok to make certificate, rewards balance is 0
                if Credential 'Staking -> Set (Credential 'Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Credential 'Staking
deregCred Set (Credential 'Staking)
honest
                  then ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
                  else
                    [TxCert era]
-> Map (Credential 'Staking) Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map (Credential 'Staking) Coin)
insertIfNotPresent [TxCert era]
dcs (Credential 'Staking
-> Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Credential 'Staking
deregCred Map (Credential 'Staking) Coin
regCreds) Maybe (KeyHash 'StakePool)
forall a. Maybe a
Nothing
                      (Maybe (IsValid, ScriptHash)
 -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
     Map (Credential 'Staking) Coin))
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential 'Staking
-> PlutusPurposeTag
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag Credential 'Staking
deregCred PlutusPurposeTag
Certifying
              Just (Coin Integer
_) -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
          DelegStakeTxCert Credential 'Staking
delegCred KeyHash 'StakePool
delegKey ->
            let ([TxCert era]
dcs', Map (Credential 'Staking) Coin
regCreds') =
                  if Credential 'Staking
delegCred Credential 'Staking -> Map (Credential 'Staking) Coin -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Credential 'Staking) Coin
regCreds
                    then ([TxCert era]
dcs, Map (Credential 'Staking) Coin
regCreds)
                    else -- In order to Delegate, the delegCred must exist in rewards.
                    -- so if it is not there, we put it there, otherwise we may
                    -- never generate a valid delegation.
                      ( Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
delegCred TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs
                      , Credential 'Staking
-> Coin
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
delegCred (Integer -> Coin
Coin Integer
99) Map (Credential 'Staking) Coin
regCreds
                      )
             in [TxCert era]
-> Map (Credential 'Staking) Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map (Credential 'Staking) Coin)
insertIfNotPresent [TxCert era]
dcs' Map (Credential 'Staking) Coin
regCreds' (KeyHash 'StakePool -> Maybe (KeyHash 'StakePool)
forall a. a -> Maybe a
Just KeyHash 'StakePool
delegKey)
                  (Maybe (IsValid, ScriptHash)
 -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
     Map (Credential 'Staking) Coin))
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential 'Staking
-> PlutusPurposeTag
-> RWST
     (GenEnv era) () (GenState era) Gen (Maybe (IsValid, ScriptHash))
forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag Credential 'Staking
delegCred PlutusPurposeTag
Certifying
          TxCert era
_ -> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc TxCert era -> [TxCert era] -> [TxCert era]
forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map (Credential 'Staking) Coin
regCreds)
  Int
maxcert <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Int
forall era. GenState era -> Int
getCertificateMax
  Int
n <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxcert)
  Accounts era
accounts <- (GenState era -> Accounts era)
-> RWST (GenEnv era) () (GenState era) Gen (Accounts era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts (ModelNewEpochState era -> Accounts era)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  let initSets ::
        ( [TxCert era]
        , Set (ScriptHash, Maybe (KeyHash 'StakePool))
        , Map (Credential 'Staking) Coin
        )
      initSets :: ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
initSets = ([], Set (ScriptHash, Maybe (KeyHash 'StakePool))
forall a. Set a
Set.empty, (AccountState era -> Coin)
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (AccountState era -> CompactForm Coin)
-> AccountState era
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL)) (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential 'Staking) (AccountState era))
     (Accounts era)
     (Map (Credential 'Staking) (AccountState era))
-> Map (Credential 'Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential 'Staking) (AccountState era))
  (Accounts era)
  (Map (Credential 'Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
accountsMapL))
  ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
_, Map (Credential 'Staking) Coin
_) <- (([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
  Map (Credential 'Staking) Coin)
 -> Int
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
       Map (Credential 'Staking) Coin))
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map (Credential 'Staking) Coin)
-> [Int]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map (Credential 'Staking) Coin)
genUniqueScript ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map (Credential 'Staking) Coin)
initSets ([Int
Item [Int]
1 .. Int
Item [Int]
n] :: [Int])
  [TxCert era] -> GenRS era [TxCert era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era] -> GenRS era [TxCert era])
-> [TxCert era] -> GenRS era [TxCert era]
forall a b. (a -> b) -> a -> b
$ [TxCert era] -> [TxCert era]
forall a. [a] -> [a]
reverse [TxCert era]
dcs

spendOnly :: EraTxOut era => TxOut era -> Bool
spendOnly :: forall era. EraTxOut era => TxOut era -> Bool
spendOnly TxOut era
txOut = case TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
  Addr Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_ -> Bool
False
  Addr
_ -> Bool
True

-- | Generate a set of Collateral inputs sufficient to pay the minimum fee ('minCollTotal') computed
--   from the fee and the collateralPercentage from the PParams. Return the new UTxO, the inputs,
--   and coin of the excess amount included in the inputs, above what is needed to pay the minimum fee.
genCollateralUTxO ::
  forall era.
  (HasCallStack, EraGenericGen era) =>
  [Addr] ->
  Coin ->
  MUtxo era ->
  GenRS era (MUtxo era, Map.Map TxIn (TxOut era), Coin)
genCollateralUTxO :: forall era.
(HasCallStack, EraGenericGen era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses (Coin Integer
fee) Map TxIn (TxOut era)
utxo = do
  GenEnv {PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams :: PParams era
gePParams} <- (GenState era -> GenEnv era)
-> RWST (GenEnv era) () (GenState era) Gen (GenEnv era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> GenEnv era
forall era. GenState era -> GenEnv era
gsGenEnv
  let collPerc :: Nat
collPerc = PParams era
gePParams PParams era -> Getting Nat (PParams era) Nat -> Nat
forall s a. s -> Getting a s a -> a
^. Getting Nat (PParams era) Nat
forall era. EraGenericGen era => Lens' (PParams era) Nat
Lens' (PParams era) Nat
ppCollateralPercentageT
      minCollTotal :: Coin
minCollTotal = Integer -> Coin
Coin (Ratio Integer -> Integer
forall b. Integral b => Ratio Integer -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Nat -> Integer
forall a. Integral a => a -> Integer
toInteger Nat
collPerc) Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
100))
      -- Generate a collateral that is neither in UTxO map nor has already been generated
      genNewCollateral :: Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genNewCollateral Addr
addr Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um Coin
c = do
        -- The size of the Gen computation is driven down when we generate scripts, so it can be 0 here
        -- that is really bad, because if the happens we get the same TxIn every time, and 'coll' never grows,
        -- so this function doesn't terminate. We want many choices of TxIn, so resize just this arbitrary by 30.
        Map TxIn (TxOut era)
entriesInUse <- (GenState era -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (Map TxIn (TxOut era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map TxIn (TxOut era)
forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo
        TxIn
txIn <- Gen TxIn -> RWST (GenEnv era) () (GenState era) Gen TxIn
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> Gen TxIn -> Gen TxIn
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
30 (Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary :: Gen TxIn))
        if TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn Map TxIn (TxOut era)
utxo Bool -> Bool -> Bool
|| TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn Map TxIn (TxOut era)
coll Bool -> Bool -> Bool
|| TxIn
txIn TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TxIn (TxOut era)
entriesInUse
          then Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genNewCollateral Addr
addr Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um Coin
c
          else (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut era)
um, TxIn -> TxOut era -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn (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
c)) Map TxIn (TxOut era)
coll, Coin
c)
      -- Either pick a collateral from a map or generate a completely new one
      genCollateral :: Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genCollateral Addr
addr Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um
        | Map TxIn (TxOut era) -> Bool
forall k a. Map k a -> Bool
Map.null Map TxIn (TxOut era)
um = Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genNewCollateral Addr
addr Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um (Coin
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin))
-> RWST (GenEnv era) () (GenState era) Gen Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
        | Bool
otherwise = do
            Int
i <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, Map TxIn (TxOut era) -> Int
forall k a. Map k a -> Int
Map.size Map TxIn (TxOut era)
um Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            let (TxIn
txIn, TxOut era
txOut) = Int -> Map TxIn (TxOut era) -> (TxIn, TxOut era)
forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i Map TxIn (TxOut era)
um
            (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
i Map TxIn (TxOut era)
um, TxIn -> TxOut era -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn TxOut era
txOut Map TxIn (TxOut era)
coll, TxOut era
txOut 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)
      -- Recursively either pick existing key spend only outputs or generate new ones that
      -- will be later added to the UTxO map
      go ::
        [Addr] ->
        Map TxIn (TxOut era) ->
        Coin ->
        Map TxIn (TxOut era) ->
        GenRS era (Map TxIn (TxOut era), Coin)
      go :: [Addr]
-> Map TxIn (TxOut era)
-> Coin
-> Map TxIn (TxOut era)
-> GenRS era (Map TxIn (TxOut era), Coin)
go [Addr]
ecs !Map TxIn (TxOut era)
coll !Coin
curCollTotal !Map TxIn (TxOut era)
um
        | Coin
curCollTotal Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minCollTotal = (Map TxIn (TxOut era), Coin)
-> GenRS era (Map TxIn (TxOut era), Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut era)
coll, Coin
curCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
minCollTotal)
        | [] <- [Addr]
ecs = [Char] -> GenRS era (Map TxIn (TxOut era), Coin)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: supplied less addresses than `maxCollateralInputs`"
        | Addr
ec : [Addr]
ecs' <- [Addr]
ecs = do
            (Map TxIn (TxOut era)
um', Map TxIn (TxOut era)
coll', Coin
c) <-
              if [Addr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
ecs'
                then -- This is the last input, so most of the time, put something (val > 0)
                -- extra in it or we will always have a ColReturn with zero in it.
                  do
                    Coin
excess <- Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
                    Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genNewCollateral Addr
ec Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um ((Coin
minCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
curCollTotal) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
excess)
                else [RWST
   (GenEnv era)
   ()
   (GenState era)
   Gen
   (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genCollateral Addr
ec Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
forall k a. Map k a
Map.empty, Addr
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
genCollateral Addr
ec Map TxIn (TxOut era)
coll Map TxIn (TxOut era)
um]
            [Addr]
-> Map TxIn (TxOut era)
-> Coin
-> Map TxIn (TxOut era)
-> GenRS era (Map TxIn (TxOut era), Coin)
go [Addr]
ecs' Map TxIn (TxOut era)
coll' (Coin
curCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
c) Map TxIn (TxOut era)
um'
  (Map TxIn (TxOut era)
collaterals, Coin
excessColCoin) <-
    [Addr]
-> Map TxIn (TxOut era)
-> Coin
-> Map TxIn (TxOut era)
-> GenRS era (Map TxIn (TxOut era), Coin)
go [Addr]
collateralAddresses Map TxIn (TxOut era)
forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0) (Map TxIn (TxOut era) -> GenRS era (Map TxIn (TxOut era), Coin))
-> Map TxIn (TxOut era) -> GenRS era (Map TxIn (TxOut era), Coin)
forall a b. (a -> b) -> a -> b
$ (TxOut era -> Bool) -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter TxOut era -> Bool
forall era. EraTxOut era => TxOut era -> Bool
spendOnly Map TxIn (TxOut era)
utxo
  (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (TxOut era)
collaterals Map TxIn (TxOut era)
utxo, Map TxIn (TxOut era)
collaterals, Coin
excessColCoin)

-- | This function is used to generate the Outputs of a TxBody, It is computed by taking the
--   Outputs of the range of the (UTxO resticted by the Inputs of the TxBody),
--   as input to the function, and then making new Outputs, where the sum of the Coin is the same.
--   This way we generate a 'balanced' TxBody (modulo fees, deposits, refunds etc. which are
--   handled separately). The idea is to make sum(txOuts) == sum(genRecipientsFrom txouts), the
--   sum will be the same, but the size may be different.
genRecipientsFrom ::
  forall era. EraGenericGen era => [TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom :: forall era.
EraGenericGen era =>
[TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom [TxOut era]
txOuts = do
  let outCount :: Int
outCount = [TxOut era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut era]
txOuts
  Int
approxCount <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
outCount)
  let extra :: Int
extra = Int
outCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
approxCount
      avgExtra :: Int
avgExtra = Ratio Integer -> Int
forall b. Integral b => Ratio Integer -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
extra Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
approxCount)
      genExtra :: Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
avgExtra Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
        | Bool
otherwise = Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, Int
avgExtra)
  let goNew :: Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
_ [] ![TxOut era]
rs = [TxOut era] -> GenRS era [TxOut era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut era]
rs
      goNew Int
e (TxOut era
tx : [TxOut era]
txs) ![TxOut era]
rs = do
        Int
leftToAdd <- Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftToAdd) Int
leftToAdd (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
0)) TxOut era
tx [TxOut era]
txs [TxOut era]
rs
      goExtra :: Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra Int
_ Int
_ Value era
s TxOut era
tx [] ![TxOut era]
rs = Value era -> TxOut era -> [TxOut era] -> GenRS era [TxOut era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Reflect era) =>
Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
tx [TxOut era]
rs
      goExtra Int
e Int
0 Value era
s TxOut era
tx [TxOut era]
txs ![TxOut era]
rs = Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
e [TxOut era]
txs ([TxOut era] -> GenRS era [TxOut era])
-> GenRS era [TxOut era] -> GenRS era [TxOut era]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value era -> TxOut era -> [TxOut era] -> GenRS era [TxOut era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Reflect era) =>
Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
tx [TxOut era]
rs
      goExtra Int
e Int
n !Value era
s TxOut era
txOut (TxOut era
tx : [TxOut era]
txs) ![TxOut era]
rs = Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra Int
e (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Value era
s Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Value era
v) TxOut era
tx [TxOut era]
txs [TxOut era]
rs
        where
          v :: Value era
v = TxOut era
txOut TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
      -- Potentially split 'txout' into two TxOuts. If the two piece path is used
      -- one of two TxOuts uses the same 'addr' as 'txout' and holds the 'change'
      -- (i.e. difference between the original and the second, non-change, TxOut).
      -- In either case whether it adds 1 or 2 TxOuts to 'rs', the coin value of
      -- the new TxOut(s), is the same as the coin value of 'txout'.
      genWithChange :: Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
txout [TxOut era]
rs = do
        let v :: Value era
v = TxOut era
txout TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
            vCoin :: Integer
vCoin = Coin -> Integer
unCoin (Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
v)
        if Integer
vCoin Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -- If the coin balance is 0, don't add any TxOuts to 'rs'
          then [TxOut era] -> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut era]
rs
          else do
            Coin
c <- Integer -> Coin
Coin (Integer -> Coin)
-> RWST (GenEnv era) () (GenState era) Gen Integer
-> RWST (GenEnv era) () (GenState era) Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer -> RWST (GenEnv era) () (GenState era) Gen Integer
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
vCoin))
            TxOut era
newTxOut <- Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
forall era. Reflect era => Value era -> GenRS era (TxOut era)
genTxOut (Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era))
-> Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
forall a b. (a -> b) -> a -> b
$ Value era
s Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
c
            [TxOut era] -> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxOut era]
 -> RWST (GenEnv era) () (GenState era) Gen [TxOut era])
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall a b. (a -> b) -> a -> b
$
              if Coin
c Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
v
                then
                  let !change :: TxOut era
change = TxOut era
txout TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Value era -> Identity (Value era))
-> TxOut era -> Identity (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL ((Value era -> Identity (Value era))
 -> TxOut era -> Identity (TxOut era))
-> (Value era -> Value era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<-> Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
c)
                   in TxOut era
newTxOut TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: TxOut era
change TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: [TxOut era]
rs
                else TxOut era
newTxOut TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: [TxOut era]
rs
  Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
extra [TxOut era]
txOuts []

getTxCertCredential ::
  forall era. Reflect era => TxCert era -> Maybe (Credential 'Staking)
getTxCertCredential :: forall era.
Reflect era =>
TxCert era -> Maybe (Credential 'Staking)
getTxCertCredential = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> TxCert era -> Maybe (Credential 'Staking)
ShelleyTxCert ShelleyEra -> Maybe (Credential 'Staking)
forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential
  Proof era
Mary -> TxCert era -> Maybe (Credential 'Staking)
ShelleyTxCert MaryEra -> Maybe (Credential 'Staking)
forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential
  Proof era
Allegra -> TxCert era -> Maybe (Credential 'Staking)
ShelleyTxCert AllegraEra -> Maybe (Credential 'Staking)
forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential
  Proof era
Alonzo -> TxCert era -> Maybe (Credential 'Staking)
ShelleyTxCert AlonzoEra -> Maybe (Credential 'Staking)
forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential
  Proof era
Babbage -> TxCert era -> Maybe (Credential 'Staking)
ShelleyTxCert BabbageEra -> Maybe (Credential 'Staking)
forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential
  Proof era
Conway -> TxCert era -> Maybe (Credential 'Staking)
ConwayTxCert ConwayEra -> Maybe (Credential 'Staking)
forall era. ConwayTxCert era -> Maybe (Credential 'Staking)
getConwayTxCertCredential

getShelleyTxCertCredential :: ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential :: forall era. ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential = \case
  ShelleyTxCertDelegCert ShelleyDelegCert
d ->
    case ShelleyDelegCert
d of
      ShelleyRegCert Credential 'Staking
_rk -> Maybe (Credential 'Staking)
forall a. Maybe a
Nothing -- we don't require witnesses for ShelleyRegCert
      ShelleyUnRegCert Credential 'Staking
drk -> Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just Credential 'Staking
drk
      ShelleyDelegCert Credential 'Staking
dk KeyHash 'StakePool
_ -> Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just Credential 'Staking
dk
  ShelleyTxCertPool PoolCert
pc ->
    case PoolCert
pc of
      RegPool PoolParams {Set (KeyHash 'Staking)
StrictMaybe PoolMetadata
KeyHash 'StakePool
VRFVerKeyHash 'StakePoolVRF
RewardAccount
Coin
StrictSeq StakePoolRelay
UnitInterval
ppId :: KeyHash 'StakePool
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppPledge :: Coin
ppCost :: Coin
ppMargin :: UnitInterval
ppRewardAccount :: RewardAccount
ppOwners :: Set (KeyHash 'Staking)
ppRelays :: StrictSeq StakePoolRelay
ppMetadata :: StrictMaybe PoolMetadata
ppId :: PoolParams -> KeyHash 'StakePool
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppPledge :: PoolParams -> Coin
ppCost :: PoolParams -> Coin
ppMargin :: PoolParams -> UnitInterval
ppRewardAccount :: PoolParams -> RewardAccount
ppOwners :: PoolParams -> Set (KeyHash 'Staking)
ppRelays :: PoolParams -> StrictSeq StakePoolRelay
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
..} -> Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just (Credential 'Staking -> Maybe (Credential 'Staking))
-> (Credential 'StakePool -> Credential 'Staking)
-> Credential 'StakePool
-> Maybe (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'StakePool -> Credential 'Staking
forall (r :: KeyRole) (r' :: KeyRole).
Credential r -> Credential r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (Credential 'StakePool -> Maybe (Credential 'Staking))
-> Credential 'StakePool -> Maybe (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Credential 'StakePool
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
ppId
      RetirePool KeyHash 'StakePool
kh EpochNo
_ -> Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just (Credential 'Staking -> Maybe (Credential 'Staking))
-> (Credential 'StakePool -> Credential 'Staking)
-> Credential 'StakePool
-> Maybe (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'StakePool -> Credential 'Staking
forall (r :: KeyRole) (r' :: KeyRole).
Credential r -> Credential r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (Credential 'StakePool -> Maybe (Credential 'Staking))
-> Credential 'StakePool -> Maybe (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Credential 'StakePool
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
kh
  ShelleyTxCertGenesisDeleg GenesisDelegCert
_g -> Maybe (Credential 'Staking)
forall a. Maybe a
Nothing
  ShelleyTxCertMir MIRCert
_m -> Maybe (Credential 'Staking)
forall a. Maybe a
Nothing

getConwayTxCertCredential :: ConwayTxCert era -> Maybe (Credential 'Staking)
getConwayTxCertCredential :: forall era. ConwayTxCert era -> Maybe (Credential 'Staking)
getConwayTxCertCredential (ConwayTxCertPool (RegPool PoolParams {Set (KeyHash 'Staking)
StrictMaybe PoolMetadata
KeyHash 'StakePool
VRFVerKeyHash 'StakePoolVRF
RewardAccount
Coin
StrictSeq StakePoolRelay
UnitInterval
ppId :: PoolParams -> KeyHash 'StakePool
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppPledge :: PoolParams -> Coin
ppCost :: PoolParams -> Coin
ppMargin :: PoolParams -> UnitInterval
ppRewardAccount :: PoolParams -> RewardAccount
ppOwners :: PoolParams -> Set (KeyHash 'Staking)
ppRelays :: PoolParams -> StrictSeq StakePoolRelay
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
ppId :: KeyHash 'StakePool
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppPledge :: Coin
ppCost :: Coin
ppMargin :: UnitInterval
ppRewardAccount :: RewardAccount
ppOwners :: Set (KeyHash 'Staking)
ppRelays :: StrictSeq StakePoolRelay
ppMetadata :: StrictMaybe PoolMetadata
..})) = Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just (Credential 'Staking -> Maybe (Credential 'Staking))
-> (Credential 'StakePool -> Credential 'Staking)
-> Credential 'StakePool
-> Maybe (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'StakePool -> Credential 'Staking
forall (r :: KeyRole) (r' :: KeyRole).
Credential r -> Credential r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (Credential 'StakePool -> Maybe (Credential 'Staking))
-> Credential 'StakePool -> Maybe (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Credential 'StakePool
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
ppId
getConwayTxCertCredential (ConwayTxCertPool (RetirePool KeyHash 'StakePool
kh EpochNo
_)) = Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just (Credential 'Staking -> Maybe (Credential 'Staking))
-> (Credential 'StakePool -> Credential 'Staking)
-> Credential 'StakePool
-> Maybe (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'StakePool -> Credential 'Staking
forall (r :: KeyRole) (r' :: KeyRole).
Credential r -> Credential r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (Credential 'StakePool -> Maybe (Credential 'Staking))
-> Credential 'StakePool -> Maybe (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Credential 'StakePool
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
kh
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayRegCert Credential 'Staking
_ StrictMaybe Coin
_)) = Maybe (Credential 'Staking)
forall a. Maybe a
Nothing
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayUnRegCert Credential 'Staking
cred StrictMaybe Coin
_)) = Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just Credential 'Staking
cred
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayDelegCert Credential 'Staking
cred Delegatee
_)) = Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just Credential 'Staking
cred
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayRegDelegCert Credential 'Staking
cred Delegatee
_ Coin
_)) = Credential 'Staking -> Maybe (Credential 'Staking)
forall a. a -> Maybe a
Just Credential 'Staking
cred
getConwayTxCertCredential (ConwayTxCertGov ConwayGovCert
_) = Maybe (Credential 'Staking)
forall a. Maybe a
Nothing

genWithdrawals ::
  Reflect era => SlotNo -> GenRS era (Withdrawals)
genWithdrawals :: forall era. Reflect era => SlotNo -> GenRS era Withdrawals
genWithdrawals SlotNo
slot =
  if SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0
    then do
      let networkId :: Network
networkId = Network
Testnet
      Map (Credential 'Staking) Coin
newRewards <- GenRS era (Map (Credential 'Staking) Coin)
forall era.
Reflect era =>
GenRS era (Map (Credential 'Staking) Coin)
genRewards
      Withdrawals -> GenRS era Withdrawals
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map RewardAccount Coin -> Withdrawals
Withdrawals (Map RewardAccount Coin -> Withdrawals)
-> Map RewardAccount Coin -> Withdrawals
forall a b. (a -> b) -> a -> b
$ (Credential 'Staking -> RewardAccount)
-> Map (Credential 'Staking) Coin -> Map RewardAccount Coin
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
networkId) Map (Credential 'Staking) Coin
newRewards)
    else Withdrawals -> GenRS era Withdrawals
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map RewardAccount Coin -> Withdrawals
Withdrawals Map RewardAccount Coin
forall k a. Map k a
Map.empty)

-- ============================================================================

minus :: MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus :: forall era. MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus MUtxo era
m Maybe (UtxoEntry era)
Nothing = MUtxo era
m
minus MUtxo era
m (Just (TxIn
txin, TxOut era
_)) = TxIn -> MUtxo era -> MUtxo era
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn
txin MUtxo era
m

genAlonzoTx ::
  forall era.
  EraGenericGen era =>
  SlotNo -> GenRS era (UTxO era, Tx era)
genAlonzoTx :: forall era.
EraGenericGen era =>
SlotNo -> GenRS era (UTxO era, Tx era)
genAlonzoTx SlotNo
slot = do
  (UTxO era
utxo, Tx era
tx, (TxIn, TxOut era)
_fee, Maybe (TxIn, TxOut era)
_old) <- SlotNo
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (UTxO era, Tx era, (TxIn, TxOut era), Maybe (TxIn, TxOut era))
forall era.
EraGenericGen era =>
SlotNo
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo SlotNo
slot
  (UTxO era, Tx era) -> GenRS era (UTxO era, Tx era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO era
utxo, Tx era
tx)

applyIsValid :: forall era. Reflect era => IsValid -> Tx era -> Tx era
applyIsValid :: forall era. Reflect era => IsValid -> Tx era -> Tx era
applyIsValid IsValid
isValid = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> Tx era -> Tx era
forall a. a -> a
id
  Proof era
Mary -> Tx era -> Tx era
forall a. a -> a
id
  Proof era
Allegra -> Tx era -> Tx era
forall a. a -> a
id
  Proof era
Alonzo -> (IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era)
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL ((IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era))
-> IsValid -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsValid
isValid
  Proof era
Babbage -> (IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era)
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL ((IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era))
-> IsValid -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsValid
isValid
  Proof era
Conway -> (IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era)
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL ((IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era))
-> IsValid -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsValid
isValid

genAlonzoTxAndInfo ::
  forall era.
  EraGenericGen era =>
  SlotNo ->
  GenRS
    era
    ( UTxO era
    , Tx era
    , UtxoEntry era -- The fee key
    , Maybe (UtxoEntry era) -- from oldUtxO
    )
genAlonzoTxAndInfo :: forall era.
EraGenericGen era =>
SlotNo
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo SlotNo
slot = do
  GenEnv {PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams :: PParams era
gePParams} <- (GenState era -> GenEnv era)
-> RWST (GenEnv era) () (GenState era) Gen (GenEnv era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> GenEnv era
forall era. GenState era -> GenEnv era
gsGenEnv
  ValidityInterval
validityInterval <- Gen ValidityInterval
-> RWST (GenEnv era) () (GenState era) Gen ValidityInterval
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen ValidityInterval
 -> RWST (GenEnv era) () (GenState era) Gen ValidityInterval)
-> Gen ValidityInterval
-> RWST (GenEnv era) () (GenState era) Gen ValidityInterval
forall a b. (a -> b) -> a -> b
$ SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsValidityInterval = validityInterval})

  -- 1. Produce utxos that will be spent
  (Map TxIn (TxOut era)
utxoChoices, Maybe (UtxoEntry era)
maybeoldpair) <- GenRS era (Map TxIn (TxOut era), Maybe (UtxoEntry era))
forall era.
EraGenericGen era =>
GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO

  -- 2. Generate UTxO for spending and reference inputs
  --    Note the spending inputs and the reference inputs may overlap.
  --    feeKey is one of the inputs from the spending inputs, safe to pay the fee with.
  ( feepair :: UtxoEntry era
feepair@(TxIn
feeKey, TxOut era
_) -- One of the spending inputs, to be used to pay the fee
    , Map TxIn (TxOut era)
toSpendNoCollateral -- All of the spending inputs
    , Map TxIn (TxOut era)
refInputsUtxo -- All the reference inputs
    , Map TxIn (TxOut era)
utxoNoCollateral -- Union of all the above
    ) <-
    Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
forall era.
Map TxIn (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
genSpendReferenceInputs Map TxIn (TxOut era)
utxoChoices

  -- 3. Check if all Plutus scripts are valid
  let toSpendNoCollateralTxOuts :: [TxOut era]
      toSpendNoCollateralTxOuts :: [TxOut era]
toSpendNoCollateralTxOuts = Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
toSpendNoCollateral
      -- We use maxBound to ensure the serialized size overestimation
      maxCoin :: Coin
maxCoin = Integer -> Coin
Coin (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int))
  -- 4. Generate all recipients and witnesses needed for spending Plutus scripts
  [TxOut era]
recipients <- [TxOut era] -> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall era.
EraGenericGen era =>
[TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom [TxOut era]
toSpendNoCollateralTxOuts

  -- mkPaymentWits :: ExUnits -> TxWits era -> TxWits era
  (IsValid Bool
v1, [ExUnits -> TxWits era -> TxWits era]
mkPaymentWits) <-
    PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential 'Payment)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall era (k :: KeyRole).
EraGenericGen era =>
PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> TxWits era -> TxWits era])
redeemerWitnessMaker
      PlutusPurposeTag
Spending
      [ (\DataHash
dh Credential 'Payment
cred -> ([Char]
-> DataHash
-> (GenState era -> Map DataHash (Data era))
-> GenRS era (Data era)
forall k era v.
(Ord k, Show k, HasCallStack) =>
[Char] -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM [Char]
"datum" DataHash
dh GenState era -> Map DataHash (Data era)
forall era. GenState era -> Map DataHash (Data era)
gsDatums, Credential 'Payment
cred))
          (DataHash
 -> Credential 'Payment
 -> (GenRS era (Data era), Credential 'Payment))
-> Maybe DataHash
-> Maybe
     (Credential 'Payment
      -> (GenRS era (Data era), Credential 'Payment))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DataHash
mDatumHash
          Maybe
  (Credential 'Payment
   -> (GenRS era (Data era), Credential 'Payment))
-> Maybe (Credential 'Payment)
-> Maybe (GenRS era (Data era), Credential 'Payment)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Credential 'Payment -> Maybe (Credential 'Payment)
forall a. a -> Maybe a
Just Credential 'Payment
credential
      | (TxIn
_, TxOut era
coretxout) <- Map TxIn (TxOut era) -> [UtxoEntry era]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxIn (TxOut era)
toSpendNoCollateral
      , let ([Credential 'Payment]
credentials, Maybe DataHash
mDatumHash) = Proof era -> TxOut era -> ([Credential 'Payment], Maybe DataHash)
forall era.
Proof era -> TxOut era -> ([Credential 'Payment], Maybe DataHash)
txoutEvidence (forall era. Reflect era => Proof era
reify @era) TxOut era
coretxout
      , Credential 'Payment
credential <- [Credential 'Payment]
credentials
      ]

  -- generate Withdrawals before TxCerts, as Rewards are populated in the Model here,
  -- and we need to avoid certain TxCerts if they conflict with existing Rewards
  withdrawals :: Withdrawals
withdrawals@(Withdrawals Map RewardAccount Coin
wdrlMap) <- SlotNo -> GenRS era Withdrawals
forall era. Reflect era => SlotNo -> GenRS era Withdrawals
genWithdrawals SlotNo
slot
  let withdrawalAmount :: Coin
withdrawalAmount = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold Map RewardAccount Coin
wdrlMap

  Maybe (TxOut era)
rewardsWithdrawalTxOut <-
    if Coin
withdrawalAmount Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Coin
Coin Integer
0
      then Maybe (TxOut era)
-> RWST (GenEnv era) () (GenState era) Gen (Maybe (TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxOut era)
forall a. Maybe a
Nothing
      else TxOut era -> Maybe (TxOut era)
forall a. a -> Maybe a
Just (TxOut era -> Maybe (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
-> RWST (GenEnv era) () (GenState era) Gen (Maybe (TxOut era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
forall era. Reflect era => Value era -> GenRS era (TxOut era)
genTxOut (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
withdrawalAmount)
  let wdrlCreds :: [Credential 'Staking]
wdrlCreds = ((RewardAccount, Coin) -> Credential 'Staking)
-> [(RewardAccount, Coin)] -> [Credential 'Staking]
forall a b. (a -> b) -> [a] -> [b]
map (RewardAccount -> Credential 'Staking
raCredential (RewardAccount -> Credential 'Staking)
-> ((RewardAccount, Coin) -> RewardAccount)
-> (RewardAccount, Coin)
-> Credential 'Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewardAccount, Coin) -> RewardAccount
forall a b. (a, b) -> a
fst) ([(RewardAccount, Coin)] -> [Credential 'Staking])
-> [(RewardAccount, Coin)] -> [Credential 'Staking]
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> [(RewardAccount, Coin)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map RewardAccount Coin
wdrlMap
  (IsValid Bool
v2, [ExUnits -> TxWits era -> TxWits era]
mkWithdrawalsWits) <-
    PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall era (k :: KeyRole).
EraGenericGen era =>
PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> TxWits era -> TxWits era])
redeemerWitnessMaker PlutusPurposeTag
Rewarding ([Maybe (GenRS era (Data era), Credential 'Staking)]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (IsValid, [ExUnits -> TxWits era -> TxWits era]))
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall a b. (a -> b) -> a -> b
$ (Credential 'Staking
 -> Maybe (GenRS era (Data era), Credential 'Staking))
-> [Credential 'Staking]
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
forall a b. (a -> b) -> [a] -> [b]
map ((GenRS era (Data era), Credential 'Staking)
-> Maybe (GenRS era (Data era), Credential 'Staking)
forall a. a -> Maybe a
Just ((GenRS era (Data era), Credential 'Staking)
 -> Maybe (GenRS era (Data era), Credential 'Staking))
-> (Credential 'Staking
    -> (GenRS era (Data era), Credential 'Staking))
-> Credential 'Staking
-> Maybe (GenRS era (Data era), Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) GenRS era (Data era)
forall era. Era era => GenRS era (Data era)
genDatum) [Credential 'Staking]
wdrlCreds

  [TxCert era]
dcerts <- SlotNo -> RWST (GenEnv era) () (GenState era) Gen [TxCert era]
forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts SlotNo
slot
  let dcertCreds :: [Maybe (Credential 'Staking)]
dcertCreds = (TxCert era -> Maybe (Credential 'Staking))
-> [TxCert era] -> [Maybe (Credential 'Staking)]
forall a b. (a -> b) -> [a] -> [b]
map TxCert era -> Maybe (Credential 'Staking)
forall era.
Reflect era =>
TxCert era -> Maybe (Credential 'Staking)
getTxCertCredential [TxCert era]
dcerts
  (IsValid Bool
v3, [ExUnits -> TxWits era -> TxWits era]
mkCertsWits) <-
    PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall era (k :: KeyRole).
EraGenericGen era =>
PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> TxWits era -> TxWits era])
redeemerWitnessMaker PlutusPurposeTag
Certifying ([Maybe (GenRS era (Data era), Credential 'Staking)]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (IsValid, [ExUnits -> TxWits era -> TxWits era]))
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> TxWits era -> TxWits era])
forall a b. (a -> b) -> a -> b
$ (Maybe (Credential 'Staking)
 -> Maybe (GenRS era (Data era), Credential 'Staking))
-> [Maybe (Credential 'Staking)]
-> [Maybe (GenRS era (Data era), Credential 'Staking)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) GenRS era (Data era)
forall era. Era era => GenRS era (Data era)
genDatum (Credential 'Staking
 -> (GenRS era (Data era), Credential 'Staking))
-> Maybe (Credential 'Staking)
-> Maybe (GenRS era (Data era), Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Maybe (Credential 'Staking)]
dcertCreds

  let isValid :: IsValid
isValid = Bool -> IsValid
IsValid (Bool
v1 Bool -> Bool -> Bool
&& Bool
v2 Bool -> Bool -> Bool
&& Bool
v3)
      mkWits :: [ExUnits -> TxWits era -> TxWits era]
      mkWits :: [ExUnits -> TxWits era -> TxWits era]
mkWits = [ExUnits -> TxWits era -> TxWits era]
mkPaymentWits [ExUnits -> TxWits era -> TxWits era]
-> [ExUnits -> TxWits era -> TxWits era]
-> [ExUnits -> TxWits era -> TxWits era]
forall a. Semigroup a => a -> a -> a
<> [ExUnits -> TxWits era -> TxWits era]
mkCertsWits [ExUnits -> TxWits era -> TxWits era]
-> [ExUnits -> TxWits era -> TxWits era]
-> [ExUnits -> TxWits era -> TxWits era]
forall a. Semigroup a => a -> a -> a
<> [ExUnits -> TxWits era -> TxWits era]
mkWithdrawalsWits
  [ExUnits]
exUnits <- Int -> GenRS era [ExUnits]
forall era. EraGenericGen era => Int -> GenRS era [ExUnits]
genExUnits ([ExUnits -> TxWits era -> TxWits era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExUnits -> TxWits era -> TxWits era]
mkWits)

  let
    redeemerWitsList :: TxWits era -> TxWits era
    redeemerWitsList :: TxWits era -> TxWits era
redeemerWitsList = [TxWits era -> TxWits era] -> TxWits era -> TxWits era
forall a. [a -> a] -> a -> a
foldFn ([TxWits era -> TxWits era] -> TxWits era -> TxWits era)
-> [TxWits era -> TxWits era] -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$ ((ExUnits -> TxWits era -> TxWits era)
 -> ExUnits -> TxWits era -> TxWits era)
-> [ExUnits -> TxWits era -> TxWits era]
-> [ExUnits]
-> [TxWits era -> TxWits era]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ExUnits -> TxWits era -> TxWits era)
-> ExUnits -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
($) [ExUnits -> TxWits era -> TxWits era]
mkWits [ExUnits]
exUnits
  TxWits era -> TxWits era
datumWitsList <- [TxWits era -> TxWits era] -> TxWits era -> TxWits era
forall a. [a -> a] -> a -> a
foldFn ([TxWits era -> TxWits era] -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era) () (GenState era) Gen [TxWits era -> TxWits era]
-> RWST
     (GenEnv era) () (GenState era) Gen (TxWits era -> TxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxOut era
 -> RWST
      (GenEnv era) () (GenState era) Gen (TxWits era -> TxWits era))
-> [TxOut era]
-> RWST
     (GenEnv era) () (GenState era) Gen [TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TxOut era
-> RWST
     (GenEnv era) () (GenState era) Gen (TxWits era -> TxWits era)
forall era.
Reflect era =>
TxOut era -> GenRS era (TxWits era -> TxWits era)
makeDatumWitness (Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
toSpendNoCollateral)
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
keyWitsMakers <-
    (TxOut era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      (Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genTxOutKeyWitness (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending))
      ([TxOut era]
toSpendNoCollateralTxOuts [TxOut era] -> [TxOut era] -> [TxOut era]
forall a. [a] -> [a] -> [a]
++ Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
refInputsUtxo)
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
dcertWitsMakers <- (Credential 'Staking
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> Credential 'Staking
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Certifying)) ([Credential 'Staking]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a b. (a -> b) -> a -> b
$ [Maybe (Credential 'Staking)] -> [Credential 'Staking]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Credential 'Staking)]
dcertCreds
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
rewardsWitsMakers <- (Credential 'Staking
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> Credential 'Staking
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era (kr :: KeyRole).
Reflect era =>
Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
mkWitVKey (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Rewarding)) [Credential 'Staking]
wdrlCreds

  -- 5. Estimate inputs that will be used as collateral
  Int
maxCollateralCount <-
    Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
1, Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era
gePParams PParams era -> Getting Nat (PParams era) Nat -> Nat
forall s a. s -> Getting a s a -> a
^. Getting Nat (PParams era) Nat
forall era. EraGenericGen era => Lens' (PParams era) Nat
Lens' (PParams era) Nat
ppMaxCollateralInputsT))
  TxId
bogusCollateralTxId <- Gen TxId -> RWST (GenEnv era) () (GenState era) Gen TxId
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TxId
forall a. Arbitrary a => Gen a
arbitrary :: Gen TxId)
  let bogusCollateralTxIns :: Set TxIn
bogusCollateralTxIns =
        [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
          [ TxId -> TxIx -> TxIn
TxIn TxId
bogusCollateralTxId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i))
          | Word16
i <- [Word16
Item [Word16]
forall a. Bounded a => a
maxBound, Word16
forall a. Bounded a => a
maxBound Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1 .. Word16
forall a. Bounded a => a
maxBound Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxCollateralCount Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1] :: [Word16]
          ]
  [Addr]
collateralAddresses <- Int
-> RWST (GenEnv era) () (GenState era) Gen Addr
-> RWST (GenEnv era) () (GenState era) Gen [Addr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
maxCollateralCount RWST (GenEnv era) () (GenState era) Gen Addr
forall era. GenRS era Addr
genNoScriptRecipient
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
bogusCollateralKeyWitsMakers <- ([[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]]
 -> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a b.
(a -> b)
-> RWST (GenEnv era) () (GenState era) Gen a
-> RWST (GenEnv era) () (GenState era) Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RWST
   (GenEnv era)
   ()
   (GenState era)
   Gen
   [[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> ((Addr
     -> RWST
          (GenEnv era)
          ()
          (GenState era)
          Gen
          [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         [[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]])
-> (Addr
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Addr]
-> (Addr
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [[SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Addr]
collateralAddresses ((Addr
  -> RWST
       (GenEnv era)
       ()
       (GenState era)
       Gen
       [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> (Addr
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a b. (a -> b) -> a -> b
$ \Addr
a ->
    ((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
 -> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a b.
(a -> b)
-> RWST (GenEnv era) () (GenState era) Gen a
-> RWST (GenEnv era) () (GenState era) Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a. a -> [a]
List.singleton (RWST
   (GenEnv era)
   ()
   (GenState era)
   Gen
   (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> (TxOut era
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genTxOutKeyWitness Maybe PlutusPurposeTag
forall a. Maybe a
Nothing (TxOut era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits 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 -> Value era
forall t s. Inject t s => t -> s
inject Coin
maxCoin)
  StrictMaybe Network
networkId <- Gen (StrictMaybe Network)
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (StrictMaybe Network)
 -> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network))
-> Gen (StrictMaybe Network)
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network)
forall a b. (a -> b) -> a -> b
$ [StrictMaybe Network] -> Gen (StrictMaybe Network)
forall a. HasCallStack => [a] -> Gen a
elements [Item [StrictMaybe Network]
StrictMaybe Network
forall a. StrictMaybe a
SNothing, Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Testnet]

  -- 6. Generate bogus collateral fields, and functions for updating them when we know their real values
  -- Add a stub for the TotalCol field
  StrictMaybe Coin
bogusTotalCol <- [(Int, RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Coin))]
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Coin)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
1, StrictMaybe Coin
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe Coin
forall a. StrictMaybe a
SNothing), (Int
9, StrictMaybe Coin
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
0)))] -- generate a bogus Coin, fill it in later
  let updateTotalColl :: StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
SNothing Coin
_ = StrictMaybe Coin
forall a. StrictMaybe a
SNothing
      updateTotalColl (SJust (Coin Integer
n)) (Coin Integer
m) = Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m))
  -- If Babbage era, or greater, add a stub for a CollateralReturn TxOut
  StrictMaybe (TxOut era)
bogusCollReturn <-
    if Proof era -> Some Proof
forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some (forall era. Reflect era => Proof era
reify @era) Some Proof -> Some Proof -> Bool
forall a. Ord a => a -> a -> Bool
>= Proof BabbageEra -> Some Proof
forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof BabbageEra
Babbage
      then
        [(Int,
  RWST (GenEnv era) () (GenState era) Gen (StrictMaybe (TxOut era)))]
-> RWST
     (GenEnv era) () (GenState era) Gen (StrictMaybe (TxOut era))
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
          [ (Int
1, StrictMaybe (TxOut era)
-> RWST
     (GenEnv era) () (GenState era) Gen (StrictMaybe (TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (TxOut era)
forall a. StrictMaybe a
SNothing)
          , (Int
9, TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
SJust (TxOut era -> StrictMaybe (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
-> RWST
     (GenEnv era) () (GenState era) Gen (StrictMaybe (TxOut era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value era -> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
forall era. Reflect era => Value era -> GenRS era (TxOut era)
genTxOut (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
0)))
          ]
      else StrictMaybe (TxOut era)
-> RWST
     (GenEnv era) () (GenState era) Gen (StrictMaybe (TxOut era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (TxOut era)
forall a. StrictMaybe a
SNothing
  let updateCollReturn :: StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
SNothing Coin
_ = StrictMaybe (TxOut era)
forall a. StrictMaybe a
SNothing
      updateCollReturn (SJust TxOut era
txout) Coin
v = TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
SJust (Coin -> TxOut era -> TxOut era
forall era. EraTxOut era => Coin -> TxOut era -> TxOut era
injectFee Coin
v TxOut era
txout)

  -- 7. Estimate the fee
  let redeemerDatumWits :: TxWits era
      redeemerDatumWits :: TxWits era
redeemerDatumWits = TxWits era -> TxWits era
redeemerWitsList (TxWits era -> TxWits era) -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$ TxWits era -> TxWits era
datumWitsList TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
      bogusIntegrityHash :: StrictMaybe ScriptIntegrityHash
bogusIntegrityHash = PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
EraModel era =>
PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash PParams era
gePParams [Language]
forall a. Monoid a => a
mempty ([(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
EraModel era =>
[(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers []) TxDats era
forall a. Monoid a => a
mempty
      inputSet :: Set TxIn
inputSet = Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
toSpendNoCollateral
      outputList :: [TxOut era]
outputList = [TxOut era]
-> (TxOut era -> [TxOut era]) -> Maybe (TxOut era) -> [TxOut era]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut era]
recipients (TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: [TxOut era]
recipients) Maybe (TxOut era)
rewardsWithdrawalTxOut
      txBodyNoFee :: TxBody era
txBodyNoFee =
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
inputSet
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody era -> TxBody era
setCollateralInputs Set TxIn
bogusCollateralTxIns
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody era -> TxBody era
setReferenceInputs (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputsUtxo)
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe Coin -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe Coin -> TxBody era -> TxBody era
setTotalCollateral StrictMaybe Coin
bogusTotalCol
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxOut era]
outputList
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe (TxOut era) -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe (TxOut era) -> TxBody era -> TxBody era
setCollateralReturn StrictMaybe (TxOut era)
bogusCollReturn
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxCert era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxCert era]
dcerts
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Withdrawals
withdrawals
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
maxCoin
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& ValidityInterval -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
ValidityInterval -> TxBody era -> TxBody era
setValidity ValidityInterval
validityInterval
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
setScriptIntegrityHash StrictMaybe ScriptIntegrityHash
bogusIntegrityHash
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe Network -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe Network -> TxBody era -> TxBody era
setNetworkIdTxBody StrictMaybe Network
networkId
      txBodyNoFeeHash :: SafeHash EraIndependentTxBody
txBodyNoFeeHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBodyNoFee
      witsMakers :: [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
      witsMakers :: [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
witsMakers = [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
keyWitsMakers [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
dcertWitsMakers [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
rewardsWitsMakers
      bogusNeededScripts :: Set ScriptHash
bogusNeededScripts = Proof era -> Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' (forall era. Reflect era => Proof era
reify @era) Map TxIn (TxOut era)
utxoNoCollateral TxBody era
txBodyNoFee
      noFeeWitsUnfiltered :: TxWits era
      noFeeWitsUnfiltered :: TxWits era
noFeeWitsUnfiltered =
        [TxWits era -> TxWits era] -> TxWits era -> TxWits era
forall a. [a -> a] -> a -> a
foldFn (((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
 -> TxWits era -> TxWits era)
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [TxWits era -> TxWits era]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyNoFeeHash) ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
witsMakers [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
bogusCollateralKeyWitsMakers)) TxWits era
redeemerDatumWits
      noFeeWits :: TxWits era
      noFeeWits :: TxWits era
noFeeWits = Set ScriptHash -> TxWits era -> TxWits era
forall era.
EraTxWits era =>
Set ScriptHash -> TxWits era -> TxWits era
onlyNecessaryScripts Set ScriptHash
bogusNeededScripts TxWits era
noFeeWitsUnfiltered
      bogusTxForFeeCalc :: Tx era
bogusTxForFeeCalc =
        IsValid -> Tx era -> Tx era
forall era. Reflect era => IsValid -> Tx era -> Tx era
applyIsValid IsValid
isValid (Tx era -> Tx era) -> Tx era -> Tx era
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBodyNoFee Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> TxWits era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
noFeeWits
      fee :: Coin
fee = PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
gePParams Tx era
bogusTxForFeeCalc (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
refInputsUtxo)
  -- traceM $ "noFeeWits:\n" <> showExpr noFeeWits

  Accounts era
accounts <- (GenState era -> Accounts era)
-> RWST (GenEnv era) () (GenState era) Gen (Accounts era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts (ModelNewEpochState era -> Accounts era)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  let deposits :: Coin
deposits = PParams era -> [TxCert era] -> Accounts era -> Coin
forall era.
(EraAccounts era, EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Accounts era -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Accounts era
accounts

  -- 8. Crank up the amount in one of outputs to account for the fee and deposits. Note
  -- this is a hack that is not possible in a real life, but in the end it does produce
  -- real life like setup. We use the entry with TxIn feeKey, which we can safely overwrite.
  let utxoFeeAdjusted :: Map TxIn (TxOut era)
utxoFeeAdjusted = (TxOut era -> TxOut era)
-> TxIn -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Coin -> TxOut era -> TxOut era
forall era. EraTxOut era => Coin -> TxOut era -> TxOut era
injectFee (Coin
fee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
deposits)) TxIn
feeKey Map TxIn (TxOut era)
utxoNoCollateral

  -- 9. Generate utxos that will be used as collateral
  (Map TxIn (TxOut era)
utxo, Map TxIn (TxOut era)
collMap, Coin
excessColCoin) <- [Addr]
-> Coin
-> Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall era.
(HasCallStack, EraGenericGen era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses Coin
fee Map TxIn (TxOut era)
utxoFeeAdjusted
  [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
collateralKeyWitsMakers <-
    ((TxOut era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall era.
Reflect era =>
Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
genTxOutKeyWitness Maybe PlutusPurposeTag
forall a. Maybe a
Nothing) ([TxOut era]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era])
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
collMap) ::
      GenRS era [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]

  -- 10. Construct the correct Tx with valid fee and collaterals
  let sNeeded :: Set ScriptHash
sNeeded = Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era.
EraUTxO era =>
MUtxo era -> TxBody era -> Set ScriptHash
scriptsNeeded' Map TxIn (TxOut era)
utxo TxBody era
txBodyNoFee
      langs :: [Language]
langs = Set Language -> [Language]
forall a. Set a -> [a]
Set.toList (Set Language -> [Language]) -> Set Language -> [Language]
forall a b. (a -> b) -> a -> b
$ Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed (forall era. Reflect era => Proof era
reify @era) Tx era
bogusTxForFeeCalc (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoNoCollateral) Set ScriptHash
sNeeded
      mIntegrityHash :: StrictMaybe ScriptIntegrityHash
mIntegrityHash = PParams era
-> [Language] -> TxWits era -> StrictMaybe ScriptIntegrityHash
forall era.
EraGenericGen era =>
PParams era
-> [Language] -> TxWits era -> StrictMaybe ScriptIntegrityHash
mkScriptIntegrityHash PParams era
gePParams [Language]
langs TxWits era
redeemerDatumWits
      balance :: Coin
balance =
        case StrictMaybe (TxOut era)
bogusCollReturn of
          StrictMaybe (TxOut era)
SNothing -> Set TxIn -> Map TxIn (TxOut era) -> Coin
forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo
          SJust TxOut era
_ -> Set TxIn -> Map TxIn (TxOut era) -> Coin
forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
excessColCoin
      txBody :: TxBody era
txBody =
        TxBody era
txBodyNoFee
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody era -> TxBody era
setCollateralInputs (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap)
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe (TxOut era) -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe (TxOut era) -> TxBody era -> TxBody era
setCollateralReturn (StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
bogusCollReturn Coin
excessColCoin)
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe Coin -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe Coin -> TxBody era -> TxBody era
setTotalCollateral (StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
bogusTotalCol Coin
balance)
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
setScriptIntegrityHash StrictMaybe ScriptIntegrityHash
mIntegrityHash
      txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody
      neededScripts :: Set ScriptHash
neededScripts = Proof era -> Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' (forall era. Reflect era => Proof era
reify @era) Map TxIn (TxOut era)
utxo TxBody era
txBody
      wits :: TxWits era
      wits :: TxWits era
wits =
        Set ScriptHash -> TxWits era -> TxWits era
forall era.
EraTxWits era =>
Set ScriptHash -> TxWits era -> TxWits era
onlyNecessaryScripts Set ScriptHash
neededScripts (TxWits era -> TxWits era) -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$
          [TxWits era -> TxWits era] -> TxWits era -> TxWits era
forall a. [a -> a] -> a -> a
foldFn (((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
-> SafeHash EraIndependentTxBody -> TxWits era -> TxWits era
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyHash) ((SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
 -> TxWits era -> TxWits era)
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [TxWits era -> TxWits era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
collateralKeyWitsMakers [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
-> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
forall a. Semigroup a => a -> a -> a
<> [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]
witsMakers)) TxWits era
redeemerDatumWits
      validTx :: Tx era
validTx =
        IsValid -> Tx era -> Tx era
forall era. Reflect era => IsValid -> Tx era -> Tx era
applyIsValid IsValid
isValid (Tx era -> Tx era) -> Tx era -> Tx era
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> TxWits era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
wits
  Int
count <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Int
forall era. ModelNewEpochState era -> Int
mCount (ModelNewEpochState era -> Int)
-> (GenState era -> ModelNewEpochState era) -> GenState era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyGenStateInitialUtxo (Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map TxIn (TxOut era)
-> Maybe (UtxoEntry era) -> Map TxIn (TxOut era)
forall era. MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus Map TxIn (TxOut era)
utxo Maybe (UtxoEntry era)
maybeoldpair)
  (Int -> Int) -> RWST (GenEnv era) () (GenState era) Gen ()
forall era. (Int -> Int) -> GenRS era ()
modifyModelCount (Int -> Int -> Int
forall a b. a -> b -> a
const (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  (Map Int TxId -> Map Int TxId)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era. (Map Int TxId -> Map Int TxId) -> GenRS era ()
modifyModelIndex (Int -> TxId -> Map Int TxId -> Map Int TxId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
count (SafeHash EraIndependentTxBody -> TxId
TxId SafeHash EraIndependentTxBody
txBodyHash))
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelUTxO (Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall a b. a -> b -> a
const Map TxIn (TxOut era)
utxo)

  (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxo, Tx era
validTx, UtxoEntry era
feepair, Maybe (UtxoEntry era)
maybeoldpair)

-- | Keep only Script witnesses that are neccessary in 'era',
onlyNecessaryScripts ::
  EraTxWits era => Set ScriptHash -> TxWits era -> TxWits era
onlyNecessaryScripts :: forall era.
EraTxWits era =>
Set ScriptHash -> TxWits era -> TxWits era
onlyNecessaryScripts Set ScriptHash
necessary = (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> TxWits era
-> TxWits era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Map ScriptHash (Script era)
m -> Map ScriptHash (Script era)
-> Set ScriptHash -> Map ScriptHash (Script era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
m Set ScriptHash
necessary

-- ==============================================================================
-- How we take the generated stuff and put it through the STS rule mechanism
-- in a way that is Era Agnostic

runSTSWithContext ::
  forall era.
  ( BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , STS (EraRule "LEDGER" era)
  ) =>
  RuleContext 'Transition (EraRule "LEDGER" era) ->
  Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era))
runSTSWithContext :: forall era.
(BaseM (EraRule "LEDGER" era) ~ ShelleyBase,
 STS (EraRule "LEDGER" era)) =>
RuleContext 'Transition (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
runSTSWithContext RuleContext 'Transition (EraRule "LEDGER" era)
trc = ShelleyBase
  (Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era)))
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era)))
-> ShelleyBase
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ RuleContext 'Transition (EraRule "LEDGER" era)
-> ShelleyBase
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era)))
forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc

foldFn :: [a -> a] -> a -> a
foldFn :: forall a. [a -> a] -> a -> a
foldFn = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id

foldFn' :: [a -> b -> b] -> a -> b -> b
foldFn' :: forall a b. [a -> b -> b] -> a -> b -> b
foldFn' [] a
_ b
x = b
x
foldFn' (a -> b -> b
f : [a -> b -> b]
fs) a
a b
y = a -> b -> b
f a
a (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ [a -> b -> b] -> a -> b -> b
forall a b. [a -> b -> b] -> a -> b -> b
foldFn' [a -> b -> b]
fs a
a b
y