{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Currently this uses the trace mechanism to check that computing rewards has
-- a required set of properties. It works only in the Shelley Era. It could be
-- generalized, and then moved to the Generator/Trace/ directory which computes
-- property tests in all eras.
module Test.Cardano.Ledger.Shelley.Rewards (
  tests,
  C,
  defaultMain,
  newEpochProp,
  newEpochEventsProp,
  RewardUpdateOld (..),
  createRUpdOld,
  createRUpdOld_,
)
where

import qualified Cardano.Crypto.DSIGN as Crypto
import Cardano.Crypto.Hash (Blake2b_256, hashToBytes)
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Cardano.Crypto.VRF as Crypto
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BlocksMade (..),
  BoundedRational (..),
  Globals (..),
  Network (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  activeSlotVal,
  epochInfoPure,
  mkActiveSlotCoeff,
 )
import Cardano.Ledger.Binary (encCBOR, hashWithEncoder, natVersion, shelleyProtVer)
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), rationalToCoinViaFloor, toDeltaCoin)
import Cardano.Ledger.Compactible
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Crypto (VRF)
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.EpochBoundary (
  Stake (..),
  maxPool,
  poolStake,
  sumAllStake,
  sumStakePerPool,
 )
import Cardano.Ledger.Keys (
  KeyHash,
  KeyRole (..),
  VKey (..),
  hashKey,
 )
import Cardano.Ledger.Shelley.API (NonMyopic, SnapShot (..), SnapShots (..))
import Cardano.Ledger.Shelley.API.Types (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  CertState (..),
  EpochState (..),
  FilteredRewards (..),
  LedgerState (..),
  NewEpochState (..),
  RewardUpdate (..),
  circulation,
  completeRupd,
  createRUpd,
  filterAllRewards,
  lsCertState,
  prevPParamsEpochStateL,
  rewards,
  updateNonMyopic,
 )
import Cardano.Ledger.Shelley.PoolRank (Likelihood, leaderProbability, likelihood)
import Cardano.Ledger.Shelley.RewardUpdate (
  FreeVars (..),
  Pulser,
  RewardAns (..),
  RewardEvent,
  RewardPulser (RSLP),
 )
import Cardano.Ledger.Shelley.Rewards (
  StakeShare (..),
  aggregateRewards,
  leaderRew,
  memberRew,
  mkApparentPerformance,
  mkPoolRewardInfo,
 )
import Cardano.Ledger.Shelley.Rules (
  PulsingRewUpdate (..),
  RupdEvent (RupdEvent),
  ShelleyNewEpochEvent (DeltaRewardEvent, TotalRewardEvent),
  ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent),
 )
import Cardano.Ledger.Shelley.TxBody (RewardAccount (..))
import Cardano.Ledger.Slot (epochInfoSize)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (Val (..), invert, (<+>), (<->))
import Cardano.Slotting.Slot (EpochSize (..))
import Control.Monad (replicateM)
import Control.Monad.Trans.Reader (asks, runReader)
import Control.SetAlgebra (eval, (◁))
import Data.Foldable as F (fold, foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy
import Data.Pulse (Pulsable (..))
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff (ansiWlEditExprCompact, ediff)
import qualified Data.VMap as VMap
import Data.Word (Word64)
import GHC.Stack
import Lens.Micro ((&), (.~), (^.))
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C)
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (genCoin, genNatural)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainEvent (..), ChainState (..))
import Test.Cardano.Ledger.Shelley.Rules.TestChain (forAllChainTrace, forEachEpochTrace)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
import Test.Cardano.Ledger.Shelley.Utils (
  runShelleyBase,
  testGlobals,
  unsafeBoundRational,
 )
import Test.Cardano.Ledger.TerseTools (Terse (..), tersemapdiffs)
import Test.Control.State.Transition.Trace (SourceSignalTarget (..), getEvents, sourceSignalTargets)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.QuickCheck (
  Gen,
  Property,
  arbitrary,
  choose,
  counterexample,
  elements,
  noShrinking,
  property,
  testProperty,
  withMaxSuccess,
  (===),
 )

-- ========================================================================
-- Bounds and Constants --

maxNumPools :: Int
maxNumPools :: Int
maxNumPools = Int
100

maxNumMembers :: Int
maxNumMembers :: Int
maxNumMembers = Int
100

maxMemberLovelace :: Integer
maxMemberLovelace :: Integer
maxMemberLovelace = Integer
100000

maxOwnerLovelaceAbovePledge :: Integer
maxOwnerLovelaceAbovePledge :: Integer
maxOwnerLovelaceAbovePledge = Integer
100000

maxPoolPledeg :: Integer
maxPoolPledeg :: Integer
maxPoolPledeg = Integer
1000000

maxPoolCost :: Integer
maxPoolCost :: Integer
maxPoolCost = Integer
1000000

maxPoolBlocks :: Natural
maxPoolBlocks :: Natural
maxPoolBlocks = Natural
1000000

numberOfTests :: Int
numberOfTests :: Int
numberOfTests = Int
500

decentralizationRange :: [Rational]
decentralizationRange :: [Rational]
decentralizationRange = [Rational
0, Rational
0.1 .. Rational
1]

tauRange :: [Rational]
tauRange :: [Rational]
tauRange = [Rational
0, Rational
0.05 .. Rational
0.3]

rhoRange :: [Rational]
rhoRange :: [Rational]
rhoRange = [Rational
0, Rational
0.05 .. Rational
0.3]

-- Helpers --

keyPair :: CC.Crypto c => Int -> KeyPair r c
keyPair :: forall c (r :: KeyRole). Crypto c => Int -> KeyPair r c
keyPair Int
seed = forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair VKey r c
vk SignKeyDSIGN (DSIGN c)
sk
  where
    vk :: VKey r c
vk = forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
VKey (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
Crypto.deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
sk)
    sk :: SignKeyDSIGN (DSIGN c)
sk =
      forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
Crypto.genKeyDSIGN forall a b. (a -> b) -> a -> b
$
        ByteString -> Seed
mkSeedFromBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. Hash h a -> ByteString
hashToBytes forall a b. (a -> b) -> a -> b
$
          forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @Blake2b_256 Version
shelleyProtVer forall a. EncCBOR a => a -> Encoding
encCBOR Int
seed

vrfKeyPair :: forall v. Crypto.VRFAlgorithm v => Int -> (Crypto.SignKeyVRF v, Crypto.VerKeyVRF v)
vrfKeyPair :: forall v. VRFAlgorithm v => Int -> (SignKeyVRF v, VerKeyVRF v)
vrfKeyPair Int
seed = (SignKeyVRF v
sk, VerKeyVRF v
vk)
  where
    vk :: VerKeyVRF v
vk = forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
Crypto.deriveVerKeyVRF SignKeyVRF v
sk
    sk :: SignKeyVRF v
sk =
      forall v. VRFAlgorithm v => Seed -> SignKeyVRF v
Crypto.genKeyVRF forall a b. (a -> b) -> a -> b
$
        ByteString -> Seed
mkSeedFromBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. Hash h a -> ByteString
hashToBytes forall a b. (a -> b) -> a -> b
$
          forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @Blake2b_256 Version
shelleyProtVer forall a. EncCBOR a => a -> Encoding
encCBOR Int
seed

data PoolSetUpArgs c f = PoolSetUpArgs
  { forall c (f :: * -> *). PoolSetUpArgs c f -> f Coin
poolPledge :: f Coin
  , forall c (f :: * -> *). PoolSetUpArgs c f -> f Coin
poolCost :: f Coin
  , forall c (f :: * -> *). PoolSetUpArgs c f -> f UnitInterval
poolMargin :: f UnitInterval
  , forall c (f :: * -> *).
PoolSetUpArgs c f -> f (Map (Credential 'Staking c) Coin)
poolMembers :: f (Map (Credential 'Staking c) Coin)
  }

emptySetupArgs :: PoolSetUpArgs c Maybe
emptySetupArgs :: forall c. PoolSetUpArgs c Maybe
emptySetupArgs =
  PoolSetUpArgs
    { poolPledge :: Maybe Coin
poolPledge = forall a. Maybe a
Nothing
    , poolCost :: Maybe Coin
poolCost = forall a. Maybe a
Nothing
    , poolMargin :: Maybe UnitInterval
poolMargin = forall a. Maybe a
Nothing
    , poolMembers :: Maybe (Map (Credential 'Staking c) Coin)
poolMembers = forall a. Maybe a
Nothing
    }

data PoolInfo c = PoolInfo
  { forall c. PoolInfo c -> PoolParams c
params :: PoolParams c
  , forall c. PoolInfo c -> KeyPair 'StakePool c
coldKey :: KeyPair 'StakePool c
  , forall c. PoolInfo c -> KeyPair 'Staking c
ownerKey :: KeyPair 'Staking c
  , forall c. PoolInfo c -> Coin
ownerStake :: Coin
  , forall c. PoolInfo c -> KeyPair 'Staking c
rewardKey :: KeyPair 'Staking c
  , forall c. PoolInfo c -> Map (Credential 'Staking c) Coin
members :: Map (Credential 'Staking c) Coin
  }

-- Generators --

genNonOwnerMembers :: CC.Crypto c => Gen (Map (Credential 'Staking c) Coin)
genNonOwnerMembers :: forall c. Crypto c => Gen (Map (Credential 'Staking c) Coin)
genNonOwnerMembers = do
  Int
numMembers <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxNumMembers)
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numMembers forall a b. (a -> b) -> a -> b
$ do
    Credential 'Staking c
credential <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). Crypto c => Int -> KeyPair r c
keyPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
    Coin
coins <- Integer -> Integer -> Gen Coin
genCoin Integer
0 Integer
maxMemberLovelace
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential 'Staking c
credential, Coin
coins)

getOrGen :: Maybe a -> Gen a -> Gen a
getOrGen :: forall a. Maybe a -> Gen a -> Gen a
getOrGen (Just a
x) Gen a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
getOrGen Maybe a
Nothing Gen a
g = Gen a
g

genMargin :: Gen UnitInterval
genMargin :: Gen UnitInterval
genMargin = do
  let denom :: Integer
denom = Integer
10
  Integer
numer <- forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
denom)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational (Integer
numer forall a. Integral a => a -> a -> Ratio a
% Integer
denom)

genPoolInfo :: forall c. CC.Crypto c => PoolSetUpArgs c Maybe -> Gen (PoolInfo c)
genPoolInfo :: forall c. Crypto c => PoolSetUpArgs c Maybe -> Gen (PoolInfo c)
genPoolInfo PoolSetUpArgs {Maybe Coin
poolPledge :: Maybe Coin
poolPledge :: forall c (f :: * -> *). PoolSetUpArgs c f -> f Coin
poolPledge, Maybe Coin
poolCost :: Maybe Coin
poolCost :: forall c (f :: * -> *). PoolSetUpArgs c f -> f Coin
poolCost, Maybe UnitInterval
poolMargin :: Maybe UnitInterval
poolMargin :: forall c (f :: * -> *). PoolSetUpArgs c f -> f UnitInterval
poolMargin, Maybe (Map (Credential 'Staking c) Coin)
poolMembers :: Maybe (Map (Credential 'Staking c) Coin)
poolMembers :: forall c (f :: * -> *).
PoolSetUpArgs c f -> f (Map (Credential 'Staking c) Coin)
poolMembers} = do
  Coin
pledge <- forall a. Maybe a -> Gen a -> Gen a
getOrGen Maybe Coin
poolPledge forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Coin
genCoin Integer
0 Integer
maxPoolPledeg
  Coin
cost <- forall a. Maybe a -> Gen a -> Gen a
getOrGen Maybe Coin
poolCost forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Coin
genCoin Integer
0 Integer
maxPoolCost
  UnitInterval
margin <- forall a. Maybe a -> Gen a -> Gen a
getOrGen Maybe UnitInterval
poolMargin Gen UnitInterval
genMargin
  (SignKeyVRF (VRF c), VerKeyVRF (VRF c))
vrfKey <- forall v. VRFAlgorithm v => Int -> (SignKeyVRF v, VerKeyVRF v)
vrfKeyPair @(VRF c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  KeyPair 'StakePool c
coldKey <- forall c (r :: KeyRole). Crypto c => Int -> KeyPair r c
keyPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  KeyPair 'Staking c
ownerKey <- forall c (r :: KeyRole). Crypto c => Int -> KeyPair r c
keyPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  KeyPair 'Staking c
rewardKey <- forall c (r :: KeyRole). Crypto c => Int -> KeyPair r c
keyPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Map (Credential 'Staking c) Coin
members' <- forall a. Maybe a -> Gen a -> Gen a
getOrGen Maybe (Map (Credential 'Staking c) Coin)
poolMembers forall c. Crypto c => Gen (Map (Credential 'Staking c) Coin)
genNonOwnerMembers
  Coin
ownerStake <- (Coin
pledge forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Coin
genCoin Integer
0 Integer
maxOwnerLovelaceAbovePledge
  -- here we are forcing the pool to meet the pledeg, later we may want flexibility
  let members :: Map (Credential 'Staking c) Coin
members = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'Staking c
ownerKey) Coin
ownerStake Map (Credential 'Staking c) Coin
members'
      params :: PoolParams c
params =
        PoolParams
          { ppId :: KeyHash 'StakePool c
ppId = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'StakePool c
coldKey
          , ppVrf :: Hash c (VerKeyVRF (VRF c))
ppVrf = forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
Crypto.hashVerKeyVRF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (SignKeyVRF (VRF c), VerKeyVRF (VRF c))
vrfKey
          , ppPledge :: Coin
ppPledge = Coin
pledge
          , ppCost :: Coin
ppCost = Coin
cost
          , ppMargin :: UnitInterval
ppMargin = UnitInterval
margin
          , ppRewardAccount :: RewardAccount c
ppRewardAccount = forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'Staking c
rewardKey
          , ppOwners :: Set (KeyHash 'Staking c)
ppOwners = forall a. Ord a => [a] -> Set a
Set.fromList [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 'Staking c
ownerKey]
          , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. StrictSeq a
StrictSeq.empty
          , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata = forall a. StrictMaybe a
SNothing
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PoolInfo {PoolParams c
params :: PoolParams c
params :: PoolParams c
params, KeyPair 'StakePool c
coldKey :: KeyPair 'StakePool c
coldKey :: KeyPair 'StakePool c
coldKey, KeyPair 'Staking c
ownerKey :: KeyPair 'Staking c
ownerKey :: KeyPair 'Staking c
ownerKey, Coin
ownerStake :: Coin
ownerStake :: Coin
ownerStake, KeyPair 'Staking c
rewardKey :: KeyPair 'Staking c
rewardKey :: KeyPair 'Staking c
rewardKey, Map (Credential 'Staking c) Coin
members :: Map (Credential 'Staking c) Coin
members :: Map (Credential 'Staking c) Coin
members}

genRewardPPs :: (EraPParams era, ProtVerAtMost era 6) => Gen (PParams era)
genRewardPPs :: forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Gen (PParams era)
genRewardPPs = do
  UnitInterval
d <- forall {b}. (Typeable b, BoundedRational b) => [Rational] -> Gen b
g [Rational]
decentralizationRange
  UnitInterval
tau <- forall {b}. (Typeable b, BoundedRational b) => [Rational] -> Gen b
g [Rational]
tauRange
  UnitInterval
rho <- forall {b}. (Typeable b, BoundedRational b) => [Rational] -> Gen b
g [Rational]
rhoRange
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era. EraPParams era => PParams era
emptyPParams
      forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
d
      forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
tau
      forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
rho
  where
    g :: [Rational] -> Gen b
g [Rational]
xs = forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
elements [Rational]
xs

genBlocksMade :: [PoolParams c] -> Gen (BlocksMade c)
genBlocksMade :: forall c. [PoolParams c] -> Gen (BlocksMade c)
genBlocksMade [PoolParams c]
pools = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall {c}. PoolParams c -> Gen (KeyHash 'StakePool c, Natural)
f [PoolParams c]
pools
  where
    f :: PoolParams c -> Gen (KeyHash 'StakePool c, Natural)
f PoolParams c
p = (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams c
p,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
0 Natural
maxPoolBlocks

-- Properties --

toCompactCoinError :: HasCallStack => Coin -> CompactForm Coin
toCompactCoinError :: HasCallStack => Coin -> CompactForm Coin
toCompactCoinError Coin
c =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid Coin: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Coin
c) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Coin
c

rewardsBoundedByPot ::
  forall era.
  (EraPParams era, ProtVerAtMost era 6) =>
  Proxy era ->
  Property
rewardsBoundedByPot :: forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Proxy era -> Property
rewardsBoundedByPot Proxy era
_ = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
numPools <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxNumPools)
  [PoolInfo (EraCrypto era)]
pools <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => PoolSetUpArgs c Maybe -> Gen (PoolInfo c)
genPoolInfo @(EraCrypto era) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> a -> [a]
replicate Int
numPools forall c. PoolSetUpArgs c Maybe
emptySetupArgs
  PParams era
pp <- forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Gen (PParams era)
genRewardPPs
  Coin
rewardPot <- Integer -> Integer -> Gen Coin
genCoin Integer
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
testGlobals)
  Coin
undelegatedLovelace <- Integer -> Integer -> Gen Coin
genCoin Integer
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
testGlobals)
  ActiveSlotCoeff
asc <- PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
elements [Rational
0.1, Rational
0.2, Rational
0.3]
  bs :: BlocksMade (EraCrypto era)
bs@(BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
blocks) <- forall c. [PoolParams c] -> Gen (BlocksMade c)
genBlocksMade (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. PoolInfo c -> PoolParams c
params [PoolInfo (EraCrypto era)]
pools)
  let totalBlocks :: Natural
totalBlocks = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash 'StakePool (EraCrypto era)) Natural
blocks
  Natural
silentSlots <- Natural -> Natural -> Gen Natural
genNatural Natural
0 (Natural
3 forall a. Num a => a -> a -> a
* Natural
totalBlocks) -- the '3 * sum blocks' is pretty arbitrary
  let stake :: Map (Credential 'Staking (EraCrypto era)) Coin
stake = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall c. PoolInfo c -> Map (Credential 'Staking c) Coin
members forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolInfo (EraCrypto era)]
pools)
      delegs :: Map
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PoolInfo (EraCrypto era)]
pools forall a b. (a -> b) -> a -> b
$
          \PoolInfo {PoolParams (EraCrypto era)
params :: PoolParams (EraCrypto era)
params :: forall c. PoolInfo c -> PoolParams c
params, Map (Credential 'Staking (EraCrypto era)) Coin
members :: Map (Credential 'Staking (EraCrypto era)) Coin
members :: forall c. PoolInfo c -> Map (Credential 'Staking c) Coin
members} ->
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (,forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
params) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [k]
Map.keys Map (Credential 'Staking (EraCrypto era)) Coin
members
      rewardAccounts :: Set (Credential 'Staking (EraCrypto era))
rewardAccounts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
      poolParams :: VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams =
        forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
[(k, v)] -> VMap kv vv k v
VMap.fromList
          [(forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
params, PoolParams (EraCrypto era)
params) | PoolInfo {PoolParams (EraCrypto era)
params :: PoolParams (EraCrypto era)
params :: forall c. PoolInfo c -> PoolParams c
params} <- [PoolInfo (EraCrypto era)]
pools]
      totalLovelace :: Coin
totalLovelace = Coin
undelegatedLovelace forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential 'Staking (EraCrypto era)) Coin
stake
      slotsPerEpoch :: EpochSize
slotsPerEpoch = Word64 -> EpochSize
EpochSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Natural
totalBlocks forall a. Num a => a -> a -> a
+ Natural
silentSlots
      (RewardAns Map (Credential 'Staking (EraCrypto era)) (Reward (EraCrypto era))
rs RewardEvent (EraCrypto era)
_) =
        forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$
          forall era.
EraPParams era =>
PParams era
-> BlocksMade (EraCrypto era)
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Coin
-> ShelleyBase (RewardAns (EraCrypto era))
reward @era
            PParams era
pp
            BlocksMade (EraCrypto era)
bs
            Coin
rewardPot
            Set (Credential 'Staking (EraCrypto era))
rewardAccounts
            VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
            (forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
Stake (forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap (HasCallStack => Coin -> CompactForm Coin
toCompactCoinError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Credential 'Staking (EraCrypto era)) Coin
stake)))
            (forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs)
            Coin
totalLovelace
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall prop. Testable prop => [Char] -> prop -> Property
counterexample
      ( forall a. Monoid a => [a] -> a
mconcat
          [ [Char]
"pp\n"
          , forall a. Show a => a -> [Char]
show PParams era
pp
          , [Char]
"\nrewardPot\n"
          , forall a. Show a => a -> [Char]
show Coin
rewardPot
          , [Char]
"\nrewardAccounts\n"
          , forall a. Show a => a -> [Char]
show Set (Credential 'Staking (EraCrypto era))
rewardAccounts
          , [Char]
"\npoolParams\n"
          , forall a. Show a => a -> [Char]
show VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
          , [Char]
"\nstake\n"
          , forall a. Show a => a -> [Char]
show Map (Credential 'Staking (EraCrypto era)) Coin
stake
          , [Char]
"\ndelegs\n"
          , forall a. Show a => a -> [Char]
show Map
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
          , [Char]
"\ntotalLovelace\n"
          , forall a. Show a => a -> [Char]
show Coin
totalLovelace
          , [Char]
"\nasc\n"
          , forall a. Show a => a -> [Char]
show ActiveSlotCoeff
asc
          , [Char]
"\nslotsPerEpoch\n"
          , forall a. Show a => a -> [Char]
show EpochSize
slotsPerEpoch
          ]
      )
      (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall c. Reward c -> Coin
rewardAmount Map (Credential 'Staking (EraCrypto era)) (Reward (EraCrypto era))
rs forall a. Ord a => a -> a -> Bool
< Coin
rewardPot)

-- ====================================================================================
-- To demonstrate that the code we wrote that uses pulsing does not
-- change the result of reward calculation. we reproduce the old style functions here.

rewardOnePool ::
  EraPParams era =>
  PParams era ->
  Coin ->
  Natural ->
  Natural ->
  PoolParams (EraCrypto era) ->
  Stake (EraCrypto era) ->
  Rational ->
  Rational ->
  Coin ->
  Set.Set (Credential 'Staking (EraCrypto era)) ->
  Map (Credential 'Staking (EraCrypto era)) Coin
rewardOnePool :: forall era.
EraPParams era =>
PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams (EraCrypto era)
-> Stake (EraCrypto era)
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
rewardOnePool
  PParams era
pp
  Coin
r
  Natural
blocksN
  Natural
blocksTotal
  PoolParams (EraCrypto era)
pool
  (Stake VMap VB VP (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stake)
  Rational
sigma
  Rational
sigmaA
  (Coin Integer
totalStake)
  Set (Credential 'Staking (EraCrypto era))
addrsRew =
    Map (Credential 'Staking (EraCrypto era)) Coin
rewards'
    where
      Coin Integer
ostake =
        forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
          (\Coin
c KeyHash 'Staking (EraCrypto era)
o -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
c (forall a. Monoid a => a -> a -> a
mappend Coin
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Compactible a => CompactForm a -> a
fromCompact) forall a b. (a -> b) -> a -> b
$ forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
o) VMap VB VP (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stake)
          forall a. Monoid a => a
mempty
          (forall c. PoolParams c -> Set (KeyHash 'Staking c)
ppOwners PoolParams (EraCrypto era)
pool)
      Coin Integer
pledge = forall c. PoolParams c -> Coin
ppPledge PoolParams (EraCrypto era)
pool
      pr :: Rational
pr = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pledge forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      Coin Integer
maxP =
        if Integer
pledge forall a. Ord a => a -> a -> Bool
<= Integer
ostake
          then forall era.
EraPParams era =>
PParams era -> Coin -> Rational -> Rational -> Coin
maxPool PParams era
pp Coin
r Rational
sigma Rational
pr
          else forall a. Monoid a => a
mempty
      appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG) Rational
sigmaA Natural
blocksN Natural
blocksTotal
      poolR :: Coin
poolR = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxP)
      tot :: Integer
tot = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      pv :: ProtVer
pv = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
      mRewards :: Map (Credential 'Staking (EraCrypto era)) Coin
mRewards =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ ( Credential 'Staking (EraCrypto era)
hk
            , forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
memberRew
                Coin
poolR
                PoolParams (EraCrypto era)
pool
                (Rational -> StakeShare
StakeShare (Coin -> Integer
unCoin (forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
c) forall a. Integral a => a -> a -> Ratio a
% Integer
tot))
                (Rational -> StakeShare
StakeShare Rational
sigma)
            )
          | (Credential 'Staking (EraCrypto era)
hk, CompactForm Coin
c) <- forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList VMap VB VP (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stake
          , Credential 'Staking (EraCrypto era) -> Bool
notPoolOwner Credential 'Staking (EraCrypto era)
hk
          ]
      notPoolOwner :: Credential 'Staking (EraCrypto era) -> Bool
notPoolOwner (KeyHashObj KeyHash 'Staking (EraCrypto era)
hk) = KeyHash 'Staking (EraCrypto era)
hk forall a. Ord a => a -> Set a -> Bool
`Set.notMember` forall c. PoolParams c -> Set (KeyHash 'Staking c)
ppOwners PoolParams (EraCrypto era)
pool
      notPoolOwner (ScriptHashObj ScriptHash (EraCrypto era)
_) = Bool
True
      lReward :: Coin
lReward =
        forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
leaderRew
          Coin
poolR
          PoolParams (EraCrypto era)
pool
          (Rational -> StakeShare
StakeShare forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ostake forall a. Integral a => a -> a -> Ratio a
% Integer
tot)
          (Rational -> StakeShare
StakeShare Rational
sigma)
      f :: Credential 'Staking (EraCrypto era)
-> Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
f =
        if ProtVer -> Bool
HardForks.aggregatedRewards ProtVer
pv
          then forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>)
          else forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
      potentialRewards :: Map (Credential 'Staking (EraCrypto era)) Coin
potentialRewards =
        Credential 'Staking (EraCrypto era)
-> Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
f (forall c. RewardAccount c -> Credential 'Staking c
raCredential forall a b. (a -> b) -> a -> b
$ forall c. PoolParams c -> RewardAccount c
ppRewardAccount PoolParams (EraCrypto era)
pool) Coin
lReward Map (Credential 'Staking (EraCrypto era)) Coin
mRewards
      potentialRewards' :: Map (Credential 'Staking (EraCrypto era)) Coin
potentialRewards' =
        if ProtVer -> Bool
HardForks.forgoRewardPrefilter ProtVer
pv
          then Map (Credential 'Staking (EraCrypto era)) Coin
potentialRewards
          else forall s t. Embed s t => Exp t -> s
eval (Set (Credential 'Staking (EraCrypto era))
addrsRew forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (Credential 'Staking (EraCrypto era)) Coin
potentialRewards)
      rewards' :: Map (Credential 'Staking (EraCrypto era)) Coin
rewards' = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0) Map (Credential 'Staking (EraCrypto era)) Coin
potentialRewards'

rewardOld ::
  forall era.
  EraPParams era =>
  PParams era ->
  BlocksMade (EraCrypto era) ->
  Coin ->
  Set.Set (Credential 'Staking (EraCrypto era)) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
  Stake (EraCrypto era) ->
  VMap.VMap VMap.VB VMap.VB (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era)) ->
  Coin ->
  ActiveSlotCoeff ->
  EpochSize ->
  ( Map
      (Credential 'Staking (EraCrypto era))
      Coin
  , Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
  )
rewardOld :: forall era.
EraPParams era =>
PParams era
-> BlocksMade (EraCrypto era)
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Coin
-> ActiveSlotCoeff
-> EpochSize
-> (Map (Credential 'Staking (EraCrypto era)) Coin,
    Map (KeyHash 'StakePool (EraCrypto era)) Likelihood)
rewardOld
  PParams era
pp
  (BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
b)
  Coin
r
  Set (Credential 'Staking (EraCrypto era))
addrsRew
  VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
  Stake (EraCrypto era)
stake
  VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
  (Coin Integer
totalStake)
  ActiveSlotCoeff
asc
  EpochSize
slotsPerEpoch = (Map (Credential 'Staking (EraCrypto era)) Coin
rewards', Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
hs)
    where
      totalBlocks :: Natural
totalBlocks = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash 'StakePool (EraCrypto era)) Natural
b
      Coin Integer
activeStake = forall c. Stake c -> Coin
sumAllStake Stake (EraCrypto era)
stake
      results ::
        [ ( KeyHash 'StakePool (EraCrypto era)
          , Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
          , Likelihood
          )
        ]
      results :: [(KeyHash 'StakePool (EraCrypto era),
  Maybe (Map (Credential 'Staking (EraCrypto era)) Coin),
  Likelihood)]
results = do
        (KeyHash 'StakePool (EraCrypto era)
hk, PoolParams (EraCrypto era)
pparams) <- forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
        let sigma :: Rational
sigma = if Integer
totalStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
            sigmaA :: Rational
sigmaA = if Integer
activeStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
activeStake
            blocksProduced :: Maybe Natural
blocksProduced = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
hk Map (KeyHash 'StakePool (EraCrypto era)) Natural
b
            actgr :: Stake (EraCrypto era)
actgr = forall c.
KeyHash 'StakePool c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Stake c
poolStake KeyHash 'StakePool (EraCrypto era)
hk VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stake
            Coin Integer
pstake = forall c. Stake c -> Coin
sumAllStake Stake (EraCrypto era)
actgr
            rewardMap :: Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
rewardMap = case Maybe Natural
blocksProduced of
              Maybe Natural
Nothing -> forall a. Maybe a
Nothing -- This is equivalent to calling rewarOnePool with n = 0
              Just Natural
n ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  forall era.
EraPParams era =>
PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams (EraCrypto era)
-> Stake (EraCrypto era)
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
rewardOnePool
                    PParams era
pp
                    Coin
r
                    Natural
n
                    Natural
totalBlocks
                    PoolParams (EraCrypto era)
pparams
                    Stake (EraCrypto era)
actgr
                    Rational
sigma
                    Rational
sigmaA
                    (Integer -> Coin
Coin Integer
totalStake)
                    Set (Credential 'Staking (EraCrypto era))
addrsRew
            ls :: Likelihood
ls =
              Natural -> Double -> EpochSize -> Likelihood
likelihood
                (forall a. a -> Maybe a -> a
fromMaybe Natural
0 Maybe Natural
blocksProduced)
                (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc Rational
sigma (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG))
                EpochSize
slotsPerEpoch
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool (EraCrypto era)
hk, Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
rewardMap, Likelihood
ls)
      pv :: ProtVer
pv = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
      f :: [Map (Credential 'Staking (EraCrypto era)) Coin]
-> Map (Credential 'Staking (EraCrypto era)) Coin
f =
        if ProtVer -> Bool
HardForks.aggregatedRewards ProtVer
pv
          then forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. Semigroup a => a -> a -> a
(<>)
          else forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      rewards' :: Map (Credential 'Staking (EraCrypto era)) Coin
rewards' = [Map (Credential 'Staking (EraCrypto era)) Coin]
-> Map (Credential 'Staking (EraCrypto era)) Coin
f forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(KeyHash 'StakePool (EraCrypto era)
_, Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
x, Likelihood
_) -> Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
x) [(KeyHash 'StakePool (EraCrypto era),
  Maybe (Map (Credential 'Staking (EraCrypto era)) Coin),
  Likelihood)]
results
      hs :: Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
hs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(KeyHash 'StakePool (EraCrypto era)
hk, Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
_, Likelihood
l) -> (KeyHash 'StakePool (EraCrypto era)
hk, Likelihood
l)) [(KeyHash 'StakePool (EraCrypto era),
  Maybe (Map (Credential 'Staking (EraCrypto era)) Coin),
  Likelihood)]
results

data RewardUpdateOld c = RewardUpdateOld
  { forall c. RewardUpdateOld c -> DeltaCoin
deltaTOld :: !DeltaCoin
  , forall c. RewardUpdateOld c -> DeltaCoin
deltaROld :: !DeltaCoin
  , forall c. RewardUpdateOld c -> Map (Credential 'Staking c) Coin
rsOld :: !(Map (Credential 'Staking c) Coin)
  , forall c. RewardUpdateOld c -> DeltaCoin
deltaFOld :: !DeltaCoin
  , forall c. RewardUpdateOld c -> NonMyopic c
nonMyopicOld :: !(NonMyopic c)
  }
  deriving (Int -> RewardUpdateOld c -> ShowS
forall c. Int -> RewardUpdateOld c -> ShowS
forall c. [RewardUpdateOld c] -> ShowS
forall c. RewardUpdateOld c -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RewardUpdateOld c] -> ShowS
$cshowList :: forall c. [RewardUpdateOld c] -> ShowS
show :: RewardUpdateOld c -> [Char]
$cshow :: forall c. RewardUpdateOld c -> [Char]
showsPrec :: Int -> RewardUpdateOld c -> ShowS
$cshowsPrec :: forall c. Int -> RewardUpdateOld c -> ShowS
Show, RewardUpdateOld c -> RewardUpdateOld c -> Bool
forall c. RewardUpdateOld c -> RewardUpdateOld c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardUpdateOld c -> RewardUpdateOld c -> Bool
$c/= :: forall c. RewardUpdateOld c -> RewardUpdateOld c -> Bool
== :: RewardUpdateOld c -> RewardUpdateOld c -> Bool
$c== :: forall c. RewardUpdateOld c -> RewardUpdateOld c -> Bool
Eq)

createRUpdOld ::
  forall era.
  EraGov era =>
  EpochSize ->
  BlocksMade (EraCrypto era) ->
  EpochState era ->
  Coin ->
  ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld :: forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
b es :: EpochState era
es@(EpochState AccountState
acnt LedgerState era
ls SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
nm) Coin
maxSupply =
  forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
b SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pr Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs NonMyopic (EraCrypto era)
nm
  where
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    rs :: Set (Credential 'Staking (EraCrypto era))
rs = forall c k v. UView c k v -> Set k
UM.domain forall a b. (a -> b) -> a -> b
$ forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards DState era
ds
    reserves :: Coin
reserves = AccountState -> Coin
asReserves AccountState
acnt
    totalStake :: Coin
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    pr :: PParams era
pr = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL

createRUpdOld_ ::
  forall era.
  EraPParams era =>
  EpochSize ->
  BlocksMade (EraCrypto era) ->
  SnapShots (EraCrypto era) ->
  Coin ->
  PParams era ->
  Coin ->
  Set.Set (Credential 'Staking (EraCrypto era)) ->
  NonMyopic (EraCrypto era) ->
  ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ :: forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ EpochSize
slotsPerEpoch b :: BlocksMade (EraCrypto era)
b@(BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
b') SnapShots (EraCrypto era)
ss (Coin Integer
reserves) PParams era
pr Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs NonMyopic (EraCrypto era)
nm = do
  ActiveSlotCoeff
asc <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> ActiveSlotCoeff
activeSlotCoeff
  let SnapShot Stake (EraCrypto era)
stake' VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs' VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams = forall c. SnapShots c -> SnapShot c
ssStakeGo SnapShots (EraCrypto era)
ss
      -- reserves and rewards change
      deltaR1 :: Coin
deltaR1 =
        Rational -> Coin
rationalToCoinViaFloor forall a b. (a -> b) -> a -> b
$
          forall a. Ord a => a -> a -> a
min Rational
1 Rational
eta
            forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL)
            forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
reserves
      d :: Rational
d = forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG)
      expectedBlocks :: Integer
expectedBlocks =
        forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
          (Rational
1 forall a. Num a => a -> a -> a
- Rational
d) forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational (ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
asc) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral EpochSize
slotsPerEpoch
      -- TODO asc is a global constant, and slotsPerEpoch should not change often at all,
      -- it would be nice to not have to compute expectedBlocks every epoch
      eta :: Rational
eta
        | forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG) forall a. Ord a => a -> a -> Bool
>= Rational
0.8 = Rational
1
        | Bool
otherwise = Integer
blocksMade forall a. Integral a => a -> a -> Ratio a
% Integer
expectedBlocks
      Coin Integer
rPot = forall c. SnapShots c -> Coin
ssFee SnapShots (EraCrypto era)
ss forall a. Semigroup a => a -> a -> a
<> Coin
deltaR1
      deltaT1 :: Integer
deltaT1 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rPot
      _R :: Coin
_R = Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
rPot forall a. Num a => a -> a -> a
- Integer
deltaT1
      (Map (Credential 'Staking (EraCrypto era)) Coin
rs_, Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
newLikelihoods) =
        forall era.
EraPParams era =>
PParams era
-> BlocksMade (EraCrypto era)
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Coin
-> ActiveSlotCoeff
-> EpochSize
-> (Map (Credential 'Staking (EraCrypto era)) Coin,
    Map (KeyHash 'StakePool (EraCrypto era)) Likelihood)
rewardOld
          PParams era
pr
          BlocksMade (EraCrypto era)
b
          Coin
_R
          Set (Credential 'Staking (EraCrypto era))
rs
          VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
          Stake (EraCrypto era)
stake'
          VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs'
          Coin
totalStake
          ActiveSlotCoeff
asc
          EpochSize
slotsPerEpoch
      deltaR2 :: Coin
deltaR2 = Coin
_R forall t. Val t => t -> t -> t
<-> forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr forall t. Val t => t -> t -> t
(<+>) forall a. Monoid a => a
mempty Map (Credential 'Staking (EraCrypto era)) Coin
rs_
      blocksMade :: Integer
blocksMade = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr forall a. Num a => a -> a -> a
(+) Natural
0 Map (KeyHash 'StakePool (EraCrypto era)) Natural
b' :: Integer
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    RewardUpdateOld
      { deltaTOld :: DeltaCoin
deltaTOld = Integer -> DeltaCoin
DeltaCoin Integer
deltaT1
      , deltaROld :: DeltaCoin
deltaROld = forall t. Val t => t -> t
invert (Coin -> DeltaCoin
toDeltaCoin Coin
deltaR1) forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
deltaR2
      , rsOld :: Map (Credential 'Staking (EraCrypto era)) Coin
rsOld = Map (Credential 'Staking (EraCrypto era)) Coin
rs_
      , deltaFOld :: DeltaCoin
deltaFOld = forall t. Val t => t -> t
invert (Coin -> DeltaCoin
toDeltaCoin forall a b. (a -> b) -> a -> b
$ forall c. SnapShots c -> Coin
ssFee SnapShots (EraCrypto era)
ss)
      , nonMyopicOld :: NonMyopic (EraCrypto era)
nonMyopicOld = forall c.
NonMyopic c
-> Coin -> Map (KeyHash 'StakePool c) Likelihood -> NonMyopic c
updateNonMyopic NonMyopic (EraCrypto era)
nm Coin
_R Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
newLikelihoods
      }

overrideProtocolVersionUsedInRewardCalc ::
  EraGov era =>
  ProtVer ->
  EpochState era ->
  EpochState era
overrideProtocolVersionUsedInRewardCalc :: forall era.
EraGov era =>
ProtVer -> EpochState era -> EpochState era
overrideProtocolVersionUsedInRewardCalc ProtVer
pv EpochState era
es =
  EpochState era
es forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv

oldEqualsNew ::
  forall era.
  era ~ C =>
  ProtVer ->
  NewEpochState era ->
  Property
oldEqualsNew :: forall era. (era ~ C) => ProtVer -> NewEpochState era -> Property
oldEqualsNew ProtVer
pv NewEpochState era
newepochstate =
  forall prop. Testable prop => [Char] -> prop -> Property
counterexample
    (forall a. Show a => a -> [Char]
show NewEpochState era
newepochstate forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Edit EditExpr -> Doc
ansiWlEditExprCompact forall a b. (a -> b) -> a -> b
$ forall a. ToExpr a => a -> a -> Edit EditExpr
ediff Map (Credential 'Staking C_Crypto) Coin
old Map (Credential 'Staking C_Crypto) Coin
new))
    (Map (Credential 'Staking C_Crypto) Coin
old forall a. (Eq a, Show a) => a -> a -> Property
=== Map (Credential 'Staking C_Crypto) Coin
new)
  where
    globals :: Globals
globals = Globals
testGlobals
    epochstate :: EpochState era
epochstate = forall era.
EraGov era =>
ProtVer -> EpochState era -> EpochState era
overrideProtocolVersionUsedInRewardCalc ProtVer
pv forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
newepochstate
    maxsupply :: Coin
    maxsupply :: Coin
maxsupply = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Globals -> Word64
maxLovelaceSupply Globals
globals))
    blocksmade :: BlocksMade (EraCrypto era)
    blocksmade :: BlocksMade (EraCrypto era)
blocksmade = forall era. NewEpochState era -> BlocksMade (EraCrypto era)
nesBprev NewEpochState era
newepochstate
    epochnumber :: EpochNo
epochnumber = forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
newepochstate
    slotsPerEpoch :: EpochSize
    slotsPerEpoch :: EpochSize
slotsPerEpoch = forall r a. Reader r a -> r -> a
runReader (HasCallStack =>
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochnumber) Globals
globals
    unAggregated :: RewardUpdate C_Crypto
unAggregated =
      forall r a. Reader r a -> r -> a
runReader (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase (RewardUpdate (EraCrypto era))
createRUpd EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epochstate Coin
maxsupply ActiveSlotCoeff
asc Word64
k) Globals
globals
    old :: Map (Credential 'Staking C_Crypto) Coin
old = forall c. RewardUpdateOld c -> Map (Credential 'Staking c) Coin
rsOld forall a b. (a -> b) -> a -> b
$ forall r a. Reader r a -> r -> a
runReader (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epochstate Coin
maxsupply) Globals
globals
    newWithZeros :: Map (Credential 'Staking (EraCrypto era)) Coin
newWithZeros = forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards @(EraCrypto era) ProtVer
pv (forall c.
RewardUpdate c -> Map (Credential 'Staking c) (Set (Reward c))
rs RewardUpdate C_Crypto
unAggregated)
    new :: Map (Credential 'Staking C_Crypto) Coin
new = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0) Map (Credential 'Staking (EraCrypto era)) Coin
newWithZeros
    asc :: ActiveSlotCoeff
asc = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    k :: Word64
k = Globals -> Word64
securityParameter Globals
testGlobals

oldEqualsNewOn ::
  forall era.
  era ~ C =>
  ProtVer ->
  NewEpochState era ->
  Property
oldEqualsNewOn :: forall era. (era ~ C) => ProtVer -> NewEpochState era -> Property
oldEqualsNewOn ProtVer
pv NewEpochState era
newepochstate = Map (Credential 'Staking (EraCrypto era)) Coin
old forall a. (Eq a, Show a) => a -> a -> Property
=== Map (Credential 'Staking C_Crypto) Coin
new
  where
    globals :: Globals
globals = Globals
testGlobals
    epochstate :: EpochState era
epochstate = forall era.
EraGov era =>
ProtVer -> EpochState era -> EpochState era
overrideProtocolVersionUsedInRewardCalc ProtVer
pv forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
newepochstate
    maxsupply :: Coin
    maxsupply :: Coin
maxsupply = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Globals -> Word64
maxLovelaceSupply Globals
globals))
    blocksmade :: BlocksMade (EraCrypto era)
    blocksmade :: BlocksMade (EraCrypto era)
blocksmade = forall era. NewEpochState era -> BlocksMade (EraCrypto era)
nesBprev NewEpochState era
newepochstate
    epochnumber :: EpochNo
epochnumber = forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
newepochstate
    slotsPerEpoch :: EpochSize
    slotsPerEpoch :: EpochSize
slotsPerEpoch = forall r a. Reader r a -> r -> a
runReader (HasCallStack =>
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochnumber) Globals
globals
    unAggregated :: RewardUpdate C_Crypto
unAggregated =
      forall r a. Reader r a -> r -> a
runReader (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase (RewardUpdate (EraCrypto era))
createRUpd EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epochstate Coin
maxsupply ActiveSlotCoeff
asc Word64
k) Globals
globals
    old :: Map (Credential 'Staking (EraCrypto era)) Coin
    old :: Map (Credential 'Staking (EraCrypto era)) Coin
old = forall c. RewardUpdateOld c -> Map (Credential 'Staking c) Coin
rsOld forall a b. (a -> b) -> a -> b
$ forall r a. Reader r a -> r -> a
runReader (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epochstate Coin
maxsupply) Globals
globals
    newWithZeros :: Map (Credential 'Staking (EraCrypto era)) Coin
newWithZeros = forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards @(EraCrypto era) ProtVer
pv (forall c.
RewardUpdate c -> Map (Credential 'Staking c) (Set (Reward c))
rs RewardUpdate C_Crypto
unAggregated)
    new :: Map (Credential 'Staking C_Crypto) Coin
new = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0) Map (Credential 'Staking (EraCrypto era)) Coin
newWithZeros
    asc :: ActiveSlotCoeff
asc = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    k :: Word64
k = Globals -> Word64
securityParameter Globals
testGlobals

lastElem :: [a] -> Maybe a
lastElem :: forall a. [a] -> Maybe a
lastElem [a
a] = forall a. a -> Maybe a
Just a
a
lastElem [] = forall a. Maybe a
Nothing
lastElem (a
_ : [a]
xs) = forall a. [a] -> Maybe a
lastElem [a]
xs

-- | Provide a legitimate NewEpochState to make an test Property
newEpochProp :: Word64 -> (NewEpochState C -> Property) -> Property
newEpochProp :: Word64 -> (NewEpochState C -> Property) -> Property
newEpochProp Word64
tracelen NewEpochState C -> Property
propf = forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
100 forall a b. (a -> b) -> a -> b
$
  forall era prop.
(Testable prop, EraGen era, HasTrace (CHAIN era) (GenEnv era),
 EraGov era) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace @C Word64
tracelen Constants
defaultConstants forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN C)
tr ->
    case forall a. [a] -> Maybe a
lastElem (forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN C)
tr) of
      Just SourceSignalTarget {State (CHAIN C)
target :: forall a. SourceSignalTarget a -> State a
target :: State (CHAIN C)
target} -> NewEpochState C -> Property
propf (forall era. ChainState era -> NewEpochState era
chainNes State (CHAIN C)
target)
      Maybe (SourceSignalTarget (CHAIN C))
_ -> forall prop. Testable prop => prop -> Property
property Bool
True

-- | Given a NewEpochState and [ChainEvent], test a Property at every Epoch Boundary
newEpochEventsProp :: Word64 -> ([ChainEvent C] -> NewEpochState C -> Property) -> Property
newEpochEventsProp :: Word64
-> ([ChainEvent C] -> NewEpochState C -> Property) -> Property
newEpochEventsProp Word64
tracelen [ChainEvent C] -> NewEpochState C -> Property
propf = forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
10 forall a b. (a -> b) -> a -> b
$
  forall era prop.
(EraGen era, Testable prop, HasTrace (CHAIN era) (GenEnv era),
 EraGov era) =>
Int
-> Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forEachEpochTrace @C Int
10 Word64
tracelen Constants
defaultConstants forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN C)
tr ->
    case forall a. [a] -> Maybe a
lastElem (forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN C)
tr) of
      Just SourceSignalTarget {State (CHAIN C)
target :: State (CHAIN C)
target :: forall a. SourceSignalTarget a -> State a
target} ->
        [ChainEvent C] -> NewEpochState C -> Property
propf (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall sts. STS sts => Trace sts -> BaseM sts [[Event sts]]
getEvents Trace (CHAIN C)
tr)) (forall era. ChainState era -> NewEpochState era
chainNes State (CHAIN C)
target)
      Maybe (SourceSignalTarget (CHAIN C))
_ -> forall prop. Testable prop => prop -> Property
property Bool
True

aggIncrementalRewardEvents ::
  [ChainEvent C] ->
  Map (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggIncrementalRewardEvents :: [ChainEvent C]
-> Map
     (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggIncrementalRewardEvents = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era} {era} {era} {c}.
(Event (EraRule "TICK" era) ~ ShelleyTickEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era,
 Event (EraRule "RUPD" era) ~ RupdEvent c,
 Event (EraRule "RUPD" era) ~ RupdEvent c) =>
Map (Credential 'Staking c) (Set (Reward c))
-> ChainEvent era -> Map (Credential 'Staking c) (Set (Reward c))
accum forall k a. Map k a
Map.empty
  where
    accum :: Map (Credential 'Staking c) (Set (Reward c))
-> ChainEvent era -> Map (Credential 'Staking c) (Set (Reward c))
accum Map (Credential 'Staking c) (Set (Reward c))
ans (TickEvent (TickRupdEvent (RupdEvent EpochNo
_ Map (Credential 'Staking c) (Set (Reward c))
m))) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Map (Credential 'Staking c) (Set (Reward c))
m Map (Credential 'Staking c) (Set (Reward c))
ans
    accum Map (Credential 'Staking c) (Set (Reward c))
ans (TickEvent (TickNewEpochEvent (DeltaRewardEvent (RupdEvent EpochNo
_ Map (Credential 'Staking c) (Set (Reward c))
m)))) =
      forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Map (Credential 'Staking c) (Set (Reward c))
m Map (Credential 'Staking c) (Set (Reward c))
ans
    accum Map (Credential 'Staking c) (Set (Reward c))
ans ChainEvent era
_ = Map (Credential 'Staking c) (Set (Reward c))
ans

getMostRecentTotalRewardEvent ::
  [ChainEvent C] ->
  Map (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
getMostRecentTotalRewardEvent :: [ChainEvent C]
-> Map
     (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
getMostRecentTotalRewardEvent = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era} {era} {era}.
(Event (EraRule "TICK" era) ~ ShelleyTickEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era) =>
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> ChainEvent era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
accum forall k a. Map k a
Map.empty
  where
    accum :: Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> ChainEvent era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
accum Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
ans (TickEvent (TickNewEpochEvent (TotalRewardEvent EpochNo
_ Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
m))) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
m Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
ans
    accum Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
ans ChainEvent era
_ = Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
ans

complete :: PulsingRewUpdate c -> (RewardUpdate c, RewardEvent c)
complete :: forall c. PulsingRewUpdate c -> (RewardUpdate c, RewardEvent c)
complete (Complete RewardUpdate c
r) = (RewardUpdate c
r, forall a. Monoid a => a
mempty)
complete (Pulsing RewardSnapShot c
rewsnap Pulser c
pulser) = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ (forall c.
PulsingRewUpdate c -> ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd (forall c. RewardSnapShot c -> Pulser c -> PulsingRewUpdate c
Pulsing RewardSnapShot c
rewsnap Pulser c
pulser))

eventsMirrorRewards :: [ChainEvent C] -> NewEpochState C -> Property
eventsMirrorRewards :: [ChainEvent C] -> NewEpochState C -> Property
eventsMirrorRewards [ChainEvent C]
events NewEpochState C
nes = forall {a} {b}.
(Terse a, Terse b, Ord a, Eq b, Show a, Show b) =>
Map a b -> Map a b -> Property
same Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
eventRew Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
compRew
  where
    (Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
compRew, Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
eventRew) =
      case forall era.
NewEpochState era -> StrictMaybe (PulsingRewUpdate (EraCrypto era))
nesRu NewEpochState C
nes of
        StrictMaybe (PulsingRewUpdate (EraCrypto C))
SNothing -> (Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
total, Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggFilteredEvent)
        SJust PulsingRewUpdate (EraCrypto C)
pulser ->
          ( forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall c.
RewardUpdate c -> Map (Credential 'Staking c) (Set (Reward c))
rs RewardUpdate C_Crypto
completed) Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
total
          , forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
lastevent Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggevent
          )
          where
            (RewardUpdate C_Crypto
completed, Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
lastevent) = forall c. PulsingRewUpdate c -> (RewardUpdate c, RewardEvent c)
complete PulsingRewUpdate (EraCrypto C)
pulser
    total :: Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
total = [ChainEvent C]
-> Map
     (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
getMostRecentTotalRewardEvent [ChainEvent C]
events
    aggevent :: Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggevent = [ChainEvent C]
-> Map
     (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggIncrementalRewardEvents [ChainEvent C]
events
    FilteredRewards Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggFilteredEvent Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
_ Set (Credential 'Staking (EraCrypto C))
_ Coin
_ = forall era.
EraGov era =>
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> EpochState era -> FilteredRewards era
filterAllRewards Map
  (Credential 'Staking (EraCrypto C)) (Set (Reward (EraCrypto C)))
aggevent (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState C
nes)
    same :: Map a b -> Map a b -> Property
same Map a b
x Map a b
y = forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
1 forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
message (Map a b
x forall a. (Eq a, Show a) => a -> a -> Property
=== Map a b
y)
      where
        message :: [Char]
message =
          [Char]
"events don't mirror rewards "
            forall a. [a] -> [a] -> [a]
++ forall a b.
(Terse a, Terse b, Ord a, Eq b) =>
[Char] -> Map a b -> Map a b -> [Char]
tersemapdiffs
              [Char]
"Map differences: aggregated filtered events on the left, computed on the right."
              Map a b
x
              Map a b
y

instance Terse (Reward c) where
  terse :: Reward c -> [Char]
terse (Reward RewardType
ty KeyHash 'StakePool c
pl (Coin Integer
n)) = [Char]
"Reward{" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RewardType
ty forall a. [a] -> [a] -> [a]
++ [Char]
", #" forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
9 (forall a. Show a => a -> [Char]
show KeyHash 'StakePool c
pl) forall a. [a] -> [a] -> [a]
++ [Char]
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
n forall a. [a] -> [a] -> [a]
++ [Char]
"}"

instance Terse x => Terse (Set x) where
  terse :: Set x -> [Char]
terse Set x
x = [[Char]] -> [Char]
unlines (forall a. Set a -> [a]
Set.toList (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall t. Terse t => t -> [Char]
terse Set x
x))

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

reward ::
  forall era.
  EraPParams era =>
  PParams era ->
  BlocksMade (EraCrypto era) ->
  Coin ->
  Set (Credential 'Staking (EraCrypto era)) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
  Stake (EraCrypto era) ->
  VMap.VMap VMap.VB VMap.VB (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era)) ->
  Coin ->
  ShelleyBase (RewardAns (EraCrypto era))
reward :: forall era.
EraPParams era =>
PParams era
-> BlocksMade (EraCrypto era)
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Coin
-> ShelleyBase (RewardAns (EraCrypto era))
reward
  PParams era
pp
  (BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
b)
  Coin
r
  Set (Credential 'Staking (EraCrypto era))
addrsRew
  VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
  Stake (EraCrypto era)
stake
  VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
  Coin
totalStake = forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser (EraCrypto era)
pulser
    where
      totalBlocks :: Natural
totalBlocks = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash 'StakePool (EraCrypto era)) Natural
b
      stakePerPool :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
stakePerPool = forall c.
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c -> Map (KeyHash 'StakePool c) Coin
sumStakePerPool VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stake
      activeStake :: Coin
activeStake = forall c. Stake c -> Coin
sumAllStake Stake (EraCrypto era)
stake
      -- ensure mkPoolRewardInfo does not use stake that doesn't belong to the pool
      stakeForPool :: PoolParams (EraCrypto era) -> Stake (EraCrypto era)
stakeForPool PoolParams (EraCrypto era)
pool = forall c.
KeyHash 'StakePool c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Stake c
poolStake (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
pool) VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stake
      mkPoolRewardInfo' :: PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo' PoolParams (EraCrypto era)
pool =
        forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade (EraCrypto era)
-> Natural
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) Coin
-> Coin
-> Coin
-> PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo
          PParams era
pp
          Coin
r
          (forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
b)
          Natural
totalBlocks
          (PoolParams (EraCrypto era) -> Stake (EraCrypto era)
stakeForPool PoolParams (EraCrypto era)
pool)
          VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
          Map (KeyHash 'StakePool (EraCrypto era)) Coin
stakePerPool
          Coin
totalStake
          Coin
activeStake
          PoolParams (EraCrypto era)
pool
      free :: FreeVars (EraCrypto era)
free =
        FreeVars
          { fvAddrsRew :: Set (Credential 'Staking (EraCrypto era))
fvAddrsRew = Set (Credential 'Staking (EraCrypto era))
addrsRew
          , fvTotalStake :: Coin
fvTotalStake = Coin
totalStake
          , fvPoolRewardInfo :: Map
  (KeyHash 'StakePool (EraCrypto era))
  (PoolRewardInfo (EraCrypto era))
fvPoolRewardInfo =
              forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(a -> Maybe b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo') VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
          , fvDelegs :: VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
fvDelegs = VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
          , fvProtVer :: ProtVer
fvProtVer = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
          }
      pulser :: Pulser (EraCrypto era)
      pulser :: Pulser (EraCrypto era)
pulser = forall ans c (m :: * -> *).
(ans ~ RewardAns c, m ~ ShelleyBase) =>
Int
-> FreeVars c
-> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> ans
-> RewardPulser c m ans
RSLP Int
2 FreeVars (EraCrypto era)
free (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake Stake (EraCrypto era)
stake) (forall c.
Map (Credential 'Staking c) (Reward c)
-> RewardEvent c -> RewardAns c
RewardAns forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)

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

-- | Note that chainlen must be set high enough so that enough epochs
-- have passed to get non-trivial rewards.
chainlen :: Word64
chainlen :: Word64
chainlen = Word64
200

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Reward Tests"
    [ forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"Sum of rewards is bounded by reward pot" forall a b. (a -> b) -> a -> b
$
        forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
numberOfTests (forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Proxy era -> Property
rewardsBoundedByPot (forall {k} (t :: k). Proxy t
Proxy @C))
    , forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"compare with reference impl, no provenance, v3" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => prop -> Property
noShrinking forall a b. (a -> b) -> a -> b
$
        Word64 -> (NewEpochState C -> Property) -> Property
newEpochProp Word64
chainlen (forall era. (era ~ C) => ProtVer -> NewEpochState era -> Property
oldEqualsNew @C (Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @3) Natural
0))
    , forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"compare with reference impl, no provenance, v7" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => prop -> Property
noShrinking forall a b. (a -> b) -> a -> b
$
        Word64 -> (NewEpochState C -> Property) -> Property
newEpochProp Word64
chainlen (forall era. (era ~ C) => ProtVer -> NewEpochState era -> Property
oldEqualsNew @C (Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @7) Natural
0))
    , forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"compare with reference impl, with provenance" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => prop -> Property
noShrinking forall a b. (a -> b) -> a -> b
$
        Word64 -> (NewEpochState C -> Property) -> Property
newEpochProp Word64
chainlen (forall era. (era ~ C) => ProtVer -> NewEpochState era -> Property
oldEqualsNewOn @C (Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @3) Natural
0))
    , forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"delta events mirror reward updates" forall a b. (a -> b) -> a -> b
$
        Word64
-> ([ChainEvent C] -> NewEpochState C -> Property) -> Property
newEpochEventsProp Word64
chainlen [ChainEvent C] -> NewEpochState C -> Property
eventsMirrorRewards
    ]