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

-- | Strategy for Generic Tests
--   Make the GenState include a Mode of the NewEpochState, modify
--   the ModelNewEpochState to reflect what we generated.
module Test.Cardano.Ledger.Generic.GenState (
  GenEnv (..),
  GenRS,
  GenState (..),
  GenSize (..),
  PlutusPurposeTag (..),
  plutusPurposeTags,
  mkRedeemers,
  mkRedeemersFromTags,
  mkPlutusPurposePointer,
  mkAlonzoPlutusPurposePointer,
  mkConwayPlutusPurposePointer,
  elementsT, -- TODO move to a utilities module
  frequencyT, -- TODO move to a utilities module
  positiveSingleDigitInt,
  nonNegativeSingleDigitInt,
  genSetElem,
  genMapElem,
  genMapElemWhere,
  genRewardVal,
  genPositiveVal,
  genGenState,
  genGenEnv,
  genValidityInterval,
  getBlocksizeMax,
  getCertificateMax,
  getOldUtxoPercent,
  getRefInputsMax,
  getReserves,
  getSlot,
  getSlotDelta,
  getSpendInputsMax,
  getTreasury,
  getUtxoChoicesMax,
  getUtxoElem,
  getUtxoTest,
  getCollInputsMax,
  getNewPoolTest,
  viewGenState,
  initialLedgerState,
  modifyModel,
  runGenRS,
  ioGenRS,
  small,
  genDatumWithHash,
  genKeyHash,
  genScript,
  genFreshKeyHash,
  genCredential,
  genFreshCredential,
  genFreshRegCred,
  genPool,
  genPoolParams,
  genRewards,
  genNewPool,
  genRetirementHash,
  initStableFields,
  modifyGenStateInitialUtxo,
  modifyGenStateInitialRewards,
  modifyModelCount,
  modifyModelIndex,
  modifyModelUTxO,
  modifyModelMutFee,
) where

import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
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.TxWits (Redeemers (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), Network (Testnet), inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj), StakeCredential)
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  CertState (..),
  DState (..),
  LedgerState (..),
  PState (..),
  RewardAccounts,
  smartUTxOState,
  totalObligation,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (join, replicateM, when, zipWithM_)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (RWST (..), ask, asks, get, gets, modify)
import Control.SetAlgebra (eval, (⨃))
import Data.Default (Default (def))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (SJust, SNothing))
import qualified Data.Sequence.Strict as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Word (Word32, Word64)
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Generic.Fields
import Test.Cardano.Ledger.Generic.Functions (
  alwaysFalse,
  alwaysTrue,
  primaryLanguage,
  protocolVersion,
  txoutFields,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  ModelNewEpochState (..),
  genDelegsZero,
  instantaneousRewardsZero,
  mKeyDeposits,
  mNewEpochStateZero,
  mPoolDeposits,
  pcModelNewEpochState,
 )
import Test.Cardano.Ledger.Generic.PrettyCore (
  PDoc,
  PrettyA (..),
  pcCoin,
  pcCredential,
  pcIndividualPoolStake,
  pcKeyHash,
  pcPoolParams,
  pcTxIn,
  pcTxOut,
  ppInt,
  ppMap,
  ppRecord,
  ppSet,
  ppString,
  ppValidityInterval,
 )
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Generic.Updaters (defaultCostModels, newPParams)
import Test.Tasty.QuickCheck (
  Gen,
  Positive (..),
  arbitrary,
  choose,
  chooseInt,
  elements,
  frequency,
  generate,
 )

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

-- | Constants that determine how big a GenState is generated.
data GenSize = GenSize
  { GenSize -> Integer
treasury :: !Integer
  , GenSize -> Integer
reserves :: !Integer
  , GenSize -> Word64
startSlot :: !Word64
  , GenSize -> (Word64, Word64)
slotDelta :: !(Word64, Word64)
  , GenSize -> Integer
blocksizeMax :: !Integer
  , GenSize -> Natural
collInputsMax :: !Natural
  , GenSize -> Int
spendInputsMax :: !Int
  , GenSize -> Int
refInputsMax :: !Int
  , GenSize -> Int
utxoChoicesMax :: !Int
  , GenSize -> Int
certificateMax :: !Int
  , GenSize -> Int
withdrawalMax :: !Int
  , GenSize -> Int
oldUtxoPercent :: !Int -- between 0-100, 10 means pick an old UTxO 10% of the time
  , GenSize -> Int
maxStablePools :: !Int
  , GenSize -> Int
invalidScriptFreq :: !Int -- percentage
  , GenSize -> Int
regCertFreq :: !Int
  , GenSize -> Int
delegCertFreq :: !Int
  }
  deriving (Int -> GenSize -> ShowS
[GenSize] -> ShowS
GenSize -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenSize] -> ShowS
$cshowList :: [GenSize] -> ShowS
show :: GenSize -> String
$cshow :: GenSize -> String
showsPrec :: Int -> GenSize -> ShowS
$cshowsPrec :: Int -> GenSize -> ShowS
Show)

data GenEnv era = GenEnv
  { forall era. GenEnv era -> PParams era
gePParams :: !(PParams era)
  , forall era. GenEnv era -> GenSize
geSize :: !GenSize
  }

data GenState era = GenState
  { forall era. GenState era -> ValidityInterval
gsValidityInterval :: !ValidityInterval
  , forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys :: !(Map (KeyHash 'Witness) (KeyPair 'Witness))
  , forall era. GenState era -> Map ScriptHash (Script era)
gsScripts :: !(Map ScriptHash (Script era))
  , forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts :: !(Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
  , forall era. GenState era -> Map DataHash (Data era)
gsDatums :: !(Map DataHash (Data era))
  , forall era. GenState era -> Map ValidityInterval (Set ScriptHash)
gsVI :: !(Map ValidityInterval (Set ScriptHash))
  , forall era. GenState era -> ModelNewEpochState era
gsModel :: !(ModelNewEpochState era)
  , forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo :: !(Map TxIn (TxOut era))
  , forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards :: !(Map (Credential 'Staking) Coin)
  , forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations ::
      !(Map (Credential 'Staking) (KeyHash 'StakePool))
  , forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  , forall era.
GenState era -> Map (KeyHash 'StakePool) IndividualPoolStake
gsInitialPoolDistr ::
      !(Map (KeyHash 'StakePool) IndividualPoolStake)
  , -- Stable fields are stable from initialization to the end of the generation process
    forall era. GenState era -> Set (KeyHash 'StakePool)
gsStablePools :: !(Set (KeyHash 'StakePool))
  , forall era. GenState era -> Set (Credential 'Staking)
gsStableDelegators :: !(Set StakeCredential)
  , forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred :: !(Set (Credential 'Staking))
  , forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey :: !(Set (KeyHash 'StakePool))
  , forall era. GenState era -> Proof era
gsProof :: !(Proof era)
  , forall era. GenState era -> GenEnv era
gsGenEnv :: !(GenEnv era)
  , forall era. GenState era -> Int
gsSeedIdx :: !Int
  }

emptyGenState :: Reflect era => Proof era -> GenEnv era -> GenState era
emptyGenState :: forall era. Reflect era => Proof era -> GenEnv era -> GenState era
emptyGenState Proof era
proof GenEnv era
genv =
  forall era.
ValidityInterval
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map ScriptHash (Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map DataHash (Data era)
-> Map ValidityInterval (Set ScriptHash)
-> ModelNewEpochState era
-> Map TxIn (TxOut era)
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Set (KeyHash 'StakePool)
-> Set (Credential 'Staking)
-> Set (Credential 'Staking)
-> Set (KeyHash 'StakePool)
-> Proof era
-> GenEnv era
-> Int
-> GenState era
GenState
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval forall a. StrictMaybe a
SNothing forall a. StrictMaybe a
SNothing)
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    (forall era. Reflect era => ModelNewEpochState era
mNewEpochStateZero {mPParams :: PParams era
mPParams = forall era. GenEnv era -> PParams era
gePParams GenEnv era
genv})
    forall k a. Map k a
Map.empty
    forall k a. Map k a
Map.empty
    forall k a. Map k a
Map.empty
    forall k a. Map k a
Map.empty
    forall k a. Map k a
Map.empty
    forall a. Set a
Set.empty
    forall a. Set a
Set.empty
    forall a. Set a
Set.empty
    forall a. Set a
Set.empty
    Proof era
proof
    GenEnv era
genv
    Int
0
{-# NOINLINE emptyGenState #-}

instance Default GenSize where
  def :: GenSize
def =
    GenSize
      { treasury :: Integer
treasury = Integer
1000000
      , reserves :: Integer
reserves = Integer
1000000
      , startSlot :: Word64
startSlot = Word64
0
      , slotDelta :: (Word64, Word64)
slotDelta = (Word64
3, Word64
7)
      , blocksizeMax :: Integer
blocksizeMax = Integer
10
      , collInputsMax :: Natural
collInputsMax = Natural
5
      , oldUtxoPercent :: Int
oldUtxoPercent = Int
15
      , spendInputsMax :: Int
spendInputsMax = Int
10
      , refInputsMax :: Int
refInputsMax = Int
6
      , utxoChoicesMax :: Int
utxoChoicesMax = Int
30
      , certificateMax :: Int
certificateMax = Int
10
      , withdrawalMax :: Int
withdrawalMax = Int
10
      , maxStablePools :: Int
maxStablePools = Int
5
      , invalidScriptFreq :: Int
invalidScriptFreq = Int
5
      , regCertFreq :: Int
regCertFreq = Int
75
      , delegCertFreq :: Int
delegCertFreq = Int
50
      }

small :: GenSize
small :: GenSize
small =
  GenSize
    { treasury :: Integer
treasury = Integer
1000000
    , reserves :: Integer
reserves = Integer
1000000
    , startSlot :: Word64
startSlot = Word64
0
    , slotDelta :: (Word64, Word64)
slotDelta = (Word64
2, Word64
5)
    , blocksizeMax :: Integer
blocksizeMax = Integer
3
    , collInputsMax :: Natural
collInputsMax = Natural
2
    , oldUtxoPercent :: Int
oldUtxoPercent = Int
5
    , spendInputsMax :: Int
spendInputsMax = Int
3
    , refInputsMax :: Int
refInputsMax = Int
1
    , utxoChoicesMax :: Int
utxoChoicesMax = Int
12
    , certificateMax :: Int
certificateMax = Int
2
    , withdrawalMax :: Int
withdrawalMax = Int
2
    , maxStablePools :: Int
maxStablePools = Int
4
    , invalidScriptFreq :: Int
invalidScriptFreq = Int
5
    , regCertFreq :: Int
regCertFreq = Int
75
    , delegCertFreq :: Int
delegCertFreq = Int
50
    }

data PlutusPurposeTag
  = Spending
  | Minting
  | Certifying
  | Rewarding
  | Voting
  | Proposing
  deriving (PlutusPurposeTag -> PlutusPurposeTag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c/= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
== :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c== :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
Eq, Eq PlutusPurposeTag
PlutusPurposeTag -> PlutusPurposeTag -> Bool
PlutusPurposeTag -> PlutusPurposeTag -> Ordering
PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
$cmin :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
max :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
$cmax :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
>= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c>= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
> :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c> :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
<= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c<= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
< :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c< :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
compare :: PlutusPurposeTag -> PlutusPurposeTag -> Ordering
$ccompare :: PlutusPurposeTag -> PlutusPurposeTag -> Ordering
Ord, Int -> PlutusPurposeTag -> ShowS
[PlutusPurposeTag] -> ShowS
PlutusPurposeTag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlutusPurposeTag] -> ShowS
$cshowList :: [PlutusPurposeTag] -> ShowS
show :: PlutusPurposeTag -> String
$cshow :: PlutusPurposeTag -> String
showsPrec :: Int -> PlutusPurposeTag -> ShowS
$cshowsPrec :: Int -> PlutusPurposeTag -> ShowS
Show, Int -> PlutusPurposeTag
PlutusPurposeTag -> Int
PlutusPurposeTag -> [PlutusPurposeTag]
PlutusPurposeTag -> PlutusPurposeTag
PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromThenTo :: PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFromTo :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromTo :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFromThen :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromThen :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFrom :: PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFrom :: PlutusPurposeTag -> [PlutusPurposeTag]
fromEnum :: PlutusPurposeTag -> Int
$cfromEnum :: PlutusPurposeTag -> Int
toEnum :: Int -> PlutusPurposeTag
$ctoEnum :: Int -> PlutusPurposeTag
pred :: PlutusPurposeTag -> PlutusPurposeTag
$cpred :: PlutusPurposeTag -> PlutusPurposeTag
succ :: PlutusPurposeTag -> PlutusPurposeTag
$csucc :: PlutusPurposeTag -> PlutusPurposeTag
Enum, PlutusPurposeTag
forall a. a -> a -> Bounded a
maxBound :: PlutusPurposeTag
$cmaxBound :: PlutusPurposeTag
minBound :: PlutusPurposeTag
$cminBound :: PlutusPurposeTag
Bounded)

plutusPurposeTags :: Proof era -> [PlutusPurposeTag]
plutusPurposeTags :: forall era. Proof era -> [PlutusPurposeTag]
plutusPurposeTags = \case
  Shelley {} -> []
  Allegra {} -> []
  Mary {} -> []
  Alonzo {} -> [PlutusPurposeTag
Spending .. PlutusPurposeTag
Rewarding]
  Babbage {} -> [PlutusPurposeTag
Spending .. PlutusPurposeTag
Rewarding]
  Conway {} -> [PlutusPurposeTag
Spending .. PlutusPurposeTag
Proposing]

mkRedeemers ::
  forall era.
  Proof era ->
  [(PlutusPurpose AsIx era, (Data era, ExUnits))] ->
  Redeemers era
mkRedeemers :: forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerMap =
  -- Pattern match on proof is needed in order to avoid leacking Ord constraint.
  case Proof era
proof of
    Shelley {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Allegra {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Mary {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Alonzo {} -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerMap
    Babbage {} -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerMap
    Conway {} -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerMap

mkRedeemersFromTags ::
  forall era.
  Proof era ->
  [((PlutusPurposeTag, Word32), (Data era, ExUnits))] ->
  Redeemers era
mkRedeemersFromTags :: forall era.
Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags Proof era
proof [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
redeemerPointers =
  case Proof era
proof of
    Shelley {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Allegra {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Mary {} -> forall a. HasCallStack => String -> a
error String
"No Redeemers"
    Alonzo {} -> forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs
    Babbage {} -> forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs
    Conway {} -> forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs
  where
    redeemerAssocs :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
    redeemerAssocs :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeemerAssocs =
      [ (forall era.
Proof era -> PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
mkPlutusPurposePointer Proof era
proof PlutusPurposeTag
tag Word32
i, (Data era, ExUnits)
redeemer)
      | ((PlutusPurposeTag
tag, Word32
i), (Data era, ExUnits)
redeemer) <- [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
redeemerPointers
      ]

mkPlutusPurposePointer ::
  Proof era ->
  PlutusPurposeTag ->
  Word32 ->
  PlutusPurpose AsIx era
mkPlutusPurposePointer :: forall era.
Proof era -> PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
mkPlutusPurposePointer Proof era
proof PlutusPurposeTag
tag Word32
i =
  case Proof era
proof of
    Shelley {} -> forall a. HasCallStack => String -> a
error String
"No PlutusPurpose"
    Allegra {} -> forall a. HasCallStack => String -> a
error String
"No PlutusPurpose"
    Mary {} -> forall a. HasCallStack => String -> a
error String
"No PlutusPurpose"
    Alonzo {} -> forall era.
Era era =>
PlutusPurposeTag -> Word32 -> AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer PlutusPurposeTag
tag Word32
i
    Babbage {} -> forall era.
Era era =>
PlutusPurposeTag -> Word32 -> AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer PlutusPurposeTag
tag Word32
i
    Conway {} -> forall era.
PlutusPurposeTag -> Word32 -> ConwayPlutusPurpose AsIx era
mkConwayPlutusPurposePointer PlutusPurposeTag
tag Word32
i

mkAlonzoPlutusPurposePointer ::
  forall era.
  Era era =>
  PlutusPurposeTag ->
  Word32 ->
  AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer :: forall era.
Era era =>
PlutusPurposeTag -> Word32 -> AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer PlutusPurposeTag
tag Word32
i =
  case PlutusPurposeTag
tag of
    PlutusPurposeTag
Spending -> forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Minting -> forall (f :: * -> * -> *) era.
f Word32 PolicyID -> AlonzoPlutusPurpose f era
AlonzoMinting (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Certifying -> forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> AlonzoPlutusPurpose f era
AlonzoCertifying (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Rewarding -> forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> AlonzoPlutusPurpose f era
AlonzoRewarding (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unsupported tag: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PlutusPurposeTag
tag forall a. [a] -> [a] -> [a]
++ String
" in era " forall a. [a] -> [a] -> [a]
++ forall era. Era era => String
eraName @era

mkConwayPlutusPurposePointer :: PlutusPurposeTag -> Word32 -> ConwayPlutusPurpose AsIx era
mkConwayPlutusPurposePointer :: forall era.
PlutusPurposeTag -> Word32 -> ConwayPlutusPurpose AsIx era
mkConwayPlutusPurposePointer PlutusPurposeTag
tag Word32
i =
  case PlutusPurposeTag
tag of
    PlutusPurposeTag
Spending -> forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
ConwaySpending (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Minting -> forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
ConwayMinting (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Certifying -> forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> ConwayPlutusPurpose f era
ConwayCertifying (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Rewarding -> forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> ConwayPlutusPurpose f era
ConwayRewarding (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Voting -> forall (f :: * -> * -> *) era.
f Word32 Voter -> ConwayPlutusPurpose f era
ConwayVoting (forall ix it. ix -> AsIx ix it
AsIx Word32
i)
    PlutusPurposeTag
Proposing -> forall (f :: * -> * -> *) era.
f Word32 (ProposalProcedure era) -> ConwayPlutusPurpose f era
ConwayProposing (forall ix it. ix -> AsIx ix it
AsIx Word32
i)

-- =====================================================================
-- Accessing information

getSlot :: GenState era -> SlotNo
getSlot :: forall era. GenState era -> SlotNo
getSlot = Word64 -> SlotNo
SlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSize -> Word64
startSlot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getSlotDelta :: GenState era -> (Word64, Word64)
getSlotDelta :: forall era. GenState era -> (Word64, Word64)
getSlotDelta = GenSize -> (Word64, Word64)
slotDelta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getBlocksizeMax :: GenState era -> Integer
getBlocksizeMax :: forall era. GenState era -> Integer
getBlocksizeMax = GenSize -> Integer
blocksizeMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getSpendInputsMax :: GenState era -> Int
getSpendInputsMax :: forall era. GenState era -> Int
getSpendInputsMax = GenSize -> Int
spendInputsMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getRefInputsMax :: GenState era -> Int
getRefInputsMax :: forall era. GenState era -> Int
getRefInputsMax = GenSize -> Int
refInputsMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getCertificateMax :: GenState era -> Int
getCertificateMax :: forall era. GenState era -> Int
getCertificateMax = GenSize -> Int
certificateMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getUtxoChoicesMax :: GenState era -> Int
getUtxoChoicesMax :: forall era. GenState era -> Int
getUtxoChoicesMax = GenSize -> Int
utxoChoicesMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getCollInputsMax :: GenState era -> Natural
getCollInputsMax :: forall era. GenState era -> Natural
getCollInputsMax = GenSize -> Natural
collInputsMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getOldUtxoPercent :: GenState era -> Int
getOldUtxoPercent :: forall era. GenState era -> Int
getOldUtxoPercent GenState era
x = forall a. Ord a => a -> a -> a
max Int
0 (forall a. Ord a => a -> a -> a
min Int
100 (GenSize -> Int
oldUtxoPercent (forall era. GenEnv era -> GenSize
geSize (forall era. GenState era -> GenEnv era
gsGenEnv GenState era
x))))

getTreasury :: GenState era -> Coin
getTreasury :: forall era. GenState era -> Coin
getTreasury = Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSize -> Integer
treasury forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

getReserves :: GenState era -> Coin
getReserves :: forall era. GenState era -> Coin
getReserves = Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSize -> Integer
reserves forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv

-- ========================================================
-- Modifying fields of the GenState as side effects in GenRS

setVi :: GenState era -> ValidityInterval -> GenState era
setVi :: forall era. GenState era -> ValidityInterval -> GenState era
setVi GenState era
gs ValidityInterval
vi = GenState era
gs {gsValidityInterval :: ValidityInterval
gsValidityInterval = ValidityInterval
vi}
{-# NOINLINE setVi #-}

modifyGenStateKeys ::
  ( Map.Map (KeyHash 'Witness) (KeyPair 'Witness) ->
    Map.Map (KeyHash 'Witness) (KeyPair 'Witness)
  ) ->
  GenRS era ()
modifyGenStateKeys :: forall era.
(Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era ()
modifyGenStateKeys Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsKeys :: Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys = Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
f (forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys GenState era
x)})

modifyGenStateDatums ::
  (Map.Map DataHash (Data era) -> Map.Map DataHash (Data era)) ->
  GenRS era ()
modifyGenStateDatums :: forall era.
(Map DataHash (Data era) -> Map DataHash (Data era))
-> GenRS era ()
modifyGenStateDatums Map DataHash (Data era) -> Map DataHash (Data era)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsDatums :: Map DataHash (Data era)
gsDatums = Map DataHash (Data era) -> Map DataHash (Data era)
f (forall era. GenState era -> Map DataHash (Data era)
gsDatums GenState era
x)})

modifyGenStateVI ::
  ( Map ValidityInterval (Set ScriptHash) ->
    Map ValidityInterval (Set ScriptHash)
  ) ->
  GenRS era ()
modifyGenStateVI :: forall era.
(Map ValidityInterval (Set ScriptHash)
 -> Map ValidityInterval (Set ScriptHash))
-> GenRS era ()
modifyGenStateVI Map ValidityInterval (Set ScriptHash)
-> Map ValidityInterval (Set ScriptHash)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsVI :: Map ValidityInterval (Set ScriptHash)
gsVI = Map ValidityInterval (Set ScriptHash)
-> Map ValidityInterval (Set ScriptHash)
f (forall era. GenState era -> Map ValidityInterval (Set ScriptHash)
gsVI GenState era
x)})

modifyGenStateInitialRewards ::
  ( Map.Map (Credential 'Staking) Coin ->
    Map.Map (Credential 'Staking) Coin
  ) ->
  GenRS era ()
modifyGenStateInitialRewards :: forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \GenState era
st -> GenState era
st {gsInitialRewards :: Map (Credential 'Staking) Coin
gsInitialRewards = Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
f (forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards GenState era
st)}

modifyGenStateInitialUtxo ::
  ( Map TxIn (TxOut era) ->
    Map TxIn (TxOut era)
  ) ->
  GenRS era ()
modifyGenStateInitialUtxo :: forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyGenStateInitialUtxo Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \GenState era
st -> GenState era
st {gsInitialUtxo :: Map TxIn (TxOut era)
gsInitialUtxo = Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f (forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo GenState era
st)}

modifyGenStateAvoidCred ::
  ( Set (Credential 'Staking) ->
    Set (Credential 'Staking)
  ) ->
  GenRS era ()
modifyGenStateAvoidCred :: forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateAvoidCred Set (Credential 'Staking) -> Set (Credential 'Staking)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
st -> GenState era
st {gsAvoidCred :: Set (Credential 'Staking)
gsAvoidCred = Set (Credential 'Staking) -> Set (Credential 'Staking)
f (forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred GenState era
st)})

modifyGenStateAvoidKey ::
  (Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)) ->
  GenRS era ()
modifyGenStateAvoidKey :: forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateAvoidKey Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
s -> GenState era
s {gsAvoidKey :: Set (KeyHash 'StakePool)
gsAvoidKey = Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
f (forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey GenState era
s)})

modifyGenStateStablePools ::
  (Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)) ->
  GenRS era ()
modifyGenStateStablePools :: forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateStablePools Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsStablePools :: Set (KeyHash 'StakePool)
gsStablePools = Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
f (forall era. GenState era -> Set (KeyHash 'StakePool)
gsStablePools GenState era
gs)})

modifyGenStateInitialPoolParams ::
  ( Map.Map (KeyHash 'StakePool) PoolParams ->
    Map.Map (KeyHash 'StakePool) PoolParams
  ) ->
  GenRS era ()
modifyGenStateInitialPoolParams :: forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsInitialPoolParams :: Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams = Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
f (forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams GenState era
gs)})

modifyGenStateInitialPoolDistr ::
  ( Map.Map (KeyHash 'StakePool) IndividualPoolStake ->
    Map.Map (KeyHash 'StakePool) IndividualPoolStake
  ) ->
  GenRS era ()
modifyGenStateInitialPoolDistr :: forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsInitialPoolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
gsInitialPoolDistr = Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
f (forall era.
GenState era -> Map (KeyHash 'StakePool) IndividualPoolStake
gsInitialPoolDistr GenState era
gs)})

modifyGenStateStableDelegators ::
  (Set StakeCredential -> Set StakeCredential) ->
  GenRS era ()
modifyGenStateStableDelegators :: forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateStableDelegators Set (Credential 'Staking) -> Set (Credential 'Staking)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsStableDelegators :: Set (Credential 'Staking)
gsStableDelegators = Set (Credential 'Staking) -> Set (Credential 'Staking)
f (forall era. GenState era -> Set (Credential 'Staking)
gsStableDelegators GenState era
gs)})

modifyGenStateInitialDelegations ::
  ( Map.Map (Credential 'Staking) (KeyHash 'StakePool) ->
    Map.Map (Credential 'Staking) (KeyHash 'StakePool)
  ) ->
  GenRS era ()
modifyGenStateInitialDelegations :: forall era.
(Map (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateInitialDelegations Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsInitialDelegations :: Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations = Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
f (forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations GenState era
gs)})

modifyGenStateScripts ::
  ( Map.Map ScriptHash (Script era) ->
    Map.Map ScriptHash (Script era)
  ) ->
  GenRS era ()
modifyGenStateScripts :: forall era.
(Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
modifyGenStateScripts Map ScriptHash (Script era) -> Map ScriptHash (Script era)
f =
  forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \GenState era
gs -> GenState era
gs {gsScripts :: Map ScriptHash (Script era)
gsScripts = Map ScriptHash (Script era) -> Map ScriptHash (Script era)
f (forall era. GenState era -> Map ScriptHash (Script era)
gsScripts GenState era
gs)}

modifyPlutusScripts ::
  ( Map.Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era) ->
    Map.Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
  ) ->
  GenRS era ()
modifyPlutusScripts :: forall era.
(Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenRS era ()
modifyPlutusScripts Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsPlutusScripts :: Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts = Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
f (forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts GenState era
gs)})

-- ===================================================
-- functions that modify individual fields of ModelState

modifyModel :: (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel :: forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel ModelNewEpochState era -> ModelNewEpochState era
f = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gstate -> GenState era
gstate {gsModel :: ModelNewEpochState era
gsModel = ModelNewEpochState era -> ModelNewEpochState era
f (forall era. GenState era -> ModelNewEpochState era
gsModel GenState era
gstate)})

modifyModelDelegations ::
  ( Map.Map (Credential 'Staking) (KeyHash 'StakePool) ->
    Map.Map (Credential 'Staking) (KeyHash 'StakePool)
  ) ->
  GenRS era ()
modifyModelDelegations :: forall era.
(Map (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> GenRS era ()
modifyModelDelegations Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mDelegations :: Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations = Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
f (forall era.
ModelNewEpochState era
-> Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations ModelNewEpochState era
ms)})

modifyModelRewards ::
  ( Map.Map (Credential 'Staking) Coin ->
    Map.Map (Credential 'Staking) Coin
  ) ->
  GenRS era ()
modifyModelRewards :: forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyModelRewards Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mRewards :: Map (Credential 'Staking) Coin
mRewards = Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
f (forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards ModelNewEpochState era
ms)})

modifyModelDeposited :: (Coin -> Coin) -> GenRS era ()
modifyModelDeposited :: forall era. (Coin -> Coin) -> GenRS era ()
modifyModelDeposited Coin -> Coin
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mDeposited :: Coin
mDeposited = Coin -> Coin
f (forall era. ModelNewEpochState era -> Coin
mDeposited ModelNewEpochState era
ms)})

modifyKeyDeposits :: Credential 'Staking -> Coin -> GenRS era ()
modifyKeyDeposits :: forall era. Credential 'Staking -> Coin -> GenRS era ()
modifyKeyDeposits Credential 'Staking
cred Coin
c =
  forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mKeyDeposits :: Map (Credential 'Staking) Coin
mKeyDeposits = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred Coin
c (forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mKeyDeposits ModelNewEpochState era
ms)})

modifyModelPoolParams ::
  ( Map.Map (KeyHash 'StakePool) PoolParams ->
    Map.Map (KeyHash 'StakePool) PoolParams
  ) ->
  GenRS era ()
modifyModelPoolParams :: forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mPoolParams :: Map (KeyHash 'StakePool) PoolParams
mPoolParams = Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
f (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams ModelNewEpochState era
ms)})

modifyModelPoolDistr ::
  ( Map (KeyHash 'StakePool) IndividualPoolStake ->
    Map (KeyHash 'StakePool) IndividualPoolStake
  ) ->
  GenRS era ()
modifyModelPoolDistr :: forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyModelPoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mPoolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr = Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
f (forall era.
ModelNewEpochState era
-> Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr ModelNewEpochState era
ms)})

modifyModelKeyDeposits :: KeyHash 'StakePool -> Coin -> GenRS era ()
modifyModelKeyDeposits :: forall era. KeyHash 'StakePool -> Coin -> GenRS era ()
modifyModelKeyDeposits KeyHash 'StakePool
kh Coin
pooldeposit =
  forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mPoolDeposits :: Map (KeyHash 'StakePool) Coin
mPoolDeposits = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh Coin
pooldeposit (forall era. ModelNewEpochState era -> Map (KeyHash 'StakePool) Coin
mPoolDeposits ModelNewEpochState era
ms)})

modifyModelCount :: (Int -> Int) -> GenRS era ()
modifyModelCount :: forall era. (Int -> Int) -> GenRS era ()
modifyModelCount Int -> Int
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mCount :: Int
mCount = Int -> Int
f (forall era. ModelNewEpochState era -> Int
mCount ModelNewEpochState era
ms)})

modifyModelIndex ::
  (Map Int TxId -> Map Int TxId) ->
  GenRS era ()
modifyModelIndex :: forall era. (Map Int TxId -> Map Int TxId) -> GenRS era ()
modifyModelIndex Map Int TxId -> Map Int TxId
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mIndex :: Map Int TxId
mIndex = Map Int TxId -> Map Int TxId
f (forall era. ModelNewEpochState era -> Map Int TxId
mIndex ModelNewEpochState era
ms)})

modifyModelUTxO ::
  (Map TxIn (TxOut era) -> Map TxIn (TxOut era)) ->
  GenRS era ()
modifyModelUTxO :: forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelUTxO Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mUTxO :: Map TxIn (TxOut era)
mUTxO = Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO ModelNewEpochState era
ms)})

modifyModelMutFee ::
  ( Map TxIn (TxOut era) ->
    Map TxIn (TxOut era)
  ) ->
  GenRS era ()
modifyModelMutFee :: forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelMutFee Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f = forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
m -> ModelNewEpochState era
m {mMutFee :: Map TxIn (TxOut era)
mMutFee = Map TxIn (TxOut era) -> Map TxIn (TxOut era)
f (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mMutFee ModelNewEpochState era
m)})

-- ==============================================================
-- The Monad

type GenRS era = RWST (GenEnv era) () (GenState era) Gen

genMapElem :: Map k a -> Gen (Maybe (k, a))
genMapElem :: forall k a. Map k a -> Gen (Maybe (k, a))
genMapElem Map k a
m
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n forall a. Num a => a -> a -> a
- Int
1)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i Map k a
m
  where
    n :: Int
n = forall k a. Map k a -> Int
Map.size Map k a
m

genSetElem :: Set a -> Gen (Maybe a)
genSetElem :: forall a. Set a -> Gen (Maybe a)
genSetElem Set a
m
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n forall a. Num a => a -> a -> a
- Int
1)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Int -> Set a -> a
Set.elemAt Int
i Set a
m
  where
    n :: Int
n = forall a. Set a -> Int
Set.size Set a
m

-- | Use up to 'tries' attempts to choose a random (k,a) pair from 'm', that meets predicate 'p'
genMapElemWhere :: Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere :: forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map k a
m Int
tries k -> a -> Bool
p
  | Int
tries forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n forall a. Num a => a -> a -> a
- Int
1)
      let (k
k, a
a) = forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i Map k a
m
      if k -> a -> Bool
p k
k a
a
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (k
k, a
a)
        else forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map k a
m (Int
tries forall a. Num a => a -> a -> a
- Int
1) k -> a -> Bool
p
  where
    n :: Int
n = forall k a. Map k a -> Int
Map.size Map k a
m

elementsT :: (Monad (t Gen), MonadTrans t) => [t Gen b] -> t Gen b
elementsT :: forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => [a] -> Gen a
elements

frequencyT :: (Monad (t Gen), MonadTrans t) => [(Int, t Gen b)] -> t Gen b
frequencyT :: forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [] = forall a. HasCallStack => String -> a
error (String
"frequencyT called with empty list")
frequencyT [(Int, t Gen b)]
choices = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall a b. (a -> b) -> a -> b
$ [(Int, t Gen b)]
choices

-- | Gen a positive single digit Int, on a skewed distribution that
--   favors 2,3,4,5 but occasionally gets others
positiveSingleDigitInt :: Gen Int
positiveSingleDigitInt :: Gen Int
positiveSingleDigitInt =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency (forall a b. (a -> b) -> [a] -> [b]
map forall {f :: * -> *} {a} {a}. Applicative f => (a, a) -> (a, f a)
f [(Int
1, Int
1), (Int
5, Int
2), (Int
4, Int
3), (Int
4, Int
4), (Int
3, Int
5), (Int
2, Int
6), (Int
1, Int
7), (Int
1, Int
8), (Int
1, Int
9)])
  where
    f :: (a, a) -> (a, f a)
f (a
x, a
y) = (a
x, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y)

-- | Gen a non-negative single digit Int, on a skewed distribution that
--   favors 2,3,4,5 but occasionally gets others
nonNegativeSingleDigitInt :: Gen Int
nonNegativeSingleDigitInt :: Gen Int
nonNegativeSingleDigitInt =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency (forall a b. (a -> b) -> [a] -> [b]
map forall {f :: * -> *} {a} {a}. Applicative f => (a, a) -> (a, f a)
f [(Int
1, Int
0), (Int
2, Int
1), (Int
5, Int
2), (Int
4, Int
3), (Int
3, Int
4), (Int
2, Int
5), (Int
2, Int
6), (Int
1, Int
7), (Int
1, Int
8), (Int
1, Int
9)])
  where
    f :: (a, a) -> (a, f a)
f (a
x, a
y) = (a
x, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y)

-- | Generate a non-zero value
genPositiveVal :: Val v => Gen v
genPositiveVal :: forall v. Val v => Gen v
genPositiveVal = forall t s. Inject t s => t -> s
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positive a -> a
getPositive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

-- | Generate a value (which is occaisionally 0) useful in generating Rewards, where we need a
--   few 0's, because we cannot generate a DeReg certificates, without a 0 Reg value.
--   Also used when generating the CollReturn, where an occasional 0 would be nice
genRewardVal :: Val v => Gen v
genRewardVal :: forall v. Val v => Gen v
genRewardVal = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
3, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty), (Int
97, forall v. Val v => Gen v
genPositiveVal)]

-- | Test if the Payment part of the Address in the TxOut
--   is valid in the current ValidityInterval. Using the simple rule allowing
--   only (Key or Plutus or MutiSig) locking. Disallowing all Timelock scripts
validTxOut ::
  Proof era ->
  Map ScriptHash (Script era) ->
  TxIn ->
  TxOut era ->
  Bool
validTxOut :: forall era.
Proof era
-> Map ScriptHash (Script era) -> TxIn -> TxOut era -> Bool
validTxOut Proof era
proof Map ScriptHash (Script era)
m TxIn
_txin TxOut era
txout = case forall era.
Proof era -> TxOut era -> (Addr, Value era, [TxOutField era])
txoutFields Proof era
proof TxOut era
txout of
  (Addr Network
_ (KeyHashObj KeyHash 'Payment
_) StakeReference
_, Value era
_, [TxOutField era]
_) -> Bool
True
  (Addr Network
_ (ScriptHashObj ScriptHash
h) StakeReference
_, Value era
_, [TxOutField era]
_) -> case (Proof era
proof, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
h Map ScriptHash (Script era)
m) of
    (Proof era
Conway, Just (PlutusScript PlutusScript ConwayEra
_)) -> Bool
True
    (Proof era
Babbage, Just (PlutusScript PlutusScript BabbageEra
_)) -> Bool
True
    (Proof era
Alonzo, Just (PlutusScript PlutusScript AlonzoEra
_)) -> Bool
True
    (Proof era
Shelley, Just Script era
_msig) -> Bool
True
    (Proof era, Maybe (Script era))
_ -> Bool
False
  (Addr, Value era, [TxOutField era])
_bootstrap -> Bool
False

-- | Pick a UTxO element where we can use it in a new Tx. Most of the time we generate new
--   elements for each Tx, but once in a while we choose an existing one. We must be carefull
--   that that the Pay credential of the TxOut can run in the curent ValidityInterval
--   A crude but simple way is to insist Pay credential is either Key locked, or locked
--   with Plutus or MultiSig scripts, and return False for any Timelock scripts.
getUtxoElem :: Reflect era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem :: forall era. Reflect era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem = do
  Map TxIn (TxOut era)
x <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  Map ScriptHash (Script era)
scriptmap <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map ScriptHash (Script era)
gsScripts
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map TxIn (TxOut era)
x Int
20 (forall era.
Proof era
-> Map ScriptHash (Script era) -> TxIn -> TxOut era -> Bool
validTxOut forall era. Reflect era => Proof era
reify Map ScriptHash (Script era)
scriptmap)

getUtxoTest :: GenRS era (TxIn -> Bool)
getUtxoTest :: forall era. GenRS era (TxIn -> Bool)
getUtxoTest = do
  Map TxIn (TxOut era)
x <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TxIn (TxOut era)
x)

-- | To compute deposits we need a function that tells if the KeyHash is a new Pool
--   Compute this function before we do any generation, since such generation
--   may actually add to the mPoolParams, and then the added thing won't appear new.
getNewPoolTest :: GenRS era (KeyHash 'StakePool -> Bool)
getNewPoolTest :: forall era. GenRS era (KeyHash 'StakePool -> Bool)
getNewPoolTest = do
  Map (KeyHash 'StakePool) PoolParams
poolparams <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'StakePool) PoolParams
poolparams)

-- ========================================================================
-- Tools to get started in the Monad

runGenRS ::
  Reflect era =>
  Proof era ->
  GenSize ->
  GenRS era a ->
  Gen (a, GenState era)
runGenRS :: forall era a.
Reflect era =>
Proof era -> GenSize -> GenRS era a -> Gen (a, GenState era)
runGenRS Proof era
proof GenSize
gsize GenRS era a
action = do
  GenEnv era
genenv <- forall era.
EraPParams era =>
Proof era -> GenSize -> Gen (GenEnv era)
genGenEnv Proof era
proof GenSize
gsize
  (a
ans, GenState era
state, ()) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST GenRS era a
action GenEnv era
genenv (forall era. Reflect era => Proof era -> GenEnv era -> GenState era
emptyGenState Proof era
proof GenEnv era
genenv)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ans, GenState era
state)

-- | Should not be used in tests, this is a helper function to be used in ghci only!
ioGenRS :: Reflect era => Proof era -> GenSize -> GenRS era ans -> IO (ans, GenState era)
ioGenRS :: forall era ans.
Reflect era =>
Proof era -> GenSize -> GenRS era ans -> IO (ans, GenState era)
ioGenRS Proof era
proof GenSize
gsize GenRS era ans
action = forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ forall era a.
Reflect era =>
Proof era -> GenSize -> GenRS era a -> Gen (a, GenState era)
runGenRS Proof era
proof GenSize
gsize GenRS era ans
action

-- | Generate a random, well-formed, GenEnv
genGenEnv :: EraPParams era => Proof era -> GenSize -> Gen (GenEnv era)
genGenEnv :: forall era.
EraPParams era =>
Proof era -> GenSize -> Gen (GenEnv era)
genGenEnv Proof era
proof GenSize
gsize = do
  ExUnits
maxTxExUnits <- forall a. Arbitrary a => Gen a
arbitrary :: Gen ExUnits
  Natural
maxCollateralInputs <- forall a. HasCallStack => [a] -> Gen a
elements [Natural
1 .. GenSize -> Natural
collInputsMax GenSize
gsize]
  Natural
collateralPercentage <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
1, Int
10000)
  Coin
minfeeA <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
1000)
  Coin
minfeeB <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
10000)
  let pp :: PParams era
pp =
        forall era.
EraPParams era =>
Proof era -> [PParamsField era] -> PParams era
newPParams
          Proof era
proof
          [ forall era. Coin -> PParamsField era
MinfeeA Coin
minfeeA
          , forall era. Coin -> PParamsField era
MinfeeB Coin
minfeeB
          , forall era. Proof era -> PParamsField era
defaultCostModels Proof era
proof
          , forall era. Natural -> PParamsField era
MaxValSize Natural
1000
          , forall era. Word32 -> PParamsField era
MaxTxSize forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
          , forall era. ExUnits -> PParamsField era
MaxTxExUnits ExUnits
maxTxExUnits
          , forall era. Natural -> PParamsField era
MaxCollateralInputs Natural
maxCollateralInputs
          , forall era. Natural -> PParamsField era
CollateralPercentage Natural
collateralPercentage
          , forall era. ProtVer -> PParamsField era
ProtocolVersion forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> ProtVer
protocolVersion Proof era
proof
          , forall era. Coin -> PParamsField era
PoolDeposit forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5
          , forall era. Coin -> PParamsField era
KeyDeposit forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2
          , forall era. EpochInterval -> PParamsField era
EMax forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
5
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    GenEnv
      { gePParams :: PParams era
gePParams = PParams era
pp
      , geSize :: GenSize
geSize = GenSize
gsize
      }

genGenState :: Reflect era => Proof era -> GenSize -> Gen (GenState era)
genGenState :: forall era.
Reflect era =>
Proof era -> GenSize -> Gen (GenState era)
genGenState Proof era
proof GenSize
gsize = do
  let slotNo :: Word64
slotNo = GenSize -> Word64
startSlot GenSize
gsize
  StrictMaybe Word64
minSlotNo <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
4, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (forall a. Bounded a => a
minBound, Word64
slotNo))]
  StrictMaybe Word64
maxSlotNo <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
4, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Word64
slotNo forall a. Num a => a -> a -> a
+ Word64
1, forall a. Bounded a => a
maxBound))]
  let vi :: ValidityInterval
vi = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe Word64
minSlotNo) (Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe Word64
maxSlotNo)
  GenEnv era
env <- forall era.
EraPParams era =>
Proof era -> GenSize -> Gen (GenEnv era)
genGenEnv Proof era
proof GenSize
gsize
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. GenState era -> ValidityInterval -> GenState era
setVi (forall era. Reflect era => Proof era -> GenEnv era -> GenState era
emptyGenState Proof era
proof GenEnv era
env) ValidityInterval
vi)

-- | Generate a transaction body validity interval which is close in proximity
--  (less than a stability window) from the current slot.
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval (SlotNo Word64
s) = do
  let stabilityWindow :: Word64
stabilityWindow = Word64
29 -- < 3k/f many slots, where 10k is the epoch length
  StrictMaybe Word64
start <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
4, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (forall a. Bounded a => a
minBound, Word64
s))]
  StrictMaybe Word64
end <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
4, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Word64
s forall a. Num a => a -> a -> a
+ Word64
1, Word64
s forall a. Num a => a -> a -> a
+ Word64
stabilityWindow))]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe Word64
start) (Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe Word64
end)

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

pcGenState :: forall era. Reflect era => Proof era -> GenState era -> PDoc
pcGenState :: forall era. Reflect era => Proof era -> GenState era -> PDoc
pcGenState Proof era
proof GenState era
gs =
  Text -> [(Text, PDoc)] -> PDoc
ppRecord
    Text
"GenState Summary"
    [ (Text
"ValidityInterval", ValidityInterval -> PDoc
ppValidityInterval (forall era. GenState era -> ValidityInterval
gsValidityInterval GenState era
gs))
    , (Text
"Keymap", forall a. Int -> Doc a
ppInt (forall k a. Map k a -> Int
Map.size (forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys GenState era
gs)))
    , (Text
"Scriptmap", forall a. Int -> Doc a
ppInt (forall k a. Map k a -> Int
Map.size (forall era. GenState era -> Map ScriptHash (Script era)
gsScripts GenState era
gs)))
    , (Text
"PlutusScripts", forall a. Int -> Doc a
ppInt (forall k a. Map k a -> Int
Map.size (forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts GenState era
gs)))
    , (Text
"Datums", forall a. Int -> Doc a
ppInt (forall k a. Map k a -> Int
Map.size (forall era. GenState era -> Map DataHash (Data era)
gsDatums GenState era
gs)))
    , (Text
"VI-ScriptMap", forall a. Int -> Doc a
ppInt (forall k a. Map k a -> Int
Map.size (forall era. GenState era -> Map ValidityInterval (Set ScriptHash)
gsVI GenState era
gs)))
    , (Text
"Model", forall era.
Reflect era =>
Proof era -> ModelNewEpochState era -> PDoc
pcModelNewEpochState @era Proof era
proof (forall era. GenState era -> ModelNewEpochState era
gsModel GenState era
gs))
    , (Text
"Initial Utxo", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap TxIn -> PDoc
pcTxIn (forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut @era Proof era
proof) (forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo GenState era
gs))
    , (Text
"Initial Rewards", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). Credential keyrole -> PDoc
pcCredential Coin -> PDoc
pcCoin (forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards GenState era
gs))
    , (Text
"Initial SPoolUView", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). Credential keyrole -> PDoc
pcCredential forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash (forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations GenState era
gs))
    , (Text
"Initial PoolParams", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash PoolParams -> PDoc
pcPoolParams (forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams GenState era
gs))
    , (Text
"Initial PoolDistr", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash IndividualPoolStake -> PDoc
pcIndividualPoolStake (forall era.
GenState era -> Map (KeyHash 'StakePool) IndividualPoolStake
gsInitialPoolDistr GenState era
gs))
    , (Text
"Stable PoolParams", forall x ann. (x -> Doc ann) -> Set x -> Doc ann
ppSet forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash (forall era. GenState era -> Set (KeyHash 'StakePool)
gsStablePools GenState era
gs))
    , (Text
"Stable Delegators", forall x ann. (x -> Doc ann) -> Set x -> Doc ann
ppSet forall (keyrole :: KeyRole). Credential keyrole -> PDoc
pcCredential (forall era. GenState era -> Set (Credential 'Staking)
gsStableDelegators GenState era
gs))
    , (Text
"Previous RegKey", forall x ann. (x -> Doc ann) -> Set x -> Doc ann
ppSet forall (keyrole :: KeyRole). Credential keyrole -> PDoc
pcCredential (forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred GenState era
gs))
    , (Text
"GenEnv", forall a. String -> Doc a
ppString String
"GenEnv ...")
    , (Text
"Proof", forall a. String -> Doc a
ppString (forall a. Show a => a -> String
show (forall era. GenState era -> Proof era
gsProof GenState era
gs)))
    ]

-- | Helper function for development and debugging in ghci
viewGenState :: Reflect era => Proof era -> GenSize -> Bool -> IO ()
viewGenState :: forall era. Reflect era => Proof era -> GenSize -> Bool -> IO ()
viewGenState Proof era
proof GenSize
gsize Bool
verbose = do
  GenState era
st <- forall a. Gen a -> IO a
generate (forall era.
Reflect era =>
Proof era -> GenSize -> Gen (GenState era)
genGenState Proof era
proof GenSize
gsize)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print (forall era. Reflect era => Proof era -> GenState era -> PDoc
pcGenState Proof era
proof GenState era
st)

instance Reflect era => PrettyA (GenState era) where prettyA :: GenState era -> PDoc
prettyA = forall era. Reflect era => Proof era -> GenState era -> PDoc
pcGenState forall era. Reflect era => Proof era
reify

instance Reflect era => Show (GenState era) where
  show :: GenState era -> String
show GenState era
x = forall a. Show a => a -> String
show (forall era. Reflect era => Proof era -> GenState era -> PDoc
pcGenState forall era. Reflect era => Proof era
reify GenState era
x)

-- =====================================================================
-- Build an Initial LedgerState for a Trace from a GenState, after
-- generating a coherent Trace (a sequence of Transactions that can
-- logically be applied one after another)

initialLedgerState :: forall era. Reflect era => GenState era -> LedgerState era
initialLedgerState :: forall era. Reflect era => GenState era -> LedgerState era
initialLedgerState GenState era
gstate = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState era
utxostate CertState era
dpstate
  where
    umap :: UMap
umap =
      Map (Credential 'Staking) RDPair
-> Map Ptr (Credential 'Staking)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) DRep
-> UMap
UM.unify
        (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Coin -> RDPair
rdpair (forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards GenState era
gstate))
        forall k a. Map k a
Map.empty
        (forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations GenState era
gstate)
        forall k a. Map k a
Map.empty
    utxostate :: UTxOState era
utxostate = forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pp (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo GenState era
gstate)) Coin
deposited (Integer -> Coin
Coin Integer
0) forall era. EraGov era => GovState era
emptyGovState forall a. Monoid a => a
mempty
    dpstate :: CertState era
dpstate = forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def PState era
pstate DState era
dstate
    dstate :: DState era
dstate =
      forall era.
UMap
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState
        UMap
umap
        forall k a. Map k a
Map.empty
        GenDelegs
genDelegsZero
        InstantaneousRewards
instantaneousRewardsZero
    pstate :: PState era
pstate = forall era.
Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) Coin
-> PState era
PState Map (KeyHash 'StakePool) PoolParams
pools forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Coin
poolDeposit) Map (KeyHash 'StakePool) PoolParams
pools)
    -- In a wellformed LedgerState the deposited equals the obligation
    deposited :: Coin
deposited = forall era. EraGov era => CertState era -> GovState era -> Coin
totalObligation CertState era
dpstate (UTxOState era
utxostate forall s a. s -> Getting a s a -> a
^. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL)
    pools :: Map (KeyHash 'StakePool) PoolParams
pools = forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams GenState era
gstate
    pp :: PParams era
pp = forall era. ModelNewEpochState era -> PParams era
mPParams (forall era. GenState era -> ModelNewEpochState era
gsModel GenState era
gstate)
    keyDeposit :: Coin
keyDeposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
    !poolDeposit :: Coin
poolDeposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL
    rdpair :: Coin -> RDPair
rdpair Coin
rew = CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
rew) (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
keyDeposit)

-- =============================================
-- Generators of inter-related items

-- Adds to the gsKeys
genKeyHash :: GenRS era (KeyHash kr)
genKeyHash :: forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash = do
  KeyPair 'Witness
keyPair <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Arbitrary a => Gen a
arbitrary
  let keyHash :: KeyHash 'Witness
keyHash = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Witness
keyPair
  forall era.
(Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era ()
modifyGenStateKeys (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'Witness
keyHash KeyPair 'Witness
keyPair)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Witness
keyHash

-- Adds to the gsDatums
genDatumWithHash :: Era era => GenRS era (DataHash, Data era)
genDatumWithHash :: forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash = do
  Data era
datum <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Arbitrary a => Gen a
arbitrary
  let datumHash :: DataHash
datumHash = forall era. Data era -> DataHash
hashData Data era
datum
  forall era.
(Map DataHash (Data era) -> Map DataHash (Data era))
-> GenRS era ()
modifyGenStateDatums (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
datumHash Data era
datum)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataHash
datumHash, Data era
datum)

genFreshKeyHash :: GenRS era (KeyHash kr)
genFreshKeyHash :: forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash = forall {a} {era} {r :: KeyRole}.
(Ord a, Num a) =>
a -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
go (Int
100 :: Int) -- avoid unlikely chance of generated hash collisions.
  where
    go :: a -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
go a
n
      | a
n forall a. Ord a => a -> a -> Bool
<= a
0 = forall a. HasCallStack => String -> a
error String
"Something very unlikely happened"
      | Bool
otherwise = do
          Set (KeyHash 'StakePool)
avoidKeys <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey
          KeyHash r
kh <- forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash
          if forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash r
kh forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'StakePool)
avoidKeys
            then a -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
go forall a b. (a -> b) -> a -> b
$ a
n forall a. Num a => a -> a -> a
- a
1
            else forall (m :: * -> *) a. Monad m => a -> m a
return KeyHash r
kh

-- ===========================================================
-- Generate Era agnostic Scripts

-- Adds to gsScripts and gsPlutusScripts
genScript :: Reflect era => Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript :: forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript Proof era
proof PlutusPurposeTag
tag = case Proof era
proof of
  Proof era
Conway -> forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof PlutusPurposeTag
tag]
  Proof era
Babbage -> forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof PlutusPurposeTag
tag]
  Proof era
Alonzo -> forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof PlutusPurposeTag
tag]
  Proof era
Mary -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Allegra -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Shelley -> forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
GenRS era ScriptHash
genMultiSigScript

-- Adds to gsScripts
genTimelockScript ::
  forall era.
  (AllegraEraScript era, NativeScript era ~ Timelock era) =>
  GenRS era ScriptHash
genTimelockScript :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript = do
  vi :: ValidityInterval
vi@(ValidityInterval StrictMaybe SlotNo
mBefore StrictMaybe SlotNo
mAfter) <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> ValidityInterval
gsValidityInterval
  -- We need to limit how deep these timelocks can go, otherwise this generator will
  -- diverge. It also has to stay very shallow because it grows too fast.
  let genNestedTimelock :: Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
genNestedTimelock Natural
k
        | Natural
k forall a. Ord a => a -> a -> Bool
> Natural
0 =
            forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT forall a b. (a -> b) -> a -> b
$
              [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
nonRecTimelocks forall a. [a] -> [a] -> [a]
++ [Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireAllOf Natural
k, Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireAnyOf Natural
k, Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireMOf Natural
k]
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
nonRecTimelocks
      nonRecTimelocks :: [GenRS era (Timelock era)]
      nonRecTimelocks :: [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
nonRecTimelocks =
        [ RWST (GenEnv era) () (GenState era) Gen (Timelock era)
r
        | SJust RWST (GenEnv era) () (GenState era) Gen (Timelock era)
r <-
            [ forall {t :: (* -> *) -> * -> *} {era}.
(Monad (t Gen), MonadTrans t, AllegraEraScript era) =>
SlotNo -> t Gen (NativeScript era)
requireTimeStart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mBefore
            , forall {t :: (* -> *) -> * -> *} {era}.
(Monad (t Gen), MonadTrans t, AllegraEraScript era) =>
SlotNo -> t Gen (NativeScript era)
requireTimeExpire forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mAfter
            , forall a. a -> StrictMaybe a
SJust forall {era}.
RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
requireSignature
            ]
        ]
      requireSignature :: RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
requireSignature = forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash
      requireAllOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireAllOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireAnyOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireAnyOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
positiveSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireMOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireMOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        Int
m <- 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
n)
        forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireTimeStart :: SlotNo -> t Gen (NativeScript era)
requireTimeStart (SlotNo Word64
validFrom) = do
        Word64
minSlotNo <- 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 (forall a. Bounded a => a
minBound, Word64
validFrom)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
minSlotNo)
      requireTimeExpire :: SlotNo -> t Gen (NativeScript era)
requireTimeExpire (SlotNo Word64
validTill) = do
        Word64
maxSlotNo <- 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
validTill, forall a. Bounded a => a
maxBound)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (Word64 -> SlotNo
SlotNo Word64
maxSlotNo)
  Timelock era
tlscript <- Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
genNestedTimelock (Natural
2 :: Natural)
  let corescript :: Script era
corescript = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
tlscript
  let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
      insertOrCreate :: a -> Maybe (Set a) -> Maybe (Set a)
insertOrCreate a
x Maybe (Set a)
Nothing = forall a. a -> Maybe a
Just (forall a. a -> Set a
Set.singleton a
x)
      insertOrCreate a
x (Just Set a
s) = forall a. a -> Maybe a
Just (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s)
  forall era.
(Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
modifyGenStateScripts (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash Script era
corescript)
  forall era.
(Map ValidityInterval (Set ScriptHash)
 -> Map ValidityInterval (Set ScriptHash))
-> GenRS era ()
modifyGenStateVI (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall {a}. Ord a => a -> Maybe (Set a) -> Maybe (Set a)
insertOrCreate ScriptHash
scriptHash) ValidityInterval
vi)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

-- Adds to gsScripts
genMultiSigScript ::
  forall era.
  (ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
  GenRS era ScriptHash
genMultiSigScript :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
GenRS era ScriptHash
genMultiSigScript = do
  let genNestedMultiSig :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig Natural
k
        | Natural
k forall a. Ord a => a -> a -> Bool
> Natural
0 =
            forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT forall a b. (a -> b) -> a -> b
$
              [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
nonRecTimelocks forall a. [a] -> [a] -> [a]
++ [Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAllOf Natural
k, Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAnyOf Natural
k, Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireMOf Natural
k]
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
nonRecTimelocks
      nonRecTimelocks :: [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
nonRecTimelocks = [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireSignature]
      requireSignature :: RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireSignature = forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash
      requireAllOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAllOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireAnyOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAnyOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
positiveSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireMOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireMOf Natural
k = do
        Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        Int
m <- 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
n)
        forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
  MultiSig era
msscript <- Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig (Natural
2 :: Natural)
  let corescript :: Script era
corescript = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript MultiSig era
msscript
  let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
  forall era.
(Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
modifyGenStateScripts (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash Script era
corescript)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

-- Adds to gsPlutusScripts
genPlutusScript ::
  forall era.
  Reflect era =>
  Proof era ->
  PlutusPurposeTag ->
  GenRS era ScriptHash
genPlutusScript :: forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof PlutusPurposeTag
tag = do
  Int
falseFreq <- 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
$ GenSize -> Int
invalidScriptFreq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize
  Bool
isValid <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
falseFreq, forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
100 forall a. Num a => a -> a -> a
- Int
falseFreq, forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]
  -- Plutus scripts alwaysSucceeds needs at least numArgs, while
  -- alwaysFails needs exactly numArgs to have the desired affect.
  -- For reasons unknown, this number differs from Alonzo to Babbage
  -- Perhaps because Babbage is using PlutusV2 scripts?
  let numArgs :: Natural
numArgs = case (Proof era
proof, PlutusPurposeTag
tag) of
        (Proof era
Conway, PlutusPurposeTag
Spending) -> Natural
2
        (Proof era
Conway, PlutusPurposeTag
_) -> Natural
1
        (Proof era
Babbage, PlutusPurposeTag
Spending) -> Natural
2
        (Proof era
Babbage, PlutusPurposeTag
_) -> Natural
1
        (Proof era
_, PlutusPurposeTag
Spending) -> Natural
3
        (Proof era
_, PlutusPurposeTag
_) -> Natural
2
  -- While using varying number of arguments for alwaysSucceeds we get
  -- varying script hashes, which helps with the fuzziness
  let mlanguage :: Maybe Language
mlanguage = forall era. Proof era -> Maybe Language
primaryLanguage Proof era
proof
  Script era
script <-
    if Bool
isValid
      then forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysTrue Proof era
proof Maybe Language
mlanguage forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Natural
numArgs) 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. HasCallStack => [a] -> Gen a
elements [Natural
0, Natural
1, Natural
2, Natural
3 :: Natural])
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysFalse Proof era
proof Maybe Language
mlanguage Natural
numArgs

  let corescript :: Script era
      corescript :: Script era
corescript = case Proof era
proof of
        Proof era
Alonzo -> Script era
script
        Proof era
Babbage -> Script era
script
        Proof era
Conway -> Script era
script
        Proof era
_ ->
          forall a. HasCallStack => String -> a
error
            ( String
"PlutusScripts are available starting in the Alonzo era. "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Proof era
proof
                forall a. [a] -> [a] -> [a]
++ String
" does not support PlutusScripts."
            )
      scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
  forall era.
(Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenRS era ()
modifyPlutusScripts (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ScriptHash
scriptHash, PlutusPurposeTag
tag) (Bool -> IsValid
IsValid Bool
isValid, Script era
corescript))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

-- ======================================================================
-- Generators of Transaction components
-- =======================================================================

-- | Generate a credential that can be used for supplied purpose (in case of
-- plutus scripts), while occasionally picking out randomly from previously
-- generated set. Returns the credential
-- Adds to both gsKeys and gsScripts and gsPlutusScript
-- via genKeyHash and genScript
genCredential ::
  forall era kr. Reflect era => PlutusPurposeTag -> GenRS era (Credential kr)
genCredential :: forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
tag =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
35, forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash')
    , (Int
35, forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen ScriptHash
genScript')
    , (Int
10, RWST (GenEnv era) () (GenState era) Gen (Credential kr)
pickExistingKeyHash)
    , (Int
20, RWST (GenEnv era) () (GenState era) Gen (Credential kr)
pickExistingScript)
    ]
  where
    genKeyHash' :: RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash' = do
      KeyHash 'Staking
kh <- forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash -- We need to avoid some key credentials
      case PlutusPurposeTag
tag of
        PlutusPurposeTag
Rewarding -> forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh) (Integer -> Coin
Coin Integer
0))
        PlutusPurposeTag
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Staking
kh
    genScript' :: RWST (GenEnv era) () (GenState era) Gen ScriptHash
genScript' = Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
f (Int
100 :: Int)
      where
        f :: Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
f Int
n
          | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error String
"Failed to generate a fresh script hash"
          | Bool
otherwise = do
              ScriptHash
sh <- forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript @era forall era. Reflect era => Proof era
reify PlutusPurposeTag
tag
              Map (Credential 'Staking) Coin
initialRewards <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards
              Set (Credential 'Staking)
avoidCredentials <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
              let newcred :: Credential 'Staking
newcred = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
sh
              if forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'Staking
newcred Map (Credential 'Staking) Coin
initialRewards Bool -> Bool -> Bool
&& forall a. Ord a => a -> Set a -> Bool
Set.notMember Credential 'Staking
newcred Set (Credential 'Staking)
avoidCredentials
                then do
                  case PlutusPurposeTag
tag of
                    PlutusPurposeTag
Rewarding -> forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
newcred (Integer -> Coin
Coin Integer
0))
                    PlutusPurposeTag
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  forall (m :: * -> *) a. Monad m => a -> m a
return ScriptHash
sh
                else Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
f forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
1
    pickExistingKeyHash :: RWST (GenEnv era) () (GenState era) Gen (Credential kr)
pickExistingKeyHash =
      forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Map (KeyHash 'Witness) (KeyPair 'Witness)
keysMap <- forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys 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
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall k a. Map k a -> Gen (Maybe (k, a))
genMapElem Map (KeyHash 'Witness) (KeyPair 'Witness)
keysMap) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (KeyHash 'Witness
k, KeyPair 'Witness
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Witness
k
          Maybe (KeyHash 'Witness, KeyPair 'Witness)
Nothing -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash'
    pickExistingScript :: RWST (GenEnv era) () (GenState era) Gen (Credential kr)
pickExistingScript =
      forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [RWST (GenEnv era) () (GenState era) Gen ScriptHash
pickExistingPlutusScript, RWST (GenEnv era) () (GenState era) Gen ScriptHash
pickExistingTimelockScript]
    pickExistingPlutusScript :: RWST (GenEnv era) () (GenState era) Gen ScriptHash
pickExistingPlutusScript = do
      Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
plutusScriptsMap <-
        forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\(ScriptHash
_, PlutusPurposeTag
t) (IsValid, Script era)
_ -> PlutusPurposeTag
t forall a. Eq a => a -> a -> Bool
== PlutusPurposeTag
tag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts 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
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall k a. Map k a -> Gen (Maybe (k, a))
genMapElem Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
plutusScriptsMap) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ((ScriptHash
h, PlutusPurposeTag
_), (IsValid, Script era)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
h
        Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era))
Nothing -> forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript forall era. Reflect era => Proof era
reify PlutusPurposeTag
tag
    pickExistingTimelockScript :: RWST (GenEnv era) () (GenState era) Gen ScriptHash
pickExistingTimelockScript = do
      -- Only pick one if it matches the
      ValidityInterval
vi <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> ValidityInterval
gsValidityInterval -- current ValidityInterval
      Map ValidityInterval (Set ScriptHash)
vimap <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map ValidityInterval (Set ScriptHash)
gsVI
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ValidityInterval
vi Map ValidityInterval (Set ScriptHash)
vimap of
        Maybe (Set ScriptHash)
Nothing -> forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript @era forall era. Reflect era => Proof era
reify PlutusPurposeTag
tag
        Just Set ScriptHash
s ->
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Set a -> Gen (Maybe a)
genSetElem Set ScriptHash
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ScriptHash
Nothing -> forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript forall era. Reflect era => Proof era
reify PlutusPurposeTag
tag
            Just ScriptHash
hash -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
hash

-- Return a fresh credential, one that is not a member of the set 'old'.
-- One gets 'tries' chances to generate a fresh one, before an error is raised.
-- This avoids silent infinite loops.
genFreshCredential ::
  forall era kr.
  Reflect era =>
  Int ->
  PlutusPurposeTag ->
  Set (Credential kr) ->
  GenRS era (Credential kr)
genFreshCredential :: forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
0 PlutusPurposeTag
_tag Set (Credential kr)
_old = forall a. HasCallStack => String -> a
error String
"Ran out of tries in genFreshCredential."
genFreshCredential Int
tries0 PlutusPurposeTag
tag Set (Credential kr)
old = Int -> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
go Int
tries0
  where
    go :: Int -> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
go Int
tries = do
      Credential kr
c <- forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
tag
      if forall a. Ord a => a -> Set a -> Bool
Set.member Credential kr
c Set (Credential kr)
old
        then Int -> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
go (Int
tries forall a. Num a => a -> a -> a
- Int
1)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential kr
c

genFreshRegCred ::
  Reflect era => PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred :: forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred PlutusPurposeTag
tag = do
  Set (Credential 'Staking)
old <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards)
  Set (Credential 'Staking)
avoid <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
  Set (Credential 'Staking)
rewards <- 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 k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel
  Credential 'Staking
cred <- forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
100 PlutusPurposeTag
tag forall a b. (a -> b) -> a -> b
$ Set (Credential 'Staking)
old forall a. Semigroup a => a -> a -> a
<> Set (Credential 'Staking)
avoid forall a. Semigroup a => a -> a -> a
<> Set (Credential 'Staking)
rewards
  forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateAvoidCred (forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking
cred)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'Staking
cred

genPoolParams ::
  Reflect era =>
  KeyHash 'StakePool ->
  GenRS era PoolParams
genPoolParams :: forall era.
Reflect era =>
KeyHash 'StakePool -> GenRS era PoolParams
genPoolParams KeyHash 'StakePool
ppId = do
  VRFVerKeyHash 'StakePoolVRF
ppVrf <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Arbitrary a => Gen a
arbitrary
  Coin
ppPledge <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
  Coin
ppCost <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
  UnitInterval
ppMargin <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Arbitrary a => Gen a
arbitrary
  RewardAccount
ppRewardAccount <- Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred PlutusPurposeTag
Rewarding
  let ppOwners :: Set (KeyHash 'Staking)
ppOwners = forall a. Monoid a => a
mempty
  let ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. Monoid a => a
mempty
  let ppMetadata :: StrictMaybe a
ppMetadata = forall a. StrictMaybe a
SNothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure PoolParams {Set (KeyHash 'Staking)
VRFVerKeyHash 'StakePoolVRF
KeyHash 'StakePool
Coin
RewardAccount
StrictSeq StakePoolRelay
UnitInterval
forall a. StrictMaybe a
ppId :: KeyHash 'StakePool
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppPledge :: Coin
ppCost :: Coin
ppMargin :: UnitInterval
ppRewardAccount :: RewardAccount
ppOwners :: Set (KeyHash 'Staking)
ppRelays :: StrictSeq StakePoolRelay
ppMetadata :: StrictMaybe PoolMetadata
ppMetadata :: forall a. StrictMaybe a
ppRelays :: StrictSeq StakePoolRelay
ppOwners :: Set (KeyHash 'Staking)
ppRewardAccount :: RewardAccount
ppMargin :: UnitInterval
ppCost :: Coin
ppPledge :: Coin
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppId :: KeyHash 'StakePool
..}

-- | Generate a 'n' fresh credentials (ones not in the set 'old'). We get 'tries' chances,
--   if it doesn't work in 'tries' attempts then quit with an error. Better to raise an error
--   than go into an infinite loop.
genFreshCredentials ::
  forall era kr.
  Reflect era =>
  Int ->
  Int ->
  PlutusPurposeTag ->
  Set (Credential kr) ->
  [Credential kr] ->
  GenRS era [Credential kr]
genFreshCredentials :: forall era (kr :: KeyRole).
Reflect era =>
Int
-> Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> [Credential kr]
-> GenRS era [Credential kr]
genFreshCredentials Int
_n Int
0 PlutusPurposeTag
_tag Set (Credential kr)
_old [Credential kr]
_ans = forall a. HasCallStack => String -> a
error String
"Ran out of tries in genFreshCredentials."
genFreshCredentials Int
n0 Int
tries PlutusPurposeTag
tag Set (Credential kr)
old0 [Credential kr]
ans0 = Int
-> Set (Credential kr)
-> [Credential kr]
-> RWST (GenEnv era) () (GenState era) Gen [Credential kr]
go Int
n0 Set (Credential kr)
old0 [Credential kr]
ans0
  where
    go :: Int
-> Set (Credential kr)
-> [Credential kr]
-> RWST (GenEnv era) () (GenState era) Gen [Credential kr]
go Int
0 Set (Credential kr)
_ [Credential kr]
ans = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Credential kr]
ans
    go Int
n Set (Credential kr)
old [Credential kr]
ans = do
      Credential kr
c <- forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
tries PlutusPurposeTag
tag Set (Credential kr)
old
      Int
-> Set (Credential kr)
-> [Credential kr]
-> RWST (GenEnv era) () (GenState era) Gen [Credential kr]
go (Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a. Ord a => a -> Set a -> Set a
Set.insert Credential kr
c Set (Credential kr)
old) (Credential kr
c forall a. a -> [a] -> [a]
: [Credential kr]
ans)

-- | Use this function to get a new pool that should not be used in the future transactions
genNewPool ::
  forall era.
  Reflect era =>
  GenRS
    era
    ( KeyHash 'StakePool
    , PoolParams
    , IndividualPoolStake
    )
genNewPool :: forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool = do
  KeyHash 'StakePool
poolId <- forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash
  PoolParams
poolParam <- forall era.
Reflect era =>
KeyHash 'StakePool -> GenRS era PoolParams
genPoolParams KeyHash 'StakePool
poolId
  Float
percent <- 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 (Float
0, Float
1 :: Float)
  let stake :: IndividualPoolStake
stake = Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake (forall a. Real a => a -> Rational
toRational Float
percent) forall a. Monoid a => a
mempty (PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf PoolParams
poolParam)
  forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateAvoidKey (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'StakePool
poolId))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
poolId, PoolParams
poolParam, IndividualPoolStake
stake)

-- | Initialize (or overwrite if they are not empty) the Stable fields. It is
--   intended that this be called just once at the beginning of a trace generation.
initStableFields :: forall era. Reflect era => GenRS era ()
initStableFields :: forall era. Reflect era => GenRS era ()
initStableFields = do
  GenEnv {GenSize
geSize :: GenSize
geSize :: forall era. GenEnv era -> GenSize
geSize} <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
  [KeyHash 'StakePool]
hashes <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (GenSize -> Int
maxStablePools GenSize
geSize) forall a b. (a -> b) -> a -> b
$ do
    PParams era
pp <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall era. GenEnv era -> PParams era
gePParams
    (KeyHash 'StakePool
kh, PoolParams
poolParams, IndividualPoolStake
ips) <- forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
    forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateStablePools (forall a. Ord a => a -> Set a -> Set a
Set.insert KeyHash 'StakePool
kh)
    forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
poolParams)
    forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh IndividualPoolStake
ips)
    forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
poolParams)
    forall era. KeyHash 'StakePool -> Coin -> GenRS era ()
modifyModelKeyDeposits KeyHash 'StakePool
kh (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)
    forall (m :: * -> *) a. Monad m => a -> m a
return KeyHash 'StakePool
kh

  -- This incantation gets a list of fresh (not previously generated) Credential
  [Credential 'Staking]
credentials <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (GenSize -> Int
maxStablePools GenSize
geSize) forall a b. (a -> b) -> a -> b
$ do
    Set (Credential 'Staking)
old' <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards)
    Set (Credential 'Staking)
prev <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
    Credential 'Staking
cred <- forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
100 PlutusPurposeTag
Rewarding (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Credential 'Staking)
old' Set (Credential 'Staking)
prev)
    forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateStableDelegators (forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking
cred)
    forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred (Integer -> Coin
Coin Integer
0))
    forall (m :: * -> *) a. Monad m => a -> m a
return Credential 'Staking
cred
  let f :: Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
      f :: Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
f Credential 'Staking
cred KeyHash 'StakePool
kh = do
        PParams era
pp <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall era. GenEnv era -> PParams era
gePParams
        let keyDeposit :: Coin
keyDeposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
        forall era.
(Map (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> GenRS era ()
modifyModelDelegations (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred KeyHash 'StakePool
kh)
        forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyModelRewards (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred (Integer -> Coin
Coin Integer
0))
        forall era. (Coin -> Coin) -> GenRS era ()
modifyModelDeposited (forall t. Val t => t -> t -> t
<+> Coin
keyDeposit)
        forall era. Credential 'Staking -> Coin -> GenRS era ()
modifyKeyDeposits Credential 'Staking
cred Coin
keyDeposit
        forall era.
(Map (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateInitialDelegations (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred KeyHash 'StakePool
kh)
  forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
f [Credential 'Staking]
credentials [KeyHash 'StakePool]
hashes

-- =============================================
-- Generators of inter-related items

-- Adds to the rewards of the ModelNewEpochState. This used exclusively to generate Withdrawals, so
-- we mark these as ones to avoid in the future. Especialy when generating DeRegKey.
genRewards :: Reflect era => GenRS era RewardAccounts
genRewards :: forall era.
Reflect era =>
GenRS era (Map (Credential 'Staking) Coin)
genRewards = do
  Int
wmax <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (GenSize -> Int
withdrawalMax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> GenEnv era
gsGenEnv)
  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
wmax)
  -- we need a fresh credential, one that was not previously
  -- generated here, or one that arose from gsAvoidCred (i.e. prev)
  Set (Credential 'Staking)
old <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards)
  Set (Credential 'Staking)
prev <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
  [Credential 'Staking]
credentials <- forall era (kr :: KeyRole).
Reflect era =>
Int
-> Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> [Credential kr]
-> GenRS era [Credential kr]
genFreshCredentials Int
n Int
100 PlutusPurposeTag
Rewarding (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Credential 'Staking)
old Set (Credential 'Staking)
prev) []
  Map (Credential 'Staking) Coin
newRewards <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList 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 (\Credential 'Staking
x -> (,) Credential 'Staking
x 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 v. Val v => Gen v
genRewardVal) [Credential 'Staking]
credentials
  forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyModelRewards (\Map (Credential 'Staking) Coin
rewards -> forall s t. Embed s t => Exp t -> s
eval (Map (Credential 'Staking) Coin
rewards forall k s1 (f :: * -> * -> *) v s2 (g :: * -> * -> *).
(Ord k, HasExp s1 (f k v), HasExp s2 (g k v)) =>
s1 -> s2 -> Exp (f k v)
⨃ Map (Credential 'Staking) Coin
newRewards)) -- Prefers coins in newrewards
  PParams era
pp <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall era. GenEnv era -> PParams era
gePParams
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall a b. (a -> b) -> [a] -> [b]
map (\Credential 'Staking
cred -> forall era. Credential 'Staking -> Coin -> GenRS era ()
modifyKeyDeposits Credential 'Staking
cred (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)) [Credential 'Staking]
credentials)
  forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards (\Map (Credential 'Staking) Coin
rewards -> forall s t. Embed s t => Exp t -> s
eval (Map (Credential 'Staking) Coin
rewards forall k s1 (f :: * -> * -> *) v s2 (g :: * -> * -> *).
(Ord k, HasExp s1 (f k v), HasExp s2 (g k v)) =>
s1 -> s2 -> Exp (f k v)
⨃ Map (Credential 'Staking) Coin
newRewards))
  forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateAvoidCred (forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall a. Ord a => [a] -> Set a
Set.fromList [Credential 'Staking]
credentials))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (Credential 'Staking) Coin
newRewards

genRetirementHash :: forall era. Reflect era => GenRS era (KeyHash 'StakePool)
genRetirementHash :: forall era. Reflect era => GenRS era (KeyHash 'StakePool)
genRetirementHash = do
  Map (KeyHash 'StakePool) PoolParams
m <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  Set (KeyHash 'StakePool)
honestKhs <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (KeyHash 'StakePool)
gsStablePools
  Set (KeyHash 'StakePool)
avoidKey <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey
  Maybe (KeyHash 'StakePool, PoolParams)
res <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map (KeyHash 'StakePool) PoolParams
m Int
10 forall a b. (a -> b) -> a -> b
$ \KeyHash 'StakePool
kh PoolParams
_ ->
    KeyHash 'StakePool
kh forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash 'StakePool)
honestKhs Bool -> Bool -> Bool
&& KeyHash 'StakePool
kh forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash 'StakePool)
avoidKey
  case Maybe (KeyHash 'StakePool, PoolParams)
res of
    Just (KeyHash 'StakePool, PoolParams)
x -> do
      forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateAvoidKey (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall a b. (a, b) -> a
fst (KeyHash 'StakePool, PoolParams)
x))
      -- if it is retiring, we should probably avoid it in the future
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (KeyHash 'StakePool, PoolParams)
x
    Maybe (KeyHash 'StakePool, PoolParams)
Nothing -> do
      (KeyHash 'StakePool
poolid, PoolParams
poolparams, IndividualPoolStake
stake) <- forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool

      -- add the Pool to the initial state
      forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid PoolParams
poolparams)
      forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid IndividualPoolStake
stake)

      -- add the Pool to the Model
      forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid PoolParams
poolparams)
      forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyModelPoolDistr (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid IndividualPoolStake
stake)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash 'StakePool
poolid

-- Adds to the mPoolParams and the  mPoolDistr of the Model, and the initial set of objects for Traces
genPool ::
  forall era.
  Reflect era =>
  GenRS era (KeyHash 'StakePool, PoolParams)
genPool :: forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams)
genPool = forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
10, RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
genNew), (Int
90, RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
pickExisting)]
  where
    genNew :: RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
genNew = do
      (KeyHash 'StakePool
kh, PoolParams
pp, IndividualPoolStake
ips) <- forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
      -- add pool to initial state
      forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
pp)
      forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh IndividualPoolStake
ips)
      -- update the model
      forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
pp)
      forall (m :: * -> *) a. Monad m => a -> m a
return (KeyHash 'StakePool
kh, PoolParams
pp)
    pickExisting :: RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
pickExisting = do
      Map (KeyHash 'StakePool) PoolParams
psStakePoolParams <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
      Set (KeyHash 'StakePool)
avoidKey <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map (KeyHash 'StakePool) PoolParams
psStakePoolParams Int
10 (\KeyHash 'StakePool
kh PoolParams
_ -> KeyHash 'StakePool
kh forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash 'StakePool)
avoidKey)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (KeyHash 'StakePool, PoolParams)
Nothing -> RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
genNew
        Just (KeyHash 'StakePool
kh, PoolParams
pp) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
kh, PoolParams
pp)