{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Generic.TxGen (
  genAlonzoTx,
  Box (..),
  applySTSByProof,
  assembleWits,
  coreTx,
  coreTxBody,
  coreTxOut,
  genUTxO,
) where

import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Scripts hiding (Script)
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..))
import Cardano.Ledger.Alonzo.TxWits (
  Redeemers (..),
  TxDats (..),
  unRedeemers,
 )
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), Network (..), mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayTxCert (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.Data (Data, Datum (..), dataToBinaryData, hashData)
import Cardano.Ledger.Shelley.API (
  Addr (..),
  Credential (..),
  PoolParams (..),
  RewardAccount (..),
  ShelleyDelegCert (..),
  Withdrawals (..),
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.TxCert (
  ShelleyTxCert (..),
  pattern DelegStakeTxCert,
  pattern RegTxCert,
  pattern UnRegTxCert,
 )
import Cardano.Ledger.Slot (EpochNo (EpochNo))
import Cardano.Ledger.State (EraUTxO (..), UTxO (..))
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 Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word16)
import GHC.Stack
import Lens.Micro ((^.))
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessVKey)
import Test.Cardano.Ledger.Generic.Fields hiding (Mint)
import qualified Test.Cardano.Ledger.Generic.Fields as Generic (TxBodyField (Mint))
import Test.Cardano.Ledger.Generic.Functions
import Test.Cardano.Ledger.Generic.GenState (
  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,
  mkRedeemers,
  mkRedeemersFromTags,
  modifyGenStateInitialRewards,
  modifyGenStateInitialUtxo,
  modifyModelCount,
  modifyModelIndex,
  modifyModelMutFee,
  modifyModelUTxO,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  MUtxo,
  ModelNewEpochState (..),
  UtxoEntry,
 )
import Test.Cardano.Ledger.Generic.PrettyCore (PrettyA (..), ppRecord)
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Generic.Updaters hiding (first)
import Test.Cardano.Ledger.Shelley.Generator.Core (genNatural)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo, runShelleyBase)
import Test.QuickCheck

-- ===================================================
-- Assembing lists of Fields in to (XX era)

-- | This uses merging semantics, it expects duplicate fields, and merges them together
assembleWits :: Proof era -> [WitnessesField era] -> TxWits era
assembleWits :: forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
era = (TxWits era -> WitnessesField era -> TxWits era)
-> TxWits era -> [WitnessesField era] -> TxWits era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Policy
-> Proof era -> TxWits era -> WitnessesField era -> TxWits era
forall era.
Policy
-> Proof era -> TxWits era -> WitnessesField era -> TxWits era
updateWitnesses t -> t -> t
Policy
merge Proof era
era) (Proof era -> TxWits era
forall era. Proof era -> TxWits era
initialWitnesses Proof era
era)

coreTxOut :: Proof era -> [TxOutField era] -> TxOut era
coreTxOut :: forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
era = (TxOut era -> TxOutField era -> TxOut era)
-> TxOut era -> [TxOutField era] -> TxOut era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Proof era -> TxOut era -> TxOutField era -> TxOut era
forall era. Proof era -> TxOut era -> TxOutField era -> TxOut era
updateTxOut Proof era
era) (Proof era -> TxOut era
forall era. Proof era -> TxOut era
initialTxOut Proof era
era)

coreTxBody :: EraTxBody era => Proof era -> [TxBodyField era] -> TxBody era
coreTxBody :: forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
coreTxBody Proof era
era = (TxBody era -> TxBodyField era -> TxBody era)
-> TxBody era -> [TxBodyField era] -> TxBody era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Proof era -> TxBody era -> TxBodyField era -> TxBody era
forall era.
EraTxBody era =>
Proof era -> TxBody era -> TxBodyField era -> TxBody era
updateTxBody Proof era
era) (Proof era -> TxBody era
forall era. Proof era -> TxBody era
initialTxBody Proof era
era)

overrideTxBody :: EraTxBody era => Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody :: forall era.
EraTxBody era =>
Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody Proof era
era = (TxBody era -> TxBodyField era -> TxBody era)
-> TxBody era -> [TxBodyField era] -> TxBody era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Proof era -> TxBody era -> TxBodyField era -> TxBody era
forall era.
EraTxBody era =>
Proof era -> TxBody era -> TxBodyField era -> TxBody era
updateTxBody Proof era
era)

coreTx :: Proof era -> [TxField era] -> Tx era
coreTx :: forall era. Proof era -> [TxField era] -> Tx era
coreTx Proof era
era = (Tx era -> TxField era -> Tx era)
-> Tx era -> [TxField era] -> Tx era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Proof era -> Tx era -> TxField era -> Tx era
forall era. Proof era -> Tx era -> TxField era -> Tx era
updateTx Proof era
era) (Proof era -> Tx era
forall era. Proof era -> Tx era
initialTx Proof era
era)

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

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

-- | Generate a list of specified length with randomish `ExUnit`s where the sum
--   of all values produced will not exceed the maxTxExUnits.
genExUnits :: Proof era -> Int -> GenRS era [ExUnits]
genExUnits :: forall era. Proof era -> Int -> GenRS era [ExUnits]
genExUnits Proof era
era Int
n = do
  GenEnv {PParams era
gePParams :: PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams} <- (GenState era -> GenEnv era)
-> RWST (GenEnv era) () (GenState era) Gen (GenEnv era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> GenEnv era
forall era. GenState era -> GenEnv era
gsGenEnv
  let ExUnits Natural
maxMemUnits Natural
maxStepUnits = Proof era -> PParams era -> ExUnits
forall era. Proof era -> PParams era -> ExUnits
maxTxExUnits' Proof era
era PParams era
gePParams
  [Natural]
memUnits <- Gen [Natural] -> RWST (GenEnv era) () (GenState era) Gen [Natural]
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 [Natural]
 -> RWST (GenEnv era) () (GenState era) Gen [Natural])
-> Gen [Natural]
-> RWST (GenEnv era) () (GenState era) Gen [Natural]
forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxMemUnits
  [Natural]
stepUnits <- Gen [Natural] -> RWST (GenEnv era) () (GenState era) Gen [Natural]
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 [Natural]
 -> RWST (GenEnv era) () (GenState era) Gen [Natural])
-> Gen [Natural]
-> RWST (GenEnv era) () (GenState era) Gen [Natural]
forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxStepUnits
  [ExUnits] -> GenRS era [ExUnits]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ExUnits] -> GenRS era [ExUnits])
-> [ExUnits] -> GenRS era [ExUnits]
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> ExUnits)
-> [Natural] -> [Natural] -> [ExUnits]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Natural -> ExUnits
ExUnits [Natural]
memUnits [Natural]
stepUnits
  where
    un :: Natural
un = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    genUpTo :: Natural -> (Natural, [Natural]) -> Int -> Gen (Natural, [Natural])
genUpTo Natural
maxVal (!Natural
totalLeft, ![Natural]
acc) Int
_
      | Natural
totalLeft Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 = (Natural, [Natural]) -> Gen (Natural, [Natural])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
0, Natural
0 Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
acc)
      | Bool
otherwise = do
          Natural
x <- Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
min Natural
totalLeft (Natural -> Natural) -> (Natural -> Natural) -> Natural -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Natural -> Natural
forall b. Integral b => Ratio Natural -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Ratio Natural -> Natural)
-> (Natural -> Ratio Natural) -> Natural -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> Ratio Natural
forall a. Integral a => a -> a -> Ratio a
% Natural
un) (Natural -> Natural) -> Gen Natural -> Gen Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
0 Natural
maxVal
          (Natural, [Natural]) -> Gen (Natural, [Natural])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
totalLeft Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
x, Natural
x Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
acc)
    genSequenceSum :: Natural -> Gen [Natural]
genSequenceSum Natural
maxVal
      | Natural
maxVal Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 = [Natural] -> Gen [Natural]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Natural] -> Gen [Natural]) -> [Natural] -> Gen [Natural]
forall a b. (a -> b) -> a -> b
$ Int -> Natural -> [Natural]
forall a. Int -> a -> [a]
replicate Int
n Natural
0
      | Bool
otherwise = (Natural, [Natural]) -> [Natural]
forall a b. (a, b) -> b
snd ((Natural, [Natural]) -> [Natural])
-> Gen (Natural, [Natural]) -> Gen [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Natural, [Natural]) -> Int -> Gen (Natural, [Natural]))
-> (Natural, [Natural]) -> [Int] -> Gen (Natural, [Natural])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM (Natural -> (Natural, [Natural]) -> Int -> Gen (Natural, [Natural])
genUpTo Natural
maxVal) (Natural
maxVal, []) [Int
1 .. Int
n]

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

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

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

-- | 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 =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Credential kr ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
_ Maybe PlutusPurposeTag
_mTag (KeyHashObj KeyHash kr
keyHash) = do
  KeyPair 'Witness
keyPair <- String
-> KeyHash 'Witness
-> (GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era (KeyPair 'Witness)
forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"credential" (KeyHash kr -> KeyHash 'Witness
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash kr
keyHash) GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys
  (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SafeHash EraIndependentTxBody -> [WitnessesField era])
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a b. (a -> b) -> a -> b
$ \SafeHash EraIndependentTxBody
bodyHash -> [[WitVKey 'Witness] -> WitnessesField era
forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [SafeHash EraIndependentTxBody
-> KeyPair 'Witness -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
bodyHash KeyPair 'Witness
keyPair]]
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (ScriptHashObj ScriptHash
scriptHash) =
  forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript @era ScriptHash
scriptHash Maybe PlutusPurposeTag
mTag RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era))
-> (Maybe (Script era)
    -> GenRS
         era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField 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 ->
      String
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. HasCallStack => String -> a
error (String
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> String
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a b. (a -> b) -> a -> b
$ String
"Impossible: Cannot find script with hash " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
scriptHash
    Just Script era
script -> do
      let scriptWit :: WitnessesField era
scriptWit = [Script era] -> WitnessesField era
forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [Script era
script]
      SafeHash EraIndependentTxBody -> [WitnessesField era]
otherWit <- Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness Proof era
era Maybe PlutusPurposeTag
mTag Script era
script
      (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
hash -> WitnessesField era
scriptWit WitnessesField era -> [WitnessesField era] -> [WitnessesField era]
forall a. a -> [a] -> [a]
: SafeHash EraIndependentTxBody -> [WitnessesField 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) =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  MultiSig era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireSignature KeyHash 'Witness
keyHash) = Proof era
-> Maybe PlutusPurposeTag
-> Credential 'Witness
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (KeyHash 'Witness -> Credential 'Witness
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireAllOf StrictSeq (NativeScript era)
timelocks) = StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall m. Monoid m => StrictSeq m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era])
 -> SafeHash EraIndependentTxBody -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MultiSig era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> StrictSeq (MultiSig era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField 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) -> StrictSeq a -> m (StrictSeq b)
mapM (Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks
mkMultiSigWit Proof era
era 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 -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WitnessesField era]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. a -> b -> a
const [])
  | Bool
otherwise = Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (MultiSig era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField 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 Proof era
era Maybe PlutusPurposeTag
mTag (RequireMOf Int
m StrictSeq (NativeScript era)
timelocks) = do
  [MultiSig era]
ts <- Int -> [MultiSig era] -> [MultiSig era]
forall a. Int -> [a] -> [a]
take Int
m ([MultiSig era] -> [MultiSig era])
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([MultiSig era] -> Gen [MultiSig era]
forall a. [a] -> Gen [a]
shuffle (StrictSeq (MultiSig era) -> [MultiSig era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
StrictSeq (MultiSig era)
timelocks))
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
 -> SafeHash EraIndependentTxBody -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MultiSig era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [MultiSig era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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 (Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) [MultiSig era]
ts
mkMultiSigWit Proof era
_ Maybe PlutusPurposeTag
_ MultiSig era
_ = String
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. HasCallStack => String -> a
error String
"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) =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Timelock era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag =
  \case
    RequireSignature KeyHash 'Witness
keyHash -> Proof era
-> Maybe PlutusPurposeTag
-> Credential 'Witness
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (KeyHash 'Witness -> Credential 'Witness
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
    RequireAllOf StrictSeq (NativeScript era)
timelocks -> StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall m. Monoid m => StrictSeq m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era])
 -> SafeHash EraIndependentTxBody -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> StrictSeq (Timelock era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (StrictSeq (SafeHash EraIndependentTxBody -> [WitnessesField 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) -> StrictSeq a -> m (StrictSeq b)
mapM (Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) 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 -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WitnessesField era]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. a -> b -> a
const [])
      | Bool
otherwise -> Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Timelock era] -> Gen (Timelock era)
forall a. HasCallStack => [a] -> Gen a
elements (StrictSeq (Timelock era) -> [Timelock era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks))
    RequireMOf Int
m StrictSeq (NativeScript era)
timelocks -> do
      [Timelock era]
ts <- Int -> [Timelock era] -> [Timelock era]
forall a. Int -> [a] -> [a]
take Int
m ([Timelock era] -> [Timelock era])
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Timelock era] -> Gen [Timelock era]
forall a. [a] -> Gen [a]
shuffle (StrictSeq (Timelock era) -> [Timelock era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (Timelock era)
StrictSeq (NativeScript era)
timelocks))
      [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
 -> SafeHash EraIndependentTxBody -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock era
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [Timelock era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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 (Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) [Timelock era]
ts
    RequireTimeStart SlotNo
_ -> (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WitnessesField era]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. a -> b -> a
const [])
    RequireTimeExpire SlotNo
_ -> (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WitnessesField era]
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. a -> b -> a
const [])

-- | Same as `genCredKeyWit`, but for `TxOuts`
genTxOutKeyWitness ::
  forall era.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  TxOut era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness :: forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
era 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 ->
      String
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. HasCallStack => String -> a
error (String
 -> GenRS
      era (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> String
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a b. (a -> b) -> a -> b
$ String
"Can't authorize bootstrap address: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BootstrapAddress -> String
forall a. Show a => a -> String
show BootstrapAddress
baddr
    Addr Network
_ PaymentCredential
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 -> Proof era
-> Maybe PlutusPurposeTag
-> PaymentCredential
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential
payCred
        SJust Script era
script -> do
          SafeHash EraIndependentTxBody -> [WitnessesField era]
f1 <- Proof era
-> Maybe PlutusPurposeTag
-> PaymentCredential
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential
payCred
          SafeHash EraIndependentTxBody -> [WitnessesField era]
f2 <- Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness Proof era
forall era. Reflect era => Proof era
reify (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending) Script era
script
          (SafeHash EraIndependentTxBody -> [WitnessesField era])
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
safehash -> SafeHash EraIndependentTxBody -> [WitnessesField era]
f1 SafeHash EraIndependentTxBody
safehash [WitnessesField era]
-> [WitnessesField era] -> [WitnessesField era]
forall a. [a] -> [a] -> [a]
++ SafeHash EraIndependentTxBody -> [WitnessesField era]
f2 SafeHash EraIndependentTxBody
safehash)

genCredKeyWit ::
  forall era k.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Credential k ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
era Maybe PlutusPurposeTag
mTag Credential k
cred = Proof era
-> Maybe PlutusPurposeTag
-> Credential k
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag Credential k
cred

makeDatumWitness :: Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness :: forall era.
Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness Proof era
proof TxOut era
txout = 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 [WitnessesField era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era) =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField 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)
_) -> [WitnessesField era] -> GenRS era [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ Datum BabbageEra
NoDatum StrictMaybe (Script BabbageEra)
_) -> [WitnessesField era] -> GenRS era [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ (DatumHash DataHash
h) StrictMaybe (Script ConwayEra)
_) -> StrictMaybe DataHash -> GenRS era [WitnessesField era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era) =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField 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)
_) -> [WitnessesField era] -> GenRS era [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ Datum ConwayEra
NoDatum StrictMaybe (Script ConwayEra)
_) -> [WitnessesField era] -> GenRS era [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Alonzo, AlonzoTxOut Addr
_ Value AlonzoEra
_ StrictMaybe DataHash
mDatum) -> StrictMaybe DataHash -> GenRS era [WitnessesField era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era) =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe DataHash
mDatum
  (Proof era, TxOut era)
_ -> [WitnessesField era] -> GenRS era [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- No other era has data witnesses
  where
    mkDatumWit :: StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe DataHash
SNothing = [WitnessesField era]
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    mkDatumWit (SJust DataHash
datumHash) = do
      Data era
datum <- String
-> DataHash
-> (GenState era -> Map DataHash (Data era))
-> GenRS era (Data era)
forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"datum" DataHash
datumHash GenState era -> Map DataHash (Data era)
forall era. GenState era -> Map DataHash (Data era)
gsDatums
      [WitnessesField era]
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Data era] -> WitnessesField era
forall era. Era era => [Data era] -> WitnessesField era
DataWits' [Data era
datum]]

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

-- | Make RdmrWits WitnessesField only if the Credential is for a Plutus Script
--  And it is in the spending inputs, not the reference inputs
redeemerWitnessMaker ::
  Proof era ->
  PlutusPurposeTag ->
  [Maybe (GenRS era (Data era), Credential k)] ->
  GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker :: forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
tag [Maybe (GenRS era (Data era), Credential k)]
listWithCred =
  let creds :: [(Word32, GenRS era (Data era), Credential k)]
creds =
        [ (Word32
ix, GenRS era (Data era)
genDat, Credential k
cred)
        | (Word32
ix, Maybe (GenRS era (Data era), Credential k)
mCred) <- [Word32]
-> [Maybe (GenRS era (Data era), Credential k)]
-> [(Word32, Maybe (GenRS era (Data era), Credential k))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [Maybe (GenRS era (Data era), Credential k)]
listWithCred
        , Just (GenRS era (Data era)
genDat, Credential k
cred) <- [Maybe (GenRS era (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 -> [WitnessesField era])]
 -> (IsValid, [ExUnits -> [WitnessesField era]]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> [WitnessesField era])]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> [WitnessesField 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 -> [WitnessesField era]])
-> (IsValid, [ExUnits -> [WitnessesField 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 -> [WitnessesField era]])
 -> (IsValid, [ExUnits -> [WitnessesField era]]))
-> ([Maybe (IsValid, ExUnits -> [WitnessesField era])]
    -> ([IsValid], [ExUnits -> [WitnessesField era]]))
-> [Maybe (IsValid, ExUnits -> [WitnessesField era])]
-> (IsValid, [ExUnits -> [WitnessesField era]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IsValid, ExUnits -> [WitnessesField era])]
-> ([IsValid], [ExUnits -> [WitnessesField era]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(IsValid, ExUnits -> [WitnessesField era])]
 -> ([IsValid], [ExUnits -> [WitnessesField era]]))
-> ([Maybe (IsValid, ExUnits -> [WitnessesField era])]
    -> [(IsValid, ExUnits -> [WitnessesField era])])
-> [Maybe (IsValid, ExUnits -> [WitnessesField era])]
-> ([IsValid], [ExUnits -> [WitnessesField era]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (IsValid, ExUnits -> [WitnessesField era])]
-> [(IsValid, ExUnits -> [WitnessesField era])]
forall a. [Maybe a] -> [a]
catMaybes) (RWST
   (GenEnv era)
   ()
   (GenState era)
   Gen
   [Maybe (IsValid, ExUnits -> [WitnessesField era])]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (IsValid, [ExUnits -> [WitnessesField era]]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> [WitnessesField era])]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (IsValid, [ExUnits -> [WitnessesField era]])
forall a b. (a -> b) -> a -> b
$
        [(Word32, GenRS era (Data era), Credential k)]
-> ((Word32, GenRS era (Data era), Credential k)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (Maybe (IsValid, ExUnits -> [WitnessesField era])))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> [WitnessesField era])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, GenRS era (Data era), Credential k)]
creds (((Word32, GenRS era (Data era), Credential k)
  -> RWST
       (GenEnv era)
       ()
       (GenState era)
       Gen
       (Maybe (IsValid, ExUnits -> [WitnessesField era])))
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [Maybe (IsValid, ExUnits -> [WitnessesField era])])
-> ((Word32, GenRS era (Data era), Credential k)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (Maybe (IsValid, ExUnits -> [WitnessesField era])))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [Maybe (IsValid, ExUnits -> [WitnessesField era])]
forall a b. (a -> b) -> a -> b
$ \(Word32
ix, GenRS era (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 -> [WitnessesField era])))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> [WitnessesField 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 -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> [WitnessesField era]))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IsValid, ExUnits -> [WitnessesField era])
forall a. Maybe a
Nothing
            Just (IsValid
isValid, ScriptHash
_) -> do
              Data era
datum <- GenRS era (Data era)
genDat
              let mkWit3 :: ExUnits -> [WitnessesField era]
mkWit3 ExUnits
exUnits =
                    [Redeemers era -> WitnessesField era
forall era. Redeemers era -> WitnessesField era
RdmrWits (Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
forall era.
Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags Proof era
proof [((PlutusPurposeTag
tag, Word32
ix), (Data era
datum, ExUnits
exUnits))])]
              -- we should not add this if the tx turns out to be in the reference inputs.
              -- we accomplish this by not calling this function on referenceInputs
              Maybe (IsValid, ExUnits -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> [WitnessesField era]))
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (IsValid, ExUnits -> [WitnessesField era])
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (Maybe (IsValid, ExUnits -> [WitnessesField era])))
-> Maybe (IsValid, ExUnits -> [WitnessesField era])
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (IsValid, ExUnits -> [WitnessesField era]))
forall a b. (a -> b) -> a -> b
$ (IsValid, ExUnits -> [WitnessesField era])
-> Maybe (IsValid, ExUnits -> [WitnessesField era])
forall a. a -> Maybe a
Just (IsValid
isValid, ExUnits -> [WitnessesField era]
mkWit3)

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

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

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

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

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

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

-- | Gen the Datum and RefScript fields of a TxOut by Analyzing the payment credential's script
genDataHashField :: Reflect era => Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField :: forall era.
Reflect era =>
Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField Proof era
proof Maybe (Script era)
maybeCoreScript =
  case Proof era
proof of
    Proof era
Conway -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript ConwayEra
_) -> do
        Datum era
datum <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript ConwayEra)
script <- Proof era -> GenRS era (StrictMaybe (Script era))
forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Datum era -> TxOutField era
forall era. Datum era -> TxOutField era
FDatum Datum era
datum, StrictMaybe (Script era) -> TxOutField era
forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (Script era)
StrictMaybe (AlonzoScript ConwayEra)
script]
      Maybe (Script era)
_ -> [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Babbage -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript BabbageEra
_) -> do
        Datum era
datum <- GenRS era (Datum era)
forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript BabbageEra)
script <- Proof era -> GenRS era (StrictMaybe (Script era))
forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Datum era -> TxOutField era
forall era. Datum era -> TxOutField era
FDatum Datum era
datum, StrictMaybe (Script era) -> TxOutField era
forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (Script era)
StrictMaybe (AlonzoScript BabbageEra)
script]
      Maybe (Script era)
_ -> [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Alonzo -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript AlonzoEra
_) -> do
        (DataHash
datahash, Data era
_data) <- GenRS era (DataHash, Data era)
forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash
        [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [StrictMaybe DataHash -> TxOutField era
forall era. StrictMaybe DataHash -> TxOutField era
DHash (DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
datahash)]
      Maybe (Script era)
_ -> [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
_ -> [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- No other Era has any datum in the TxOut

-- | Generate the list of TxOutField that constitute a TxOut
genTxOut :: Reflect era => Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut :: forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut Proof era
proof Value era
val = do
  Addr
addr <- GenRS era Addr
forall era. Reflect era => GenRS era Addr
genRecipient
  PaymentCredential
cred <- RWST (GenEnv era) () (GenState era) Gen PaymentCredential
-> (PaymentCredential
    -> RWST (GenEnv era) () (GenState era) Gen PaymentCredential)
-> Maybe PaymentCredential
-> RWST (GenEnv era) () (GenState era) Gen PaymentCredential
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> RWST (GenEnv era) () (GenState era) Gen PaymentCredential
forall a. HasCallStack => String -> a
error String
"BootstrapAddress encountered") PaymentCredential
-> RWST (GenEnv era) () (GenState era) Gen PaymentCredential
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PaymentCredential
 -> RWST (GenEnv era) () (GenState era) Gen PaymentCredential)
-> Maybe PaymentCredential
-> RWST (GenEnv era) () (GenState era) Gen PaymentCredential
forall a b. (a -> b) -> a -> b
$ Addr -> Maybe PaymentCredential
paymentCredAddr Addr
addr
  [TxOutField era]
dataHashFields <-
    case PaymentCredential
cred of
      KeyHashObj KeyHash 'Payment
_ -> [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ScriptHashObj ScriptHash
scriptHash -> do
        Maybe (Script era)
maybeCoreScript <- ScriptHash
-> Maybe PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Maybe (Script era))
forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scriptHash (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
        Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
forall era.
Reflect era =>
Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField Proof era
proof Maybe (Script era)
maybeCoreScript
  [TxOutField era] -> GenRS era [TxOutField era]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxOutField era] -> GenRS era [TxOutField era])
-> [TxOutField era] -> GenRS era [TxOutField era]
forall a b. (a -> b) -> a -> b
$ [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address Addr
addr, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount Value era
val] [TxOutField era] -> [TxOutField era] -> [TxOutField era]
forall a. [a] -> [a] -> [a]
++ [TxOutField era]
dataHashFields

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

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

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

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

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

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

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

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

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

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

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

-- getShelleyTxCertDelegG :: forall era. Reflect era => TxCert era -> Maybe (ShelleyDelegCert )
-- getShelleyTxCertDelegG = case reify @era of
--   Shelley -> getShelleyTxCertDeleg
--   Mary -> getShelleyTxCertDeleg
--   Allegra -> getShelleyTxCertDeleg
--   Alonzo -> getShelleyTxCertDeleg
--   Babbage -> getShelleyTxCertDeleg
--   Conway -> getShelleyTxCertDeleg -- TODO write a generator for Conwayerts

-- mkShelleyTxCertDelegG :: forall era. Reflect era => ShelleyDelegCert  -> TxCert era
-- mkShelleyTxCertDelegG = case reify @era of
--   Shelley -> mkShelleyTxCertDeleg
--   Mary -> mkShelleyTxCertDeleg
--   Allegra -> mkShelleyTxCertDeleg
--   Alonzo -> mkShelleyTxCertDeleg
--   Babbage -> mkShelleyTxCertDeleg
--   Conway -> mkShelleyTxCertDeleg -- TODO write a generator for Conwayerts

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

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

-- | Generate a set of Collateral inputs sufficient to pay the minimum fee ('minCollTotal') computed
--   from the fee and the collateralPercentage from the PParams. Return the new UTxO, the inputs,
--   and coin of the excess amount included in the inputs, above what is needed to pay the minimum fee.
genCollateralUTxO ::
  forall era.
  (HasCallStack, Reflect era) =>
  [Addr] ->
  Coin ->
  MUtxo era ->
  GenRS era (MUtxo era, Map.Map TxIn (TxOut era), Coin)
genCollateralUTxO :: forall era.
(HasCallStack, Reflect era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses (Coin Integer
fee) MUtxo era
utxo = do
  GenEnv {PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams :: PParams era
gePParams} <- (GenState era -> GenEnv era)
-> RWST (GenEnv era) () (GenState era) Gen (GenEnv era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> GenEnv era
forall era. GenState era -> GenEnv era
gsGenEnv
  let collPerc :: Natural
collPerc = Proof era -> PParams era -> Natural
forall era. Proof era -> PParams era -> Natural
collateralPercentage' Proof era
forall era. Reflect era => Proof era
reify PParams era
gePParams
      minCollTotal :: Coin
minCollTotal = Integer -> Coin
Coin (Ratio Integer -> Integer
forall b. Integral b => Ratio Integer -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
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
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo 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.
        MUtxo era
entriesInUse <- (GenState era -> MUtxo era)
-> RWST (GenEnv era) () (GenState era) Gen (MUtxo era)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> MUtxo era
forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo
        TxIn
txIn <- Gen TxIn -> RWST (GenEnv era) () (GenState era) Gen TxIn
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> Gen TxIn -> Gen TxIn
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
30 (Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary :: Gen TxIn))
        if TxIn -> MUtxo era -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn MUtxo era
utxo Bool -> Bool -> Bool
|| TxIn -> MUtxo era -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn MUtxo era
coll Bool -> Bool -> Bool
|| TxIn
txIn TxIn -> MUtxo era -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` MUtxo era
entriesInUse
          then Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo era
um Coin
c
          else (MUtxo era, MUtxo era, Coin)
-> GenRS era (MUtxo era, MUtxo era, Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era
um, TxIn -> TxOut era -> MUtxo era -> MUtxo era
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn (Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
forall era. Reflect era => Proof era
reify [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address Addr
addr, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
c)]) MUtxo era
coll, Coin
c)
      -- Either pick a collateral from a map or generate a completely new one
      genCollateral :: Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
addr MUtxo era
coll MUtxo era
um
        | MUtxo era -> Bool
forall k a. Map k a -> Bool
Map.null MUtxo era
um = Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo era
um (Coin -> GenRS era (MUtxo era, MUtxo era, Coin))
-> RWST (GenEnv era) () (GenState era) Gen Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
        | Bool
otherwise = do
            Int
i <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, MUtxo era -> Int
forall k a. Map k a -> Int
Map.size MUtxo era
um Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            let (TxIn
txIn, TxOut era
txOut) = Int -> MUtxo era -> (TxIn, TxOut era)
forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i MUtxo era
um
            (MUtxo era, MUtxo era, Coin)
-> GenRS era (MUtxo era, MUtxo era, Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> MUtxo era -> MUtxo era
forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
i MUtxo era
um, TxIn -> TxOut era -> MUtxo era -> MUtxo era
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn TxOut era
txOut MUtxo era
coll, TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
      -- Recursively either pick existing key spend only outputs or generate new ones that
      -- will be later added to the UTxO map
      go ::
        [Addr] ->
        Map TxIn (TxOut era) ->
        Coin ->
        Map TxIn (TxOut era) ->
        GenRS era (Map TxIn (TxOut era), Coin)
      go :: [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
ecs !MUtxo era
coll !Coin
curCollTotal !MUtxo era
um
        | Coin
curCollTotal Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minCollTotal = (MUtxo era, Coin) -> GenRS era (MUtxo era, Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era
coll, Coin
curCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
minCollTotal)
        | [] <- [Addr]
ecs = String -> GenRS era (MUtxo era, Coin)
forall a. HasCallStack => String -> a
error String
"Impossible: supplied less addresses than `maxCollateralInputs`"
        | Addr
ec : [Addr]
ecs' <- [Addr]
ecs = do
            (MUtxo era
um', MUtxo era
coll', Coin
c) <-
              if [Addr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
ecs'
                then -- This is the last input, so most of the time, put something (val > 0)
                -- extra in it or we will always have a ColReturn with zero in it.
                  do
                    Coin
excess <- Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
                    Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
ec MUtxo era
coll MUtxo era
um ((Coin
minCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
curCollTotal) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
excess)
                else [GenRS era (MUtxo era, MUtxo era, Coin)]
-> GenRS era (MUtxo era, MUtxo era, Coin)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
ec MUtxo era
coll MUtxo era
forall k a. Map k a
Map.empty, Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
ec MUtxo era
coll MUtxo era
um]
            [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
ecs' MUtxo era
coll' (Coin
curCollTotal Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
c) MUtxo era
um'
  (MUtxo era
collaterals, Coin
excessColCoin) <-
    [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
collateralAddresses MUtxo era
forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0) (MUtxo era -> GenRS era (MUtxo era, Coin))
-> MUtxo era -> GenRS era (MUtxo era, Coin)
forall a b. (a -> b) -> a -> b
$ (TxOut era -> Bool) -> MUtxo era -> MUtxo era
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter TxOut era -> Bool
forall era. EraTxOut era => TxOut era -> Bool
spendOnly MUtxo era
utxo
  (MUtxo era, MUtxo era, Coin)
-> GenRS era (MUtxo era, MUtxo era, Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era -> MUtxo era -> MUtxo era
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union MUtxo era
collaterals MUtxo era
utxo, MUtxo era
collaterals, Coin
excessColCoin)

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

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

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

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

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

timeToLive :: ValidityInterval -> SlotNo
timeToLive :: ValidityInterval -> SlotNo
timeToLive (ValidityInterval StrictMaybe SlotNo
_ (SJust SlotNo
n)) = SlotNo
n
timeToLive (ValidityInterval StrictMaybe SlotNo
_ StrictMaybe SlotNo
SNothing) = Word64 -> SlotNo
SlotNo Word64
forall a. Bounded a => a
maxBound

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

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

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

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

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

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

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

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

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

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

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

  let redeemerWitsList :: [WitnessesField era]
      redeemerWitsList :: [WitnessesField era]
redeemerWitsList = [[WitnessesField era]] -> [WitnessesField era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((ExUnits -> [WitnessesField era])
 -> ExUnits -> [WitnessesField era])
-> [ExUnits -> [WitnessesField era]]
-> [ExUnits]
-> [[WitnessesField era]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ExUnits -> [WitnessesField era])
-> ExUnits -> [WitnessesField era]
forall a b. (a -> b) -> a -> b
($) [ExUnits -> [WitnessesField era]]
mkWits [ExUnits]
exUnits)
  [WitnessesField era]
datumWitsList <- [[WitnessesField era]] -> [WitnessesField era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[WitnessesField era]] -> [WitnessesField era])
-> RWST (GenEnv era) () (GenState era) Gen [[WitnessesField era]]
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxOut era
 -> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era])
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [[WitnessesField 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 (Proof era
-> TxOut era
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
forall era.
Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness Proof era
proof) (Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
toSpendNoCollateral)
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
keyWitsMakers <-
    (TxOut era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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
      (Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Spending))
      ([TxOut era]
toSpendNoCollateralTxOuts [TxOut era] -> [TxOut era] -> [TxOut era]
forall a. [a] -> [a] -> [a]
++ Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
refInputsUtxo)
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
dcertWitsMakers <- (Credential 'Staking
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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 (Proof era
-> Maybe PlutusPurposeTag
-> Credential 'Staking
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
proof (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Certifying)) ([Credential 'Staking]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> [WitnessesField era]])
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a b. (a -> b) -> a -> b
$ [Maybe (Credential 'Staking)] -> [Credential 'Staking]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Credential 'Staking)]
dcertCreds
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
rwdrsWitsMakers <- (Credential 'Staking
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [Credential 'Staking]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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 (Proof era
-> Maybe PlutusPurposeTag
-> Credential 'Staking
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
proof (PlutusPurposeTag -> Maybe PlutusPurposeTag
forall a. a -> Maybe a
Just PlutusPurposeTag
Rewarding)) [Credential 'Staking]
wdrlCreds

  -- 5. Estimate inputs that will be used as collateral
  Int
maxCollateralCount <-
    Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
1, Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proof era -> PParams era -> Natural
forall era. Proof era -> PParams era -> Natural
maxCollateralInputs' Proof era
proof PParams era
gePParams))
  TxId
bogusCollateralTxId <- Gen TxId -> RWST (GenEnv era) () (GenState era) Gen TxId
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TxId
forall a. Arbitrary a => Gen a
arbitrary :: Gen TxId)
  let bogusCollateralTxIns :: Set TxIn
bogusCollateralTxIns =
        [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
          [ TxId -> TxIx -> TxIn
TxIn TxId
bogusCollateralTxId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i))
          | Word16
i <- [Word16
forall a. Bounded a => a
maxBound, Word16
forall a. Bounded a => a
maxBound Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1 .. Word16
forall a. Bounded a => a
maxBound Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxCollateralCount Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1] :: [Word16]
          ]
  [Addr]
collateralAddresses <- Int
-> RWST (GenEnv era) () (GenState era) Gen Addr
-> RWST (GenEnv era) () (GenState era) Gen [Addr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
maxCollateralCount RWST (GenEnv era) () (GenState era) Gen Addr
forall era. GenRS era Addr
genNoScriptRecipient
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
bogusCollateralKeyWitsMakers <- [Addr]
-> (Addr
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Addr]
collateralAddresses ((Addr
  -> RWST
       (GenEnv era)
       ()
       (GenState era)
       Gen
       (SafeHash EraIndependentTxBody -> [WitnessesField era]))
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> [WitnessesField era]])
-> (Addr
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a b. (a -> b) -> a -> b
$ \Addr
a ->
    Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof Maybe PlutusPurposeTag
forall a. Maybe a
Nothing (Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address Addr
a, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
maxCoin)])
  StrictMaybe Network
networkId <- Gen (StrictMaybe Network)
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (StrictMaybe Network)
 -> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network))
-> Gen (StrictMaybe Network)
-> RWST (GenEnv era) () (GenState era) Gen (StrictMaybe Network)
forall a b. (a -> b) -> a -> b
$ [StrictMaybe Network] -> Gen (StrictMaybe Network)
forall a. HasCallStack => [a] -> Gen a
elements [StrictMaybe Network
forall a. StrictMaybe a
SNothing, Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Testnet]

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

  -- 7. Estimate the fee
  let redeemerDatumWits :: [WitnessesField era]
redeemerDatumWits = [WitnessesField era]
redeemerWitsList [WitnessesField era]
-> [WitnessesField era] -> [WitnessesField era]
forall a. [a] -> [a] -> [a]
++ [WitnessesField era]
datumWitsList
      bogusIntegrityHash :: StrictMaybe ScriptIntegrityHash
bogusIntegrityHash = Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
proof PParams era
gePParams [Language]
forall a. Monoid a => a
mempty (Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof []) TxDats era
forall a. Monoid a => a
mempty
      inputSet :: Set TxIn
inputSet = Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
toSpendNoCollateral
      outputList :: [TxOut era]
outputList = [TxOut era]
-> (TxOut era -> [TxOut era]) -> Maybe (TxOut era) -> [TxOut era]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut era]
recipients (TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: [TxOut era]
recipients) Maybe (TxOut era)
rewardsWithdrawalTxOut
      txBodyNoFee :: TxBody era
txBodyNoFee =
        Proof era -> [TxBodyField era] -> TxBody era
forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
coreTxBody
          Proof era
proof
          [ Set TxIn -> TxBodyField era
forall era. Set TxIn -> TxBodyField era
Inputs Set TxIn
inputSet
          , Set TxIn -> TxBodyField era
forall era. Set TxIn -> TxBodyField era
Collateral Set TxIn
bogusCollateralTxIns
          , Set TxIn -> TxBodyField era
forall era. Set TxIn -> TxBodyField era
RefInputs (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputsUtxo)
          , StrictMaybe Coin -> TxBodyField era
forall era. StrictMaybe Coin -> TxBodyField era
TotalCol StrictMaybe Coin
bogusTotalCol
          , [TxOut era] -> TxBodyField era
forall era. [TxOut era] -> TxBodyField era
Outputs' [TxOut era]
outputList
          , StrictMaybe (TxOut era) -> TxBodyField era
forall era. StrictMaybe (TxOut era) -> TxBodyField era
CollateralReturn StrictMaybe (TxOut era)
bogusCollReturn
          , [TxCert era] -> TxBodyField era
forall era. [TxCert era] -> TxBodyField era
Certs' [TxCert era]
dcerts
          , Withdrawals -> TxBodyField era
forall era. Withdrawals -> TxBodyField era
Withdrawals' Withdrawals
withdrawals
          , Coin -> TxBodyField era
forall era. Coin -> TxBodyField era
Txfee Coin
maxCoin
          , if Proof era -> Some Proof
forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof era
proof Some Proof -> Some Proof -> Bool
forall a. Ord a => a -> a -> Bool
>= Proof AllegraEra -> Some Proof
forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof AllegraEra
Allegra
              then ValidityInterval -> TxBodyField era
forall era. ValidityInterval -> TxBodyField era
Vldt ValidityInterval
validityInterval
              else SlotNo -> TxBodyField era
forall era. SlotNo -> TxBodyField era
TTL (ValidityInterval -> SlotNo
timeToLive ValidityInterval
validityInterval)
          , [Update era] -> TxBodyField era
forall era. [Update era] -> TxBodyField era
Update' []
          , [KeyHash 'Witness] -> TxBodyField era
forall era. [KeyHash 'Witness] -> TxBodyField era
ReqSignerHashes' []
          , MultiAsset -> TxBodyField era
forall era. MultiAsset -> TxBodyField era
Generic.Mint MultiAsset
forall a. Monoid a => a
mempty
          , StrictMaybe ScriptIntegrityHash -> TxBodyField era
forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash StrictMaybe ScriptIntegrityHash
bogusIntegrityHash
          , [TxAuxDataHash] -> TxBodyField era
forall era. [TxAuxDataHash] -> TxBodyField era
AdHash' []
          , StrictMaybe Network -> TxBodyField era
forall era. StrictMaybe Network -> TxBodyField era
Txnetworkid StrictMaybe Network
networkId
          ]
      txBodyNoFeeHash :: SafeHash EraIndependentTxBody
txBodyNoFeeHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBodyNoFee
      witsMakers :: [SafeHash EraIndependentTxBody -> [WitnessesField era]]
      witsMakers :: [SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers = [SafeHash EraIndependentTxBody -> [WitnessesField era]]
keyWitsMakers [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
dcertWitsMakers [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
rwdrsWitsMakers
      bogusNeededScripts :: Set ScriptHash
bogusNeededScripts = Proof era -> Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' Proof era
proof Map TxIn (TxOut era)
utxoNoCollateral TxBody era
txBodyNoFee
      noFeeWits :: [WitnessesField era]
      noFeeWits :: [WitnessesField era]
noFeeWits =
        Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
bogusNeededScripts ([WitnessesField era] -> [WitnessesField era])
-> [WitnessesField era] -> [WitnessesField era]
forall a b. (a -> b) -> a -> b
$
          [WitnessesField era]
redeemerDatumWits
            [WitnessesField era]
-> [WitnessesField era] -> [WitnessesField era]
forall a. Semigroup a => a -> a -> a
<> ((SafeHash EraIndependentTxBody -> [WitnessesField era])
 -> [WitnessesField era])
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [WitnessesField era]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((SafeHash EraIndependentTxBody -> [WitnessesField era])
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyNoFeeHash) ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
bogusCollateralKeyWitsMakers)
      bogusTxForFeeCalc :: Tx era
bogusTxForFeeCalc =
        Proof era -> [TxField era] -> Tx era
forall era. Proof era -> [TxField era] -> Tx era
coreTx
          Proof era
proof
          [ TxBody era -> TxField era
forall era. TxBody era -> TxField era
Body TxBody era
txBodyNoFee
          , TxWits era -> TxField era
forall era. TxWits era -> TxField era
TxWits (Proof era -> [WitnessesField era] -> TxWits era
forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
proof [WitnessesField era]
noFeeWits)
          , IsValid -> TxField era
forall era. IsValid -> TxField era
Valid IsValid
isValid
          , [TxAuxData era] -> TxField era
forall era. [TxAuxData era] -> TxField era
AuxData' []
          ]
      fee :: Coin
fee = PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
gePParams Tx era
bogusTxForFeeCalc (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
refInputsUtxo)

  Map (Credential 'Staking) Coin
keyDeposits <- (GenState era -> Map (Credential 'Staking) Coin)
-> RWST
     (GenEnv era) () (GenState era) Gen (Map (Credential 'Staking) Coin)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (Credential 'Staking) Coin
forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mKeyDeposits (ModelNewEpochState era -> Map (Credential 'Staking) Coin)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (Credential 'Staking) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  let deposits :: Coin
deposits = case Proof era
proof of
        Proof era
Shelley -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits
        Proof era
Mary -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits
        Proof era
Allegra -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits
        Proof era
Alonzo -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits
        Proof era
Babbage -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits
        Proof era
Conway -> PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (Credential 'Staking) Coin
keyDeposits

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

  -- 9. Generate utxos that will be used as collateral
  (Map TxIn (TxOut era)
utxo, Map TxIn (TxOut era)
collMap, Coin
excessColCoin) <- [Addr]
-> Coin
-> Map TxIn (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map TxIn (TxOut era), Map TxIn (TxOut era), Coin)
forall era.
(HasCallStack, Reflect era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses Coin
fee Map TxIn (TxOut era)
utxoFeeAdjusted
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
collateralKeyWitsMakers <-
    (TxOut era
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      (SafeHash EraIndependentTxBody -> [WitnessesField era]))
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField 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 (Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (SafeHash EraIndependentTxBody -> [WitnessesField era])
forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof Maybe PlutusPurposeTag
forall a. Maybe a
Nothing) ([TxOut era]
 -> RWST
      (GenEnv era)
      ()
      (GenState era)
      Gen
      [SafeHash EraIndependentTxBody -> [WitnessesField era]])
-> [TxOut era]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
collMap

  -- 10. Construct the correct Tx with valid fee and collaterals
  let sNeeded :: Set ScriptHash
sNeeded = Proof era -> Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptsNeeded' Proof era
proof Map TxIn (TxOut era)
utxo TxBody era
txBodyNoFee
      langs :: [Language]
langs = Set Language -> [Language]
forall a. Set a -> [a]
Set.toList (Set Language -> [Language]) -> Set Language -> [Language]
forall a b. (a -> b) -> a -> b
$ Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed Proof era
proof Tx era
bogusTxForFeeCalc (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoNoCollateral) Set ScriptHash
sNeeded
      mIntegrityHash :: StrictMaybe ScriptIntegrityHash
mIntegrityHash =
        Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash
          Proof era
proof
          PParams era
gePParams
          [Language]
langs
          (Proof era -> [WitnessesField era] -> Redeemers era
forall era. Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs Proof era
proof [WitnessesField era]
redeemerDatumWits)
          ([WitnessesField era] -> TxDats era
forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats [WitnessesField era]
redeemerDatumWits)
      balance :: Coin
balance =
        case StrictMaybe (TxOut era)
bogusCollReturn of
          StrictMaybe (TxOut era)
SNothing -> Set TxIn -> Map TxIn (TxOut era) -> Coin
forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo
          SJust TxOut era
_ -> Set TxIn -> Map TxIn (TxOut era) -> Coin
forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
excessColCoin
      txBody :: TxBody era
txBody =
        Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
forall era.
EraTxBody era =>
Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody
          Proof era
proof
          TxBody era
txBodyNoFee
          [ Coin -> TxBodyField era
forall era. Coin -> TxBodyField era
Txfee Coin
fee
          , Set TxIn -> TxBodyField era
forall era. Set TxIn -> TxBodyField era
Collateral (Map TxIn (TxOut era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap)
          , StrictMaybe (TxOut era) -> TxBodyField era
forall era. StrictMaybe (TxOut era) -> TxBodyField era
CollateralReturn (StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
bogusCollReturn Coin
excessColCoin)
          , StrictMaybe Coin -> TxBodyField era
forall era. StrictMaybe Coin -> TxBodyField era
TotalCol (StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
bogusTotalCol Coin
balance)
          , StrictMaybe ScriptIntegrityHash -> TxBodyField era
forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash StrictMaybe ScriptIntegrityHash
mIntegrityHash
          ]
      txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody
      neededScripts :: Set ScriptHash
neededScripts = Proof era -> Map TxIn (TxOut era) -> TxBody era -> Set ScriptHash
forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' Proof era
proof Map TxIn (TxOut era)
utxo TxBody era
txBody
      wits :: [WitnessesField era]
wits =
        Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
neededScripts ([WitnessesField era] -> [WitnessesField era])
-> [WitnessesField era] -> [WitnessesField era]
forall a b. (a -> b) -> a -> b
$
          [WitnessesField era]
redeemerDatumWits
            [WitnessesField era]
-> [WitnessesField era] -> [WitnessesField era]
forall a. Semigroup a => a -> a -> a
<> ((SafeHash EraIndependentTxBody -> [WitnessesField era])
 -> [WitnessesField era])
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [WitnessesField era]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((SafeHash EraIndependentTxBody -> [WitnessesField era])
-> SafeHash EraIndependentTxBody -> [WitnessesField era]
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyHash) ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
-> [SafeHash EraIndependentTxBody -> [WitnessesField era]]
forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
collateralKeyWitsMakers)
      validTx :: Tx era
validTx =
        Proof era -> [TxField era] -> Tx era
forall era. Proof era -> [TxField era] -> Tx era
coreTx
          Proof era
proof
          [ TxBody era -> TxField era
forall era. TxBody era -> TxField era
Body TxBody era
txBody
          , TxWits era -> TxField era
forall era. TxWits era -> TxField era
TxWits (Proof era -> [WitnessesField era] -> TxWits era
forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
proof [WitnessesField era]
wits)
          , IsValid -> TxField era
forall era. IsValid -> TxField era
Valid IsValid
isValid
          , [TxAuxData era] -> TxField era
forall era. [TxAuxData era] -> TxField era
AuxData' []
          ]
  Int
count <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Int
forall era. ModelNewEpochState era -> Int
mCount (ModelNewEpochState era -> Int)
-> (GenState era -> ModelNewEpochState era) -> GenState era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  (Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards (Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (Credential 'Staking) Coin
newRewards)
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyGenStateInitialUtxo (Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map TxIn (TxOut era)
-> Maybe (UtxoEntry era) -> Map TxIn (TxOut era)
forall era. MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus Map TxIn (TxOut era)
utxo Maybe (UtxoEntry era)
maybeoldpair)
  (Int -> Int) -> RWST (GenEnv era) () (GenState era) Gen ()
forall era. (Int -> Int) -> GenRS era ()
modifyModelCount (Int -> Int -> Int
forall a b. a -> b -> a
const (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  (Map Int TxId -> Map Int TxId)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era. (Map Int TxId -> Map Int TxId) -> GenRS era ()
modifyModelIndex (Int -> TxId -> Map Int TxId -> Map Int TxId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
count (SafeHash EraIndependentTxBody -> TxId
TxId SafeHash EraIndependentTxBody
txBodyHash))
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelUTxO (Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall a b. a -> b -> a
const Map TxIn (TxOut era)
utxo)

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

-- | Keep only Script witnesses that are neccessary in 'era',
onlyNecessaryScripts ::
  Proof era -> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts :: forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
_ Set ScriptHash
_ [] = []
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes (ScriptWits Map ScriptHash (Script era)
m : [WitnessesField era]
xs) =
  Map ScriptHash (Script era) -> WitnessesField era
forall era. Map ScriptHash (Script era) -> WitnessesField era
ScriptWits (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
hashes) WitnessesField era -> [WitnessesField era] -> [WitnessesField era]
forall a. a -> [a] -> [a]
: Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes [WitnessesField era]
xs
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes (WitnessesField era
x : [WitnessesField era]
xs) = WitnessesField era
x WitnessesField era -> [WitnessesField era] -> [WitnessesField era]
forall a. a -> [a] -> [a]
: Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes [WitnessesField era]
xs

-- | Scan though the fields unioning all the RdrmWits fields into one Redeemer map
mkTxrdmrs :: Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs :: forall era. Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs Proof era
proof [WitnessesField era]
fields = Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof ([(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era)
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall a b. (a -> b) -> a -> b
$ ([(PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> WitnessesField era
 -> [(PlutusPurpose AsIx era, (Data era, ExUnits))])
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [WitnessesField era]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> WitnessesField era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall {era}.
[(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> WitnessesField era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
accum [] [WitnessesField era]
fields
  where
    accum :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> WitnessesField era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
accum [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 (RdmrWits Redeemers era
r2) = [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a. [a] -> [a] -> [a]
++ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList (Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers Redeemers era
r2)
    accum [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 WitnessesField era
_ = [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1

-- | Scan though the fields unioning all the DataWits fields into one TxDat
mkTxdats :: forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats :: forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats [WitnessesField era]
fields = Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats ((Map DataHash (Data era)
 -> WitnessesField era -> Map DataHash (Data era))
-> Map DataHash (Data era)
-> [WitnessesField era]
-> Map DataHash (Data era)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map DataHash (Data era)
-> WitnessesField era -> Map DataHash (Data era)
accum Map DataHash (Data era)
forall k a. Map k a
Map.empty [WitnessesField era]
fields)
  where
    accum :: Map DataHash (Data era)
-> WitnessesField era -> Map DataHash (Data era)
accum Map DataHash (Data era)
m (DataWits' [Data era]
ds) = (Map DataHash (Data era) -> Data era -> Map DataHash (Data era))
-> Map DataHash (Data era) -> [Data era] -> Map DataHash (Data era)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map DataHash (Data era) -> Data era -> Map DataHash (Data era)
accum2 Map DataHash (Data era)
m [Data era]
ds
      where
        accum2 :: Map DataHash (Data era) -> Data era -> Map DataHash (Data era)
accum2 Map DataHash (Data era)
m2 Data era
d = DataHash
-> Data era -> Map DataHash (Data era) -> Map DataHash (Data era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. Data era -> DataHash
hashData @era Data era
d) Data era
d Map DataHash (Data era)
m2
    accum Map DataHash (Data era)
m WitnessesField era
_ = Map DataHash (Data era)
m

-- =======================================================
-- An encapsulation of the Top level types we generate,
-- but that has its own Show instance that we can control.

data Box era = Box (Proof era) (TRC (EraRule "LEDGER" era)) (GenState era)

instance
  ( Era era
  , PrettyA (State (EraRule "LEDGER" era))
  , PrettyA (Script era)
  , PrettyA (Signal (EraRule "LEDGER" era))
  , Signal (EraRule "LEDGER" era) ~ Tx era
  ) =>
  Show (Box era)
  where
  show :: Box era -> String
show (Box Proof era
_proof (TRC (Environment (EraRule "LEDGER" era)
_env, State (EraRule "LEDGER" era)
_state, Signal (EraRule "LEDGER" era)
_sig)) GenState era
_gs) =
    PDoc -> String
forall a. Show a => a -> String
show (PDoc -> String) -> PDoc -> String
forall a b. (a -> b) -> a -> b
$
      Text -> [(Text, PDoc)] -> PDoc
ppRecord
        Text
"Box"
        []

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

applySTSByProof ::
  forall era.
  Era era =>
  Proof era ->
  RuleContext 'Transition (EraRule "LEDGER" era) ->
  Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era))
applySTSByProof :: forall era.
Era era =>
Proof era
-> RuleContext 'Transition (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
applySTSByProof Proof era
Conway 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 (ConwayLEDGER ConwayEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (ConwayLEDGER ConwayEra)))
        (State (ConwayLEDGER ConwayEra)))
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)
RuleContext 'Transition (ConwayLEDGER ConwayEra)
trc
applySTSByProof Proof era
Babbage 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 (BabbageLEDGER BabbageEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (BabbageLEDGER BabbageEra)))
        (State (BabbageLEDGER BabbageEra)))
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)
RuleContext 'Transition (BabbageLEDGER BabbageEra)
trc
applySTSByProof Proof era
Alonzo 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 (AlonzoLEDGER AlonzoEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (AlonzoLEDGER AlonzoEra)))
        (State (AlonzoLEDGER AlonzoEra)))
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)
RuleContext 'Transition (AlonzoLEDGER AlonzoEra)
trc
applySTSByProof Proof era
Mary 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 (ShelleyLEDGER MaryEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
        (State (ShelleyLEDGER MaryEra)))
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)
RuleContext 'Transition (ShelleyLEDGER MaryEra)
trc
applySTSByProof Proof era
Allegra 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 (ShelleyLEDGER AllegraEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (ShelleyLEDGER AllegraEra)))
        (State (ShelleyLEDGER AllegraEra)))
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)
RuleContext 'Transition (ShelleyLEDGER AllegraEra)
trc
applySTSByProof Proof era
Shelley 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 (ShelleyLEDGER ShelleyEra)
-> ReaderT
     Globals
     Identity
     (Either
        (NonEmpty (PredicateFailure (ShelleyLEDGER ShelleyEra)))
        (State (ShelleyLEDGER ShelleyEra)))
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)
RuleContext 'Transition (ShelleyLEDGER ShelleyEra)
trc