{-# 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_,
) where

import qualified Cardano.Crypto.DSIGN as Crypto
import Cardano.Crypto.Hash (Blake2b_256, hashToBytes)
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Cardano.Crypto.VRF as Crypto
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BlocksMade (..),
  BoundedRational (..),
  Globals (..),
  Network (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  activeSlotVal,
  epochInfoPure,
  mkActiveSlotCoeff,
  (%?),
 )
import Cardano.Ledger.Binary (encCBOR, hashWithEncoder, natVersion, shelleyProtVer)
import Cardano.Ledger.Coin (
  Coin (..),
  DeltaCoin (..),
  rationalToCoinViaFloor,
  toDeltaCoin,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Keys (VKey (..))
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,
  leaderRew,
  memberRew,
  mkApparentPerformance,
  mkPoolRewardInfo,
 )
import Cardano.Ledger.Shelley.Rules (
  PulsingRewUpdate (..),
  RupdEvent (RupdEvent),
  ShelleyNewEpochEvent (DeltaRewardEvent, TotalRewardEvent),
  ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent),
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.TxBody (RewardAccount (..))
import Cardano.Ledger.Slot (epochInfoSize)
import Cardano.Ledger.Val (Val (..), invert, (<+>), (<->))
import Cardano.Protocol.Crypto (VRF, hashVerKeyVRF)
import Cardano.Slotting.Slot (EpochSize (..))
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
          , sppRewardAccount :: RewardAccount
sppRewardAccount = Network -> Credential Staking -> RewardAccount
RewardAccount Network
Testnet (Credential Staking -> RewardAccount)
-> (KeyPair Staking -> Credential Staking)
-> KeyPair Staking
-> RewardAccount
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 -> RewardAccount)
-> KeyPair Staking -> RewardAccount
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 $
          reward @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 -> StakePoolParams -> StakeShare -> StakeShare -> Coin
memberRew
                Coin
poolR
                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 -> StakePoolParams -> StakeShare -> StakeShare -> Coin
leaderRew
          Coin
poolR
          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 (RewardAccount -> Credential Staking
raCredential (RewardAccount -> Credential Staking)
-> RewardAccount -> Credential Staking
forall a b. (a -> b) -> a -> b
$ StakePoolParams -> RewardAccount
sppRewardAccount 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'

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 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))

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

reward ::
  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
reward :: 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
reward
  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
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
      stakePerPool :: Map (KeyHash StakePool) Coin
stakePerPool = VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake -> Map (KeyHash StakePool) Coin
sumStakePerPool VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake
      activeStake :: Coin
activeStake = Stake -> Coin
sumAllStake Stake
stake
      -- ensure mkPoolRewardInfo does not use stake that doesn't belong to the pool
      stakeForPool :: StakePoolParams -> Stake
stakeForPool StakePoolParams
pool = KeyHash StakePool
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Stake
poolStake (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
pool) VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake
      mkPoolRewardInfo' :: StakePoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfo' StakePoolParams
pool =
        PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Map (KeyHash StakePool) Coin
-> Coin
-> Coin
-> StakePoolParams
-> Either StakeShare PoolRewardInfo
forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Map (KeyHash StakePool) Coin
-> Coin
-> Coin
-> StakePoolParams
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
          PParams era
pp
          Coin
r
          (Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash StakePool) Natural
b)
          Natural
totalBlocks
          (StakePoolParams -> Stake
stakeForPool StakePoolParams
pool)
          VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
          Map (KeyHash StakePool) Coin
stakePerPool
          Coin
totalStake
          Coin
activeStake
          StakePoolParams
pool
      free :: FreeVars
free =
        FreeVars
          { fvAddrsRew :: Set (Credential Staking)
fvAddrsRew = Set (Credential Staking)
addrsRew
          , fvTotalStake :: Coin
fvTotalStake = Coin
totalStake
          , fvPoolRewardInfo :: Map (KeyHash StakePool) PoolRewardInfo
fvPoolRewardInfo =
              VMap VB VB (KeyHash StakePool) PoolRewardInfo
-> Map (KeyHash StakePool) PoolRewardInfo
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (VMap VB VB (KeyHash StakePool) PoolRewardInfo
 -> Map (KeyHash StakePool) PoolRewardInfo)
-> VMap VB VB (KeyHash StakePool) PoolRewardInfo
-> Map (KeyHash StakePool) PoolRewardInfo
forall a b. (a -> b) -> a -> b
$ (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
stakePoolParams
          , 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)

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

-- | 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
    ]