{-# 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
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 <- GenRS era Addr
forall era. Reflect era => GenRS era Addr
genRecipient
  cred <- maybe (error "BootstrapAddress encountered") pure $ paymentCredAddr addr
  dataHashFields <-
    case 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
        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)
        genDataHashField maybeCoreScript
  pure . dataHashFields $ mkBasicTxOut addr 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
  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 Map.lookup k m of
    Maybe v
Nothing ->
      [Char] -> RWST (GenEnv era) () (GenState era) Gen v
forall a. HasCallStack => [Char] -> a
error ([Char] -> RWST (GenEnv era) () (GenState era) Gen v)
-> [Char] -> RWST (GenEnv era) () (GenState era) Gen 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 -> RWST (GenEnv era) () (GenState era) Gen 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
  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 Map.lookup scriptHash m of
    Just Script era
script -> Maybe (Script era)
-> RWST (GenEnv era) () (GenState era) Gen (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)
 -> RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era)))
-> Maybe (Script era)
-> RWST (GenEnv era) () (GenState era) Gen (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)
-> RWST (GenEnv era) () (GenState era) Gen (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)
-> RWST (GenEnv era) () (GenState era) Gen (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
      NativeScript NativeScript AlonzoEra
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
NativeScript AlonzoEra
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
      NativeScript NativeScript BabbageEra
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
NativeScript BabbageEra
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
      NativeScript NativeScript ConwayEra
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
NativeScript ConwayEra
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 <- [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
  pure $ \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)
    -> 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.
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]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era)
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> TxWits era -> TxWits era))
-> [Char]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (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)]
      otherWit <- Maybe PlutusPurposeTag
-> Script era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (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
      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
  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))
  foldFn' <$> mapM (mkMultiSigWit mTag) 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
      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))
      foldFn' <$> mapM (mkTimelockWit mTag) 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
          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
          f2 <- genGenericScriptWitness (Just Spending) script
          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
      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
      pure $ datsTxWitsL @era' <>~ TxDats [(hashData datum, 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
              datum <- RWST (GenEnv era) () (GenState era) Gen (Data era)
genDat
              let 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
              pure $ Just (isValid, 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
  paymentCred <- forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash @Payment
  stakeCred <- genKeyHash @Staking
  pure (mkAddr paymentCred 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
  paymentCred <- forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential @Payment PlutusPurposeTag
Spending
  stakeCred <- genCredential @Staking Rewarding
  pure (mkAddr paymentCred 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 <- PlutusPurposeTag -> GenRS era ScriptHash
forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript PlutusPurposeTag
Spending
  mscript <- lookupScript scripthash (Just Spending)
  case mscript of
    Maybe (Script era)
Nothing -> StrictMaybe (Script era)
-> RWST
     (GenEnv era) () (GenState era) Gen (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)
-> RWST
     (GenEnv era) () (GenState era) Gen (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 <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        script <- genRefScript
        pure $ \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 <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        script <- genRefScript
        pure $ \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, _data) <- GenRS era (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash
        pure $ \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 <- 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 <- mkTxIxPartial . fromIntegral <$> choose (numChoices + 1, numChoices + 100)
  pure (TxIn txId 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
  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
  numChoicesMax <- gets getUtxoChoicesMax
  n <- lift $ choose (1, numChoicesMax + 3)
  ins <- lift $ vectorOf n (genTxIn @era reify numChoicesMax)
  case filter (`Map.notMember` entriesInUse) 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
  ins <- Int -> GenRS era [TxIn]
forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn Int
100
  pairs <- sequence (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) ins)
  percent <- gets getOldUtxoPercent
  -- Choose a pair from the oldUTxO
  maybepair <- frequencyT [(percent, getUtxoElem), (100 - percent, pure Nothing)]
  pure (Map.fromList (maybeCons maybepair pairs), 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
      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
      genTxOut 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 :: [(TxIn, TxOut era)]
pairs = Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut era)
newUTxO
  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
  maxRef <- gets getRefInputsMax
  numInputs <- lift $ choose (1, min (Map.size newUTxO) maxInputs)
  numRefInputs <- lift $ choose (0, maxRef)
  badTest <- getUtxoTest
  (feepair@(txin, txout), inputPairs) <- lift $ chooseGood (badTest . fst) numInputs pairs
  refInputPairs <- take numRefInputs <$> lift (shuffle pairs)
  let inputs = [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut era)]
inputPairs
      refInputs = [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut era)]
refInputPairs
  -- The feepair is added to the mMutFee field
  modifyModelMutFee (Map.insert txin txout)
  let 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))
  pure (feepair, inputs, refInputs, 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)
  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
  result <- shuffle (good : tailx)
  pure (good, 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
  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
  delegCertFreq <- asks $ delegCertFreq . geSize
  frequencyT
    [ (regCertFreq, genShelleyRegCert)
    , (25, genShelleyUnRegCert)
    , (delegCertFreq, 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
      rewardAccount <- PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Credential Staking)
forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential Staking)
genFreshRegCred PlutusPurposeTag
Certifying
      (poolId, _) <- genPool
      pure $ DelegStakeTxCert rewardAccount 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, StakePoolParams -> TxCert era
forall era. EraTxCert era => StakePoolParams -> TxCert era
RegPoolTxCert (StakePoolParams -> TxCert era)
-> RWST (GenEnv era) () (GenState era) Gen StakePoolParams
-> 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 StakePoolParams
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 StakePoolParams
genFreshPool = do
      (_kh, pp, _) <- GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
genNewPool
      return pp
    genEpoch :: RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch = do
      let EpochNo Word64
txEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
      EpochNo 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 maxEpoch <- asks $ L.view ppEMaxL . gePParams
      let 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
      delta <- lift $ choose (nextEpoch, fromIntegral maxEpoch)
      return . EpochNo $ (curEpoch + 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
        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
        dc <- genTxCert 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]
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 dc of
          RegPoolTxCert StakePoolParams
_ -> ([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
            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 Map.lookup kh 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)
  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
  n <- lift $ choose (0, maxcert)
  accounts <- gets (mAccounts . gsModel)
  let 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))
  (dcs, _, _) <- F.foldlM genUniqueScript initSets ([1 .. n] :: [Int])
  pure $ reverse 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 {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 = 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 = 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
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.
        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 <- lift (resize 30 (arbitrary :: Gen TxIn))
        if Map.member txIn utxo || Map.member txIn coll || txIn `Map.member` entriesInUse
          then genNewCollateral addr coll um c
          else pure (um, Map.insert txIn (mkBasicTxOut addr (inject c)) coll, c)
      -- Either pick a collateral from a map or generate a completely new one
      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
            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, txOut) = Map.elemAt i um
            pure (Map.deleteAt i um, Map.insert txIn txOut coll, txOut ^. 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]
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
            (um', coll', 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
                    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
                    genNewCollateral ec coll um ((minCollTotal <-> curCollTotal) <+> 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]
            go ecs' coll' (curCollTotal <+> c) um'
  (collaterals, excessColCoin) <-
    go collateralAddresses Map.empty (Coin 0) $ Map.filter spendOnly utxo
  pure (Map.union collaterals utxo, collaterals, 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
  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
outCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
approxCount
      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
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]
rs = [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
      goNew Int
e (TxOut era
tx : [TxOut era]
txs) ![TxOut era]
rs = do
        leftToAdd <- Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        goExtra (e - leftToAdd) leftToAdd (inject (Coin 0)) tx txs rs
      goExtra Int
_ Int
_ Value era
s TxOut era
tx [] ![TxOut era]
rs = Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall {era}.
(ProtVerIsInBounds
   "at most"
   era
   11
   (OrdCond (CmpNat (ProtVerLow era) 11) 'True 'True 'False),
 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]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
goNew Int
e [TxOut era]
txs ([TxOut era]
 -> RWST (GenEnv era) () (GenState era) Gen [TxOut era])
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
forall {era}.
(ProtVerIsInBounds
   "at most"
   era
   11
   (OrdCond (CmpNat (ProtVerLow era) 11) 'True 'True 'False),
 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]
-> RWST (GenEnv era) () (GenState era) Gen [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
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
            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))
            newTxOut <- genTxOut $ s <+> inject c
            pure $
              if c < coin v
                then
                  let !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 newTxOut : change : rs
                else newTxOut : rs
  goNew extra 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 StakePoolParams {KeyHash StakePool
sppId :: KeyHash StakePool
sppId :: StakePoolParams -> KeyHash StakePool
sppId} -> 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
sppId
      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 StakePoolParams {Set (KeyHash Staking)
StrictMaybe PoolMetadata
KeyHash StakePool
VRFVerKeyHash StakePoolVRF
RewardAccount
Coin
UnitInterval
StrictSeq StakePoolRelay
sppId :: StakePoolParams -> KeyHash StakePool
sppId :: KeyHash StakePool
sppVrf :: VRFVerKeyHash StakePoolVRF
sppPledge :: Coin
sppCost :: Coin
sppMargin :: UnitInterval
sppRewardAccount :: RewardAccount
sppOwners :: Set (KeyHash Staking)
sppRelays :: StrictSeq StakePoolRelay
sppMetadata :: StrictMaybe PoolMetadata
sppCost :: StakePoolParams -> Coin
sppMargin :: StakePoolParams -> UnitInterval
sppMetadata :: StakePoolParams -> StrictMaybe PoolMetadata
sppOwners :: StakePoolParams -> Set (KeyHash Staking)
sppPledge :: StakePoolParams -> Coin
sppRelays :: StakePoolParams -> StrictSeq StakePoolRelay
sppRewardAccount :: StakePoolParams -> RewardAccount
sppVrf :: StakePoolParams -> VRFVerKeyHash StakePoolVRF
..})) = 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
sppId
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
      newRewards <- GenRS era (Map (Credential Staking) Coin)
forall era.
Reflect era =>
GenRS era (Map (Credential Staking) Coin)
genRewards
      pure (Withdrawals $ Map.mapKeys (RewardAccount networkId) newRewards)
    else Withdrawals -> RWST (GenEnv era) () (GenState era) Gen 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 TopTx era)
genAlonzoTx :: forall era.
EraGenericGen era =>
SlotNo -> GenRS era (UTxO era, Tx TopTx era)
genAlonzoTx SlotNo
slot = do
  (utxo, tx, _fee, _old) <- SlotNo
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (UTxO era, Tx TopTx era, (TxIn, TxOut era),
      Maybe (TxIn, TxOut era))
forall era.
EraGenericGen era =>
SlotNo
-> GenRS
     era (UTxO era, Tx TopTx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo SlotNo
slot
  pure (utxo, tx)

applyIsValid :: forall era. Reflect era => IsValid -> Tx TopTx era -> Tx TopTx era
applyIsValid :: forall era. Reflect era => IsValid -> Tx TopTx era -> Tx TopTx era
applyIsValid IsValid
isValid = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> Tx TopTx era -> Tx TopTx era
forall a. a -> a
id
  Proof era
Mary -> Tx TopTx era -> Tx TopTx era
forall a. a -> a
id
  Proof era
Allegra -> Tx TopTx era -> Tx TopTx era
forall a. a -> a
id
  Proof era
Alonzo -> (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsValid
isValid
  Proof era
Babbage -> (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsValid
isValid
  Proof era
Conway -> (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx 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 TopTx era
    , UtxoEntry era -- The fee key
    , Maybe (UtxoEntry era) -- from oldUtxO
    )
genAlonzoTxAndInfo :: forall era.
EraGenericGen era =>
SlotNo
-> GenRS
     era (UTxO era, Tx TopTx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo SlotNo
slot = do
  GenEnv {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 <- lift $ genValidityInterval slot
  modify (\GenState era
gs -> GenState era
gs {gsValidityInterval = validityInterval})

  -- 1. Produce utxos that will be spent
  (utxoChoices, maybeoldpair) <- 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@(feeKey, _) -- One of the spending inputs, to be used to pay the fee
    , toSpendNoCollateral -- All of the spending inputs
    , refInputsUtxo -- All the reference inputs
    , utxoNoCollateral -- Union of all the above
    ) <-
    genSpendReferenceInputs utxoChoices

  -- 3. Check if all Plutus scripts are valid
  let 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 = 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
  recipients <- genRecipientsFrom toSpendNoCollateralTxOuts

  -- mkPaymentWits :: ExUnits -> TxWits era -> TxWits era
  (IsValid v1, mkPaymentWits) <-
    redeemerWitnessMaker
      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))
          <$> mDatumHash
          <*> Just credential
      | (_, coretxout) <- Map.toAscList toSpendNoCollateral
      , let (credentials, mDatumHash) = txoutEvidence (reify @era) coretxout
      , credential <- 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 wdrlMap) <- genWithdrawals slot
  let 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

  rewardsWithdrawalTxOut <-
    if withdrawalAmount == Coin 0
      then pure Nothing
      else Just <$> genTxOut (inject withdrawalAmount)
  let 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 v2, mkWithdrawalsWits) <-
    redeemerWitnessMaker Rewarding $ map (Just . (,) genDatum) wdrlCreds

  dcerts <- genTxCerts slot
  let 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 v3, mkCertsWits) <-
    redeemerWitnessMaker Certifying $ map ((,) genDatum <$>) dcertCreds

  let 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]
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 <- genExUnits (length mkWits)

  let
    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
  datumWitsList <- foldFn <$> mapM makeDatumWitness (Map.elems toSpendNoCollateral)
  keyWitsMakers <-
    mapM
      (genTxOutKeyWitness (Just Spending))
      (toSpendNoCollateralTxOuts ++ Map.elems refInputsUtxo)
  dcertWitsMakers <- mapM (mkWitVKey (Just Certifying)) $ catMaybes dcertCreds
  rewardsWitsMakers <- mapM (mkWitVKey (Just Rewarding)) wdrlCreds

  -- 5. Estimate inputs that will be used as collateral
  maxCollateralCount <-
    lift $ chooseInt (1, fromIntegral (gePParams ^. ppMaxCollateralInputsT))
  bogusCollateralTxId <- lift (arbitrary :: Gen TxId)
  let 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]
          ]
  collateralAddresses <- replicateM maxCollateralCount genNoScriptRecipient
  bogusCollateralKeyWitsMakers <- fmap concat . forM collateralAddresses $ \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)
  networkId <- lift $ elements [SNothing, SJust Testnet]

  -- 6. Generate bogus collateral fields, and functions for updating them when we know their real values
  -- Add a stub for the TotalCol field
  bogusTotalCol <- frequencyT [(1, pure SNothing), (9, pure (SJust (Coin 0)))] -- generate a bogus Coin, fill it in later
  let 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
  bogusCollReturn <-
    if Some (reify @era) >= Some Babbage
      then
        frequencyT
          [ (1, pure SNothing)
          , (9, SJust <$> genTxOut (inject (Coin 0)))
          ]
      else pure SNothing
  let 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 -> 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 = 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 = Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
toSpendNoCollateral
      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 TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
inputSet
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody TopTx era -> TxBody TopTx era
setCollateralInputs Set TxIn
bogusCollateralTxIns
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody TopTx era -> TxBody TopTx era
setReferenceInputs (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputsUtxo)
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era
setTotalCollateral StrictMaybe Coin
bogusTotalCol
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxOut era]
outputList
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
setCollateralReturn StrictMaybe (TxOut era)
bogusCollReturn
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxCert era]
dcerts
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Withdrawals -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Withdrawals
withdrawals
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
maxCoin
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& ValidityInterval -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
ValidityInterval -> TxBody TopTx era -> TxBody TopTx era
setValidity ValidityInterval
validityInterval
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe ScriptIntegrityHash
-> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe ScriptIntegrityHash
-> TxBody TopTx era -> TxBody TopTx era
setScriptIntegrityHash StrictMaybe ScriptIntegrityHash
bogusIntegrityHash
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe Network -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe Network -> TxBody TopTx era -> TxBody TopTx era
setNetworkIdTxBody StrictMaybe Network
networkId
      txBodyNoFeeHash = TxBody TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
txBodyNoFee
      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 = Proof era
-> Map TxIn (TxOut era) -> TxBody TopTx era -> Set ScriptHash
forall era.
Proof era -> MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptWitsNeeded' (forall era. Reflect era => Proof era
reify @era) Map TxIn (TxOut era)
utxoNoCollateral TxBody TopTx era
txBodyNoFee
      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 = Set ScriptHash -> TxWits era -> TxWits era
forall era.
EraTxWits era =>
Set ScriptHash -> TxWits era -> TxWits era
onlyNecessaryScripts Set ScriptHash
bogusNeededScripts TxWits era
noFeeWitsUnfiltered
      bogusTxForFeeCalc =
        IsValid -> Tx TopTx era -> Tx TopTx era
forall era. Reflect era => IsValid -> Tx TopTx era -> Tx TopTx era
applyIsValid IsValid
isValid (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
txBodyNoFee Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
noFeeWits
      fee = PParams era -> Tx TopTx era -> UTxO era -> Coin
forall era (t :: TxLevel).
EraUTxO era =>
PParams era -> Tx t era -> UTxO era -> Coin
forall (t :: TxLevel). PParams era -> Tx t era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
gePParams Tx TopTx 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 <- gets (mAccounts . gsModel)
  let 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 = (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
  (utxo, collMap, excessColCoin) <- genCollateralUTxO collateralAddresses fee utxoFeeAdjusted
  collateralKeyWitsMakers <-
    (mapM (genTxOutKeyWitness Nothing) $ Map.elems collMap) ::
      GenRS era [SafeHash EraIndependentTxBody -> TxWits era -> TxWits era]

  -- 10. Construct the correct Tx with valid fee and collaterals
  let sNeeded = Map TxIn (TxOut era) -> TxBody TopTx era -> Set ScriptHash
forall era.
EraUTxO era =>
MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptsNeeded' Map TxIn (TxOut era)
utxo TxBody TopTx era
txBodyNoFee
      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 TopTx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
Proof era
-> Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed (forall era. Reflect era => Proof era
reify @era) Tx TopTx 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 = 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 =
        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 TopTx era
txBodyNoFee
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody TopTx era -> TxBody TopTx era
setCollateralInputs (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap)
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe (TxOut era) -> TxBody TopTx era -> TxBody TopTx 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 TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era
setTotalCollateral (StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
bogusTotalCol Coin
balance)
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& StrictMaybe ScriptIntegrityHash
-> TxBody TopTx era -> TxBody TopTx era
forall era.
EraGenericGen era =>
StrictMaybe ScriptIntegrityHash
-> TxBody TopTx era -> TxBody TopTx era
setScriptIntegrityHash StrictMaybe ScriptIntegrityHash
mIntegrityHash
      txBodyHash = TxBody TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
txBody
      neededScripts = Proof era
-> Map TxIn (TxOut era) -> TxBody TopTx era -> Set ScriptHash
forall era.
Proof era -> MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptWitsNeeded' (forall era. Reflect era => Proof era
reify @era) Map TxIn (TxOut era)
utxo TxBody TopTx era
txBody
      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 =
        IsValid -> Tx TopTx era -> Tx TopTx era
forall era. Reflect era => IsValid -> Tx TopTx era -> Tx TopTx era
applyIsValid IsValid
isValid (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
txBody
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
wits
  count <- gets (mCount . gsModel)
  modifyGenStateInitialUtxo (`Map.union` minus utxo maybeoldpair)
  modifyModelCount (const (count + 1))
  modifyModelIndex (Map.insert count (TxId txBodyHash))
  modifyModelUTxO (const utxo)

  pure (UTxO utxo, validTx, feepair, 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