{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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,
  defaultMain,
  newEpochProp,
  newEpochEventsProp,
  RewardUpdateOld (..),
  createRUpdOld,
  createRUpdOld_,
  mkSnapShot,
) 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,
  nonZeroOr,
  (%?),
 )
import Cardano.Ledger.Binary (encCBOR, hashWithEncoder, natVersion, shelleyProtVer)
import Cardano.Ledger.Coin (
  Coin (..),
  DeltaCoin (..),
  knownNonZeroCoin,
  rationalToCoinViaFloor,
  toDeltaCoin,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Keys (VKey (..))
import Cardano.Ledger.Rewards (Reward (..))
import Cardano.Ledger.Shelley (
  ShelleyEra,
  hardforkAllegraAggregatedRewards,
  hardforkBabbageForgoRewardPrefilter,
 )
import Cardano.Ledger.Shelley.API (NonMyopic)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  FilteredRewards (..),
  NewEpochState (..),
  RewardUpdate (..),
  circulation,
  completeRupd,
  createRUpd,
  filterAllRewards,
  lsCertStateL,
  prevPParamsEpochStateL,
  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,
  calcStakePoolMemberReward,
  calcStakePoolOperatorReward,
  mkApparentPerformance,
  mkPoolRewardInfo,
 )
import Cardano.Ledger.Shelley.Rules (
  PulsingRewUpdate (..),
  RupdEvent (RupdEvent),
  ShelleyNewEpochEvent (DeltaRewardEvent, TotalRewardEvent),
  ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent),
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Slot (epochInfoSize)
import Cardano.Ledger.Val (Val (..), invert, (<+>), (<->))
import Cardano.Protocol.Crypto (VRF, hashVerKeyVRF)
import Cardano.Slotting.Slot (EpochSize (..))
import Control.DeepSeq
import Control.Monad (replicateM)
import Control.Monad.Trans.Reader (asks, runReader)
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 (MockCrypto)
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.QuickCheck ((===))
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 :: Int -> KeyPair r
keyPair :: forall (r :: KeyRole). Int -> KeyPair r
keyPair Int
seed = VKey r -> SignKeyDSIGN DSIGN -> KeyPair r
forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vk SignKeyDSIGN DSIGN
sk
  where
    vk :: VKey r
vk = VerKeyDSIGN DSIGN -> VKey r
forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
VKey (SignKeyDSIGN DSIGN -> VerKeyDSIGN DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
Crypto.deriveVerKeyDSIGN SignKeyDSIGN DSIGN
sk)
    sk :: SignKeyDSIGN DSIGN
sk =
      Seed -> SignKeyDSIGN DSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
Crypto.genKeyDSIGN (Seed -> SignKeyDSIGN DSIGN) -> Seed -> SignKeyDSIGN DSIGN
forall a b. (a -> b) -> a -> b
$
        ByteString -> Seed
mkSeedFromBytes (ByteString -> Seed)
-> (Hash Blake2b_256 Int -> ByteString)
-> Hash Blake2b_256 Int
-> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash Blake2b_256 Int -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash Blake2b_256 Int -> Seed) -> Hash Blake2b_256 Int -> Seed
forall a b. (a -> b) -> a -> b
$
          forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @Blake2b_256 Version
shelleyProtVer Int -> Encoding
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 = SignKeyVRF v -> VerKeyVRF v
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
Crypto.deriveVerKeyVRF SignKeyVRF v
sk
    sk :: SignKeyVRF v
sk =
      Seed -> SignKeyVRF v
forall v. VRFAlgorithm v => Seed -> SignKeyVRF v
Crypto.genKeyVRF (Seed -> SignKeyVRF v) -> Seed -> SignKeyVRF v
forall a b. (a -> b) -> a -> b
$
        ByteString -> Seed
mkSeedFromBytes (ByteString -> Seed)
-> (Hash Blake2b_256 Int -> ByteString)
-> Hash Blake2b_256 Int
-> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash Blake2b_256 Int -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash Blake2b_256 Int -> Seed) -> Hash Blake2b_256 Int -> Seed
forall a b. (a -> b) -> a -> b
$
          forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @Blake2b_256 Version
shelleyProtVer Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Int
seed

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

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

data PoolInfo = PoolInfo
  { PoolInfo -> StakePoolParams
params :: StakePoolParams
  , PoolInfo -> KeyPair StakePool
coldKey :: KeyPair StakePool
  , PoolInfo -> KeyPair Staking
ownerKey :: KeyPair Staking
  , PoolInfo -> Coin
ownerStake :: Coin
  , PoolInfo -> KeyPair Staking
rewardKey :: KeyPair Staking
  , PoolInfo -> Map (Credential Staking) Coin
members :: Map (Credential Staking) Coin
  }

-- Generators --

genNonOwnerMembers :: Gen (Map (Credential Staking) Coin)
genNonOwnerMembers :: Gen (Map (Credential Staking) Coin)
genNonOwnerMembers = do
  numMembers <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxNumMembers)
  fmap Map.fromList . replicateM numMembers $ do
    credential <- KeyHashObj . hashKey . vKey . keyPair <$> arbitrary
    coins <- genCoin 0 maxMemberLovelace
    pure (credential, coins)

getOrGen :: Maybe a -> Gen a -> Gen a
getOrGen :: forall a. Maybe a -> Gen a -> Gen a
getOrGen (Just a
x) Gen a
_ = a -> Gen a
forall a. a -> 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
  numer <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
denom)
  pure $ unsafeBoundRational (numer % denom)

genPoolInfo :: PoolSetUpArgs Maybe -> Gen PoolInfo
genPoolInfo :: PoolSetUpArgs Maybe -> Gen PoolInfo
genPoolInfo PoolSetUpArgs {Maybe Coin
poolPledge :: forall (f :: * -> *). PoolSetUpArgs f -> f Coin
poolPledge :: Maybe Coin
poolPledge, Maybe Coin
poolCost :: forall (f :: * -> *). PoolSetUpArgs f -> f Coin
poolCost :: Maybe Coin
poolCost, Maybe UnitInterval
poolMargin :: forall (f :: * -> *). PoolSetUpArgs f -> f UnitInterval
poolMargin :: Maybe UnitInterval
poolMargin, Maybe (Map (Credential Staking) Coin)
poolMembers :: forall (f :: * -> *).
PoolSetUpArgs f -> f (Map (Credential Staking) Coin)
poolMembers :: Maybe (Map (Credential Staking) Coin)
poolMembers} = do
  pledge <- Maybe Coin -> Gen Coin -> Gen Coin
forall a. Maybe a -> Gen a -> Gen a
getOrGen Maybe Coin
poolPledge (Gen Coin -> Gen Coin) -> Gen Coin -> Gen Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Coin
genCoin Integer
0 Integer
maxPoolPledeg
  cost <- getOrGen poolCost $ genCoin 0 maxPoolCost
  margin <- getOrGen poolMargin genMargin
  vrfKey <- vrfKeyPair @(VRF MockCrypto) <$> arbitrary
  coldKey <- keyPair <$> arbitrary
  ownerKey <- keyPair <$> arbitrary
  rewardKey <- keyPair <$> arbitrary
  members' <- getOrGen poolMembers genNonOwnerMembers
  ownerStake <- (pledge <>) <$> genCoin 0 maxOwnerLovelaceAbovePledge
  -- here we are forcing the pool to meet the pledeg, later we may want flexibility
  let members = Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> (KeyPair Staking -> KeyHash Staking)
-> KeyPair Staking
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey Staking -> KeyHash Staking
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Staking -> KeyHash Staking)
-> (KeyPair Staking -> VKey Staking)
-> KeyPair Staking
-> KeyHash Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> VKey Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair Staking -> Credential Staking)
-> KeyPair Staking -> Credential Staking
forall a b. (a -> b) -> a -> b
$ KeyPair Staking
ownerKey) Coin
ownerStake Map (Credential Staking) Coin
members'
      params =
        StakePoolParams
          { sppId :: KeyHash StakePool
sppId = VKey StakePool -> KeyHash StakePool
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey StakePool -> KeyHash StakePool)
-> (KeyPair StakePool -> VKey StakePool)
-> KeyPair StakePool
-> KeyHash StakePool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair StakePool -> VKey StakePool
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair StakePool -> KeyHash StakePool)
-> KeyPair StakePool -> KeyHash StakePool
forall a b. (a -> b) -> a -> b
$ KeyPair StakePool
coldKey
          , sppVrf :: VRFVerKeyHash StakePoolVRF
sppVrf = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto (VerKeyVRF (VRF MockCrypto) -> VRFVerKeyHash StakePoolVRF)
-> VerKeyVRF (VRF MockCrypto) -> VRFVerKeyHash StakePoolVRF
forall a b. (a -> b) -> a -> b
$ (SignKeyVRF FakeVRF, VerKeyVRF FakeVRF) -> VerKeyVRF FakeVRF
forall a b. (a, b) -> b
snd (SignKeyVRF FakeVRF, VerKeyVRF FakeVRF)
vrfKey
          , sppPledge :: Coin
sppPledge = Coin
pledge
          , sppCost :: Coin
sppCost = Coin
cost
          , sppMargin :: UnitInterval
sppMargin = UnitInterval
margin
          , sppAccountAddress :: AccountAddress
sppAccountAddress = Network -> AccountId -> AccountAddress
AccountAddress Network
Testnet (AccountId -> AccountAddress)
-> (KeyPair Staking -> AccountId)
-> KeyPair Staking
-> AccountAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential Staking -> AccountId
AccountId (Credential Staking -> AccountId)
-> (KeyPair Staking -> Credential Staking)
-> KeyPair Staking
-> AccountId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> (KeyPair Staking -> KeyHash Staking)
-> KeyPair Staking
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey Staking -> KeyHash Staking
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Staking -> KeyHash Staking)
-> (KeyPair Staking -> VKey Staking)
-> KeyPair Staking
-> KeyHash Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> VKey Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair Staking -> AccountAddress)
-> KeyPair Staking -> AccountAddress
forall a b. (a -> b) -> a -> b
$ KeyPair Staking
rewardKey
          , sppOwners :: Set (KeyHash Staking)
sppOwners = [KeyHash Staking] -> Set (KeyHash Staking)
forall a. Ord a => [a] -> Set a
Set.fromList [VKey Staking -> KeyHash Staking
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Staking -> KeyHash Staking)
-> VKey Staking -> KeyHash Staking
forall a b. (a -> b) -> a -> b
$ KeyPair Staking -> VKey Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair Staking
ownerKey]
          , sppRelays :: StrictSeq StakePoolRelay
sppRelays = StrictSeq StakePoolRelay
forall a. StrictSeq a
StrictSeq.empty
          , sppMetadata :: StrictMaybe PoolMetadata
sppMetadata = StrictMaybe PoolMetadata
forall a. StrictMaybe a
SNothing
          }
  pure $ PoolInfo {params, coldKey, ownerKey, ownerStake, rewardKey, members}

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

genBlocksMade :: [StakePoolParams] -> Gen BlocksMade
genBlocksMade :: [StakePoolParams] -> Gen BlocksMade
genBlocksMade [StakePoolParams]
pools = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade (Map (KeyHash StakePool) Natural -> BlocksMade)
-> ([(KeyHash StakePool, Natural)]
    -> Map (KeyHash StakePool) Natural)
-> [(KeyHash StakePool, Natural)]
-> BlocksMade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(KeyHash StakePool, Natural)] -> Map (KeyHash StakePool) Natural
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash StakePool, Natural)] -> BlocksMade)
-> Gen [(KeyHash StakePool, Natural)] -> Gen BlocksMade
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StakePoolParams -> Gen (KeyHash StakePool, Natural))
-> [StakePoolParams] -> Gen [(KeyHash StakePool, Natural)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM StakePoolParams -> Gen (KeyHash StakePool, Natural)
f [StakePoolParams]
pools
  where
    f :: StakePoolParams -> Gen (KeyHash StakePool, Natural)
f StakePoolParams
p = (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
p,) (Natural -> (KeyHash StakePool, Natural))
-> Gen Natural -> Gen (KeyHash StakePool, Natural)
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 =
  CompactForm Coin -> Maybe (CompactForm Coin) -> CompactForm Coin
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> CompactForm Coin
forall a. HasCallStack => [Char] -> a
error ([Char] -> CompactForm Coin) -> [Char] -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid Coin: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Coin -> [Char]
forall a. Show a => a -> [Char]
show Coin
c) (Maybe (CompactForm Coin) -> CompactForm Coin)
-> Maybe (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ Coin -> Maybe (CompactForm Coin)
forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Coin
c

rewardsBoundedByPot ::
  forall era.
  (EraPParams era, AtMostEra "Alonzo" era) =>
  Proxy era ->
  Property
rewardsBoundedByPot :: forall era.
(EraPParams era, AtMostEra "Alonzo" era) =>
Proxy era -> Property
rewardsBoundedByPot Proxy era
_ = Gen Property -> Property
forall prop. Testable prop => prop -> Property
property (Gen Property -> Property) -> Gen Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  numPools <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxNumPools)
  pools <- sequence $ genPoolInfo <$> replicate numPools emptySetupArgs
  pp <- genRewardPPs
  rewardPot <- genCoin 0 (fromIntegral $ maxLovelaceSupply testGlobals)
  undelegatedLovelace <- genCoin 0 (fromIntegral $ maxLovelaceSupply testGlobals)
  asc <- mkActiveSlotCoeff . unsafeBoundRational <$> elements [0.1, 0.2, 0.3]
  bs@(BlocksMade blocks) <- genBlocksMade (fmap params pools)
  let totalBlocks = Map (KeyHash StakePool) Natural -> Natural
forall a. Num a => Map (KeyHash StakePool) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash StakePool) Natural
blocks
  silentSlots <- genNatural 0 (3 * totalBlocks) -- the '3 * sum blocks' is pretty arbitrary
  let stake = [Map (Credential Staking) Coin] -> Map (Credential Staking) Coin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (PoolInfo -> Map (Credential Staking) Coin
members (PoolInfo -> Map (Credential Staking) Coin)
-> [PoolInfo] -> [Map (Credential Staking) Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolInfo]
pools)
      delegs = [Map (Credential Staking) (KeyHash StakePool)]
-> Map (Credential Staking) (KeyHash StakePool)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Map (Credential Staking) (KeyHash StakePool)]
 -> Map (Credential Staking) (KeyHash StakePool))
-> [Map (Credential Staking) (KeyHash StakePool)]
-> Map (Credential Staking) (KeyHash StakePool)
forall a b. (a -> b) -> a -> b
$
        ((PoolInfo -> Map (Credential Staking) (KeyHash StakePool))
 -> [PoolInfo] -> [Map (Credential Staking) (KeyHash StakePool)])
-> [PoolInfo]
-> (PoolInfo -> Map (Credential Staking) (KeyHash StakePool))
-> [Map (Credential Staking) (KeyHash StakePool)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PoolInfo -> Map (Credential Staking) (KeyHash StakePool))
-> [PoolInfo] -> [Map (Credential Staking) (KeyHash StakePool)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PoolInfo]
pools ((PoolInfo -> Map (Credential Staking) (KeyHash StakePool))
 -> [Map (Credential Staking) (KeyHash StakePool)])
-> (PoolInfo -> Map (Credential Staking) (KeyHash StakePool))
-> [Map (Credential Staking) (KeyHash StakePool)]
forall a b. (a -> b) -> a -> b
$
          \PoolInfo {StakePoolParams
params :: PoolInfo -> StakePoolParams
params :: StakePoolParams
params, Map (Credential Staking) Coin
members :: PoolInfo -> Map (Credential Staking) Coin
members :: Map (Credential Staking) Coin
members} ->
            [(Credential Staking, KeyHash StakePool)]
-> Map (Credential Staking) (KeyHash StakePool)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Credential Staking, KeyHash StakePool)]
 -> Map (Credential Staking) (KeyHash StakePool))
-> [(Credential Staking, KeyHash StakePool)]
-> Map (Credential Staking) (KeyHash StakePool)
forall a b. (a -> b) -> a -> b
$ (,StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
params) (Credential Staking -> (Credential Staking, KeyHash StakePool))
-> [Credential Staking]
-> [(Credential Staking, KeyHash StakePool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Credential Staking) Coin -> [Credential Staking]
forall k a. Map k a -> [k]
Map.keys Map (Credential Staking) Coin
members
      rewardAccounts = [Credential Staking] -> Set (Credential Staking)
forall a. Ord a => [a] -> Set a
Set.fromList ([Credential Staking] -> Set (Credential Staking))
-> [Credential Staking] -> Set (Credential Staking)
forall a b. (a -> b) -> a -> b
$ Map (Credential Staking) (KeyHash StakePool)
-> [Credential Staking]
forall k a. Map k a -> [k]
Map.keys Map (Credential Staking) (KeyHash StakePool)
delegs
      stakePoolParams =
        [(KeyHash StakePool, StakePoolParams)]
-> VMap VB VB (KeyHash StakePool) StakePoolParams
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
[(k, v)] -> VMap kv vv k v
VMap.fromList
          [(StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
params, StakePoolParams
params) | PoolInfo {StakePoolParams
params :: PoolInfo -> StakePoolParams
params :: StakePoolParams
params} <- [PoolInfo]
pools]
      totalLovelace = Coin
undelegatedLovelace Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Map (Credential Staking) Coin -> Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) Coin
stake
      slotsPerEpoch = Word64 -> EpochSize
EpochSize (Word64 -> EpochSize)
-> (Natural -> Word64) -> Natural -> EpochSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> EpochSize) -> Natural -> EpochSize
forall a b. (a -> b) -> a -> b
$ Natural
totalBlocks Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
silentSlots
      (RewardAns rs _) =
        runShelleyBase $
          mkRewardAns @era
            pp
            bs
            rewardPot
            rewardAccounts
            stakePoolParams
            (Stake (VMap.fromMap (toCompactCoinError <$> stake)))
            (VMap.fromMap delegs)
            totalLovelace
  pure $
    counterexample
      ( mconcat
          [ "pp\n"
          , show pp
          , "\nrewardPot\n"
          , show rewardPot
          , "\nrewardAccounts\n"
          , show rewardAccounts
          , "\nstakePoolParams\n"
          , show stakePoolParams
          , "\nstake\n"
          , show stake
          , "\ndelegs\n"
          , show delegs
          , "\ntotalLovelace\n"
          , show totalLovelace
          , "\nasc\n"
          , show asc
          , "\nslotsPerEpoch\n"
          , show slotsPerEpoch
          ]
      )
      (foldMap rewardAmount rs < 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 ->
  StakePoolParams ->
  Stake ->
  Rational ->
  Rational ->
  Coin ->
  Set.Set (Credential Staking) ->
  Map (Credential Staking) Coin
rewardOnePool :: forall era.
EraPParams era =>
PParams era
-> Coin
-> Natural
-> Natural
-> StakePoolParams
-> Stake
-> Rational
-> Rational
-> Coin
-> Set (Credential Staking)
-> Map (Credential Staking) Coin
rewardOnePool
  PParams era
pp
  Coin
r
  Natural
blocksN
  Natural
blocksTotal
  StakePoolParams
pool
  (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
stake)
  Rational
sigma
  Rational
sigmaA
  (Coin Integer
totalStake)
  Set (Credential Staking)
addrsRew =
    Map (Credential Staking) Coin
rewards'
    where
      Coin Integer
ostake =
        (Coin -> KeyHash Staking -> Coin)
-> Coin -> Set (KeyHash Staking) -> Coin
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
          (\Coin
c KeyHash Staking
o -> Coin
-> (CompactForm Coin -> Coin) -> Maybe (CompactForm Coin) -> Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
c (Coin -> Coin -> Coin
forall a. Monoid a => a -> a -> a
mappend Coin
c (Coin -> Coin)
-> (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact) (Maybe (CompactForm Coin) -> Coin)
-> Maybe (CompactForm Coin) -> Coin
forall a b. (a -> b) -> a -> b
$ Credential Staking
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> Maybe (CompactForm Coin)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
o) VMap VB VP (Credential Staking) (CompactForm Coin)
stake)
          Coin
forall a. Monoid a => a
mempty
          (StakePoolParams -> Set (KeyHash Staking)
sppOwners StakePoolParams
pool)
      Coin Integer
pledge = StakePoolParams -> Coin
sppPledge StakePoolParams
pool
      pr :: Rational
pr = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      Coin Integer
maxP =
        if Integer
pledge Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
ostake
          then PParams era -> Coin -> Rational -> Rational -> Coin
forall era.
EraPParams era =>
PParams era -> Coin -> Rational -> Rational -> Coin
maxPool PParams era
pp Coin
r Rational
sigma Rational
pr
          else Coin
forall a. Monoid a => a
mempty
      appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance (PParams era
pp PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG) Rational
sigmaA Natural
blocksN Natural
blocksTotal
      poolR :: Coin
poolR = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxP)
      tot :: Integer
tot = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      pv :: ProtVer
pv = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      mRewards :: Map (Credential Staking) Coin
mRewards =
        [(Credential Staking, Coin)] -> Map (Credential Staking) Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ ( Credential Staking
hk
            , Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolMemberReward
                Coin
poolR
                (StakePoolParams -> Coin
sppCost StakePoolParams
pool)
                (StakePoolParams -> UnitInterval
sppMargin StakePoolParams
pool)
                (Rational -> StakeShare
StakeShare (Coin -> Integer
unCoin (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
c) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
tot))
                (Rational -> StakeShare
StakeShare Rational
sigma)
            )
          | (Credential Staking
hk, CompactForm Coin
c) <- VMap VB VP (Credential Staking) (CompactForm Coin)
-> [(Credential Staking, CompactForm Coin)]
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) (CompactForm Coin)
stake
          , Credential Staking -> Bool
notPoolOwner Credential Staking
hk
          ]
      notPoolOwner :: Credential Staking -> Bool
notPoolOwner (KeyHashObj KeyHash Staking
hk) = KeyHash Staking
hk KeyHash Staking -> Set (KeyHash Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` StakePoolParams -> Set (KeyHash Staking)
sppOwners StakePoolParams
pool
      notPoolOwner (ScriptHashObj ScriptHash
_) = Bool
True
      lReward :: Coin
lReward =
        Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolOperatorReward
          Coin
poolR
          (StakePoolParams -> Coin
sppCost StakePoolParams
pool)
          (StakePoolParams -> UnitInterval
sppMargin StakePoolParams
pool)
          (Rational -> StakeShare
StakeShare (Rational -> StakeShare) -> Rational -> StakeShare
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ostake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
tot)
          (Rational -> StakeShare
StakeShare Rational
sigma)
      f :: Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
f =
        if ProtVer -> Bool
hardforkAllegraAggregatedRewards ProtVer
pv
          then (Coin -> Coin -> Coin)
-> Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>)
          else Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
      potentialRewards :: Map (Credential Staking) Coin
potentialRewards =
        Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
f (AccountId -> Credential Staking
unAccountId (AccountAddress -> AccountId
aaAccountId (AccountAddress -> AccountId) -> AccountAddress -> AccountId
forall a b. (a -> b) -> a -> b
$ StakePoolParams -> AccountAddress
sppAccountAddress StakePoolParams
pool)) Coin
lReward Map (Credential Staking) Coin
mRewards
      potentialRewards' :: Map (Credential Staking) Coin
potentialRewards' =
        if ProtVer -> Bool
hardforkBabbageForgoRewardPrefilter ProtVer
pv
          then Map (Credential Staking) Coin
potentialRewards
          else Map (Credential Staking) Coin
-> Set (Credential Staking) -> Map (Credential Staking) Coin
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (Credential Staking) Coin
potentialRewards Set (Credential Staking)
addrsRew
      rewards' :: Map (Credential Staking) Coin
rewards' = (Coin -> Bool)
-> Map (Credential Staking) Coin -> Map (Credential Staking) Coin
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0) Map (Credential Staking) Coin
potentialRewards'

-- | Get stake of one pool
poolStake ::
  KeyHash StakePool ->
  VMap.VMap VMap.VB VMap.VB (Credential Staking) (KeyHash StakePool) ->
  Stake ->
  Stake
poolStake :: KeyHash StakePool
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Stake
poolStake KeyHash StakePool
hk VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
stake) =
  -- Stake $ (eval (dom (delegs ▷ setSingleton hk) ◁ stake))
  VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
Stake (VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake)
-> VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
forall a b. (a -> b) -> a -> b
$ (Credential Staking -> CompactForm Coin -> Bool)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
(k -> v -> Bool) -> VMap kv vv k v -> VMap kv vv k v
VMap.filter (\Credential Staking
cred CompactForm Coin
_ -> Credential Staking
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Maybe (KeyHash StakePool)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential Staking
cred VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Maybe (KeyHash StakePool) -> Maybe (KeyHash StakePool) -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash StakePool -> Maybe (KeyHash StakePool)
forall a. a -> Maybe a
Just KeyHash StakePool
hk) VMap VB VP (Credential Staking) (CompactForm Coin)
stake

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

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

createRUpdOld ::
  forall era.
  (EraGov era, EraCertState era) =>
  EpochSize ->
  BlocksMade ->
  EpochState era ->
  Coin ->
  ShelleyBase RewardUpdateOld
createRUpdOld :: forall era.
(EraGov era, EraCertState era) =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ShelleyBase RewardUpdateOld
createRUpdOld EpochSize
slotsPerEpoch BlocksMade
b es :: EpochState era
es@(EpochState ChainAccountState
acnt LedgerState era
ls SnapShots
ss NonMyopic
nm) Coin
maxSupply =
  forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential Staking)
-> NonMyopic
-> ShelleyBase RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
b SnapShots
ss Coin
reserves PParams era
pr Coin
totalStake Set (Credential Staking)
rs NonMyopic
nm
  where
    ds :: DState era
ds = LedgerState era
ls LedgerState era
-> Getting (DState era) (LedgerState era) (DState era)
-> DState era
forall s a. s -> Getting a s a -> a
^. (CertState era -> Const (DState era) (CertState era))
-> LedgerState era -> Const (DState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (DState era) (CertState era))
 -> LedgerState era -> Const (DState era) (LedgerState era))
-> ((DState era -> Const (DState era) (DState era))
    -> CertState era -> Const (DState era) (CertState era))
-> Getting (DState era) (LedgerState era) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (DState era) (DState era))
-> CertState era -> Const (DState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    rs :: Set (Credential Staking)
rs = Map (Credential Staking) (AccountState era)
-> Set (Credential Staking)
forall k a. Map k a -> Set k
Map.keysSet (DState era
ds DState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)
    reserves :: Coin
reserves = ChainAccountState -> Coin
casReserves ChainAccountState
acnt
    totalStake :: Coin
totalStake = EpochState era -> Coin -> Coin
forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    pr :: PParams era
pr = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL

createRUpdOld_ ::
  forall era.
  EraPParams era =>
  EpochSize ->
  BlocksMade ->
  SnapShots ->
  Coin ->
  PParams era ->
  Coin ->
  Set.Set (Credential Staking) ->
  NonMyopic ->
  ShelleyBase RewardUpdateOld
createRUpdOld_ :: forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential Staking)
-> NonMyopic
-> ShelleyBase RewardUpdateOld
createRUpdOld_ EpochSize
slotsPerEpoch b :: BlocksMade
b@(BlocksMade Map (KeyHash StakePool) Natural
b') SnapShots
ss (Coin Integer
reserves) PParams era
pr Coin
totalStake Set (Credential Staking)
rs NonMyopic
nm = do
  asc <- (Globals -> ActiveSlotCoeff)
-> ReaderT Globals Identity ActiveSlotCoeff
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> ActiveSlotCoeff
activeSlotCoeff
  let SnapShot stake' _ delegs' poolParams _ = ssStakeGo ss
      -- reserves and rewards change
      deltaR1 =
        Rational -> Coin
rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$
          Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
1 Rational
eta
            Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era. EraPParams era => Lens' (PParams era) UnitInterval
Lens' (PParams era) UnitInterval
ppRhoL)
            Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
reserves
      d = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG)
      expectedBlocks =
        Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$
          (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
d) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* PositiveUnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
asc) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* EpochSize -> Rational
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
        | UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG) Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0.8 = Rational
1
        | Bool
otherwise = Integer
blocksMade Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
expectedBlocks
      Coin rPot = ssFee ss <> deltaR1
      deltaT1 = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$ UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era. EraPParams era => Lens' (PParams era) UnitInterval
Lens' (PParams era) UnitInterval
ppTauL) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rPot
      _R = Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Integer
rPot Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
deltaT1
      (rs_, newLikelihoods) =
        rewardOld
          pr
          b
          _R
          rs
          poolParams
          stake'
          delegs'
          totalStake
          asc
          slotsPerEpoch
      deltaR2 = Coin
_R Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> (Coin -> Coin -> Coin)
-> Coin -> Map (Credential Staking) Coin -> Coin
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
(<+>) Coin
forall a. Monoid a => a
mempty Map (Credential Staking) Coin
rs_
      blocksMade = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Integer) -> Natural -> Integer
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Natural)
-> Natural -> Map (KeyHash StakePool) Natural -> Natural
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) Natural
0 Map (KeyHash StakePool) Natural
b' :: Integer
  pure $
    RewardUpdateOld
      { deltaTOld = DeltaCoin deltaT1
      , deltaROld = invert (toDeltaCoin deltaR1) <> toDeltaCoin deltaR2
      , rsOld = rs_
      , deltaFOld = invert (toDeltaCoin $ ssFee ss)
      , nonMyopicOld = updateNonMyopic nm _R $ VMap.fromMap 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 EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> ((ProtVer -> Identity ProtVer)
    -> PParams era -> Identity (PParams era))
-> (ProtVer -> Identity ProtVer)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Identity ProtVer)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> EpochState era -> Identity (EpochState era))
-> ProtVer -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv

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

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

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

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

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

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

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

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

eventsMirrorRewards :: [ChainEvent ShelleyEra] -> NewEpochState ShelleyEra -> Property
eventsMirrorRewards :: [ChainEvent ShelleyEra] -> NewEpochState ShelleyEra -> Property
eventsMirrorRewards [ChainEvent ShelleyEra]
events NewEpochState ShelleyEra
nes = RewardEvent -> RewardEvent -> Property
forall {a} {b}.
(Terse a, Terse b, Ord a, Eq b, Show a, Show b) =>
Map a b -> Map a b -> Property
same RewardEvent
eventRew RewardEvent
compRew
  where
    (RewardEvent
compRew, RewardEvent
eventRew) =
      case NewEpochState ShelleyEra -> StrictMaybe PulsingRewUpdate
forall era. NewEpochState era -> StrictMaybe PulsingRewUpdate
nesRu NewEpochState ShelleyEra
nes of
        StrictMaybe PulsingRewUpdate
SNothing -> (RewardEvent
total, RewardEvent
aggFilteredEvent)
        SJust PulsingRewUpdate
pulser ->
          ( (Set Reward -> Set Reward -> Set Reward)
-> RewardEvent -> RewardEvent -> RewardEvent
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set Reward -> Set Reward -> Set Reward
forall a. Ord a => Set a -> Set a -> Set a
Set.union (RewardUpdate -> RewardEvent
rs RewardUpdate
completed) RewardEvent
total
          , (Set Reward -> Set Reward -> Set Reward)
-> RewardEvent -> RewardEvent -> RewardEvent
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set Reward -> Set Reward -> Set Reward
forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
lastevent RewardEvent
aggevent
          )
          where
            (RewardUpdate
completed, RewardEvent
lastevent) = PulsingRewUpdate -> (RewardUpdate, RewardEvent)
complete PulsingRewUpdate
pulser
    total :: RewardEvent
total = [ChainEvent ShelleyEra] -> RewardEvent
getMostRecentTotalRewardEvent [ChainEvent ShelleyEra]
events
    aggevent :: RewardEvent
aggevent = [ChainEvent ShelleyEra] -> RewardEvent
aggIncrementalRewardEvents [ChainEvent ShelleyEra]
events
    FilteredRewards RewardEvent
aggFilteredEvent RewardEvent
_ Set (Credential Staking)
_ Coin
_ = RewardEvent -> EpochState ShelleyEra -> FilteredRewards ShelleyEra
forall era.
(EraGov era, EraCertState era) =>
RewardEvent -> EpochState era -> FilteredRewards era
filterAllRewards RewardEvent
aggevent (NewEpochState ShelleyEra -> EpochState ShelleyEra
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState ShelleyEra
nes)
    same :: Map a b -> Map a b -> Property
same Map a b
x Map a b
y = Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
1 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
message (Map a b
x Map a b -> Map a b -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map a b
y)
      where
        message :: [Char]
message =
          [Char]
"events don't mirror rewards "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Map a b -> Map a b -> [Char]
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 where
  terse :: Reward -> [Char]
terse (Reward RewardType
ty KeyHash StakePool
pl (Coin Integer
n)) = [Char]
"Reward{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RewardType -> [Char]
forall a. Show a => a -> [Char]
show RewardType
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
9 (KeyHash StakePool -> [Char]
forall a. Show a => a -> [Char]
show KeyHash StakePool
pl) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"

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

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

mkRewardAns ::
  forall era.
  EraPParams era =>
  PParams era ->
  BlocksMade ->
  Coin ->
  Set (Credential Staking) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) StakePoolParams ->
  Stake ->
  VMap.VMap VMap.VB VMap.VB (Credential Staking) (KeyHash StakePool) ->
  Coin ->
  ShelleyBase RewardAns
mkRewardAns :: forall era.
EraPParams era =>
PParams era
-> BlocksMade
-> Coin
-> Set (Credential Staking)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Coin
-> ShelleyBase RewardAns
mkRewardAns
  PParams era
pp
  (BlocksMade Map (KeyHash StakePool) Natural
b)
  Coin
r
  Set (Credential Staking)
addrsRew
  VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
  Stake
stake
  VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
  Coin
totalStake = Pulser -> ShelleyBase RewardAns
forall (m :: * -> *) ans. Monad m => RewardPulser m ans -> m ans
forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser
pulser
    where
      totalBlocks :: Natural
totalBlocks = Map (KeyHash StakePool) Natural -> Natural
forall a. Num a => Map (KeyHash StakePool) a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash StakePool) Natural
b
      totalActiveStake :: NonZero Coin
totalActiveStake = Stake -> Coin
sumAllStake Stake
stake Coin -> NonZero Coin -> NonZero Coin
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
      delegatorsPerStakePool :: Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool =
        (Map (KeyHash StakePool) (Set (Credential Staking))
 -> Credential Staking
 -> KeyHash StakePool
 -> Map (KeyHash StakePool) (Set (Credential Staking)))
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall (kv :: * -> *) k (vv :: * -> *) v a.
(Vector kv k, Vector vv v) =>
(a -> k -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldlWithKey
          (\Map (KeyHash StakePool) (Set (Credential Staking))
acc Credential Staking
cred KeyHash StakePool
poolId -> (Set (Credential Staking)
 -> Set (Credential Staking) -> Set (Credential Staking))
-> KeyHash StakePool
-> Set (Credential Staking)
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (Credential Staking)
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Semigroup a => a -> a -> a
(<>) KeyHash StakePool
poolId (Credential Staking -> Set (Credential Staking)
forall a. a -> Set a
Set.singleton Credential Staking
cred) Map (KeyHash StakePool) (Set (Credential Staking))
acc)
          Map (KeyHash StakePool) (Set (Credential Staking))
forall a. Monoid a => a
mempty
          VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs

      mkPoolRewardInfo' :: StakePoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfo' StakePoolParams
stakePoolParams =
        -- lehins: why is this restriction necessary? :o
        -- ensure mkPoolRewardInfo does not use stake that doesn't belong to the pool
        let stakeRestrictedToPool :: Stake
stakeRestrictedToPool = KeyHash StakePool
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Stake
poolStake (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams) VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake
            stakePoolId :: KeyHash StakePool
stakePoolId = StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams
            delegators :: Set (Credential Staking)
delegators = Set (Credential Staking)
-> KeyHash StakePool
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> Set (Credential Staking)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set (Credential Staking)
forall a. Monoid a => a
mempty KeyHash StakePool
stakePoolId Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool
            stakePoolState :: StakePoolState
stakePoolState = CompactForm Coin
-> Set (Credential Staking) -> StakePoolParams -> StakePoolState
mkStakePoolState (PParams era
pp PParams era
-> Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL) Set (Credential Staking)
delegators StakePoolParams
stakePoolParams
            stakePoolSnapShot :: StakePoolSnapShot
stakePoolSnapShot = Stake -> NonZero Coin -> StakePoolState -> StakePoolSnapShot
mkStakePoolSnapShot Stake
stakeRestrictedToPool NonZero Coin
totalActiveStake StakePoolState
stakePoolState
         in PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Coin
-> NonZero Coin
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> KeyHash StakePool
-> StakePoolSnapShot
-> Either StakeShare PoolRewardInfo
forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Coin
-> NonZero Coin
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> KeyHash StakePool
-> StakePoolSnapShot
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
              PParams era
pp
              Coin
r
              (Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash StakePool) Natural
b)
              Natural
totalBlocks
              Stake
stakeRestrictedToPool
              VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
              Coin
totalStake
              NonZero Coin
totalActiveStake
              VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
              KeyHash StakePool
stakePoolId
              StakePoolSnapShot
stakePoolSnapShot
      free :: FreeVars
free =
        FreeVars
          { fvAddrsRew :: Set (Credential Staking)
fvAddrsRew = Set (Credential Staking)
addrsRew
          , fvTotalStake :: Coin
fvTotalStake = Coin
totalStake
          , fvPoolRewardInfo :: VMap VB VB (KeyHash StakePool) PoolRewardInfo
fvPoolRewardInfo =
              (StakePoolParams -> Maybe PoolRewardInfo)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> VMap VB VB (KeyHash StakePool) PoolRewardInfo
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 ((StakeShare -> Maybe PoolRewardInfo)
-> (PoolRewardInfo -> Maybe PoolRewardInfo)
-> Either StakeShare PoolRewardInfo
-> Maybe PoolRewardInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe PoolRewardInfo -> StakeShare -> Maybe PoolRewardInfo
forall a b. a -> b -> a
const Maybe PoolRewardInfo
forall a. Maybe a
Nothing) PoolRewardInfo -> Maybe PoolRewardInfo
forall a. a -> Maybe a
Just (Either StakeShare PoolRewardInfo -> Maybe PoolRewardInfo)
-> (StakePoolParams -> Either StakeShare PoolRewardInfo)
-> StakePoolParams
-> Maybe PoolRewardInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfo') VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
          , fvDelegs :: VMap VB VB (Credential Staking) (KeyHash StakePool)
fvDelegs = VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
          , fvProtVer :: ProtVer
fvProtVer = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
          }
      pulser :: Pulser
      pulser :: Pulser
pulser = Int
-> FreeVars
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> RewardAns
-> Pulser
forall ans (m :: * -> *).
(ans ~ RewardAns, m ~ ShelleyBase) =>
Int
-> FreeVars
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> ans
-> RewardPulser m ans
RSLP Int
2 FreeVars
free (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake Stake
stake) (Map (Credential Staking) Reward -> RewardEvent -> RewardAns
RewardAns Map (Credential Staking) Reward
forall k a. Map k a
Map.empty RewardEvent
forall k a. Map k a
Map.empty)

-- | Adaptor that can construct new SnapShot representation from the old one
mkSnapShot ::
  Stake ->
  VMap.VMap VMap.VB VMap.VB (Credential Staking) (KeyHash StakePool) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) StakePoolParams ->
  SnapShot
mkSnapShot :: Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> SnapShot
mkSnapShot Stake
activeStake VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools =
  SnapShot
    { ssStake :: Stake
ssStake = Stake
activeStake
    , ssTotalActiveStake :: NonZero Coin
ssTotalActiveStake = NonZero Coin
totalActiveStake
    , ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations = VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
    , ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams = VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
    , ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot = VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall a. NFData a => a -> a
force (VMap VB VB (KeyHash StakePool) StakePoolSnapShot
 -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot)
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall a b. (a -> b) -> a -> b
$ (StakePoolParams -> StakePoolSnapShot)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map StakePoolParams -> StakePoolSnapShot
snapShotFromStakePoolParams VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
    }
  where
    snapShotFromStakePoolParams :: StakePoolParams -> StakePoolSnapShot
snapShotFromStakePoolParams StakePoolParams
stakePoolParams =
      let delegations :: Set (Credential Staking)
delegations = Set (Credential Staking)
-> KeyHash StakePool
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> Set (Credential Staking)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set (Credential Staking)
forall a. Monoid a => a
mempty (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams) Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool
       in Stake -> NonZero Coin -> StakePoolState -> StakePoolSnapShot
mkStakePoolSnapShot Stake
activeStake NonZero Coin
totalActiveStake (StakePoolState -> StakePoolSnapShot)
-> StakePoolState -> StakePoolSnapShot
forall a b. (a -> b) -> a -> b
$
            CompactForm Coin
-> Set (Credential Staking) -> StakePoolParams -> StakePoolState
mkStakePoolState CompactForm Coin
forall a. Monoid a => a
mempty Set (Credential Staking)
delegations StakePoolParams
stakePoolParams
    totalActiveStake :: NonZero Coin
totalActiveStake = Stake -> Coin
sumAllStake Stake
activeStake Coin -> NonZero Coin -> NonZero Coin
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
    delegatorsPerStakePool :: Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool =
      (Map (KeyHash StakePool) (Set (Credential Staking))
 -> Credential Staking
 -> KeyHash StakePool
 -> Map (KeyHash StakePool) (Set (Credential Staking)))
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall (kv :: * -> *) k (vv :: * -> *) v a.
(Vector kv k, Vector vv v) =>
(a -> k -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldlWithKey
        (\Map (KeyHash StakePool) (Set (Credential Staking))
acc Credential Staking
cred KeyHash StakePool
poolId -> (Set (Credential Staking)
 -> Set (Credential Staking) -> Set (Credential Staking))
-> KeyHash StakePool
-> Set (Credential Staking)
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (Credential Staking)
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Semigroup a => a -> a -> a
(<>) KeyHash StakePool
poolId (Credential Staking -> Set (Credential Staking)
forall a. a -> Set a
Set.singleton Credential Staking
cred) Map (KeyHash StakePool) (Set (Credential Staking))
acc)
        Map (KeyHash StakePool) (Set (Credential Staking))
forall a. Monoid a => a
mempty
        VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs

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

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