{-# 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 #-}

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

import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Scripts hiding (Script)
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), Network (Testnet), inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj), StakeCredential)
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  DState (..),
  LedgerState (..),
  PState (..),
  smartUTxOState,
  totalObligation,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.State (EraCertState (..), IndividualPoolStake (..), UTxO (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (join, replicateM, when, zipWithM_)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (RWST (..), ask, asks, get, gets, modify)
import Control.SetAlgebra (eval, (⨃))
import Data.Default (Default (def))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (SJust, SNothing))
import qualified Data.Sequence.Strict as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff (Expr, ToExpr (toExpr))
import GHC.Generics (Generic)
import GHC.Word (Word32, Word64)
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Era
import Test.Cardano.Ledger.Generic.Fields
import Test.Cardano.Ledger.Generic.Functions (
  alwaysFalse,
  alwaysTrue,
  primaryLanguage,
  protocolVersion,
  txoutFields,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  ModelNewEpochState (..),
  genDelegsZero,
  instantaneousRewardsZero,
  mKeyDeposits,
  mNewEpochStateZero,
  mPoolDeposits,
 )
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Generic.Updaters (defaultCostModels, newPParams)
import Test.Cardano.Ledger.Shelley.Era
import Test.Tasty.QuickCheck (
  Gen,
  Positive (..),
  arbitrary,
  choose,
  chooseInt,
  elements,
  frequency,
  generate,
 )

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

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

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) Coin
gsInitialRewards :: !(Map (Credential 'Staking) Coin)
  , forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations ::
      !(Map (Credential 'Staking) (KeyHash 'StakePool))
  , forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  , forall era.
GenState era -> Map (KeyHash 'StakePool) IndividualPoolStake
gsInitialPoolDistr ::
      !(Map (KeyHash 'StakePool) IndividualPoolStake)
  , -- Stable fields are stable from initialization to the end of the generation process
    forall era. GenState era -> Set (KeyHash 'StakePool)
gsStablePools :: !(Set (KeyHash 'StakePool))
  , forall era. GenState era -> Set (Credential 'Staking)
gsStableDelegators :: !(Set StakeCredential)
  , forall era. GenState era -> Set (Credential 'Staking)
gsAvoidCred :: !(Set (Credential 'Staking))
  , forall era. GenState era -> Set (KeyHash 'StakePool)
gsAvoidKey :: !(Set (KeyHash 'StakePool))
  , forall era. GenState era -> Proof era
gsProof :: !(Proof era)
  , forall era. GenState era -> GenEnv era
gsGenEnv :: !(GenEnv era)
  , forall era. GenState era -> Int
gsSeedIdx :: !Int
  }
  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 => Proof era -> GenEnv era -> GenState era
emptyGenState :: forall era. Reflect era => Proof era -> GenEnv era -> GenState era
emptyGenState Proof era
proof 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) Coin
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Set (KeyHash 'StakePool)
-> Set (Credential 'Staking)
-> Set (Credential 'Staking)
-> Set (KeyHash 'StakePool)
-> Proof era
-> GenEnv era
-> Int
-> GenState era
forall era.
ValidityInterval
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map ScriptHash (Script era)
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
-> Map DataHash (Data era)
-> Map ValidityInterval (Set ScriptHash)
-> ModelNewEpochState era
-> Map TxIn (TxOut era)
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Set (KeyHash 'StakePool)
-> Set (Credential 'Staking)
-> Set (Credential 'Staking)
-> Set (KeyHash 'StakePool)
-> Proof era
-> GenEnv era
-> Int
-> GenState era
GenState
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval 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. Reflect era => ModelNewEpochState era
mNewEpochStateZero {mPParams = gePParams genv})
    Map TxIn (TxOut era)
forall k a. Map k a
Map.empty
    Map (Credential 'Staking) Coin
forall k a. Map k a
Map.empty
    Map (Credential 'Staking) (KeyHash 'StakePool)
forall k a. Map k a
Map.empty
    Map (KeyHash 'StakePool) PoolParams
forall k a. Map k a
Map.empty
    Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Map k a
Map.empty
    Set (KeyHash 'StakePool)
forall a. Set a
Set.empty
    Set (Credential 'Staking)
forall a. Set a
Set.empty
    Set (Credential 'Staking)
forall a. Set a
Set.empty
    Set (KeyHash 'StakePool)
forall a. Set a
Set.empty
    Proof era
proof
    GenEnv era
genv
    Int
0
{-# NOINLINE emptyGenState #-}

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

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

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

instance ToExpr PlutusPurposeTag

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

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

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

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

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

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

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

getSlot :: GenState era -> SlotNo
getSlot :: forall era. GenState era -> SlotNo
getSlot = Word64 -> SlotNo
SlotNo (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)})

modifyGenStateInitialRewards ::
  ( Map.Map (Credential 'Staking) Coin ->
    Map.Map (Credential 'Staking) Coin
  ) ->
  GenRS era ()
modifyGenStateInitialRewards :: forall era.
(Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin)
-> GenRS era ()
modifyGenStateInitialRewards Map (Credential 'Staking) Coin -> Map (Credential 'Staking) Coin
f = (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 {gsInitialRewards = f (gsInitialRewards st)}

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

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

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

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

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

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

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

modifyGenStateInitialDelegations ::
  ( Map.Map (Credential 'Staking) (KeyHash 'StakePool) ->
    Map.Map (Credential 'Staking) (KeyHash 'StakePool)
  ) ->
  GenRS era ()
modifyGenStateInitialDelegations :: forall era.
(Map (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> GenRS era ()
modifyGenStateInitialDelegations Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
f = (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 {gsInitialDelegations = f (gsInitialDelegations 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)})

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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
    umap :: UMap
umap =
      Map (Credential 'Staking) RDPair
-> Map Ptr (Credential 'Staking)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) DRep
-> UMap
UM.unify
        ((Coin -> RDPair)
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) RDPair
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Coin -> RDPair
rdpair (GenState era -> Map (Credential 'Staking) Coin
forall era. GenState era -> Map (Credential 'Staking) Coin
gsInitialRewards GenState era
gstate))
        Map Ptr (Credential 'Staking)
forall k a. Map k a
Map.empty
        (GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
forall era.
GenState era -> Map (Credential 'Staking) (KeyHash 'StakePool)
gsInitialDelegations GenState era
gstate)
        Map (Credential 'Staking) DRep
forall k a. Map k a
Map.empty
    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 =
      UMap
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
forall era.
UMap
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState
        UMap
umap
        Map FutureGenDeleg GenDelegPair
forall k a. Map k a
Map.empty
        GenDelegs
genDelegsZero
        InstantaneousRewards
instantaneousRewardsZero
    pstate :: PState era
pstate = Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) Coin
-> PState era
forall era.
Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) Coin
-> PState era
PState Map (KeyHash 'StakePool) PoolParams
pools Map (KeyHash 'StakePool) PoolParams
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool) EpochNo
forall k a. Map k a
Map.empty ((PoolParams -> Coin)
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) Coin
forall a b.
(a -> b)
-> Map (KeyHash 'StakePool) a -> Map (KeyHash 'StakePool) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coin -> PoolParams -> Coin
forall a b. a -> b -> a
const Coin
poolDeposit) Map (KeyHash 'StakePool) PoolParams
pools)
    -- In a wellformed LedgerState the deposited equals the obligation
    deposited :: Coin
deposited = CertState era -> GovState era -> Coin
forall era.
(EraGov era, EraCertState era) =>
CertState era -> GovState era -> Coin
totalObligation CertState era
dpstate (UTxOState era
utxostate UTxOState era
-> Getting (GovState era) (UTxOState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. Getting (GovState era) (UTxOState era) (GovState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL)
    pools :: Map (KeyHash 'StakePool) PoolParams
pools = GenState era -> Map (KeyHash 'StakePool) PoolParams
forall era. GenState era -> Map (KeyHash 'StakePool) PoolParams
gsInitialPoolParams GenState era
gstate
    pp :: PParams era
pp = ModelNewEpochState era -> PParams era
forall era. ModelNewEpochState era -> PParams era
mPParams (GenState era -> ModelNewEpochState era
forall era. GenState era -> ModelNewEpochState era
gsModel GenState era
gstate)
    keyDeposit :: Coin
keyDeposit = 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
    !poolDeposit :: Coin
poolDeposit = 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
ppPoolDepositL
    rdpair :: Coin -> RDPair
rdpair Coin
rew = CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError Coin
rew) (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError Coin
keyDeposit)

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

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

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

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

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

-- Adds to gsScripts and gsPlutusScripts
genScript :: Reflect era => Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript :: forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript Proof era
proof PlutusPurposeTag
tag = case Proof era
proof of
  Proof era
Conway -> [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, Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof 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, Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof 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, Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genPlutusScript Proof era
proof PlutusPurposeTag
tag]
  Proof era
Mary -> GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Allegra -> GenRS era ScriptHash
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
GenRS era ScriptHash
genTimelockScript
  Proof era
Shelley -> GenRS era ScriptHash
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
GenRS era ScriptHash
genMultiSigScript

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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