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

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

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

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

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

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

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

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

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

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
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Test if the Payment part of the Address in the TxOut
--   is valid in the current ValidityInterval. Using the simple rule allowing
--   only (Key or Plutus or MutiSig) locking. Disallowing all Timelock scripts
validTxOut ::
  Proof era ->
  Map (ScriptHash (EraCrypto era)) (Script era) ->
  TxIn (EraCrypto era) ->
  TxOut era ->
  Bool
validTxOut :: forall era.
Proof era
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> TxIn (EraCrypto era)
-> TxOut era
-> Bool
validTxOut Proof era
proof Map (ScriptHash (EraCrypto era)) (Script era)
m TxIn (EraCrypto era)
_txin TxOut era
txout = case forall era.
Proof era
-> TxOut era -> (Addr (EraCrypto era), Value era, [TxOutField era])
txoutFields Proof era
proof TxOut era
txout of
  (Addr Network
_ (KeyHashObj KeyHash 'Payment (EraCrypto era)
_) StakeReference (EraCrypto era)
_, Value era
_, [TxOutField era]
_) -> Bool
True
  (Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
h) StakeReference (EraCrypto era)
_, Value era
_, [TxOutField era]
_) -> case (Proof era
proof, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash (EraCrypto era)
h Map (ScriptHash (EraCrypto era)) (Script era)
m) of
    (Proof era
Conway, Just (PlutusScript PlutusScript (ConwayEra StandardCrypto)
_)) -> Bool
True
    (Proof era
Babbage, Just (PlutusScript PlutusScript (BabbageEra StandardCrypto)
_)) -> Bool
True
    (Proof era
Alonzo, Just (PlutusScript PlutusScript (AlonzoEra StandardCrypto)
_)) -> Bool
True
    (Proof era
Shelley, Just Script era
_msig) -> Bool
True
    (Proof era, Maybe (Script era))
_ -> Bool
False
  (Addr (EraCrypto era), 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 (EraCrypto era), TxOut era))
getUtxoElem :: forall era.
Reflect era =>
GenRS era (Maybe (TxIn (EraCrypto era), TxOut era))
getUtxoElem = do
  Map (TxIn StandardCrypto) (TxOut era)
x <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era -> Map (TxIn (EraCrypto era)) (TxOut era)
mUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  Map (ScriptHash StandardCrypto) (Script era)
scriptmap <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era.
GenState era -> Map (ScriptHash (EraCrypto era)) (Script era)
gsScripts
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k a.
Map k a -> Int -> (k -> a -> Bool) -> Gen (Maybe (k, a))
genMapElemWhere Map (TxIn StandardCrypto) (TxOut era)
x Int
20 (forall era.
Proof era
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> TxIn (EraCrypto era)
-> TxOut era
-> Bool
validTxOut forall era. Reflect era => Proof era
reify Map (ScriptHash StandardCrypto) (Script era)
scriptmap)

getUtxoTest :: GenRS era (TxIn (EraCrypto era) -> Bool)
getUtxoTest :: forall era. GenRS era (TxIn (EraCrypto era) -> Bool)
getUtxoTest = do
  Map (TxIn (EraCrypto era)) (TxOut era)
x <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era -> Map (TxIn (EraCrypto era)) (TxOut era)
mUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (TxIn (EraCrypto era)) (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 (EraCrypto era) -> Bool)
getNewPoolTest :: forall era. GenRS era (KeyHash 'StakePool (EraCrypto era) -> Bool)
getNewPoolTest = do
  Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolparams <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era.
ModelNewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolparams)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | 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 (EraCrypto era)) ->
  [Credential kr (EraCrypto era)] ->
  GenRS era [Credential kr (EraCrypto era)]
genFreshCredentials :: forall era (kr :: KeyRole).
Reflect era =>
Int
-> Int
-> PlutusPurposeTag
-> Set (Credential kr (EraCrypto era))
-> [Credential kr (EraCrypto era)]
-> GenRS era [Credential kr (EraCrypto era)]
genFreshCredentials Int
_n Int
0 PlutusPurposeTag
_tag Set (Credential kr (EraCrypto era))
_old [Credential kr (EraCrypto era)]
_ans = forall a. HasCallStack => String -> a
error String
"Ran out of tries in genFreshCredentials."
genFreshCredentials Int
n0 Int
tries PlutusPurposeTag
tag Set (Credential kr (EraCrypto era))
old0 [Credential kr (EraCrypto era)]
ans0 = Int
-> Set (Credential kr StandardCrypto)
-> [Credential kr StandardCrypto]
-> RWST
     (GenEnv era) () (GenState era) Gen [Credential kr StandardCrypto]
go Int
n0 Set (Credential kr (EraCrypto era))
old0 [Credential kr (EraCrypto era)]
ans0
  where
    go :: Int
-> Set (Credential kr StandardCrypto)
-> [Credential kr StandardCrypto]
-> RWST
     (GenEnv era) () (GenState era) Gen [Credential kr StandardCrypto]
go Int
0 Set (Credential kr StandardCrypto)
_ [Credential kr StandardCrypto]
ans = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Credential kr StandardCrypto]
ans
    go Int
n Set (Credential kr StandardCrypto)
old [Credential kr StandardCrypto]
ans = do
      Credential kr StandardCrypto
c <- forall era (kr :: KeyRole).
Reflect era =>
Int
-> PlutusPurposeTag
-> Set (Credential kr (EraCrypto era))
-> GenRS era (Credential kr (EraCrypto era))
genFreshCredential Int
tries PlutusPurposeTag
tag Set (Credential kr StandardCrypto)
old
      Int
-> Set (Credential kr StandardCrypto)
-> [Credential kr StandardCrypto]
-> RWST
     (GenEnv era) () (GenState era) Gen [Credential kr StandardCrypto]
go (Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a. Ord a => a -> Set a -> Set a
Set.insert Credential kr StandardCrypto
c Set (Credential kr StandardCrypto)
old) (Credential kr StandardCrypto
c forall a. a -> [a] -> [a]
: [Credential kr StandardCrypto]
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 (EraCrypto era)
    , PoolParams (EraCrypto era)
    , IndividualPoolStake (EraCrypto era)
    )
genNewPool :: forall era.
Reflect era =>
GenRS
  era
  (KeyHash 'StakePool (EraCrypto era), PoolParams (EraCrypto era),
   IndividualPoolStake (EraCrypto era))
genNewPool = do
  KeyHash 'StakePool StandardCrypto
poolId <- forall era (kr :: KeyRole).
Reflect era =>
GenRS era (KeyHash kr (EraCrypto era))
genFreshKeyHash
  PoolParams StandardCrypto
poolParam <- forall era.
Reflect era =>
KeyHash 'StakePool (EraCrypto era)
-> GenRS era (PoolParams (EraCrypto era))
genPoolParams KeyHash 'StakePool StandardCrypto
poolId
  Float
percent <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Float
0, Float
1 :: Float)
  let stake :: IndividualPoolStake (EraCrypto era)
stake = forall c.
Rational
-> CompactForm Coin
-> Hash c (VerKeyVRF c)
-> IndividualPoolStake c
IndividualPoolStake @(EraCrypto era) (forall a. Real a => a -> Rational
toRational Float
percent) forall a. Monoid a => a
mempty (forall c. PoolParams c -> Hash c (VerKeyVRF c)
ppVrf PoolParams StandardCrypto
poolParam)
  forall era.
(Set (KeyHash 'StakePool (EraCrypto era))
 -> Set (KeyHash 'StakePool (EraCrypto era)))
-> GenRS era ()
modifyGenStateAvoidKey (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash 'StakePool StandardCrypto
poolId))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool StandardCrypto
poolId, PoolParams StandardCrypto
poolParam, IndividualPoolStake (EraCrypto era)
stake)

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

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

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

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

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

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

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