{-# 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 (
  KeyHash,
  KeyRole (..),
  coerceKeyRole,
 )
import Cardano.Ledger.Plutus.Data (Data, Datum (..), dataToBinaryData, hashData)
import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated)
import Cardano.Ledger.Shelley.API (
  Addr (..),
  Credential (..),
  PoolParams (..),
  RewardAccount (..),
  ShelleyDelegCert (..),
  StakeReference (..),
  Withdrawals (..),
 )
import Cardano.Ledger.Shelley.LedgerState (RewardAccounts)
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.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..))
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 (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,
  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 :: Era era => Proof era -> [WitnessesField era] -> TxWits era
assembleWits :: forall era.
Era era =>
Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era.
Policy
-> Proof era -> TxWits era -> WitnessesField era -> TxWits era
updateWitnesses Policy
merge Proof era
era) (forall era. Era era => Proof era -> TxWits era
initialWitnesses Proof era
era)

coreTxOut :: Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut :: forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era. Proof era -> TxOut era -> TxOutField era -> TxOut era
updateTxOut Proof era
era) (forall era. Era 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era.
EraTxBody era =>
Proof era -> TxBody era -> TxBodyField era -> TxBody era
updateTxBody Proof era
era) (forall era. Era 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era. Proof era -> Tx era -> TxField era -> Tx era
updateTx Proof era
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 <- 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
m of
    Maybe v
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        String
"Can't find " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" in the test enviroment: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show k
k
    Just v
val -> 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 :: forall era. GenEnv era -> PParams era
gePParams :: PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  let ExUnits Natural
maxMemUnits Natural
maxStepUnits = forall era. Proof era -> PParams era -> ExUnits
maxTxExUnits' Proof era
era PParams era
gePParams
  [Natural]
memUnits <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxMemUnits
  [Natural]
stepUnits <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxStepUnits
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Natural -> ExUnits
ExUnits [Natural]
memUnits [Natural]
stepUnits
  where
    un :: Natural
un = 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 forall a. Eq a => a -> a -> Bool
== Natural
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
0, Natural
0 forall a. a -> [a] -> [a]
: [Natural]
acc)
      | Bool
otherwise = do
          Natural
x <- forall a. Ord a => a -> a -> a
min Natural
totalLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> Ratio a
% Natural
un) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
0 Natural
maxVal
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
totalLeft forall a. Num a => a -> a -> a
- Natural
x, Natural
x forall a. a -> [a] -> [a]
: [Natural]
acc)
    genSequenceSum :: Natural -> Gen [Natural]
genSequenceSum Natural
maxVal
      | Natural
maxVal forall a. Eq a => a -> a -> Bool
== Natural
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Natural
0
      | Bool
otherwise = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (EraCrypto era) ->
  Maybe PlutusPurposeTag ->
  GenRS era (Maybe (Script era))
lookupScript :: forall era.
ScriptHash (EraCrypto era)
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash (EraCrypto era)
scriptHash Maybe PlutusPurposeTag
mTag = do
  Map (ScriptHash (EraCrypto era)) (Script era)
m <- forall era.
GenState era -> Map (ScriptHash (EraCrypto era)) (Script era)
gsScripts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash (EraCrypto era)
scriptHash Map (ScriptHash (EraCrypto era)) (Script era)
m of
    Just Script era
script -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Script era
script
    Maybe (Script era)
Nothing
      | Just PlutusPurposeTag
tag <- Maybe PlutusPurposeTag
mTag ->
          forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"plutusScript" (ScriptHash (EraCrypto era)
scriptHash, PlutusPurposeTag
tag) forall era.
GenState era
-> Map
     (ScriptHash (EraCrypto era), PlutusPurposeTag)
     (IsValid, Script era)
gsPlutusScripts
    Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

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

genGenericScriptWitness ::
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Script era ->
  GenRS era (SafeHash (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness :: forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genGenericScriptWitness Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script =
  case Proof era
proof of
    Proof era
Shelley -> forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkMultiSigWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Allegra -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Mary -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Alonzo -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript (AlonzoEra StandardCrypto)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    Proof era
Babbage -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript (BabbageEra StandardCrypto)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    Proof era
Conway -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript (ConwayEra StandardCrypto)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (EraCrypto era) ->
  GenRS era (SafeHash (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
mkWitVKey :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
_ Maybe PlutusPurposeTag
_mTag (KeyHashObj KeyHash kr (EraCrypto era)
keyHash) = do
  KeyPair 'Witness StandardCrypto
keyPair <- forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"credential" (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash kr (EraCrypto era)
keyHash) forall era.
GenState era
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
gsKeys
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \SafeHash StandardCrypto EraIndependentTxBody
bodyHash -> [forall era.
Era era =>
[WitVKey 'Witness (EraCrypto era)] -> WitnessesField era
AddrWits' [forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey SafeHash StandardCrypto EraIndependentTxBody
bodyHash KeyPair 'Witness StandardCrypto
keyPair]]
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) =
  forall era.
ScriptHash (EraCrypto era)
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript @era ScriptHash (EraCrypto era)
scriptHash Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Script era)
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible: Cannot find script with hash " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScriptHash (EraCrypto era)
scriptHash
    Just Script era
script -> do
      let scriptWit :: WitnessesField era
scriptWit = forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [Script era
script]
      SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
otherWit <- forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genGenericScriptWitness Proof era
era Maybe PlutusPurposeTag
mTag Script era
script
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash StandardCrypto EraIndependentTxBody
hash -> WitnessesField era
scriptWit forall a. a -> [a] -> [a]
: SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
otherWit SafeHash StandardCrypto 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 (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireSignature KeyHash 'Witness (EraCrypto era)
keyHash) = forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Witness (EraCrypto era)
keyHash)
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireAllOf StrictSeq (NativeScript era)
timelocks) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) StrictSeq (NativeScript era)
timelocks
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireAnyOf StrictSeq (NativeScript era)
timelocks)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (NativeScript era)
timelocks = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
  | Bool
otherwise = forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => [a] -> Gen a
elements (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireMOf Int
m StrictSeq (NativeScript era)
timelocks) = do
  [MultiSig era]
ts <- forall a. Int -> [a] -> [a]
take Int
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) [MultiSig era]
ts
mkMultiSigWit Proof era
_ Maybe PlutusPurposeTag
_ MultiSig 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 (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag =
  \case
    RequireSignature KeyHash 'Witness (EraCrypto era)
keyHash -> forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Witness (EraCrypto era)
keyHash)
    RequireAllOf StrictSeq (NativeScript era)
timelocks -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) StrictSeq (NativeScript era)
timelocks
    RequireAnyOf StrictSeq (NativeScript era)
timelocks
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (NativeScript era)
timelocks -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
      | Bool
otherwise -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => [a] -> Gen a
elements (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
    RequireMOf Int
m StrictSeq (NativeScript era)
timelocks -> do
      [Timelock era]
ts <- forall a. Int -> [a] -> [a]
take Int
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
      forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) [Timelock era]
ts
    RequireTimeStart SlotNo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    RequireTimeExpire SlotNo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness :: forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genTxOutKeyWitness Proof era
era Maybe PlutusPurposeTag
mTag TxOut era
txOut =
  case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
    AddrBootstrap BootstrapAddress (EraCrypto era)
baddr ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't authorize bootstrap address: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BootstrapAddress (EraCrypto era)
baddr
    Addr Network
_ PaymentCredential (EraCrypto era)
payCred StakeReference (EraCrypto era)
_ ->
      case forall era. Proof era -> TxOut era -> StrictMaybe (Script era)
getTxOutRefScript forall era. Reflect era => Proof era
reify TxOut era
txOut of
        StrictMaybe (Script era)
SNothing -> forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential (EraCrypto era)
payCred
        SJust Script era
script -> do
          SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
f1 <- forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential (EraCrypto era)
payCred
          SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
f2 <- forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genGenericScriptWitness forall era. Reflect era => Proof era
reify (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending) Script era
script
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash StandardCrypto EraIndependentTxBody
safehash -> SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
f1 SafeHash StandardCrypto EraIndependentTxBody
safehash forall a. [a] -> [a] -> [a]
++ SafeHash StandardCrypto EraIndependentTxBody
-> [WitnessesField era]
f2 SafeHash StandardCrypto EraIndependentTxBody
safehash)

genCredKeyWit ::
  forall era k.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Credential k (EraCrypto era) ->
  GenRS era (SafeHash (EraCrypto era) EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genCredKeyWit Proof era
era Maybe PlutusPurposeTag
mTag Credential k (EraCrypto era)
cred = forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag Credential k (EraCrypto era)
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 (EraCrypto (BabbageEra StandardCrypto))
_ Value (BabbageEra StandardCrypto)
_ (DatumHash DataHash (EraCrypto (BabbageEra StandardCrypto))
h) StrictMaybe (Script (BabbageEra StandardCrypto))
_) -> forall {era}.
Era era =>
StrictMaybe (DataHash (EraCrypto era))
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit (forall a. a -> StrictMaybe a
SJust DataHash (EraCrypto (BabbageEra StandardCrypto))
h)
  (Proof era
Babbage, BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
_ Value (BabbageEra StandardCrypto)
_ (Datum BinaryData (BabbageEra StandardCrypto)
_) StrictMaybe (Script (BabbageEra StandardCrypto))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Babbage, BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
_ Value (BabbageEra StandardCrypto)
_ Datum (BabbageEra StandardCrypto)
NoDatum StrictMaybe (Script (BabbageEra StandardCrypto))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
_ Value (ConwayEra StandardCrypto)
_ (DatumHash DataHash (EraCrypto (ConwayEra StandardCrypto))
h) StrictMaybe (Script (ConwayEra StandardCrypto))
_) -> forall {era}.
Era era =>
StrictMaybe (DataHash (EraCrypto era))
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit (forall a. a -> StrictMaybe a
SJust DataHash (EraCrypto (ConwayEra StandardCrypto))
h)
  (Proof era
Conway, BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
_ Value (ConwayEra StandardCrypto)
_ (Datum BinaryData (ConwayEra StandardCrypto)
_) StrictMaybe (Script (ConwayEra StandardCrypto))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
_ Value (ConwayEra StandardCrypto)
_ Datum (ConwayEra StandardCrypto)
NoDatum StrictMaybe (Script (ConwayEra StandardCrypto))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Alonzo, AlonzoTxOut Addr (EraCrypto (AlonzoEra StandardCrypto))
_ Value (AlonzoEra StandardCrypto)
_ StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
mDatum) -> forall {era}.
Era era =>
StrictMaybe (DataHash (EraCrypto era))
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
mDatum
  (Proof era, TxOut era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- No other era has data witnesses
  where
    mkDatumWit :: StrictMaybe (DataHash (EraCrypto era))
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe (DataHash (EraCrypto era))
SNothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    mkDatumWit (SJust DataHash (EraCrypto era)
datumHash) = do
      Data era
datum <- forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"datum" DataHash (EraCrypto era)
datumHash forall era.
GenState era -> Map (DataHash (EraCrypto era)) (Data era)
gsDatums
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [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 (EraCrypto era) ->
  PlutusPurposeTag ->
  GenRS era (Maybe (IsValid, ScriptHash (EraCrypto era)))
plutusScriptHashFromTag :: forall (k :: KeyRole) era.
Credential k (EraCrypto era)
-> PlutusPurposeTag
-> GenRS era (Maybe (IsValid, ScriptHash (EraCrypto era)))
plutusScriptHashFromTag (KeyHashObj KeyHash k (EraCrypto era)
_) PlutusPurposeTag
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
plutusScriptHashFromTag (ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) PlutusPurposeTag
tag =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScriptHash (EraCrypto era)
scriptHash, PlutusPurposeTag
tag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
GenState era
-> Map
     (ScriptHash (EraCrypto era), PlutusPurposeTag)
     (IsValid, Script era)
gsPlutusScripts) forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe (IsValid, Script era)
Nothing -> forall a. Maybe a
Nothing
    Just (IsValid
isValid, Script era
_) -> forall a. a -> Maybe a
Just (IsValid
isValid, ScriptHash (EraCrypto era)
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 (EraCrypto era))] ->
  GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker :: forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k (EraCrypto era))]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
tag [Maybe (GenRS era (Data era), Credential k (EraCrypto era))]
listWithCred =
  let creds :: [(Word32, GenRS era (Data era), Credential k (EraCrypto era))]
creds =
        [ (Word32
ix, GenRS era (Data era)
genDat, Credential k (EraCrypto era)
cred)
        | (Word32
ix, Maybe (GenRS era (Data era), Credential k (EraCrypto era))
mCred) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [Maybe (GenRS era (Data era), Credential k (EraCrypto era))]
listWithCred
        , Just (GenRS era (Data era)
genDat, Credential k (EraCrypto era)
cred) <- [Maybe (GenRS era (Data era), Credential k (EraCrypto era))
mCred]
        ]
      allValid :: [IsValid] -> IsValid
      allValid :: [IsValid] -> IsValid
allValid = Bool -> IsValid
IsValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(IsValid Bool
v) -> Bool -> All
All Bool
v)
   in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [IsValid] -> IsValid
allValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall a b. (a -> b) -> a -> b
$
        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 (EraCrypto era))]
creds forall a b. (a -> b) -> a -> b
$ \(Word32
ix, GenRS era (Data era)
genDat, Credential k (EraCrypto era)
cred) ->
          forall (k :: KeyRole) era.
Credential k (EraCrypto era)
-> PlutusPurposeTag
-> GenRS era (Maybe (IsValid, ScriptHash (EraCrypto era)))
plutusScriptHashFromTag Credential k (EraCrypto era)
cred PlutusPurposeTag
tag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (IsValid, ScriptHash (EraCrypto era))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just (IsValid
isValid, ScriptHash (EraCrypto era)
_) -> do
              Data era
datum <- GenRS era (Data era)
genDat
              let mkWit3 :: ExUnits -> [WitnessesField era]
mkWit3 ExUnits
exUnits =
                    [forall era. Redeemers era -> WitnessesField era
RdmrWits (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
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: Reflect era => GenRS era (Addr (EraCrypto era))
genNoScriptRecipient :: forall era. Reflect era => GenRS era (Addr (EraCrypto era))
genNoScriptRecipient = do
  Credential 'Payment StandardCrypto
paymentCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole).
Reflect era =>
GenRS era (KeyHash kr (EraCrypto era))
genKeyHash
  StakeReference StandardCrypto
stakeCred <- forall c. StakeCredential c -> StakeReference c
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole).
Reflect era =>
GenRS era (KeyHash kr (EraCrypto era))
genKeyHash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet Credential 'Payment StandardCrypto
paymentCred StakeReference StandardCrypto
stakeCred)

-- | Sometimes generates new Credentials, and some times reuses old ones
genRecipient :: Reflect era => GenRS era (Addr (EraCrypto era))
genRecipient :: forall era. Reflect era => GenRS era (Addr (EraCrypto era))
genRecipient = do
  Credential 'Payment StandardCrypto
paymentCred <- forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr (EraCrypto era))
genCredential PlutusPurposeTag
Spending
  StakeCredential StandardCrypto
stakeCred <- forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr (EraCrypto era))
genCredential PlutusPurposeTag
Certifying
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet Credential 'Payment StandardCrypto
paymentCred (forall c. StakeCredential c -> StakeReference c
StakeRefBase StakeCredential StandardCrypto
stakeCred))

genDatum :: Era era => GenRS era (Data era)
genDatum :: forall era. Era era => GenRS era (Data era)
genDatum = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Era era =>
GenRS era (DataHash (EraCrypto era), 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 =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
1, forall era. DataHash (EraCrypto era) -> Datum era
DatumHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Era era =>
GenRS era (DataHash (EraCrypto era), Data era)
genDatumWithHash)
    , (Int
4, forall era. BinaryData era -> Datum era
Datum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Era era => Data era -> BinaryData era
dataToBinaryData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Era era =>
GenRS era (DataHash (EraCrypto era), 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 StandardCrypto
scripthash <- forall era.
Reflect era =>
Proof era
-> PlutusPurposeTag -> GenRS era (ScriptHash (EraCrypto era))
genScript Proof era
proof PlutusPurposeTag
Spending
  Maybe (Script era)
mscript <- forall era.
ScriptHash (EraCrypto era)
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash StandardCrypto
scripthash (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
  case Maybe (Script era)
mscript of
    Maybe (Script era)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
    Just Script era
script -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 StandardCrypto)
_) -> do
        Datum era
datum <- forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript (ConwayEra StandardCrypto))
script <- forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. Datum era -> TxOutField era
FDatum Datum era
datum, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (AlonzoScript (ConwayEra StandardCrypto))
script]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Babbage -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript (BabbageEra StandardCrypto)
_) -> do
        Datum era
datum <- forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript (BabbageEra StandardCrypto))
script <- forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. Datum era -> TxOutField era
FDatum Datum era
datum, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (AlonzoScript (BabbageEra StandardCrypto))
script]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Alonzo -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript (AlonzoEra StandardCrypto)
_) -> do
        (DataHash StandardCrypto
datahash, Data (AlonzoEra StandardCrypto)
_data) <- forall era.
Era era =>
GenRS era (DataHash (EraCrypto era), Data era)
genDatumWithHash
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era.
StrictMaybe (DataHash (EraCrypto era)) -> TxOutField era
DHash (forall a. a -> StrictMaybe a
SJust DataHash StandardCrypto
datahash)]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
_ -> 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 StandardCrypto
addr <- forall era. Reflect era => GenRS era (Addr (EraCrypto era))
genRecipient
  Credential 'Payment StandardCrypto
cred <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"BootstrapAddress encountered") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c. Addr c -> Maybe (Credential 'Payment c)
paymentCredAddr Addr StandardCrypto
addr
  [TxOutField era]
dataHashFields <-
    case Credential 'Payment StandardCrypto
cred of
      KeyHashObj KeyHash 'Payment StandardCrypto
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ScriptHashObj ScriptHash StandardCrypto
scriptHash -> do
        Maybe (Script era)
maybeCoreScript <- forall era.
ScriptHash (EraCrypto era)
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash StandardCrypto
scriptHash (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
        forall era.
Reflect era =>
Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField Proof era
proof Maybe (Script era)
maybeCoreScript
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [forall era. Addr (EraCrypto era) -> TxOutField era
Address Addr StandardCrypto
addr, forall era. Value era -> TxOutField era
Amount Value era
val] 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. Reflect era => Proof era -> Int -> Gen (TxIn (EraCrypto era))
genTxIn :: forall era.
Reflect era =>
Proof era -> Int -> Gen (TxIn (EraCrypto era))
genTxIn Proof era
_proof Int
numChoices = do
  TxId StandardCrypto
txId <- forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
40 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
mkTxIxPartial forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int
numChoices forall a. Num a => a -> a -> a
+ Int
1, Int
numChoices forall a. Num a => a -> a -> a
+ Int
100)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. TxId c -> TxIx -> TxIn c
TxIn TxId StandardCrypto
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 (EraCrypto era)]
genFreshTxIn :: forall era. Reflect era => Int -> GenRS era [TxIn (EraCrypto era)]
genFreshTxIn Int
tries | Int
tries forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error String
"Could not generate a fresh TxIn after many tries."
genFreshTxIn Int
tries = do
  Map (TxIn StandardCrypto) (TxOut era)
entriesInUse <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map (TxIn (EraCrypto era)) (TxOut era)
gsInitialUtxo
  -- Max number of choices. So the UTxO will never be larger than this
  Int
numChoicesMax <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getUtxoChoicesMax
  Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
numChoicesMax forall a. Num a => a -> a -> a
+ Int
3)
  [TxIn StandardCrypto]
ins <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (forall era.
Reflect era =>
Proof era -> Int -> Gen (TxIn (EraCrypto era))
genTxIn @era forall era. Reflect era => Proof era
reify Int
numChoicesMax)
  case forall a. (a -> Bool) -> [a] -> [a]
filter (forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map (TxIn StandardCrypto) (TxOut era)
entriesInUse) [TxIn StandardCrypto]
ins of
    [] -> forall era. Reflect era => Int -> GenRS era [TxIn (EraCrypto era)]
genFreshTxIn (Int
tries forall a. Num a => a -> a -> a
- Int
1)
    [TxIn StandardCrypto]
freshTxIns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Int -> [a] -> [a]
take Int
numChoicesMax [TxIn StandardCrypto]
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 StandardCrypto]
ins <- forall era. Reflect era => Int -> GenRS era [TxIn (EraCrypto era)]
genFreshTxIn Int
100
  [(TxIn StandardCrypto, TxOut era)]
pairs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b. (a -> b) -> [a] -> [b]
map (\TxIn StandardCrypto
x -> (TxIn StandardCrypto
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
genOut) [TxIn StandardCrypto]
ins)
  Int
percent <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getOldUtxoPercent
  -- Choose a pair from the oldUTxO
  Maybe (TxIn StandardCrypto, TxOut era)
maybepair <- forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
percent, forall era.
Reflect era =>
GenRS era (Maybe (TxIn (EraCrypto era), TxOut era))
getUtxoElem), (Int
100 forall a. Num a => a -> a -> a
- Int
percent, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {a}. Maybe a -> [a] -> [a]
maybeCons Maybe (TxIn StandardCrypto, TxOut era)
maybepair [(TxIn StandardCrypto, TxOut era)]
pairs), Maybe (TxIn StandardCrypto, TxOut era)
maybepair)
  where
    -- Note: Never add an old pair unless there are more than 1 new pairs
    maybeCons :: Maybe a -> [a] -> [a]
maybeCons (Just a
pair) [a]
xs | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Ord a => a -> a -> Bool
> Int
1 = a
pair 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
      [TxOutField era]
fields <- forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut forall era. Reflect era => Proof era
reify Value era
val
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut 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 (EraCrypto era)) (TxOut era) ->
  GenRS
    era
    ( UtxoEntry era -- The fee key, used to pay the fee.
    , Map (TxIn (EraCrypto era)) (TxOut era)
    , Map (TxIn (EraCrypto era)) (TxOut era)
    , Map (TxIn (EraCrypto era)) (TxOut era)
    )
genSpendReferenceInputs :: forall era.
Map (TxIn (EraCrypto era)) (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map (TxIn (EraCrypto era)) (TxOut era),
      Map (TxIn (EraCrypto era)) (TxOut era),
      Map (TxIn (EraCrypto era)) (TxOut era))
genSpendReferenceInputs Map (TxIn (EraCrypto era)) (TxOut era)
newUTxO = do
  let pairs :: [UtxoEntry era]
pairs = forall k a. Map k a -> [(k, a)]
Map.toList Map (TxIn (EraCrypto era)) (TxOut era)
newUTxO
  Int
maxInputs <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getSpendInputsMax
  Int
maxRef <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getRefInputsMax
  Int
numInputs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, forall a. Ord a => a -> a -> a
min (forall k a. Map k a -> Int
Map.size Map (TxIn (EraCrypto era)) (TxOut era)
newUTxO) Int
maxInputs)
  Int
numRefInputs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxRef)
  TxIn (EraCrypto era) -> Bool
badTest <- forall era. GenRS era (TxIn (EraCrypto era) -> Bool)
getUtxoTest
  (feepair :: UtxoEntry era
feepair@(TxIn (EraCrypto era)
txin, TxOut era
txout), [UtxoEntry era]
inputPairs) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood (TxIn (EraCrypto era) -> Bool
badTest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Int
numInputs [UtxoEntry era]
pairs
  [UtxoEntry era]
refInputPairs <- forall a. Int -> [a] -> [a]
take Int
numRefInputs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle [UtxoEntry era]
pairs)
  let inputs :: Map (TxIn (EraCrypto era)) (TxOut era)
inputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
inputPairs
      refInputs :: Map (TxIn (EraCrypto era)) (TxOut era)
refInputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
refInputPairs
  -- The feepair is added to the mMutFee field
  forall era.
(Map (TxIn (EraCrypto era)) (TxOut era)
 -> Map (TxIn (EraCrypto era)) (TxOut era))
-> GenRS era ()
modifyModelMutFee (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn (EraCrypto era)
txin TxOut era
txout)
  let filtered :: Map (TxIn (EraCrypto era)) (TxOut era)
filtered = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (TxIn (EraCrypto era)) (TxOut era)
newUTxO (forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall k a. Map k a -> Set k
Map.keysSet Map (TxIn (EraCrypto era)) (TxOut era)
inputs) (forall k a. Map k a -> Set k
Map.keysSet Map (TxIn (EraCrypto era)) (TxOut era)
refInputs))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (UtxoEntry era
feepair, Map (TxIn (EraCrypto era)) (TxOut era)
inputs, Map (TxIn (EraCrypto era)) (TxOut era)
refInputs, Map (TxIn (EraCrypto era)) (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
          [] ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
              String
"empty list in chooseGood, should never happen. n = "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
                forall a. [a] -> [a] -> [a]
++ String
", length xs = "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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 forall a. a -> [a] -> [a]
: [a]
more) else (a
x, a
y forall a. a -> [a] -> [a]
: [a]
more)
  [a]
tailx <- forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen [a]
shuffle [a]
others
  [a]
result <- forall a. [a] -> Gen [a]
shuffle (a
good forall a. a -> [a] -> [a]
: [a]
tailx)
  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 =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
75, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyRegCert)
    , (Int
25, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyUnRegCert)
    , (Int
50, RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genDelegation)
    ]
  where
    genShelleyRegCert :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyRegCert = forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking (EraCrypto era))
genFreshRegCred @era PlutusPurposeTag
Certifying
    genShelleyUnRegCert :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genShelleyUnRegCert = forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
UnRegTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr (EraCrypto era))
genCredential PlutusPurposeTag
Certifying
    genDelegation :: RWST (GenEnv era) () (GenState era) Gen (TxCert era)
genDelegation = do
      Credential 'Staking (EraCrypto era)
rewardAccount <- forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking (EraCrypto era))
genFreshRegCred PlutusPurposeTag
Certifying
      (KeyHash 'StakePool (EraCrypto era)
poolId, PoolParams (EraCrypto era)
_) <- forall era.
Reflect era =>
GenRS
  era
  (KeyHash 'StakePool (EraCrypto era), PoolParams (EraCrypto era))
genPool
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert Credential 'Staking (EraCrypto era)
rewardAccount KeyHash 'StakePool (EraCrypto era)
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 -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Mary -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Allegra -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Alonzo -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Babbage -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Conway -> 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 =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT
    [ forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg
    , forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
        [ (Int
75, forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
RegPoolTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
  (GenEnv era) () (GenState era) Gen (PoolParams (EraCrypto era))
genFreshPool)
        , (Int
25, forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool (EraCrypto era))
genRetirementHash 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 (EraCrypto era))
genFreshPool = do
      (KeyHash 'StakePool (EraCrypto era)
_kh, PoolParams (EraCrypto era)
pp, IndividualPoolStake (EraCrypto era)
_) <- forall era.
Reflect era =>
GenRS
  era
  (KeyHash 'StakePool (EraCrypto era), PoolParams (EraCrypto era),
   IndividualPoolStake (EraCrypto era))
genNewPool
      forall (m :: * -> *) a. Monad m => a -> m a
return PoolParams (EraCrypto era)
pp
    genEpoch :: RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch = do
      let EpochNo Word64
txEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
      EpochNo Word64
curEpoch <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ forall era. ModelNewEpochState era -> EpochNo
mEL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel
      EpochInterval Word32
maxEpoch <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall a b. (a -> b) -> a -> b
$ forall a s. Getting a s a -> s -> a
view forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> PParams era
gePParams
      let nextEpoch :: Word64
nextEpoch = Word64
1 forall a. Num a => a -> a -> a
+ (Word64
txEpoch 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Word64
nextEpoch, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxEpoch)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochNo
EpochNo forall a b. (a -> b) -> a -> b
$ (Word64
curEpoch forall a. Num a => a -> a -> a
+ Word64
delta)

-- getShelleyTxCertDelegG :: forall era. Reflect era => TxCert era -> Maybe (ShelleyDelegCert (EraCrypto era))
-- 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 (EraCrypto era) -> 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 StandardCrypto,
    Maybe (KeyHash 'StakePool StandardCrypto)),
 Map (StakeCredential StandardCrypto) Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era],
      Set
        (ScriptHash StandardCrypto,
         Maybe (KeyHash 'StakePool StandardCrypto)),
      Map (StakeCredential StandardCrypto) Coin)
genUniqueScript (![TxCert era]
dcs, !Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, !Map (StakeCredential StandardCrypto) Coin
regCreds) Int
_ = do
        Set (StakeCredential StandardCrypto)
honest <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (StakeCredential (EraCrypto era))
gsStableDelegators
        TxCert era
dc <- 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 (StakeCredential StandardCrypto) Coin
-> Maybe (KeyHash 'StakePool StandardCrypto)
-> Maybe (IsValid, ScriptHash StandardCrypto)
-> ([TxCert era],
    Set
      (ScriptHash StandardCrypto,
       Maybe (KeyHash 'StakePool StandardCrypto)),
    Map (StakeCredential StandardCrypto) Coin)
insertIfNotPresent [TxCert era]
dcs' Map (StakeCredential StandardCrypto) Coin
regCreds' Maybe (KeyHash 'StakePool StandardCrypto)
mKey Maybe (IsValid, ScriptHash StandardCrypto)
mScriptHash
              | Just (IsValid
_, ScriptHash StandardCrypto
scriptHash) <- Maybe (IsValid, ScriptHash StandardCrypto)
mScriptHash =
                  if (ScriptHash StandardCrypto
scriptHash, Maybe (KeyHash 'StakePool StandardCrypto)
mKey) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss
                    then ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
                    else (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs', forall a. Ord a => a -> Set a -> Set a
Set.insert (ScriptHash StandardCrypto
scriptHash, Maybe (KeyHash 'StakePool StandardCrypto)
mKey) Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds')
              | Bool
otherwise = (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs', Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) 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 (EraCrypto era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
          RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
kh EpochNo
_ -> do
            -- We need to make sure that the pool is registered before
            -- we try to retire it
            Map (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
modelPools <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
kh Map (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
modelPools of
              Just PoolParams StandardCrypto
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
              Maybe (PoolParams StandardCrypto)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
          RegTxCert StakeCredential (EraCrypto era)
regCred ->
            if StakeCredential (EraCrypto era)
regCred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (StakeCredential StandardCrypto) Coin
regCreds -- Can't register if it is already registered
              then forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StakeCredential (EraCrypto era)
regCred (Integer -> Coin
Coin Integer
99) Map (StakeCredential StandardCrypto) Coin
regCreds) -- 99 is a NonZero Value
          UnRegTxCert StakeCredential (EraCrypto era)
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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeCredential (EraCrypto era)
deregCred Map (StakeCredential StandardCrypto) Coin
regCreds of
              Maybe Coin
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
              -- No credential, skip making certificate
              Just (Coin Integer
0) ->
                -- Ok to make certificate, rewards balance is 0
                if forall a. Ord a => a -> Set a -> Bool
Set.member StakeCredential (EraCrypto era)
deregCred Set (StakeCredential StandardCrypto)
honest
                  then forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
                  else
                    [TxCert era]
-> Map (StakeCredential StandardCrypto) Coin
-> Maybe (KeyHash 'StakePool StandardCrypto)
-> Maybe (IsValid, ScriptHash StandardCrypto)
-> ([TxCert era],
    Set
      (ScriptHash StandardCrypto,
       Maybe (KeyHash 'StakePool StandardCrypto)),
    Map (StakeCredential StandardCrypto) Coin)
insertIfNotPresent [TxCert era]
dcs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete StakeCredential (EraCrypto era)
deregCred Map (StakeCredential StandardCrypto) Coin
regCreds) forall a. Maybe a
Nothing
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (k :: KeyRole) era.
Credential k (EraCrypto era)
-> PlutusPurposeTag
-> GenRS era (Maybe (IsValid, ScriptHash (EraCrypto era)))
plutusScriptHashFromTag StakeCredential (EraCrypto era)
deregCred PlutusPurposeTag
Certifying
              Just (Coin Integer
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
          DelegStakeTxCert StakeCredential (EraCrypto era)
delegCred KeyHash 'StakePool (EraCrypto era)
delegKey ->
            let ([TxCert era]
dcs', Map (StakeCredential StandardCrypto) Coin
regCreds') =
                  if StakeCredential (EraCrypto era)
delegCred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (StakeCredential StandardCrypto) Coin
regCreds
                    then ([TxCert era]
dcs, Map (StakeCredential StandardCrypto) 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.
                      ( (forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert StakeCredential (EraCrypto era)
delegCred) forall a. a -> [a] -> [a]
: [TxCert era]
dcs
                      , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StakeCredential (EraCrypto era)
delegCred (Integer -> Coin
Coin Integer
99) Map (StakeCredential StandardCrypto) Coin
regCreds
                      )
             in [TxCert era]
-> Map (StakeCredential StandardCrypto) Coin
-> Maybe (KeyHash 'StakePool StandardCrypto)
-> Maybe (IsValid, ScriptHash StandardCrypto)
-> ([TxCert era],
    Set
      (ScriptHash StandardCrypto,
       Maybe (KeyHash 'StakePool StandardCrypto)),
    Map (StakeCredential StandardCrypto) Coin)
insertIfNotPresent [TxCert era]
dcs' Map (StakeCredential StandardCrypto) Coin
regCreds' (forall a. a -> Maybe a
Just KeyHash 'StakePool (EraCrypto era)
delegKey)
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (k :: KeyRole) era.
Credential k (EraCrypto era)
-> PlutusPurposeTag
-> GenRS era (Maybe (IsValid, ScriptHash (EraCrypto era)))
plutusScriptHashFromTag StakeCredential (EraCrypto era)
delegCred PlutusPurposeTag
Certifying
          TxCert era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
ss, Map (StakeCredential StandardCrypto) Coin
regCreds)
  Int
maxcert <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getCertificateMax
  Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxcert)
  Map (StakeCredential StandardCrypto) Coin
reward <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era
-> Map (Credential 'Staking (EraCrypto era)) Coin
mRewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  let initSets ::
        ( [TxCert era]
        , Set (ScriptHash (EraCrypto era), Maybe (KeyHash 'StakePool (EraCrypto era)))
        , Map (Credential 'Staking (EraCrypto era)) Coin
        )
      initSets :: ([TxCert era],
 Set
   (ScriptHash (EraCrypto era),
    Maybe (KeyHash 'StakePool (EraCrypto era))),
 Map (StakeCredential (EraCrypto era)) Coin)
initSets = ([], forall a. Set a
Set.empty, Map (StakeCredential StandardCrypto) Coin
reward)
  ([TxCert era]
dcs, Set
  (ScriptHash StandardCrypto,
   Maybe (KeyHash 'StakePool StandardCrypto))
_, Map (StakeCredential StandardCrypto) 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 StandardCrypto,
    Maybe (KeyHash 'StakePool StandardCrypto)),
 Map (StakeCredential StandardCrypto) Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era],
      Set
        (ScriptHash StandardCrypto,
         Maybe (KeyHash 'StakePool StandardCrypto)),
      Map (StakeCredential StandardCrypto) Coin)
genUniqueScript ([TxCert era],
 Set
   (ScriptHash (EraCrypto era),
    Maybe (KeyHash 'StakePool (EraCrypto era))),
 Map (StakeCredential (EraCrypto era)) Coin)
initSets [Int
1 :: Int .. Int
n]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
  Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
_) StakeReference (EraCrypto era)
_ -> Bool
False
  Addr (EraCrypto era)
_ -> 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 (EraCrypto era)] ->
  Coin ->
  MUtxo era ->
  GenRS era (MUtxo era, Map.Map (TxIn (EraCrypto era)) (TxOut era), Coin)
genCollateralUTxO :: forall era.
(HasCallStack, Reflect era) =>
[Addr (EraCrypto era)]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr (EraCrypto era)]
collateralAddresses (Coin Integer
fee) MUtxo era
utxo = do
  GenEnv {PParams era
gePParams :: PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  let collPerc :: Natural
collPerc = forall era. Proof era -> PParams era -> Natural
collateralPercentage' forall era. Reflect era => Proof era
reify PParams era
gePParams
      minCollTotal :: Coin
minCollTotal = Integer -> Coin
Coin (forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Integer
fee forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger Natural
collPerc) 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 (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genNewCollateral Addr (EraCrypto era)
addr Map (TxIn StandardCrypto) (TxOut era)
coll Map (TxIn StandardCrypto) (TxOut era)
um Coin
c = do
        -- The size of the Gen computation is driven down when we generate scripts, so it can be 0 here
        -- that is really bad, because if the happens we get the same TxIn every time, and 'coll' never grows,
        -- so this function doesn't terminate. We want many choices of TxIn, so resize just this arbitrary by 30.
        Map (TxIn StandardCrypto) (TxOut era)
entriesInUse <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map (TxIn (EraCrypto era)) (TxOut era)
gsInitialUtxo
        TxIn StandardCrypto
txIn <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
30 (forall a. Arbitrary a => Gen a
arbitrary :: Gen (TxIn (EraCrypto era))))
        if forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn StandardCrypto
txIn MUtxo era
utxo Bool -> Bool -> Bool
|| forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn StandardCrypto
txIn Map (TxIn StandardCrypto) (TxOut era)
coll Bool -> Bool -> Bool
|| TxIn StandardCrypto
txIn forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (TxIn StandardCrypto) (TxOut era)
entriesInUse
          then Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genNewCollateral Addr (EraCrypto era)
addr Map (TxIn StandardCrypto) (TxOut era)
coll Map (TxIn StandardCrypto) (TxOut era)
um Coin
c
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (TxIn StandardCrypto) (TxOut era)
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn StandardCrypto
txIn (forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [forall era. Addr (EraCrypto era) -> TxOutField era
Address Addr (EraCrypto era)
addr, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject Coin
c)]) Map (TxIn StandardCrypto) (TxOut era)
coll, Coin
c)
      -- Either pick a collateral from a map or generate a completely new one
      genCollateral :: Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genCollateral Addr (EraCrypto era)
addr Map (TxIn StandardCrypto) (TxOut era)
coll Map (TxIn StandardCrypto) (TxOut era)
um
        | forall k a. Map k a -> Bool
Map.null Map (TxIn StandardCrypto) (TxOut era)
um = Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genNewCollateral Addr (EraCrypto era)
addr Map (TxIn StandardCrypto) (TxOut era)
coll Map (TxIn StandardCrypto) (TxOut era)
um forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
        | Bool
otherwise = do
            Int
i <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, forall k a. Map k a -> Int
Map.size Map (TxIn StandardCrypto) (TxOut era)
um forall a. Num a => a -> a -> a
- Int
1)
            let (TxIn StandardCrypto
txIn, TxOut era
txOut) = forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i Map (TxIn StandardCrypto) (TxOut era)
um
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
i Map (TxIn StandardCrypto) (TxOut era)
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn StandardCrypto
txIn TxOut era
txOut Map (TxIn StandardCrypto) (TxOut era)
coll, TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => 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 (EraCrypto era)] ->
        Map (TxIn (EraCrypto era)) (TxOut era) ->
        Coin ->
        Map (TxIn (EraCrypto era)) (TxOut era) ->
        GenRS era (Map (TxIn (EraCrypto era)) (TxOut era), Coin)
      go :: [Addr (EraCrypto era)]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr (EraCrypto era)]
ecs !MUtxo era
coll !Coin
curCollTotal !MUtxo era
um
        | Coin
curCollTotal forall a. Ord a => a -> a -> Bool
>= Coin
minCollTotal = forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era
coll, Coin
curCollTotal forall t. Val t => t -> t -> t
<-> Coin
minCollTotal)
        | [] <- [Addr (EraCrypto era)]
ecs = forall a. HasCallStack => String -> a
error String
"Impossible: supplied less addresses than `maxCollateralInputs`"
        | Addr (EraCrypto era)
ec : [Addr (EraCrypto era)]
ecs' <- [Addr (EraCrypto era)]
ecs = do
            (Map (TxIn StandardCrypto) (TxOut era)
um', Map (TxIn StandardCrypto) (TxOut era)
coll', Coin
c) <-
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr (EraCrypto era)]
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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
                    Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Coin
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genNewCollateral Addr (EraCrypto era)
ec MUtxo era
coll MUtxo era
um ((Coin
minCollTotal forall t. Val t => t -> t -> t
<-> Coin
curCollTotal) forall t. Val t => t -> t -> t
<+> Coin
excess)
                else forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genCollateral Addr (EraCrypto era)
ec MUtxo era
coll forall k a. Map k a
Map.empty, Addr (EraCrypto era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> Map (TxIn StandardCrypto) (TxOut era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (TxIn StandardCrypto) (TxOut era),
      Map (TxIn StandardCrypto) (TxOut era), Coin)
genCollateral Addr (EraCrypto era)
ec MUtxo era
coll MUtxo era
um]
            [Addr (EraCrypto era)]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr (EraCrypto era)]
ecs' Map (TxIn StandardCrypto) (TxOut era)
coll' (Coin
curCollTotal forall t. Val t => t -> t -> t
<+> Coin
c) Map (TxIn StandardCrypto) (TxOut era)
um'
  (Map (TxIn StandardCrypto) (TxOut era)
collaterals, Coin
excessColCoin) <-
    [Addr (EraCrypto era)]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr (EraCrypto era)]
collateralAddresses forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0) forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter forall era. EraTxOut era => TxOut era -> Bool
spendOnly MUtxo era
utxo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (TxIn StandardCrypto) (TxOut era)
collaterals MUtxo era
utxo, Map (TxIn StandardCrypto) (TxOut era)
collaterals, Coin
excessColCoin)

-- | This function is used to generate the Outputs of a TxBody, It is computed by taking the
--   Outputs of the range of the (UTxO resticted by the Inputs of the TxBody),
--   as input to the function, and then making new Outputs, where the sum of the Coin is the same.
--   This way we generate a 'balanced' TxBody (modulo fees, deposits, refunds etc. which are
--   handled separately). The idea is to make sum(txOuts) == sum(genRecipientsFrom txouts), the
--   sum will be the same, but the size may be different.
genRecipientsFrom :: 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut era]
txOuts
  Int
approxCount <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
outCount)
  let extra :: Int
extra = Int
outCount forall a. Num a => a -> a -> a
- Int
approxCount
      avgExtra :: Int
avgExtra = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Integral a => a -> Integer
toInteger Int
extra forall a. Integral a => a -> a -> Ratio a
% forall a. Integral a => a -> Integer
toInteger Int
approxCount)
      genExtra :: Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        | Int
e forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
avgExtra forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 = 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 forall a. Num a => a -> a -> a
- Int
leftToAdd) Int
leftToAdd (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 = forall {era}.
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {era}.
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 forall a. Num a => a -> a -> a
- Int
1) (Value era
s 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut 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 (EraCrypto era)
addr, !Value era
v, ![TxOutField era]
ds) = forall era.
Proof era
-> TxOut era -> (Addr (EraCrypto era), Value era, [TxOutField era])
txoutFields forall era. Reflect era => Proof era
reify TxOut era
txout
            vCoin :: Integer
vCoin = Coin -> Integer
unCoin (forall t. Val t => t -> Coin
coin Value era
v)
        if Integer
vCoin forall a. Eq a => a -> a -> Bool
== Integer
0 -- If the coin balance is 0, don't add any TxOuts to 'rs'
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut era]
rs
          else do
            Coin
c <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
vCoin))
            [TxOutField era]
fields <- forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut forall era. Reflect era => Proof era
reify (Value era
s forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject Coin
c)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              if Coin
c forall a. Ord a => a -> a -> Bool
< forall t. Val t => t -> Coin
coin Value era
v
                then
                  let !change :: TxOut era
change = forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify (forall era. Addr (EraCrypto era) -> TxOutField era
Address Addr (EraCrypto era)
addr forall a. a -> [a] -> [a]
: forall era. Value era -> TxOutField era
Amount (Value era
v forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
c) forall a. a -> [a] -> [a]
: [TxOutField era]
ds)
                   in forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [TxOutField era]
fields forall a. a -> [a] -> [a]
: TxOut era
change forall a. a -> [a] -> [a]
: [TxOut era]
rs
                else forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [TxOutField era]
fields 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 (EraCrypto era))
getTxCertCredential :: forall era.
Reflect era =>
TxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getTxCertCredential = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> forall era.
ShelleyTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getShelleyTxCertCredential
  Proof era
Mary -> forall era.
ShelleyTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getShelleyTxCertCredential
  Proof era
Allegra -> forall era.
ShelleyTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getShelleyTxCertCredential
  Proof era
Alonzo -> forall era.
ShelleyTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getShelleyTxCertCredential
  Proof era
Babbage -> forall era.
ShelleyTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getShelleyTxCertCredential
  Proof era
Conway -> forall era.
ConwayTxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getConwayTxCertCredential

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

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

genWithdrawals ::
  Reflect era => SlotNo -> GenRS era (Withdrawals (EraCrypto era), RewardAccounts (EraCrypto era))
genWithdrawals :: forall era.
Reflect era =>
SlotNo
-> GenRS
     era (Withdrawals (EraCrypto era), RewardAccounts (EraCrypto era))
genWithdrawals SlotNo
slot =
  if SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0
    then do
      let networkId :: Network
networkId = Network
Testnet
      Map (StakeCredential StandardCrypto) Coin
newRewards <- forall era.
Reflect era =>
GenRS era (RewardAccounts (EraCrypto era))
genRewards
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
networkId) Map (StakeCredential StandardCrypto) Coin
newRewards, Map (StakeCredential StandardCrypto) Coin
newRewards)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals forall k a. Map k a
Map.empty, 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 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 (EraCrypto era)
txin, TxOut era
_)) = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn (EraCrypto era)
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 StandardCrypto, TxOut era)
_fee, Maybe (TxIn StandardCrypto, TxOut era)
_old) <- forall era.
Reflect era =>
Proof era
-> SlotNo
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo Proof era
proof SlotNo
slot
  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 :: PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  ValidityInterval
validityInterval <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  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
gsValidityInterval = ValidityInterval
validityInterval})

  -- 1. Produce utxos that will be spent
  (Map (TxIn StandardCrypto) (TxOut era)
utxoChoices, Maybe (TxIn StandardCrypto, TxOut era)
maybeoldpair) <- 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 :: (TxIn StandardCrypto, TxOut era)
feepair@(TxIn StandardCrypto
feeKey, TxOut era
_) -- One of the spending inputs, to be used to pay the fee
    , Map (TxIn StandardCrypto) (TxOut era)
toSpendNoCollateral -- All of the spending inputs
    , Map (TxIn StandardCrypto) (TxOut era)
refInputsUtxo -- All the reference inputs
    , Map (TxIn StandardCrypto) (TxOut era)
utxoNoCollateral -- Union of all the above
    ) <-
    forall era.
Map (TxIn (EraCrypto era)) (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map (TxIn (EraCrypto era)) (TxOut era),
      Map (TxIn (EraCrypto era)) (TxOut era),
      Map (TxIn (EraCrypto era)) (TxOut era))
genSpendReferenceInputs Map (TxIn StandardCrypto) (TxOut era)
utxoChoices

  -- 3. Check if all Plutus scripts are valid
  let toSpendNoCollateralTxOuts :: [TxOut era]
      toSpendNoCollateralTxOuts :: [TxOut era]
toSpendNoCollateralTxOuts = forall k a. Map k a -> [a]
Map.elems Map (TxIn StandardCrypto) (TxOut era)
toSpendNoCollateral
      -- We use maxBound to ensure the serialized size overestimation
      maxCoin :: Coin
maxCoin = Integer -> Coin
Coin (forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int))
  -- 4. Generate all recipients and witnesses needed for spending Plutus scripts
  [TxOut era]
recipients <- 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) <-
    forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k (EraCrypto era))]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker
      Proof era
proof
      PlutusPurposeTag
Spending
      [ (\DataHash StandardCrypto
dh Credential 'Payment StandardCrypto
cred -> (forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"datum" DataHash StandardCrypto
dh forall era.
GenState era -> Map (DataHash (EraCrypto era)) (Data era)
gsDatums, Credential 'Payment StandardCrypto
cred))
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (DataHash (EraCrypto era))
mDatumHash
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> Maybe a
Just Credential 'Payment StandardCrypto
credential
      | (TxIn StandardCrypto
_, TxOut era
coretxout) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map (TxIn StandardCrypto) (TxOut era)
toSpendNoCollateral
      , let ([Credential 'Payment (EraCrypto era)]
credentials, Maybe (DataHash (EraCrypto era))
mDatumHash) = forall era.
Proof era
-> TxOut era
-> ([Credential 'Payment (EraCrypto era)],
    Maybe (DataHash (EraCrypto era)))
txoutEvidence Proof era
proof TxOut era
coretxout
      , Credential 'Payment StandardCrypto
credential <- [Credential 'Payment (EraCrypto era)]
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 StandardCrypto
withdrawals@(Withdrawals Map (RewardAcnt StandardCrypto) Coin
wdrlMap), Map (StakeCredential StandardCrypto) Coin
newRewards) <- forall era.
Reflect era =>
SlotNo
-> GenRS
     era (Withdrawals (EraCrypto era), RewardAccounts (EraCrypto era))
genWithdrawals SlotNo
slot
  let withdrawalAmount :: Coin
withdrawalAmount = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold Map (RewardAcnt StandardCrypto) Coin
wdrlMap

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

  [TxCert era]
dcerts <- forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts SlotNo
slot
  let dcertCreds :: [Maybe (StakeCredential StandardCrypto)]
dcertCreds = forall a b. (a -> b) -> [a] -> [b]
map forall era.
Reflect era =>
TxCert era -> Maybe (Credential 'Staking (EraCrypto era))
getTxCertCredential [TxCert era]
dcerts
  (IsValid Bool
v3, [ExUnits -> [WitnessesField era]]
mkCertsWits) <-
    forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k (EraCrypto era))]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
Certifying forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((,) forall era. Era era => GenRS era (Data era)
genDatum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Maybe (StakeCredential StandardCrypto)]
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 forall a. [a] -> [a] -> [a]
++ [ExUnits -> [WitnessesField era]]
mkCertsWits forall a. [a] -> [a] -> [a]
++ [ExUnits -> [WitnessesField era]]
mkWithdrawalsWits
  [ExUnits]
exUnits <- forall era. Proof era -> Int -> GenRS era [ExUnits]
genExUnits Proof era
proof (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExUnits -> [WitnessesField era]]
mkWits)

  let redeemerWitsList :: [WitnessesField era]
      redeemerWitsList :: [WitnessesField era]
redeemerWitsList = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) [ExUnits -> [WitnessesField era]]
mkWits [ExUnits]
exUnits)
  [WitnessesField era]
datumWitsList <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness Proof era
proof) (forall k a. Map k a -> [a]
Map.elems Map (TxIn StandardCrypto) (TxOut era)
toSpendNoCollateral)
  [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
keyWitsMakers <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      (forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending))
      ([TxOut era]
toSpendNoCollateralTxOuts forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map (TxIn StandardCrypto) (TxOut era)
refInputsUtxo)
  [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
dcertWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genCredKeyWit Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Certifying)) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (StakeCredential StandardCrypto)]
dcertCreds
  [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
rwdrsWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr (EraCrypto era)
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genCredKeyWit Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Rewarding)) [StakeCredential StandardCrypto]
wdrlCreds

  -- 5. Estimate inputs that will be used as collateral
  Int
maxCollateralCount <-
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall era. Proof era -> PParams era -> Natural
maxCollateralInputs' Proof era
proof PParams era
gePParams))
  TxId StandardCrypto
bogusCollateralTxId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen (TxId (EraCrypto era)))
  let bogusCollateralTxIns :: Set (TxIn StandardCrypto)
bogusCollateralTxIns =
        forall a. Ord a => [a] -> Set a
Set.fromList
          [ forall c. TxId c -> TxIx -> TxIn c
TxIn TxId StandardCrypto
bogusCollateralTxId (HasCallStack => Integer -> TxIx
mkTxIxPartial (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i))
          | Word16
i <- [forall a. Bounded a => a
maxBound, forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Word16
1 .. forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxCollateralCount forall a. Num a => a -> a -> a
- Word16
1] :: [Word16]
          ]
  [Addr StandardCrypto]
collateralAddresses <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
maxCollateralCount forall era. Reflect era => GenRS era (Addr (EraCrypto era))
genNoScriptRecipient
  [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
bogusCollateralKeyWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Addr StandardCrypto]
collateralAddresses forall a b. (a -> b) -> a -> b
$ \Addr StandardCrypto
a ->
    forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era
     (SafeHash (EraCrypto era) EraIndependentTxBody
      -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof forall a. Maybe a
Nothing (forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof [forall era. Addr (EraCrypto era) -> TxOutField era
Address Addr StandardCrypto
a, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject Coin
maxCoin)])
  StrictMaybe Network
networkId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [a] -> Gen a
elements [forall a. StrictMaybe a
SNothing, 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 <- forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
9, forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
_ = forall a. StrictMaybe a
SNothing
      updateTotalColl (SJust (Coin Integer
n)) (Coin Integer
m) = forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin (Integer
n 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 forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof era
proof forall a. Ord a => a -> a -> Bool
>= forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof (BabbageEra StandardCrypto)
Babbage
      then
        forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
          [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing)
          , (Int
9, forall a. a -> StrictMaybe a
SJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut Proof era
proof (forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
0)))
          ]
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
  let updateCollReturn :: StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
SNothing Coin
_ = forall a. StrictMaybe a
SNothing
      updateCollReturn (SJust TxOut era
txout) Coin
v = forall a. a -> StrictMaybe a
SJust (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 forall a. [a] -> [a] -> [a]
++ [WitnessesField era]
datumWitsList
      bogusIntegrityHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
bogusIntegrityHash = forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
newScriptIntegrityHash Proof era
proof PParams era
gePParams forall a. Monoid a => a
mempty (forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof []) forall a. Monoid a => a
mempty
      inputSet :: Set (TxIn StandardCrypto)
inputSet = forall k a. Map k a -> Set k
Map.keysSet Map (TxIn StandardCrypto) (TxOut era)
toSpendNoCollateral
      outputList :: [TxOut era]
outputList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut era]
recipients (forall a. a -> [a] -> [a]
: [TxOut era]
recipients) Maybe (TxOut era)
rewardsWithdrawalTxOut
      txBodyNoFee :: TxBody era
txBodyNoFee =
        forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
coreTxBody
          Proof era
proof
          [ forall era. Set (TxIn (EraCrypto era)) -> TxBodyField era
Inputs Set (TxIn StandardCrypto)
inputSet
          , forall era. Set (TxIn (EraCrypto era)) -> TxBodyField era
Collateral Set (TxIn StandardCrypto)
bogusCollateralTxIns
          , forall era. Set (TxIn (EraCrypto era)) -> TxBodyField era
RefInputs (forall k a. Map k a -> Set k
Map.keysSet Map (TxIn StandardCrypto) (TxOut era)
refInputsUtxo)
          , forall era. StrictMaybe Coin -> TxBodyField era
TotalCol StrictMaybe Coin
bogusTotalCol
          , forall era. [TxOut era] -> TxBodyField era
Outputs' [TxOut era]
outputList
          , forall era. StrictMaybe (TxOut era) -> TxBodyField era
CollateralReturn StrictMaybe (TxOut era)
bogusCollReturn
          , forall era. [TxCert era] -> TxBodyField era
Certs' [TxCert era]
dcerts
          , forall era. Withdrawals (EraCrypto era) -> TxBodyField era
Withdrawals' Withdrawals StandardCrypto
withdrawals
          , forall era. Coin -> TxBodyField era
Txfee Coin
maxCoin
          , if forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof era
proof forall a. Ord a => a -> a -> Bool
>= forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof (AllegraEra StandardCrypto)
Allegra
              then forall era. ValidityInterval -> TxBodyField era
Vldt ValidityInterval
validityInterval
              else forall era. SlotNo -> TxBodyField era
TTL (ValidityInterval -> SlotNo
timeToLive ValidityInterval
validityInterval)
          , forall era. [Update era] -> TxBodyField era
Update' []
          , forall era. [KeyHash 'Witness (EraCrypto era)] -> TxBodyField era
ReqSignerHashes' []
          , forall era. MultiAsset (EraCrypto era) -> TxBodyField era
Generic.Mint forall a. Monoid a => a
mempty
          , forall era.
StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> TxBodyField era
WppHash StrictMaybe (ScriptIntegrityHash (EraCrypto era))
bogusIntegrityHash
          , forall era. [AuxiliaryDataHash (EraCrypto era)] -> TxBodyField era
AdHash' []
          , forall era. StrictMaybe Network -> TxBodyField era
Txnetworkid StrictMaybe Network
networkId
          ]
      txBodyNoFeeHash :: SafeHash StandardCrypto EraIndependentTxBody
txBodyNoFeeHash = forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBodyNoFee
      witsMakers :: [SafeHash (EraCrypto era) EraIndependentTxBody -> [WitnessesField era]]
      witsMakers :: [SafeHash (EraCrypto era) EraIndependentTxBody
 -> [WitnessesField era]]
witsMakers = [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
keyWitsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
dcertWitsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
rwdrsWitsMakers
      bogusNeededScripts :: Set (ScriptHash (EraCrypto era))
bogusNeededScripts = forall era.
Proof era
-> MUtxo era -> TxBody era -> Set (ScriptHash (EraCrypto era))
scriptWitsNeeded' Proof era
proof Map (TxIn StandardCrypto) (TxOut era)
utxoNoCollateral TxBody era
txBodyNoFee
      noFeeWits :: [WitnessesField era]
      noFeeWits :: [WitnessesField era]
noFeeWits =
        forall era.
Proof era
-> Set (ScriptHash (EraCrypto era))
-> [WitnessesField era]
-> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set (ScriptHash (EraCrypto era))
bogusNeededScripts forall a b. (a -> b) -> a -> b
$
          [WitnessesField era]
redeemerDatumWits
            forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> a -> b
$ SafeHash StandardCrypto EraIndependentTxBody
txBodyNoFeeHash) ([SafeHash (EraCrypto era) EraIndependentTxBody
 -> [WitnessesField era]]
witsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash StandardCrypto EraIndependentTxBody
 -> [WitnessesField era]]
bogusCollateralKeyWitsMakers)
      bogusTxForFeeCalc :: Tx era
bogusTxForFeeCalc =
        forall era. Proof era -> [TxField era] -> Tx era
coreTx
          Proof era
proof
          [ forall era. TxBody era -> TxField era
Body TxBody era
txBodyNoFee
          , forall era. TxWits era -> TxField era
TxWits (forall era.
Era era =>
Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
proof [WitnessesField era]
noFeeWits)
          , forall era. IsValid -> TxField era
Valid IsValid
isValid
          , forall era. [TxAuxData era] -> TxField era
AuxData' []
          ]
      fee :: Coin
fee = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
gePParams Tx era
bogusTxForFeeCalc (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn StandardCrypto) (TxOut era)
refInputsUtxo)

  Map (StakeCredential StandardCrypto) Coin
keyDeposits <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era
-> Map (Credential 'Staking (EraCrypto era)) Coin
mKeyDeposits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  let deposits :: Coin
deposits = case Proof era
proof of
        Proof era
Shelley -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) Coin
keyDeposits
        Proof era
Mary -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) Coin
keyDeposits
        Proof era
Allegra -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) Coin
keyDeposits
        Proof era
Alonzo -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) Coin
keyDeposits
        Proof era
Babbage -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) Coin
keyDeposits
        Proof era
Conway -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map (StakeCredential StandardCrypto) 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 StandardCrypto) (TxOut era)
utxoFeeAdjusted = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall era.
EraTxOut era =>
Proof era -> Coin -> TxOut era -> TxOut era
injectFee Proof era
proof (Coin
fee forall t. Val t => t -> t -> t
<+> Coin
deposits)) TxIn StandardCrypto
feeKey Map (TxIn StandardCrypto) (TxOut era)
utxoNoCollateral

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

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

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn StandardCrypto) (TxOut era)
utxo, Tx era
validTx, (TxIn StandardCrypto, TxOut era)
feepair, Maybe (TxIn StandardCrypto, TxOut era)
maybeoldpair)

-- | Keep only Script witnesses that are neccessary in 'era',
onlyNecessaryScripts ::
  Proof era -> Set (ScriptHash (EraCrypto era)) -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts :: forall era.
Proof era
-> Set (ScriptHash (EraCrypto era))
-> [WitnessesField era]
-> [WitnessesField era]
onlyNecessaryScripts Proof era
_ Set (ScriptHash (EraCrypto era))
_ [] = []
onlyNecessaryScripts Proof era
proof Set (ScriptHash (EraCrypto era))
hashes (ScriptWits Map (ScriptHash (EraCrypto era)) (Script era)
m : [WitnessesField era]
xs) =
  forall era.
Map (ScriptHash (EraCrypto era)) (Script era) -> WitnessesField era
ScriptWits (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (ScriptHash (EraCrypto era)) (Script era)
m Set (ScriptHash (EraCrypto era))
hashes) forall a. a -> [a] -> [a]
: forall era.
Proof era
-> Set (ScriptHash (EraCrypto era))
-> [WitnessesField era]
-> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set (ScriptHash (EraCrypto era))
hashes [WitnessesField era]
xs
onlyNecessaryScripts Proof era
proof Set (ScriptHash (EraCrypto era))
hashes (WitnessesField era
x : [WitnessesField era]
xs) = WitnessesField era
x forall a. a -> [a] -> [a]
: forall era.
Proof era
-> Set (ScriptHash (EraCrypto era))
-> [WitnessesField era]
-> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set (ScriptHash (EraCrypto era))
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 = forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' 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 forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [(k, a)]
Map.toList (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 = forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
TxDats (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map (DataHash (EraCrypto era)) (Data era)
-> WitnessesField era -> Map (DataHash (EraCrypto era)) (Data era)
accum forall k a. Map k a
Map.empty [WitnessesField era]
fields)
  where
    accum :: Map (DataHash (EraCrypto era)) (Data era)
-> WitnessesField era -> Map (DataHash (EraCrypto era)) (Data era)
accum Map (DataHash (EraCrypto era)) (Data era)
m (DataWits' [Data era]
ds) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map (DataHash (EraCrypto era)) (Data era)
-> Data era -> Map (DataHash (EraCrypto era)) (Data era)
accum2 Map (DataHash (EraCrypto era)) (Data era)
m [Data era]
ds
      where
        accum2 :: Map (DataHash (EraCrypto era)) (Data era)
-> Data era -> Map (DataHash (EraCrypto era)) (Data era)
accum2 Map (DataHash (EraCrypto era)) (Data era)
m2 Data era
d = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData @era Data era
d) Data era
d Map (DataHash (EraCrypto era)) (Data era)
m2
    accum Map (DataHash (EraCrypto era)) (Data era)
m WitnessesField era
_ = Map (DataHash (EraCrypto era)) (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) =
    forall a. Show a => a -> String
show 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 = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Babbage RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Alonzo RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Mary RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Allegra RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Shelley RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc