{-# 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,
  genStakePoolParams,
  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.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.TreeDiff ()
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,
 )
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Shelley.Era
import Test.QuickCheck (
  Gen,
  Positive (..),
  arbitrary,
  choose,
  elements,
  frequency,
 )

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

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

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

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

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

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

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

  setNetworkIdTxBody :: StrictMaybe Network -> TxBody TopTx era -> TxBody TopTx 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) StakePoolParams
gsInitialStakePoolParams :: !(Map (KeyHash StakePool) StakePoolParams)
  , 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) StakePoolParams
-> 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) StakePoolParams
-> 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) StakePoolParams
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)})

modifyGenStateInitialStakePoolParams ::
  ( Map.Map (KeyHash StakePool) StakePoolParams ->
    Map.Map (KeyHash StakePool) StakePoolParams
  ) ->
  GenRS era ()
modifyGenStateInitialStakePoolParams :: forall era.
(Map (KeyHash StakePool) StakePoolParams
 -> Map (KeyHash StakePool) StakePoolParams)
-> GenRS era ()
modifyGenStateInitialStakePoolParams Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) StakePoolParams
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 {gsInitialStakePoolParams = f (gsInitialStakePoolParams 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)})

modifyModelStakePools ::
  ( Map.Map (KeyHash StakePool) StakePoolState ->
    Map.Map (KeyHash StakePool) StakePoolState
  ) ->
  GenRS era ()
modifyModelStakePools :: forall era.
(Map (KeyHash StakePool) StakePoolState
 -> Map (KeyHash StakePool) StakePoolState)
-> GenRS era ()
modifyModelStakePools Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
f = (ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
forall era.
(ModelNewEpochState era -> ModelNewEpochState era) -> GenRS era ()
modifyModel (\ModelNewEpochState era
ms -> ModelNewEpochState era
ms {mStakePools = f (mStakePools 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)})

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
      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)
      pure $ Just $ Map.elemAt i 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
      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)
      pure $ Just $ Set.elemAt i 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
      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, a) = Map.elemAt i m
      if p k a
        then pure $ Just $ (k, a)
        else genMapElemWhere m (tries - 1) 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
  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)
  scriptmap <- gets gsScripts
  lift $ genMapElemWhere x 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
  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)
  pure (`Map.member` 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
  stakePools <- (GenState era -> Map (KeyHash StakePool) StakePoolState)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash StakePool) StakePoolState)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
forall era.
ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
mStakePools (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash StakePool) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  pure (`Map.member` stakePools)

-- ========================================================================
-- 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 <- GenSize -> Gen (GenEnv era)
forall era. EraGenericGen era => GenSize -> Gen (GenEnv era)
genGenEnv GenSize
gsize
  (ans, state, ()) <- runRWST action genenv (emptyGenState genenv)
  pure (ans, 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
  pp <- GenSize -> Gen (PParams era)
forall era. EraGenericGen era => GenSize -> Gen (PParams era)
genPParams GenSize
gsize
  pure
    GenEnv
      { geSize = gsize
      , gePParams = 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
  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))]
  maxSlotNo <- frequency [(1, pure SNothing), (4, SJust <$> choose (slotNo + 1, maxBound))]
  let 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)
  env <- genGenEnv gsize
  pure (setVi (emptyGenState env) 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
  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))]
  end <- frequency [(1, pure SNothing), (4, SJust <$> choose (s + 1, s + stabilityWindow))]
  pure $ ValidityInterval (SlotNo <$> start) (SlotNo <$> 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 (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) EpochNo
-> PState era
forall era.
Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) EpochNo
-> PState era
PState
        Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall k a. Map k a
Map.empty
        (CompactForm Coin
-> Set (Credential Staking) -> StakePoolParams -> StakePoolState
mkStakePoolState CompactForm Coin
poolDeposit Set (Credential Staking)
forall a. Monoid a => a
mempty (StakePoolParams -> StakePoolState)
-> Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) StakePoolState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash StakePool) StakePoolParams
pools)
        Map (KeyHash StakePool) StakePoolParams
forall k a. Map k a
Map.empty
        Map (KeyHash StakePool) EpochNo
forall k a. Map k a
Map.empty
    -- 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) StakePoolParams
pools = GenState era -> Map (KeyHash StakePool) StakePoolParams
forall era. GenState era -> Map (KeyHash StakePool) StakePoolParams
gsInitialStakePoolParams 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 <- 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 = 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
  modifyGenStateKeys (Map.insert keyHash keyPair)
  pure $ coerceKeyRole 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
  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 = Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
datum
  modifyGenStateDatums (Map.insert datumHash datum)
  pure (datumHash, 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
          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
          kh <- genKeyHash
          if coerceKeyRole kh `Set.member` avoidKeys
            then go $ n - 1
            else return 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 mBefore 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
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)
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 = 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
k = do
        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
        RequireAllOf . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1))
      requireAnyOf Natural
k = do
        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
        RequireAnyOf . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1))
      requireMOf Natural
k = do
        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
        m <- lift $ choose (0, n)
        RequireMOf m . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1))
      requireTimeStart (SlotNo Word64
validFrom) = do
        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)
        pure $ RequireTimeStart (SlotNo minSlotNo)
      requireTimeExpire (SlotNo Word64
validTill) = do
        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)
        pure $ RequireTimeExpire (SlotNo maxSlotNo)
  tlscript <- genNestedTimelock (2 :: Natural)
  let corescript = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
tlscript
  let scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
      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)
  modifyGenStateScripts (Map.insert scriptHash corescript)
  modifyGenStateVI (Map.alter (insertOrCreate scriptHash) vi)
  pure 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
        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
        RequireAllOf . Seq.fromList <$> replicateM n (genNestedMultiSig (k - 1))
      requireAnyOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireAnyOf Natural
k = do
        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
        RequireAnyOf . Seq.fromList <$> replicateM n (genNestedMultiSig (k - 1))
      requireMOf :: Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
requireMOf Natural
k = do
        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
        m <- lift $ choose (0, n)
        RequireMOf m . Seq.fromList <$> replicateM n (genNestedMultiSig (k - 1))
  msscript <- Natural -> RWST (GenEnv era) () (GenState era) Gen (MultiSig era)
genNestedMultiSig (Natural
2 :: Natural)
  let corescript = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
MultiSig era
msscript
  let scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
corescript
  modifyGenStateScripts (Map.insert scriptHash corescript)
  pure 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
  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
  isValid <- lift $ frequency [(falseFreq, pure False), (100 - falseFreq, pure 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 = 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 = 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 <-
    if isValid
      then alwaysTrue mlanguage . (+ numArgs) <$> lift (elements [0, 1, 2, 3 :: Natural])
      else pure $ alwaysFalse mlanguage numArgs

  let scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script
  modifyPlutusScripts (Map.insert (scriptHash, tag) (IsValid isValid, script))
  pure 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 <- 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
      deposit <- lift arbitrary
      pure $ mkTestAccountState (Just ptr) deposit Nothing Nothing
    genKeyHash' :: RWST (GenEnv era) () (GenState era) Gen (KeyHash kr)
genKeyHash' = do
      kh <- GenRS era (KeyHash Staking)
forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash -- We need to avoid some key credentials
      case tag of
        PlutusPurposeTag
Rewarding -> do
          accountState <- RWST (GenEnv era) () (GenState era) Gen (AccountState era)
genNewAccountState
          modifyGenStateInitialAccounts (Map.insert (KeyHashObj kh) 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 ()
      return $ coerceKeyRole 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
              sh <- forall era. Reflect era => PlutusPurposeTag -> GenRS era ScriptHash
genScript @era PlutusPurposeTag
tag
              initialRewards <- gets gsInitialAccounts
              avoidCredentials <- gets gsAvoidCred
              let newcred = ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
sh
              if Map.notMember newcred initialRewards && Set.notMember newcred avoidCredentials
                then do
                  case tag of
                    PlutusPurposeTag
Rewarding -> do
                      accountState <- RWST (GenEnv era) () (GenState era) Gen (AccountState era)
genNewAccountState
                      modifyGenStateInitialAccounts (Map.insert newcred 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 ()
                  return sh
                else f $ n - 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
        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
        lift (genMapElem keysMap) >>= \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
      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
      lift (genMapElem plutusScriptsMap) >>= \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
      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
      vimap <- gets gsVI
      case Map.lookup vi 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
      c <- PlutusPurposeTag -> GenRS era (Credential kr)
forall (kr :: KeyRole) era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
tag
      if Set.member c old
        then go (tries - 1)
        else pure c

genFreshRegCred ::
  Reflect era => PlutusPurposeTag -> GenRS era (Credential Staking)
genFreshRegCred :: forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential Staking)
genFreshRegCred PlutusPurposeTag
tag = do
  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)
  avoid <- gets gsAvoidCred
  rewards <- gets $ Map.keysSet . (^. accountsMapL) . mAccounts . gsModel
  cred <- genFreshCredential 100 tag $ old <> avoid <> rewards
  modifyGenStateAvoidCred (Set.insert cred)
  pure cred

genStakePoolParams ::
  Reflect era =>
  KeyHash StakePool ->
  GenRS era StakePoolParams
genStakePoolParams :: forall era.
Reflect era =>
KeyHash StakePool -> GenRS era StakePoolParams
genStakePoolParams KeyHash StakePool
sppId = do
  sppVrf <- 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
  sppPledge <- lift genPositiveVal
  sppCost <- lift genPositiveVal
  sppMargin <- lift arbitrary
  sppRewardAccount <- RewardAccount Testnet <$> genFreshRegCred Rewarding
  let sppOwners = Set (KeyHash Staking)
forall a. Monoid a => a
mempty
  let sppRelays = StrictSeq StakePoolRelay
forall a. Monoid a => a
mempty
  let sppMetadata = StrictMaybe a
forall a. StrictMaybe a
SNothing
  pure StakePoolParams {..}

-- | 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
      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
      go (n - 1) (Set.insert c old) (c : 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
    , StakePoolParams
    , IndividualPoolStake
    )
genNewPool :: forall era.
Reflect era =>
GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
genNewPool = do
  poolId <- GenRS era (KeyHash StakePool)
forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genFreshKeyHash
  stakePoolParams <- genStakePoolParams poolId
  percent <- lift $ choose (0, 1 :: Float)
  let 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 (StakePoolParams -> VRFVerKeyHash StakePoolVRF
sppVrf StakePoolParams
stakePoolParams)
  modifyGenStateAvoidKey (Set.insert (coerceKeyRole poolId))
  pure (poolId, stakePoolParams, 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 {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
  hashes <- replicateM (maxStablePools geSize) $ do
    pp <- asks gePParams
    (kh, stakePoolParams, ips) <- genNewPool
    modifyGenStateStablePools (Set.insert kh)
    modifyGenStateInitialStakePoolParams (Map.insert kh stakePoolParams)
    modifyGenStateInitialPoolDistr (Map.insert kh ips)
    modifyModelStakePools
      (Map.insert kh $ mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty stakePoolParams)
    return kh

  -- This incantation gets a list of fresh (not previously generated) Credential
  credentials <- replicateM (maxStablePools geSize) $ do
    old' <- gets (Map.keysSet . gsInitialAccounts)
    prev <- gets gsAvoidCred
    cred <- genFreshCredential 100 Rewarding (Set.union old' prev)
    return cred
  let 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)
  zipWithM_ registerNewAccount' credentials hashes
  modifyGenStateStableDelegators (Set.union (Set.fromList 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
  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 = 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 <- lift arbitrary
  modifyModelAccounts $
    registerTestAccount cred (Just ptr) (compactCoinOrError deposit) mPoolId Nothing
  accountState <- fromJust . lookupAccountState cred . mAccounts . gsModel <$> get
  modifyModelDeposited (<+> deposit)
  modifyGenStateInitialAccounts (Map.insert cred 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
  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)
  n <- lift $ choose (1, wmax)
  -- we need a fresh credential, one that was not previously
  -- generated here, or one that arose from gsAvoidCred (i.e. prev)
  old <- gets (Map.keysSet . gsInitialAccounts)
  prev <- gets gsAvoidCred
  credentials <- genFreshCredentials n 100 Rewarding (Set.union old prev) []
  balances <- forM credentials $ \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 = [(Credential Staking, Coin)] -> Map (Credential Staking) Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Credential Staking, Coin)]
balances
      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)
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
  modifyModelAccounts (addToBalanceAccounts compactBalanceMap)
  modifyGenStateInitialAccounts replaceBalances
  modifyGenStateAvoidCred (Set.union (Map.keysSet balanceMap))
  pure balanceMap

genRetirementHash :: forall era. Reflect era => GenRS era (KeyHash StakePool)
genRetirementHash :: forall era. Reflect era => GenRS era (KeyHash StakePool)
genRetirementHash = do
  m <- (GenState era -> Map (KeyHash StakePool) StakePoolState)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash StakePool) StakePoolState)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
forall era.
ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
mStakePools (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash StakePool) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
  pp <- gets (mPParams . gsModel)
  honestKhs <- gets gsStablePools
  avoidKey <- gets gsAvoidKey
  res <- lift . genMapElemWhere m 10 $ \KeyHash StakePool
kh StakePoolState
_ ->
    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 res of
    Just (KeyHash StakePool, StakePoolState)
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, StakePoolState) -> KeyHash StakePool
forall a b. (a, b) -> a
fst (KeyHash StakePool, StakePoolState)
x))
      -- if it is retiring, we should probably avoid it in the future
      KeyHash StakePool
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash StakePool)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash StakePool
 -> RWST (GenEnv era) () (GenState era) Gen (KeyHash StakePool))
-> KeyHash StakePool
-> RWST (GenEnv era) () (GenState era) Gen (KeyHash StakePool)
forall a b. (a -> b) -> a -> b
$ (KeyHash StakePool, StakePoolState) -> KeyHash StakePool
forall a b. (a, b) -> a
fst (KeyHash StakePool, StakePoolState)
x
    Maybe (KeyHash StakePool, StakePoolState)
Nothing -> do
      (poolid, poolparams, stake) <- GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
genNewPool

      -- add the Pool to the initial state
      modifyGenStateInitialStakePoolParams (Map.insert poolid poolparams)
      modifyGenStateInitialPoolDistr (Map.insert poolid stake)

      -- add the Pool to the Model
      modifyModelStakePools
        (Map.insert poolid $ mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty poolparams)
      modifyModelPoolDistr (Map.insert poolid stake)
      pure 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, StakePoolParams)
genPool :: forall era.
Reflect era =>
GenRS era (KeyHash StakePool, StakePoolParams)
genPool = [(Int,
  RWST
    (GenEnv era)
    ()
    (GenState era)
    Gen
    (KeyHash StakePool, StakePoolParams))]
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (KeyHash StakePool, StakePoolParams)
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, StakePoolParams)
genNew), (Int
90, RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (KeyHash StakePool, StakePoolParams)
pickExisting)]
  where
    genNew :: RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (KeyHash StakePool, StakePoolParams)
genNew = do
      (kh, spp, ips) <- GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
forall era.
Reflect era =>
GenRS era (KeyHash StakePool, StakePoolParams, IndividualPoolStake)
genNewPool
      pparams <- gets (mPParams . gsModel)
      -- add pool to initial state
      modifyGenStateInitialStakePoolParams (Map.insert kh spp)
      modifyGenStateInitialPoolDistr (Map.insert kh ips)
      -- update the model
      modifyModelStakePools
        (Map.insert kh $ mkStakePoolState (pparams ^. ppPoolDepositCompactL) mempty spp)
      return (kh, spp)
    pickExisting :: RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (KeyHash StakePool, StakePoolParams)
pickExisting = do
      psStakePools <- (GenState era -> Map (KeyHash StakePool) StakePoolState)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (Map (KeyHash StakePool) StakePoolState)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
forall era.
ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState
mStakePools (ModelNewEpochState era -> Map (KeyHash StakePool) StakePoolState)
-> (GenState era -> ModelNewEpochState era)
-> GenState era
-> Map (KeyHash StakePool) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel)
      avoidKey <- gets gsAvoidKey
      lift (genMapElemWhere psStakePools 10 (\KeyHash StakePool
kh StakePoolState
_ -> 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, StakePoolState)
Nothing -> RWST
  (GenEnv era)
  ()
  (GenState era)
  Gen
  (KeyHash StakePool, StakePoolParams)
genNew
        Just (KeyHash StakePool
kh, StakePoolState
sps) -> (KeyHash StakePool, StakePoolParams)
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     (KeyHash StakePool, StakePoolParams)
forall a. a -> RWST (GenEnv era) () (GenState era) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash StakePool
kh, KeyHash StakePool -> StakePoolState -> StakePoolParams
stakePoolStateToStakePoolParams KeyHash StakePool
kh StakePoolState
sps)