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

-- | 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 (
  EraGenericGen (..),
  GenEnv (..),
  GenRS,
  GenState (..),
  GenSize (..),
  defaultGenSize,
  PlutusPurposeTag (..),
  plutusPurposeTags,
  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,
  initialLedgerState,
  modifyModel,
  runGenRS,
  small,
  genDatumWithHash,
  genKeyHash,
  genScript,
  genFreshKeyHash,
  genCredential,
  genFreshCredential,
  genFreshRegCred,
  genPool,
  genPoolParams,
  genRewards,
  genNewPool,
  genRetirementHash,
  initStableFields,
  modifyGenStateInitialUtxo,
  modifyGenStateInitialAccounts,
  modifyModelCount,
  modifyModelIndex,
  modifyModelUTxO,
  modifyModelMutFee,
) where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext)
import Cardano.Ledger.Alonzo.Scripts hiding (Script)
import Cardano.Ledger.Alonzo.Tx (IsValid (..), ScriptIntegrityHash)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.BaseTypes (Network (Testnet), inject)
import Cardano.Ledger.Coin (Coin (..), compactCoinOrError)
import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj), StakeCredential)
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus (Language (..))
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  smartUTxOState,
  totalObligation,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.State
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (forM, join, replicateM, zipWithM_)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (RWST (..), ask, asks, get, gets, modify)
import Data.Default (Default (def))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
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 Data.TreeDiff (Expr, ToExpr (toExpr))
import GHC.Generics (Generic)
import GHC.Word (Word64)
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Allegra.TreeDiff ()
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Alonzo.TreeDiff ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Era
import Test.Cardano.Ledger.Examples.STSTestUtils (EraModel (..), PlutusPurposeTag (..))
import Test.Cardano.Ledger.Generic.Functions (
  alwaysFalse,
  alwaysTrue,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  ModelNewEpochState (..),
  genDelegsZero,
  instantaneousRewardsZero,
  mNewEpochStateZero,
  mPoolDeposits,
 )
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Shelley.Era
import Test.Tasty.QuickCheck (
  Gen,
  Positive (..),
  arbitrary,
  choose,
  elements,
  frequency,
 )

class (EraTest era, Reflect era, EraModel era) => EraGenericGen era where
  setValidity :: ValidityInterval -> TxBody era -> TxBody era

  setReferenceInputs :: Set TxIn -> TxBody era -> TxBody era

  setCollateralInputs :: Set TxIn -> TxBody era -> TxBody era

  setTotalCollateral :: StrictMaybe Coin -> TxBody era -> TxBody era

  setCollateralReturn :: StrictMaybe (TxOut era) -> TxBody era -> TxBody era

  addRedeemers :: Redeemers era -> TxWits era -> TxWits era

  setScriptIntegrityHash :: StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era

  setNetworkIdTxBody :: StrictMaybe Network -> TxBody era -> TxBody era

  genExUnits :: Int -> GenRS era [ExUnits]

  genPParams :: GenSize -> Gen (PParams era)

  -- Era generic "lenses" for testing

  ppMaxCollateralInputsT :: Lens' (PParams era) Natural

  ppCollateralPercentageT :: Lens' (PParams era) Natural

  ppCostModelsT :: Lens' (PParams era) CostModels

  ppMaxTxExUnitsT :: Lens' (PParams era) ExUnits

  ppMaxBlockExUnitsT :: Lens' (PParams era) ExUnits

  ppMaxValSizeT :: Lens' (PParams era) Natural

  -- Utils

  mkScriptIntegrityHash :: PParams era -> [Language] -> TxWits era -> StrictMaybe ScriptIntegrityHash

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

-- | 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
(Int -> GenSize -> ShowS)
-> (GenSize -> String) -> ([GenSize] -> ShowS) -> Show GenSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenSize -> ShowS
showsPrec :: Int -> GenSize -> ShowS
$cshow :: GenSize -> String
show :: GenSize -> String
$cshowList :: [GenSize] -> ShowS
showList :: [GenSize] -> ShowS
Show, (forall x. GenSize -> Rep GenSize x)
-> (forall x. Rep GenSize x -> GenSize) -> Generic GenSize
forall x. Rep GenSize x -> GenSize
forall x. GenSize -> Rep GenSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GenSize -> Rep GenSize x
from :: forall x. GenSize -> Rep GenSize x
$cto :: forall x. Rep GenSize x -> GenSize
to :: forall x. Rep GenSize x -> GenSize
Generic)

instance ToExpr GenSize

defaultGenSize :: GenSize
defaultGenSize :: GenSize
defaultGenSize =
  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
    }

data GenEnv era = GenEnv
  { forall era. GenEnv era -> PParams era
gePParams :: PParams era
  , forall era. GenEnv era -> GenSize
geSize :: GenSize
  }
  deriving ((forall x. GenEnv era -> Rep (GenEnv era) x)
-> (forall x. Rep (GenEnv era) x -> GenEnv era)
-> Generic (GenEnv era)
forall x. Rep (GenEnv era) x -> GenEnv era
forall x. GenEnv era -> Rep (GenEnv era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (GenEnv era) x -> GenEnv era
forall era x. GenEnv era -> Rep (GenEnv era) x
$cfrom :: forall era x. GenEnv era -> Rep (GenEnv era) x
from :: forall x. GenEnv era -> Rep (GenEnv era) x
$cto :: forall era x. Rep (GenEnv era) x -> GenEnv era
to :: forall x. Rep (GenEnv era) x -> GenEnv era
Generic)

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) (AccountState era)
gsInitialAccounts :: !(Map (Credential 'Staking) (AccountState era))
  , 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 -> GenEnv era
gsGenEnv :: !(GenEnv era)
  , forall era. GenState era -> Int
gsSeedIdx :: !Int
  }
  deriving ((forall x. GenState era -> Rep (GenState era) x)
-> (forall x. Rep (GenState era) x -> GenState era)
-> Generic (GenState era)
forall x. Rep (GenState era) x -> GenState era
forall x. GenState era -> Rep (GenState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (GenState era) x -> GenState era
forall era x. GenState era -> Rep (GenState era) x
$cfrom :: forall era x. GenState era -> Rep (GenState era) x
from :: forall x. GenState era -> Rep (GenState era) x
$cto :: forall era x. Rep (GenState era) x -> GenState era
to :: forall x. Rep (GenState era) x -> GenState era
Generic)

instance EraTest era => ToExpr (GenEnv era)

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

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
    }

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]

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

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

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

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

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

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

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

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

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

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

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

getReserves :: GenState era -> Coin
getReserves :: forall era. GenState era -> Coin
getReserves = Integer -> Coin
Coin (Integer -> Coin)
-> (GenState era -> Integer) -> GenState era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSize -> Integer
reserves (GenSize -> Integer)
-> (GenState era -> GenSize) -> GenState era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> GenSize
forall era. GenEnv era -> GenSize
geSize (GenEnv era -> GenSize)
-> (GenState era -> GenEnv era) -> GenState era -> GenSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> GenEnv era
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 = 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsKeys = f (gsKeys 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsDatums = f (gsDatums 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
x -> GenState era
x {gsVI = f (gsVI x)})

modifyGenStateInitialAccounts ::
  ( Map.Map (Credential 'Staking) (AccountState era) ->
    Map.Map (Credential 'Staking) (AccountState era)
  ) ->
  GenRS era ()
modifyGenStateInitialAccounts :: forall era.
(Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
modifyGenStateInitialAccounts Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
f = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((GenState era -> GenState era)
 -> RWST (GenEnv era) () (GenState era) Gen ())
-> (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall a b. (a -> b) -> a -> b
$ \GenState era
st -> GenState era
st {gsInitialAccounts = f (gsInitialAccounts 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((GenState era -> GenState era)
 -> RWST (GenEnv era) () (GenState era) Gen ())
-> (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall a b. (a -> b) -> a -> b
$ \GenState era
st -> GenState era
st {gsInitialUtxo = f (gsInitialUtxo 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
st -> GenState era
st {gsAvoidCred = f (gsAvoidCred 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
s -> GenState era
s {gsAvoidKey = f (gsAvoidKey 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsStablePools = f (gsStablePools 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsInitialPoolParams = f (gsInitialPoolParams 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsInitialPoolDistr = f (gsInitialPoolDistr 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsStableDelegators = f (gsStableDelegators 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 =
  (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((GenState era -> GenState era)
 -> RWST (GenEnv era) () (GenState era) Gen ())
-> (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall a b. (a -> b) -> a -> b
$ \GenState era
gs -> GenState era
gs {gsScripts = f (gsScripts 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsPlutusScripts = f (gsPlutusScripts 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 = (GenState era -> GenState era)
-> RWST (GenEnv era) () (GenState era) Gen ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gstate -> GenState era
gstate {gsModel = f (gsModel gstate)})

modifyModelAccounts :: (Accounts era -> Accounts era) -> GenRS era ()
modifyModelAccounts :: forall era. (Accounts era -> Accounts era) -> GenRS era ()
modifyModelAccounts Accounts era -> Accounts era
f = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mAccounts = f (mAccounts ms)})

modifyModelDeposited :: (Coin -> Coin) -> GenRS era ()
modifyModelDeposited :: forall era. (Coin -> Coin) -> GenRS era ()
modifyModelDeposited Coin -> Coin
f = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mDeposited = f (mDeposited 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 = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mPoolParams = f (mPoolParams 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 = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mPoolDistr = f (mPoolDistr ms)})

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

modifyModelCount :: (Int -> Int) -> GenRS era ()
modifyModelCount :: forall era. (Int -> Int) -> GenRS era ()
modifyModelCount Int -> Int
f = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mCount = f (mCount 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 = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mIndex = f (mIndex 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 = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mUTxO = f (mUTxO 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 = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
m -> ModelNewEpochState era
m {mMutFee = f (mMutFee 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe (k, a) -> Gen (Maybe (k, a))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (k, a)
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Maybe (k, a) -> Gen (Maybe (k, a))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (k, a) -> Gen (Maybe (k, a)))
-> Maybe (k, a) -> Gen (Maybe (k, a))
forall a b. (a -> b) -> a -> b
$ (k, a) -> Maybe (k, a)
forall a. a -> Maybe a
Just ((k, a) -> Maybe (k, a)) -> (k, a) -> Maybe (k, a)
forall a b. (a -> b) -> a -> b
$ Int -> Map k a -> (k, a)
forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i Map k a
m
  where
    n :: Int
n = Map k a -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Gen (Maybe a)) -> Maybe a -> Gen (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> Set a -> a
forall a. Int -> Set a -> a
Set.elemAt Int
i Set a
m
  where
    n :: Int
n = Set a -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Maybe (k, a) -> Gen (Maybe (k, a))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (k, a)
forall a. Maybe a
Nothing
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe (k, a) -> Gen (Maybe (k, a))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (k, a)
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      let (k
k, a
a) = Int -> Map k a -> (k, 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 Maybe (k, a) -> Gen (Maybe (k, a))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (k, a) -> Gen (Maybe (k, a)))
-> Maybe (k, a) -> Gen (Maybe (k, a))
forall a b. (a -> b) -> a -> b
$ (k, a) -> Maybe (k, a)
forall a. a -> Maybe a
Just ((k, a) -> Maybe (k, a)) -> (k, a) -> Maybe (k, a)
forall a b. (a -> b) -> a -> b
$ (k
k, a
a)
        else Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map k a
m (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) k -> a -> Bool
p
  where
    n :: Int
n = Map k a -> Int
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 = t Gen (t Gen b) -> t Gen b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t Gen (t Gen b) -> t Gen b)
-> ([t Gen b] -> t Gen (t Gen b)) -> [t Gen b] -> t Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (t Gen b) -> t Gen (t Gen b)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (t Gen b) -> t Gen (t Gen b))
-> ([t Gen b] -> Gen (t Gen b)) -> [t Gen b] -> t Gen (t Gen b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t Gen b] -> Gen (t Gen b)
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 [] = String -> t Gen b
forall a. HasCallStack => String -> a
error (String
"frequencyT called with empty list")
frequencyT [(Int, t Gen b)]
choices = t Gen (t Gen b) -> t Gen b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t Gen (t Gen b) -> t Gen b)
-> ([(Int, t Gen b)] -> t Gen (t Gen b))
-> [(Int, t Gen b)]
-> t Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (t Gen b) -> t Gen (t Gen b)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (t Gen b) -> t Gen (t Gen b))
-> ([(Int, t Gen b)] -> Gen (t Gen b))
-> [(Int, t Gen b)]
-> t Gen (t Gen b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Gen (t Gen b))] -> Gen (t Gen b)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen (t Gen b))] -> Gen (t Gen b))
-> ([(Int, t Gen b)] -> [(Int, Gen (t Gen b))])
-> [(Int, t Gen b)]
-> Gen (t Gen b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, t Gen b) -> (Int, Gen (t Gen b)))
-> [(Int, t Gen b)] -> [(Int, Gen (t Gen b))]
forall a b. (a -> b) -> [a] -> [b]
map (t Gen b -> Gen (t Gen b)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t Gen b -> Gen (t Gen b))
-> (Int, t Gen b) -> (Int, Gen (t Gen b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([(Int, t Gen b)] -> t Gen b) -> [(Int, t Gen b)] -> t Gen 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 =
  [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency (((Int, Int) -> (Int, Gen Int)) -> [(Int, Int)] -> [(Int, Gen Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> (Int, Gen Int)
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, a -> f a
forall a. a -> f a
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 =
  [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency (((Int, Int) -> (Int, Gen Int)) -> [(Int, Int)] -> [(Int, Gen Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> (Int, Gen Int)
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, a -> f a
forall a. a -> f a
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 = Coin -> v
forall t s. Inject t s => t -> s
inject (Coin -> v) -> (Positive Integer -> Coin) -> Positive Integer -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin (Integer -> Coin)
-> (Positive Integer -> Integer) -> Positive Integer -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Integer -> Integer
forall a. Positive a -> a
getPositive (Positive Integer -> v) -> Gen (Positive Integer) -> Gen v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Integer)
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 = [(Int, Gen v)] -> Gen v
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
3, v -> Gen v
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
forall a. Monoid a => a
mempty), (Int
97, Gen v
forall v. Val v => Gen v
genPositiveVal)]

-- | 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 :: EraModel era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem :: forall era. EraModel era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem = do
  Map TxIn (TxOut era)
x <- (GenState era -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (Map TxIn (TxOut era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map TxIn (TxOut era)
forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO (ModelNewEpochState era -> Map TxIn (TxOut era))
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  Map ScriptHash (Script era)
scriptmap <- (GenState era -> Map ScriptHash (Script era))
-> RWST
     (GenEnv era) () (GenState era) Gen (Map ScriptHash (Script era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map ScriptHash (Script era)
forall era. GenState era -> Map ScriptHash (Script era)
gsScripts
  Gen (Maybe (TxIn, TxOut era))
-> GenRS era (Maybe (TxIn, TxOut era))
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (Maybe (TxIn, TxOut era))
 -> GenRS era (Maybe (TxIn, TxOut era)))
-> Gen (Maybe (TxIn, TxOut era))
-> GenRS era (Maybe (TxIn, TxOut era))
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut era)
-> Int
-> (TxIn -> TxOut era -> Bool)
-> Gen (Maybe (TxIn, TxOut era))
forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map TxIn (TxOut era)
x Int
20 (\TxIn
_ -> Map ScriptHash (Script era) -> TxOut era -> Bool
forall era.
EraModel era =>
Map ScriptHash (Script era) -> TxOut era -> Bool
validTxOut Map ScriptHash (Script era)
scriptmap)

getUtxoTest :: GenRS era (TxIn -> Bool)
getUtxoTest :: forall era. GenRS era (TxIn -> Bool)
getUtxoTest = do
  Map TxIn (TxOut era)
x <- (GenState era -> Map TxIn (TxOut era))
-> RWST (GenEnv era) () (GenState era) Gen (Map TxIn (TxOut era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map TxIn (TxOut era)
forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO (ModelNewEpochState era -> Map TxIn (TxOut era))
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  (TxIn -> Bool) -> GenRS era (TxIn -> Bool)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> Map TxIn (TxOut era) -> Bool
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 <- (GenState era -> Map (KeyHash 'StakePool) PoolParams)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash 'StakePool) PoolParams)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams (ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash 'StakePool) PoolParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  (KeyHash 'StakePool -> Bool)
-> GenRS era (KeyHash 'StakePool -> Bool)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool
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 ::
  EraGenericGen era =>
  GenSize ->
  GenRS era a ->
  Gen (a, GenState era)
runGenRS :: forall era a.
EraGenericGen era =>
GenSize -> GenRS era a -> Gen (a, GenState era)
runGenRS GenSize
gsize GenRS era a
action = do
  GenEnv era
genenv <- GenSize -> Gen (GenEnv era)
forall era. EraGenericGen era => GenSize -> Gen (GenEnv era)
genGenEnv GenSize
gsize
  (a
ans, GenState era
state, ()) <- GenRS era a
-> GenEnv era -> GenState era -> Gen (a, GenState era, ())
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 (GenEnv era -> GenState era
forall era. Reflect era => GenEnv era -> GenState era
emptyGenState GenEnv era
genenv)
  (a, GenState era) -> Gen (a, GenState era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ans, GenState era
state)

-- | Generate a random, well-formed, GenEnv
genGenEnv :: forall era. EraGenericGen era => GenSize -> Gen (GenEnv era)
genGenEnv :: forall era. EraGenericGen era => GenSize -> Gen (GenEnv era)
genGenEnv GenSize
gsize = do
  PParams era
pp <- GenSize -> Gen (PParams era)
forall era. EraGenericGen era => GenSize -> Gen (PParams era)
genPParams GenSize
gsize
  GenEnv era -> Gen (GenEnv era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    GenEnv
      { geSize :: GenSize
geSize = GenSize
gsize
      , gePParams :: PParams era
gePParams = PParams era
pp
      }

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

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

pcGenState :: ShelleyEraTest era => GenState era -> Expr
pcGenState :: forall era. ShelleyEraTest era => GenState era -> Expr
pcGenState = GenState era -> Expr
forall a. ToExpr a => a -> Expr
toExpr

instance ShelleyEraTest era => ToExpr (GenState era)

instance (Reflect era, ShelleyEraTest era) => Show (GenState era) where
  show :: GenState era -> String
show GenState era
x = Expr -> String
forall a. Show a => a -> String
show (GenState era -> Expr
forall era. ShelleyEraTest era => GenState era -> Expr
pcGenState 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 = UTxOState era -> CertState era -> LedgerState era
forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState era
utxostate CertState era
dpstate
  where
    utxostate :: UTxOState era
utxostate = PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pp (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (GenState era -> Map TxIn (TxOut era)
forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo GenState era
gstate)) Coin
deposited (Integer -> Coin
Coin Integer
0) GovState era
forall era. EraGov era => GovState era
emptyGovState Coin
forall a. Monoid a => a
mempty
    dpstate :: CertState era
dpstate =
      CertState era
forall a. Default a => a
def
        CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
pstate
        CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
dstate
    dstate :: DState era
dstate =
      Accounts era
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
forall era.
Accounts era
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState
        (Map (Credential 'Staking) (AccountState era) -> Accounts era
forall era.
EraTest era =>
Map (Credential 'Staking) (AccountState era) -> Accounts era
accountsFromAccountsMap (GenState era -> Map (Credential 'Staking) (AccountState era)
forall era.
GenState era -> Map (Credential 'Staking) (AccountState era)
gsInitialAccounts GenState era
gstate))
        Map FutureGenDeleg GenDelegPair
forall k a. Map k a
Map.empty
        GenDelegs
genDelegsZero
        InstantaneousRewards
instantaneousRewardsZero
    pstate :: PState era
pstate = Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) (CompactForm Coin)
-> PState era
forall era.
Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) (CompactForm Coin)
-> PState era
PState Map (KeyHash 'StakePool) PoolParams
pools Map (KeyHash 'StakePool) PoolParams
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool) EpochNo
forall k a. Map k a
Map.empty ((PoolParams -> CompactForm Coin)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) (CompactForm Coin)
forall a b.
(a -> b)
-> Map (KeyHash 'StakePool) a -> Map (KeyHash 'StakePool) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CompactForm Coin -> PoolParams -> CompactForm Coin
forall a b. a -> b -> a
const CompactForm Coin
poolDeposit) Map (KeyHash 'StakePool) PoolParams
pools)
    -- In a wellformed LedgerState the deposited equals the obligation
    deposited :: Coin
deposited = CertState era -> GovState era -> Coin
forall era.
(EraGov era, EraCertState era) =>
CertState era -> GovState era -> Coin
totalObligation CertState era
dpstate (UTxOState era
utxostate UTxOState era
-> Getting (GovState era) (UTxOState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. Getting (GovState era) (UTxOState era) (GovState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL)
    pools :: Map (KeyHash 'StakePool) PoolParams
pools = GenState era -> Map (KeyHash 'StakePool) PoolParams
forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams GenState era
gstate
    pp :: PParams era
pp = ModelNewEpochState era -> PParams era
forall era. ModelNewEpochState era -> PParams era
mPParams (GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel GenState era
gstate)
    poolDeposit :: CompactForm Coin
poolDeposit = PParams era
pp PParams era
-> Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL

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

-- Adds to the gsKeys
genKeyHash :: forall kr era. GenRS era (KeyHash kr)
genKeyHash :: forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash = do
  KeyPair 'Witness
keyPair <- Gen (KeyPair 'Witness)
-> RWST (GenEnv era) () (GenState era) Gen (KeyPair 'Witness)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (KeyPair 'Witness)
forall a. Arbitrary a => Gen a
arbitrary
  let keyHash :: KeyHash 'Witness
keyHash = VKey 'Witness -> KeyHash 'Witness
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey 'Witness -> KeyHash 'Witness)
-> VKey 'Witness -> KeyHash 'Witness
forall a b. (a -> b) -> a -> b
$ KeyPair 'Witness -> VKey 'Witness
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Witness
keyPair
  (Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era ()
forall era.
(Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> GenRS era ()
modifyGenStateKeys (KeyHash 'Witness
-> KeyPair 'Witness
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'Witness
keyHash KeyPair 'Witness
keyPair)
  KeyHash kr -> GenRS era (KeyHash kr)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash kr -> GenRS era (KeyHash kr))
-> KeyHash kr -> GenRS era (KeyHash kr)
forall a b. (a -> b) -> a -> b
$ KeyHash 'Witness -> KeyHash kr
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
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 <- Gen (Data era)
-> RWST (GenEnv era) () (GenState era) Gen (Data era)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (Data era)
forall a. Arbitrary a => Gen a
arbitrary
  let datumHash :: DataHash
datumHash = Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
datum
  (Map DataHash (Data era) -> Map DataHash (Data era))
-> GenRS era ()
forall era.
(Map DataHash (Data era) -> Map DataHash (Data era))
-> GenRS era ()
modifyGenStateDatums (DataHash
-> Data era -> Map DataHash (Data era) -> Map DataHash (Data era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
datumHash Data era
datum)
  (DataHash, Data era) -> GenRS era (DataHash, Data era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 = Int -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = String -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
forall a. HasCallStack => String -> a
error String
"Something very unlikely happened"
      | Bool
otherwise = do
          Set (KeyHash 'StakePool)
avoidKeys <- (GenState era -> Set (KeyHash 'StakePool))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (KeyHash 'StakePool))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (KeyHash 'StakePool)
forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey
          KeyHash r
kh <- RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash
          if KeyHash r -> KeyHash 'StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash r
kh KeyHash 'StakePool -> Set (KeyHash 'StakePool) -> Bool
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 (a -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r))
-> a -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1
            else KeyHash r -> RWST (GenEnv era) () (GenState era) Gen (KeyHash r)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return KeyHash r
kh

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

-- Adds to gsScripts and gsPlutusScripts
genScript :: forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript :: forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript PlutusPurposeTag
tag = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Conway -> [GenRS era ScriptHash] -> GenRS era ScriptHash
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, PlutusPurposeTag -> GenRS era ScriptHash
forall era.
(Reflect era, EraPlutusContext era) =>
PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript PlutusPurposeTag
tag]
  Proof era
Babbage -> [GenRS era ScriptHash] -> GenRS era ScriptHash
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, PlutusPurposeTag -> GenRS era ScriptHash
forall era.
(Reflect era, EraPlutusContext era) =>
PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript PlutusPurposeTag
tag]
  Proof era
Alonzo -> [GenRS era ScriptHash] -> GenRS era ScriptHash
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript, PlutusPurposeTag -> GenRS era ScriptHash
forall era.
(Reflect era, EraPlutusContext era) =>
PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript PlutusPurposeTag
tag]
  Proof era
Mary -> GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Allegra -> GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Shelley -> GenRS era ScriptHash
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) <- (GenState era -> ValidityInterval)
-> RWST (GenEnv era) () (GenState era) Gen ValidityInterval
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> ValidityInterval
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 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0 =
            [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT ([RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
 -> RWST (GenEnv era) () (GenState era) Gen (Timelock era))
-> [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall a b. (a -> b) -> a -> b
$
              [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
nonRecTimelocks [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
-> [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
-> [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
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 = [RWST (GenEnv era) () (GenState era) Gen (Timelock era)]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
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 <-
            [ SlotNo -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
SlotNo
-> RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
forall {era} {t :: (* -> *) -> * -> *}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Monad (t Gen), MonadTrans t, AllegraEraScript era) =>
SlotNo -> t Gen (NativeScript era)
requireTimeStart (SlotNo -> RWST (GenEnv era) () (GenState era) Gen (Timelock era))
-> StrictMaybe SlotNo
-> StrictMaybe
     (RWST (GenEnv era) () (GenState era) Gen (Timelock era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mBefore
            , SlotNo -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
SlotNo
-> RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
forall {era} {t :: (* -> *) -> * -> *}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Monad (t Gen), MonadTrans t, AllegraEraScript era) =>
SlotNo -> t Gen (NativeScript era)
requireTimeExpire (SlotNo -> RWST (GenEnv era) () (GenState era) Gen (Timelock era))
-> StrictMaybe SlotNo
-> StrictMaybe
     (RWST (GenEnv era) () (GenState era) Gen (Timelock era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mAfter
            , RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> StrictMaybe
     (RWST (GenEnv era) () (GenState era) Gen (Timelock era))
forall a. a -> StrictMaybe a
SJust RWST (GenEnv era) () (GenState era) Gen (Timelock era)
RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
forall {era}.
RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
requireSignature
            ]
        ]
      requireSignature :: RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
requireSignature = KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash 'Witness -> NativeScript era)
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'Witness)
-> RWST (GenEnv era) () (GenState era) Gen (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'Witness)
forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash
      requireAllOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
requireAllOf Natural
k = do
        Int
n <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        StrictSeq (Timelock era) -> Timelock era
StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (Timelock era) -> Timelock era)
-> ([Timelock era] -> StrictSeq (Timelock era))
-> [Timelock era]
-> Timelock era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Timelock era] -> StrictSeq (Timelock era)
forall a. [a] -> StrictSeq a
Seq.fromList ([Timelock era] -> Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
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 Natural -> Natural -> Natural
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 <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
positiveSingleDigitInt
        StrictSeq (Timelock era) -> Timelock era
StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (Timelock era) -> Timelock era)
-> ([Timelock era] -> StrictSeq (Timelock era))
-> [Timelock era]
-> Timelock era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Timelock era] -> StrictSeq (Timelock era)
forall a. [a] -> StrictSeq a
Seq.fromList ([Timelock era] -> Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
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 Natural -> Natural -> Natural
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 <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        Int
m <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
        Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m (StrictSeq (Timelock era) -> Timelock era)
-> ([Timelock era] -> StrictSeq (Timelock era))
-> [Timelock era]
-> Timelock era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Timelock era] -> StrictSeq (Timelock era)
forall a. [a] -> StrictSeq a
Seq.fromList ([Timelock era] -> Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (Timelock era)
-> RWST (GenEnv era) () (GenState era) Gen [Timelock era]
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 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1))
      requireTimeStart :: SlotNo -> t Gen (NativeScript era)
requireTimeStart (SlotNo Word64
validFrom) = do
        Word64
minSlotNo <- Gen Word64 -> t Gen Word64
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Word64 -> t Gen Word64) -> Gen Word64 -> t Gen Word64
forall a b. (a -> b) -> a -> b
$ (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
forall a. Bounded a => a
minBound, Word64
validFrom)
        NativeScript era -> t Gen (NativeScript era)
forall a. a -> t Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NativeScript era -> t Gen (NativeScript era))
-> NativeScript era -> t Gen (NativeScript era)
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
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 <- Gen Word64 -> t Gen Word64
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Word64 -> t Gen Word64) -> Gen Word64 -> t Gen Word64
forall a b. (a -> b) -> a -> b
$ (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
validTill, Word64
forall a. Bounded a => a
maxBound)
        NativeScript era -> t Gen (NativeScript era)
forall a. a -> t Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NativeScript era -> t Gen (NativeScript era))
-> NativeScript era -> t Gen (NativeScript era)
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
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 = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript 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 = Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just (a -> Set a
forall a. a -> Set a
Set.singleton a
x)
      insertOrCreate a
x (Just Set a
s) = Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s)
  (Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
forall era.
(Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
modifyGenStateScripts (ScriptHash
-> Script era
-> Map ScriptHash (Script era)
-> Map ScriptHash (Script era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash Script era
corescript)
  (Map ValidityInterval (Set ScriptHash)
 -> Map ValidityInterval (Set ScriptHash))
-> GenRS era ()
forall era.
(Map ValidityInterval (Set ScriptHash)
 -> Map ValidityInterval (Set ScriptHash))
-> GenRS era ()
modifyGenStateVI ((Maybe (Set ScriptHash) -> Maybe (Set ScriptHash))
-> ValidityInterval
-> Map ValidityInterval (Set ScriptHash)
-> Map ValidityInterval (Set ScriptHash)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (ScriptHash -> Maybe (Set ScriptHash) -> Maybe (Set ScriptHash)
forall {a}. Ord a => a -> Maybe (Set a) -> Maybe (Set a)
insertOrCreate ScriptHash
scriptHash) ValidityInterval
vi)
  ScriptHash -> GenRS era ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0 =
            [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT ([RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
 -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era))
-> [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall a b. (a -> b) -> a -> b
$
              [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
nonRecTimelocks [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
-> [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
-> [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
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 = [RWST (GenEnv era) () (GenState era) Gen (MultiSig era)]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
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 (KeyHash 'Witness -> MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'Witness)
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'Witness)
forall (kr :: KeyRole) era. GenRS era (KeyHash kr)
genKeyHash
      requireAllOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAllOf Natural
k = do
        Int
n <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        StrictSeq (NativeScript era) -> NativeScript era
StrictSeq (MultiSig era) -> MultiSig era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (MultiSig era) -> MultiSig era)
-> ([MultiSig era] -> StrictSeq (MultiSig era))
-> [MultiSig era]
-> MultiSig era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MultiSig era] -> StrictSeq (MultiSig era)
forall a. [a] -> StrictSeq a
Seq.fromList ([MultiSig era] -> MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
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 Natural -> Natural -> Natural
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 <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
positiveSingleDigitInt
        StrictSeq (NativeScript era) -> NativeScript era
StrictSeq (MultiSig era) -> MultiSig era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (MultiSig era) -> MultiSig era)
-> ([MultiSig era] -> StrictSeq (MultiSig era))
-> [MultiSig era]
-> MultiSig era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MultiSig era] -> StrictSeq (MultiSig era)
forall a. [a] -> StrictSeq a
Seq.fromList ([MultiSig era] -> MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
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 Natural -> Natural -> Natural
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 <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
nonNegativeSingleDigitInt
        Int
m <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
        Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m (StrictSeq (MultiSig era) -> MultiSig era)
-> ([MultiSig era] -> StrictSeq (MultiSig era))
-> [MultiSig era]
-> MultiSig era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MultiSig era] -> StrictSeq (MultiSig era)
forall a. [a] -> StrictSeq a
Seq.fromList ([MultiSig era] -> MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
-> RWST (GenEnv era) () (GenState era) Gen [MultiSig era]
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 Natural -> Natural -> Natural
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 = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
MultiSig era
msscript
  let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
  (Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
forall era.
(Map ScriptHash (Script era) -> Map ScriptHash (Script era))
-> GenRS era ()
modifyGenStateScripts (ScriptHash
-> Script era
-> Map ScriptHash (Script era)
-> Map ScriptHash (Script era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash Script era
corescript)
  ScriptHash -> GenRS era ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

-- Adds to gsPlutusScripts
genPlutusScript ::
  forall era.
  ( Reflect era
  , EraPlutusContext era
  ) =>
  PlutusPurposeTag ->
  GenRS era ScriptHash
genPlutusScript :: forall era.
(Reflect era, EraPlutusContext era) =>
PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript PlutusPurposeTag
tag = do
  Int
falseFreq <- (GenEnv era -> Int) -> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks ((GenEnv era -> Int)
 -> RWST (GenEnv era) () (GenState era) Gen Int)
-> (GenEnv era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ GenSize -> Int
invalidScriptFreq (GenSize -> Int) -> (GenEnv era -> GenSize) -> GenEnv era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> GenSize
forall era. GenEnv era -> GenSize
geSize
  Bool
isValid <- Gen Bool -> RWST (GenEnv era) () (GenState era) Gen Bool
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Bool -> RWST (GenEnv era) () (GenState era) Gen Bool)
-> Gen Bool -> RWST (GenEnv era) () (GenState era) Gen Bool
forall a b. (a -> b) -> a -> b
$ [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
falseFreq, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
falseFreq, Bool -> Gen Bool
forall a. a -> Gen a
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 (forall era. Reflect era => Proof era
reify @era, 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 = case forall era. Reflect era => Proof era
reify @era of
        Proof era
Conway -> Language -> Maybe Language
forall a. a -> Maybe a
Just Language
PlutusV2
        Proof era
Babbage -> Language -> Maybe Language
forall a. a -> Maybe a
Just Language
PlutusV2
        Proof era
Alonzo -> Language -> Maybe Language
forall a. a -> Maybe a
Just Language
PlutusV1
        Proof era
_ -> Maybe Language
forall a. Maybe a
Nothing
  Script era
script <-
    if Bool
isValid
      then Maybe Language -> Natural -> Script era
forall era.
EraPlutusContext era =>
Maybe Language -> Natural -> Script era
alwaysTrue Maybe Language
mlanguage (Natural -> Script era)
-> (Natural -> Natural) -> Natural -> Script era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
numArgs) (Natural -> Script era)
-> RWST (GenEnv era) () (GenState era) Gen Natural
-> RWST (GenEnv era) () (GenState era) Gen (Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Natural -> RWST (GenEnv era) () (GenState era) Gen Natural
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Natural] -> Gen Natural
forall a. HasCallStack => [a] -> Gen a
elements [Natural
0, Natural
1, Natural
2, Natural
3 :: Natural])
      else Script era -> RWST (GenEnv era) () (GenState era) Gen (Script era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script era
 -> RWST (GenEnv era) () (GenState era) Gen (Script era))
-> Script era
-> RWST (GenEnv era) () (GenState era) Gen (Script era)
forall a b. (a -> b) -> a -> b
$ Maybe Language -> Natural -> Script era
forall era.
EraPlutusContext era =>
Maybe Language -> Natural -> Script era
alwaysFalse Maybe Language
mlanguage Natural
numArgs

  let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script
  (Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenRS era ()
forall era.
(Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenRS era ()
modifyPlutusScripts ((ScriptHash, PlutusPurposeTag)
-> (IsValid, Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
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
script))
  ScriptHash -> GenRS era ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 kr era. Reflect era => PlutusPurposeTag -> GenRS era (Credential kr)
genCredential :: forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
tag =
  [(Int, RWST (GenEnv era) () (GenState era) Gen (Credential kr))]
-> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
35, KeyHash kr -> Credential kr
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash kr -> Credential kr)
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
-> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash')
    , (Int
35, ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential kr)
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
-> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
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
    genNewAccountState :: RWST (GenEnv era) () (GenState era) Gen (AccountState era)
genNewAccountState = do
      Ptr
ptr <- Gen Ptr -> RWST (GenEnv era) () (GenState era) Gen Ptr
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Ptr
forall a. Arbitrary a => Gen a
arbitrary
      CompactForm Coin
deposit <- Gen (CompactForm Coin)
-> RWST (GenEnv era) () (GenState era) Gen (CompactForm Coin)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (CompactForm Coin)
forall a. Arbitrary a => Gen a
arbitrary
      AccountState era
-> RWST (GenEnv era) () (GenState era) Gen (AccountState era)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AccountState era
 -> RWST (GenEnv era) () (GenState era) Gen (AccountState era))
-> AccountState era
-> RWST (GenEnv era) () (GenState era) Gen (AccountState era)
forall a b. (a -> b) -> a -> b
$ Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
forall era.
(EraTest era, HasCallStack) =>
Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
mkTestAccountState (Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
ptr) CompactForm Coin
deposit Maybe (KeyHash 'StakePool)
forall a. Maybe a
Nothing Maybe DRep
forall a. Maybe a
Nothing
    genKeyHash' :: RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash' = do
      KeyHash 'Staking
kh <- GenRS era (KeyHash 'Staking)
forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash -- We need to avoid some key credentials
      case PlutusPurposeTag
tag of
        PlutusPurposeTag
Rewarding -> do
          AccountState era
accountState <- RWST (GenEnv era) () (GenState era) Gen (AccountState era)
genNewAccountState
          (Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
modifyGenStateInitialAccounts (Credential 'Staking
-> AccountState era
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh) AccountState era
accountState)
        PlutusPurposeTag
_ -> () -> RWST (GenEnv era) () (GenState era) Gen ()
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      KeyHash kr -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyHash kr
 -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr))
-> KeyHash kr
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
forall a b. (a -> b) -> a -> b
$ KeyHash 'Staking -> KeyHash kr
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a. HasCallStack => String -> a
error String
"Failed to generate a fresh script hash"
          | Bool
otherwise = do
              ScriptHash
sh <- forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript @era PlutusPurposeTag
tag
              Map (Credential 'Staking) (AccountState era)
initialRewards <- (GenState era -> Map (Credential 'Staking) (AccountState era))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (Credential 'Staking) (AccountState era))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map (Credential 'Staking) (AccountState era)
forall era.
GenState era -> Map (Credential 'Staking) (AccountState era)
gsInitialAccounts
              Set (Credential 'Staking)
avoidCredentials <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (Credential 'Staking)
forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
              let newcred :: Credential 'Staking
newcred = ScriptHash -> Credential 'Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
sh
              if Credential 'Staking
-> Map (Credential 'Staking) (AccountState era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'Staking
newcred Map (Credential 'Staking) (AccountState era)
initialRewards Bool -> Bool -> Bool
&& Credential 'Staking -> Set (Credential 'Staking) -> 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 -> do
                      AccountState era
accountState <- RWST (GenEnv era) () (GenState era) Gen (AccountState era)
genNewAccountState
                      (Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> RWST (GenEnv era) () (GenState era) Gen ()
forall era.
(Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
modifyGenStateInitialAccounts (Credential 'Staking
-> AccountState era
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
newcred AccountState era
accountState)
                    PlutusPurposeTag
_ -> () -> RWST (GenEnv era) () (GenState era) Gen ()
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  ScriptHash -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptHash
sh
                else Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
f (Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash)
-> Int -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    pickExistingKeyHash :: RWST (GenEnv era) () (GenState era) Gen (Credential kr)
pickExistingKeyHash =
      KeyHash kr -> Credential kr
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash kr -> Credential kr)
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
-> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Map (KeyHash 'Witness) (KeyPair 'Witness)
keysMap <- GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys (GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> RWST (GenEnv era) () (GenState era) Gen (GenState era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (GenState era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
        Gen (Maybe (KeyHash 'Witness, KeyPair 'Witness))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (KeyHash 'Witness, KeyPair 'Witness))
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Gen (Maybe (KeyHash 'Witness, KeyPair 'Witness))
forall k a. Map k a -> Gen (Maybe (k, a))
genMapElem Map (KeyHash 'Witness) (KeyPair 'Witness)
keysMap) RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (Maybe (KeyHash 'Witness, KeyPair 'Witness))
-> (Maybe (KeyHash 'Witness, KeyPair 'Witness)
    -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr))
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (KeyHash 'Witness
k, KeyPair 'Witness
_) -> KeyHash kr -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash kr
 -> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr))
-> KeyHash kr
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
forall a b. (a -> b) -> a -> b
$ KeyHash 'Witness -> KeyHash kr
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
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 =
      ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj
        (ScriptHash -> Credential kr)
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
-> RWST (GenEnv era) () (GenState era) Gen (Credential kr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RWST (GenEnv era) () (GenState era) Gen ScriptHash]
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
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 <-
        ((ScriptHash, PlutusPurposeTag) -> (IsValid, Script era) -> Bool)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\(ScriptHash
_, PlutusPurposeTag
t) (IsValid, Script era)
_ -> PlutusPurposeTag
t PlutusPurposeTag -> PlutusPurposeTag -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusPurposeTag
tag) (Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> (GenState era
    -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts (GenState era
 -> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
-> RWST (GenEnv era) () (GenState era) Gen (GenState era)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (GenState era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
      Gen (Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era)))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era)))
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Gen
     (Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era)))
forall k a. Map k a -> Gen (Maybe (k, a))
genMapElem Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
plutusScriptsMap) RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era)))
-> (Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era))
    -> RWST (GenEnv era) () (GenState era) Gen ScriptHash)
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ((ScriptHash
h, PlutusPurposeTag
_), (IsValid, Script era)
_) -> ScriptHash -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
h
        Maybe ((ScriptHash, PlutusPurposeTag), (IsValid, Script era))
Nothing -> PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript PlutusPurposeTag
tag
    pickExistingTimelockScript :: RWST (GenEnv era) () (GenState era) Gen ScriptHash
pickExistingTimelockScript = do
      -- Only pick one if it matches the
      ValidityInterval
vi <- (GenState era -> ValidityInterval)
-> RWST (GenEnv era) () (GenState era) Gen ValidityInterval
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> ValidityInterval
forall era. GenState era -> ValidityInterval
gsValidityInterval -- current ValidityInterval
      Map ValidityInterval (Set ScriptHash)
vimap <- (GenState era -> Map ValidityInterval (Set ScriptHash))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map ValidityInterval (Set ScriptHash))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map ValidityInterval (Set ScriptHash)
forall era. GenState era -> Map ValidityInterval (Set ScriptHash)
gsVI
      case ValidityInterval
-> Map ValidityInterval (Set ScriptHash) -> Maybe (Set ScriptHash)
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 => PlutusPurposeTag -> GenRS era ScriptHash
genScript @era PlutusPurposeTag
tag
        Just Set ScriptHash
s ->
          Gen (Maybe ScriptHash)
-> RWST (GenEnv era) () (GenState era) Gen (Maybe ScriptHash)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Set ScriptHash -> Gen (Maybe ScriptHash)
forall a. Set a -> Gen (Maybe a)
genSetElem Set ScriptHash
s) RWST (GenEnv era) () (GenState era) Gen (Maybe ScriptHash)
-> (Maybe ScriptHash
    -> RWST (GenEnv era) () (GenState era) Gen ScriptHash)
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ScriptHash
Nothing -> PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript PlutusPurposeTag
tag
            Just ScriptHash
hash -> ScriptHash -> RWST (GenEnv era) () (GenState era) Gen ScriptHash
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 = String -> GenRS era (Credential kr)
forall a. HasCallStack => String -> a
error String
"Ran out of tries in genFreshCredential."
genFreshCredential Int
tries0 PlutusPurposeTag
tag Set (Credential kr)
old = Int -> GenRS era (Credential kr)
go Int
tries0
  where
    go :: Int -> GenRS era (Credential kr)
go Int
tries = do
      Credential kr
c <- PlutusPurposeTag -> GenRS era (Credential kr)
forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
tag
      if Credential kr -> Set (Credential kr) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Credential kr
c Set (Credential kr)
old
        then Int -> GenRS era (Credential kr)
go (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        else Credential kr -> GenRS era (Credential kr)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (Map (Credential 'Staking) (AccountState era)
-> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential 'Staking) (AccountState era)
 -> Set (Credential 'Staking))
-> (GenState era -> Map (Credential 'Staking) (AccountState era))
-> GenState era
-> Set (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> Map (Credential 'Staking) (AccountState era)
forall era.
GenState era -> Map (Credential 'Staking) (AccountState era)
gsInitialAccounts)
  Set (Credential 'Staking)
avoid <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (Credential 'Staking)
forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
  Set (Credential 'Staking)
rewards <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets ((GenState era -> Set (Credential 'Staking))
 -> RWST
      (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking)))
-> (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking) (AccountState era)
-> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential 'Staking) (AccountState era)
 -> Set (Credential 'Staking))
-> (GenState era -> Map (Credential 'Staking) (AccountState era))
-> GenState era
-> Set (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
-> Getting
     (Map (Credential 'Staking) (AccountState era))
     (Accounts era)
     (Map (Credential 'Staking) (AccountState era))
-> Map (Credential 'Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential 'Staking) (AccountState era))
  (Accounts era)
  (Map (Credential 'Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
accountsMapL) (Accounts era -> Map (Credential 'Staking) (AccountState era))
-> (GenState era -> Accounts era)
-> GenState era
-> Map (Credential 'Staking) (AccountState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModelNewEpochState era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts (ModelNewEpochState era -> Accounts era)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel
  Credential 'Staking
cred <- Int
-> PlutusPurposeTag
-> Set (Credential 'Staking)
-> GenRS era (Credential 'Staking)
forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
100 PlutusPurposeTag
tag (Set (Credential 'Staking) -> GenRS era (Credential 'Staking))
-> Set (Credential 'Staking) -> GenRS era (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Set (Credential 'Staking)
old Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Semigroup a => a -> a -> a
<> Set (Credential 'Staking)
avoid Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Semigroup a => a -> a -> a
<> Set (Credential 'Staking)
rewards
  (Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateAvoidCred (Credential 'Staking
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking
cred)
  Credential 'Staking -> GenRS era (Credential 'Staking)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 <- Gen (VRFVerKeyHash 'StakePoolVRF)
-> RWST
     (GenEnv era) () (GenState era) Gen (VRFVerKeyHash 'StakePoolVRF)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (VRFVerKeyHash 'StakePoolVRF)
forall a. Arbitrary a => Gen a
arbitrary
  Coin
ppPledge <- Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
  Coin
ppCost <- Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genPositiveVal
  UnitInterval
ppMargin <- Gen UnitInterval
-> RWST (GenEnv era) () (GenState era) Gen UnitInterval
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen UnitInterval
forall a. Arbitrary a => Gen a
arbitrary
  RewardAccount
ppRewardAccount <- Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (Credential 'Staking -> RewardAccount)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen RewardAccount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlutusPurposeTag
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential 'Staking)
genFreshRegCred PlutusPurposeTag
Rewarding
  let ppOwners :: Set (KeyHash 'Staking)
ppOwners = Set (KeyHash 'Staking)
forall a. Monoid a => a
mempty
  let ppRelays :: StrictSeq StakePoolRelay
ppRelays = StrictSeq StakePoolRelay
forall a. Monoid a => a
mempty
  let ppMetadata :: StrictMaybe a
ppMetadata = StrictMaybe a
forall a. StrictMaybe a
SNothing
  PoolParams -> GenRS era PoolParams
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PoolParams {Set (KeyHash 'Staking)
StrictMaybe PoolMetadata
KeyHash 'StakePool
VRFVerKeyHash 'StakePoolVRF
RewardAccount
Coin
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 :: 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
..}

-- | 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 = String -> GenRS era [Credential kr]
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]
-> GenRS era [Credential kr]
go Int
n0 Set (Credential kr)
old0 [Credential kr]
ans0
  where
    go :: Int
-> Set (Credential kr)
-> [Credential kr]
-> GenRS era [Credential kr]
go Int
0 Set (Credential kr)
_ [Credential kr]
ans = [Credential kr] -> GenRS era [Credential kr]
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 <- Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
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]
-> GenRS era [Credential kr]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Credential kr -> Set (Credential kr) -> Set (Credential kr)
forall a. Ord a => a -> Set a -> Set a
Set.insert Credential kr
c Set (Credential kr)
old) (Credential kr
c Credential kr -> [Credential kr] -> [Credential kr]
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 <- GenRS era (KeyHash 'StakePool)
forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash
  PoolParams
poolParam <- KeyHash 'StakePool -> GenRS era PoolParams
forall era.
Reflect era =>
KeyHash 'StakePool -> GenRS era PoolParams
genPoolParams KeyHash 'StakePool
poolId
  Float
percent <- Gen Float -> RWST (GenEnv era) () (GenState era) Gen Float
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Float -> RWST (GenEnv era) () (GenState era) Gen Float)
-> Gen Float -> RWST (GenEnv era) () (GenState era) Gen Float
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Gen Float
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 (Float -> Rational
forall a. Real a => a -> Rational
toRational Float
percent) CompactForm Coin
forall a. Monoid a => a
mempty (PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf PoolParams
poolParam)
  (Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateAvoidKey (KeyHash 'StakePool
-> Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'StakePool -> KeyHash 'StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'StakePool
poolId))
  (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
-> GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 :: forall era. GenEnv era -> GenSize
geSize :: GenSize
geSize} <- RWST (GenEnv era) () (GenState era) Gen (GenEnv era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
  [KeyHash 'StakePool]
hashes <- Int
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
-> RWST (GenEnv era) () (GenState era) Gen [KeyHash 'StakePool]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (GenSize -> Int
maxStablePools GenSize
geSize) (RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
 -> RWST (GenEnv era) () (GenState era) Gen [KeyHash 'StakePool])
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
-> RWST (GenEnv era) () (GenState era) Gen [KeyHash 'StakePool]
forall a b. (a -> b) -> a -> b
$ do
    PParams era
pp <- (GenEnv era -> PParams era)
-> RWST (GenEnv era) () (GenState era) Gen (PParams era)
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks GenEnv era -> PParams era
forall era. GenEnv era -> PParams era
gePParams
    (KeyHash 'StakePool
kh, PoolParams
poolParams, IndividualPoolStake
ips) <- GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
    (Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
forall era.
(Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateStablePools (KeyHash 'StakePool
-> Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyHash 'StakePool
kh)
    (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
poolParams)
    (Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (KeyHash 'StakePool
-> IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh IndividualPoolStake
ips)
    (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
poolParams)
    KeyHash 'StakePool -> Coin -> GenRS era ()
forall era. KeyHash 'StakePool -> Coin -> GenRS era ()
modifyModelKeyDeposits KeyHash 'StakePool
kh (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL)
    KeyHash 'StakePool
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 <- Int
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen [Credential 'Staking]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (GenSize -> Int
maxStablePools GenSize
geSize) (RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
 -> RWST (GenEnv era) () (GenState era) Gen [Credential 'Staking])
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen [Credential 'Staking]
forall a b. (a -> b) -> a -> b
$ do
    Set (Credential 'Staking)
old' <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (Map (Credential 'Staking) (AccountState era)
-> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential 'Staking) (AccountState era)
 -> Set (Credential 'Staking))
-> (GenState era -> Map (Credential 'Staking) (AccountState era))
-> GenState era
-> Set (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> Map (Credential 'Staking) (AccountState era)
forall era.
GenState era -> Map (Credential 'Staking) (AccountState era)
gsInitialAccounts)
    Set (Credential 'Staking)
prev <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (Credential 'Staking)
forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
    Credential 'Staking
cred <- Int
-> PlutusPurposeTag
-> Set (Credential 'Staking)
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr)
-> GenRS era (Credential kr)
genFreshCredential Int
100 PlutusPurposeTag
Rewarding (Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Credential 'Staking)
old' Set (Credential 'Staking)
prev)
    Credential 'Staking
-> RWST (GenEnv era) () (GenState era) Gen (Credential 'Staking)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Credential 'Staking
cred
  let registerNewAccount' :: Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
registerNewAccount' Credential 'Staking
cred KeyHash 'StakePool
poolId = do
        Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
forall era.
EraTest era =>
Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
registerNewAccount Credential 'Staking
cred (KeyHash 'StakePool -> Maybe (KeyHash 'StakePool)
forall a. a -> Maybe a
Just KeyHash 'StakePool
poolId)
  (Credential 'Staking -> KeyHash 'StakePool -> GenRS era ())
-> [Credential 'Staking] -> [KeyHash 'StakePool] -> GenRS era ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTest era) =>
Credential 'Staking -> KeyHash 'StakePool -> GenRS era ()
registerNewAccount' [Credential 'Staking]
credentials [KeyHash 'StakePool]
hashes
  (Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateStableDelegators (Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Credential 'Staking] -> Set (Credential 'Staking)
forall a. Ord a => [a] -> Set a
Set.fromList [Credential 'Staking]
credentials))

registerNewAccount ::
  EraTest era => Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
registerNewAccount :: forall era.
EraTest era =>
Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
registerNewAccount Credential 'Staking
cred Maybe (KeyHash 'StakePool)
mPoolId = do
  PParams era
pp <- (GenEnv era -> PParams era)
-> RWST (GenEnv era) () (GenState era) Gen (PParams era)
forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks GenEnv era -> PParams era
forall era. GenEnv era -> PParams era
gePParams
  let deposit :: Coin
deposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
  Ptr
ptr <- Gen Ptr -> RWST (GenEnv era) () (GenState era) Gen Ptr
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Ptr
forall a. Arbitrary a => Gen a
arbitrary
  (Accounts era -> Accounts era) -> GenRS era ()
forall era. (Accounts era -> Accounts era) -> GenRS era ()
modifyModelAccounts ((Accounts era -> Accounts era) -> GenRS era ())
-> (Accounts era -> Accounts era) -> GenRS era ()
forall a b. (a -> b) -> a -> b
$
    Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
forall era.
(HasCallStack, EraTest era) =>
Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
registerTestAccount Credential 'Staking
cred (Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
ptr) (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Coin
deposit) Maybe (KeyHash 'StakePool)
mPoolId Maybe DRep
forall a. Maybe a
Nothing
  AccountState era
accountState <- Maybe (AccountState era) -> AccountState era
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AccountState era) -> AccountState era)
-> (GenState era -> Maybe (AccountState era))
-> GenState era
-> AccountState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential 'Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential 'Staking
cred (Accounts era -> Maybe (AccountState era))
-> (GenState era -> Accounts era)
-> GenState era
-> Maybe (AccountState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModelNewEpochState era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts (ModelNewEpochState era -> Accounts era)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel (GenState era -> AccountState era)
-> RWST (GenEnv era) () (GenState era) Gen (GenState era)
-> RWST (GenEnv era) () (GenState era) Gen (AccountState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (GenState era)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
  (Coin -> Coin) -> GenRS era ()
forall era. (Coin -> Coin) -> GenRS era ()
modifyModelDeposited (Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
deposit)
  (Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
forall era.
(Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
modifyGenStateInitialAccounts (Credential 'Staking
-> AccountState era
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred AccountState era
accountState)

-- =============================================
-- 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 (Map (Credential 'Staking) Coin)
genRewards :: forall era.
Reflect era =>
GenRS era (Map (Credential 'Staking) Coin)
genRewards = do
  Int
wmax <- (GenState era -> Int)
-> RWST (GenEnv era) () (GenState era) Gen Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (GenSize -> Int
withdrawalMax (GenSize -> Int)
-> (GenState era -> GenSize) -> GenState era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv era -> GenSize
forall era. GenEnv era -> GenSize
geSize (GenEnv era -> GenSize)
-> (GenState era -> GenEnv era) -> GenState era -> GenSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> GenEnv era
forall era. GenState era -> GenEnv era
gsGenEnv)
  Int
n <- Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int)
-> Gen Int -> RWST (GenEnv era) () (GenState era) Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
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 <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (Map (Credential 'Staking) (AccountState era)
-> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential 'Staking) (AccountState era)
 -> Set (Credential 'Staking))
-> (GenState era -> Map (Credential 'Staking) (AccountState era))
-> GenState era
-> Set (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> Map (Credential 'Staking) (AccountState era)
forall era.
GenState era -> Map (Credential 'Staking) (AccountState era)
gsInitialAccounts)
  Set (Credential 'Staking)
prev <- (GenState era -> Set (Credential 'Staking))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (Credential 'Staking))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (Credential 'Staking)
forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred
  [Credential 'Staking]
credentials <- Int
-> Int
-> PlutusPurposeTag
-> Set (Credential 'Staking)
-> [Credential 'Staking]
-> GenRS era [Credential 'Staking]
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 (Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Credential 'Staking)
old Set (Credential 'Staking)
prev) []
  [(Credential 'Staking, Coin)]
balances <- [Credential 'Staking]
-> (Credential 'Staking
    -> RWST
         (GenEnv era) () (GenState era) Gen (Credential 'Staking, Coin))
-> RWST
     (GenEnv era) () (GenState era) Gen [(Credential 'Staking, Coin)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Credential 'Staking]
credentials ((Credential 'Staking
  -> RWST
       (GenEnv era) () (GenState era) Gen (Credential 'Staking, Coin))
 -> RWST
      (GenEnv era) () (GenState era) Gen [(Credential 'Staking, Coin)])
-> (Credential 'Staking
    -> RWST
         (GenEnv era) () (GenState era) Gen (Credential 'Staking, Coin))
-> RWST
     (GenEnv era) () (GenState era) Gen [(Credential 'Staking, Coin)]
forall a b. (a -> b) -> a -> b
$ \Credential 'Staking
cred -> do
    Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
forall era.
EraTest era =>
Credential 'Staking -> Maybe (KeyHash 'StakePool) -> GenRS era ()
registerNewAccount Credential 'Staking
cred Maybe (KeyHash 'StakePool)
forall a. Maybe a
Nothing
    (,) Credential 'Staking
cred (Coin -> (Credential 'Staking, Coin))
-> RWST (GenEnv era) () (GenState era) Gen Coin
-> RWST
     (GenEnv era) () (GenState era) Gen (Credential 'Staking, Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Coin -> RWST (GenEnv era) () (GenState era) Gen Coin
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Coin
forall v. Val v => Gen v
genRewardVal
  let balanceMap :: Map (Credential 'Staking) Coin
balanceMap = [(Credential 'Staking, Coin)] -> Map (Credential 'Staking) Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Credential 'Staking, Coin)]
balances
      compactBalanceMap :: Map (Credential 'Staking) (CompactForm Coin)
compactBalanceMap = (Coin -> CompactForm Coin)
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) (CompactForm Coin)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Map (Credential 'Staking) Coin
balanceMap
      replaceBalances :: Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
replaceBalances Map (Credential 'Staking) (AccountState era)
acc =
        (Credential 'Staking
 -> CompactForm Coin
 -> Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) (AccountState era)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' (\Credential 'Staking
cred CompactForm Coin
b -> (AccountState era -> AccountState era)
-> Credential 'Staking
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((CompactForm Coin -> Identity (CompactForm Coin))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> AccountState era -> Identity (AccountState era))
-> CompactForm Coin -> AccountState era -> AccountState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
b) Credential 'Staking
cred) Map (Credential 'Staking) (AccountState era)
acc Map (Credential 'Staking) (CompactForm Coin)
compactBalanceMap
  (Accounts era -> Accounts era) -> GenRS era ()
forall era. (Accounts era -> Accounts era) -> GenRS era ()
modifyModelAccounts (Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts Map (Credential 'Staking) (CompactForm Coin)
compactBalanceMap)
  (Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
forall era.
(Map (Credential 'Staking) (AccountState era)
 -> Map (Credential 'Staking) (AccountState era))
-> GenRS era ()
modifyGenStateInitialAccounts Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) (AccountState era)
replaceBalances
  (Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
forall era.
(Set (Credential 'Staking) -> Set (Credential 'Staking))
-> GenRS era ()
modifyGenStateAvoidCred (Set (Credential 'Staking)
-> Set (Credential 'Staking) -> Set (Credential 'Staking)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Map (Credential 'Staking) Coin -> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet Map (Credential 'Staking) Coin
balanceMap))
  Map (Credential 'Staking) Coin
-> GenRS era (Map (Credential 'Staking) Coin)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (Credential 'Staking) Coin
balanceMap

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

      -- add the Pool to the initial state
      (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid PoolParams
poolparams)
      (Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (KeyHash 'StakePool
-> IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
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
      (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid PoolParams
poolparams)
      (Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyModelPoolDistr (KeyHash 'StakePool
-> IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
poolid IndividualPoolStake
stake)
      KeyHash 'StakePool -> GenRS era (KeyHash 'StakePool)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 = [(Int,
  RWST
    (GenEnv era)
    ()
    (GenState era)
    Gen
    (KeyHash 'StakePool, PoolParams))]
-> RWST
     (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
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) <- GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
      -- add pool to initial state
      (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyGenStateInitialPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
pp)
      (Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) IndividualPoolStake
 -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> GenRS era ()
modifyGenStateInitialPoolDistr (KeyHash 'StakePool
-> IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh IndividualPoolStake
ips)
      -- update the model
      (Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
forall era.
(Map (KeyHash 'StakePool) PoolParams
 -> Map (KeyHash 'StakePool) PoolParams)
-> GenRS era ()
modifyModelPoolParams (KeyHash 'StakePool
-> PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh PoolParams
pp)
      (KeyHash 'StakePool, PoolParams)
-> RWST
     (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
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 <- (GenState era -> Map (KeyHash 'StakePool) PoolParams)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash 'StakePool) PoolParams)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams (ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash 'StakePool) PoolParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
      Set (KeyHash 'StakePool)
avoidKey <- (GenState era -> Set (KeyHash 'StakePool))
-> RWST
     (GenEnv era) () (GenState era) Gen (Set (KeyHash 'StakePool))
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Set (KeyHash 'StakePool)
forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey
      Gen (Maybe (KeyHash 'StakePool, PoolParams))
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Maybe (KeyHash 'StakePool, PoolParams))
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (GenEnv era) () (GenState era) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Map (KeyHash 'StakePool) PoolParams
-> Int
-> (KeyHash 'StakePool -> PoolParams -> Bool)
-> Gen (Maybe (KeyHash 'StakePool, PoolParams))
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 KeyHash 'StakePool -> Set (KeyHash 'StakePool) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash 'StakePool)
avoidKey)) RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (Maybe (KeyHash 'StakePool, PoolParams))
-> (Maybe (KeyHash 'StakePool, PoolParams)
    -> RWST
         (GenEnv era)
         ()
         (GenState era)
         Gen
         (KeyHash 'StakePool, PoolParams))
-> RWST
     (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
forall a b.
RWST (GenEnv era) () (GenState era) Gen a
-> (a -> RWST (GenEnv era) () (GenState era) Gen b)
-> RWST (GenEnv era) () (GenState era) Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (KeyHash 'StakePool, PoolParams)
Nothing -> RWST
  (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
genNew
        Just (KeyHash 'StakePool
kh, PoolParams
pp) -> (KeyHash 'StakePool, PoolParams)
-> RWST
     (GenEnv era) () (GenState era) Gen (KeyHash 'StakePool, PoolParams)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
kh, PoolParams
pp)