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

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

import qualified Cardano.Crypto.DSIGN as Crypto
import Cardano.Crypto.Hash (Blake2b_256, hashToBytes)
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Cardano.Crypto.VRF as Crypto
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BlocksMade (..),
  BoundedRational (..),
  Globals (..),
  Network (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  activeSlotVal,
  epochInfoPure,
  mkActiveSlotCoeff,
 )
import Cardano.Ledger.Binary (encCBOR, hashWithEncoder, natVersion, shelleyProtVer)
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), rationalToCoinViaFloor, toDeltaCoin)
import Cardano.Ledger.Compactible
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.EpochBoundary (
  Stake (..),
  maxPool,
  poolStake,
  sumAllStake,
  sumStakePerPool,
 )
import Cardano.Ledger.Keys (VKey (..))
import Cardano.Ledger.Shelley.API (NonMyopic, SnapShot (..), SnapShots (..))
import Cardano.Ledger.Shelley.API.Types (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  CertState (..),
  EpochState (..),
  FilteredRewards (..),
  LedgerState (..),
  NewEpochState (..),
  RewardUpdate (..),
  circulation,
  completeRupd,
  createRUpd,
  filterAllRewards,
  lsCertState,
  prevPParamsEpochStateL,
  rewards,
  updateNonMyopic,
 )
import Cardano.Ledger.Shelley.PoolRank (Likelihood, leaderProbability, likelihood)
import Cardano.Ledger.Shelley.RewardUpdate (
  FreeVars (..),
  Pulser,
  RewardAns (..),
  RewardEvent,
  RewardPulser (RSLP),
 )
import Cardano.Ledger.Shelley.Rewards (
  StakeShare (..),
  aggregateRewards,
  leaderRew,
  memberRew,
  mkApparentPerformance,
  mkPoolRewardInfo,
 )
import Cardano.Ledger.Shelley.Rules (
  PulsingRewUpdate (..),
  RupdEvent (RupdEvent),
  ShelleyNewEpochEvent (DeltaRewardEvent, TotalRewardEvent),
  ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent),
 )
import Cardano.Ledger.Shelley.TxBody (RewardAccount (..))
import Cardano.Ledger.Slot (epochInfoSize)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (Val (..), invert, (<+>), (<->))
import Cardano.Protocol.Crypto (VRF, hashVerKeyVRF)
import Cardano.Slotting.Slot (EpochSize (..))
import Control.Monad (replicateM)
import Control.Monad.Trans.Reader (asks, runReader)
import Control.SetAlgebra (eval, (◁))
import Data.Foldable as F (fold, foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy
import Data.Pulse (Pulsable (..))
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff (ansiWlEditExprCompact, ediff)
import qualified Data.VMap as VMap
import Data.Word (Word64)
import GHC.Stack
import Lens.Micro ((&), (.~), (^.))
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C, 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.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 = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vk SignKeyDSIGN DSIGN
sk
  where
    vk :: VKey r
vk = forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
VKey (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
Crypto.deriveVerKeyDSIGN SignKeyDSIGN DSIGN
sk)
    sk :: SignKeyDSIGN DSIGN
sk =
      forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
Crypto.genKeyDSIGN forall a b. (a -> b) -> a -> b
$
        ByteString -> Seed
mkSeedFromBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. Hash h a -> ByteString
hashToBytes forall a b. (a -> b) -> a -> b
$
          forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @Blake2b_256 Version
shelleyProtVer forall a. EncCBOR a => a -> Encoding
encCBOR Int
seed

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

data PoolSetUpArgs 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 = forall a. Maybe a
Nothing
    , poolCost :: Maybe Coin
poolCost = forall a. Maybe a
Nothing
    , poolMargin :: Maybe UnitInterval
poolMargin = forall a. Maybe a
Nothing
    , poolMembers :: Maybe (Map (Credential 'Staking) Coin)
poolMembers = forall a. Maybe a
Nothing
    }

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

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

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

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

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

genBlocksMade :: [PoolParams] -> Gen BlocksMade
genBlocksMade :: [PoolParams] -> Gen BlocksMade
genBlocksMade [PoolParams]
pools = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PoolParams -> Gen (KeyHash 'StakePool, Natural)
f [PoolParams]
pools
  where
    f :: PoolParams -> Gen (KeyHash 'StakePool, Natural)
f PoolParams
p = (PoolParams -> KeyHash 'StakePool
ppId PoolParams
p,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
0 Natural
maxPoolBlocks

-- Properties --

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

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

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

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

rewardOld ::
  forall era.
  EraPParams era =>
  PParams era ->
  BlocksMade ->
  Coin ->
  Set.Set (Credential 'Staking) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool) PoolParams ->
  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) PoolParams
-> 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) PoolParams
poolParams
  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 = 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
        (KeyHash 'StakePool
hk, PoolParams
pparams) <- forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams
        let sigma :: Rational
sigma = if Integer
totalStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
            sigmaA :: Rational
sigmaA = if Integer
activeStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
activeStake
            blocksProduced :: Maybe Natural
blocksProduced = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
hk Map (KeyHash 'StakePool) Natural
b
            actgr :: Stake
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 Integer
pstake = Stake -> Coin
sumAllStake Stake
actgr
            rewardMap :: Maybe (Map (Credential 'Staking) Coin)
rewardMap = case Maybe Natural
blocksProduced of
              Maybe Natural
Nothing -> forall a. Maybe a
Nothing -- This is equivalent to calling rewarOnePool with n = 0
              Just Natural
n ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  forall era.
EraPParams era =>
PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams
-> Stake
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking)
-> Map (Credential 'Staking) Coin
rewardOnePool
                    PParams era
pp
                    Coin
r
                    Natural
n
                    Natural
totalBlocks
                    PoolParams
pparams
                    Stake
actgr
                    Rational
sigma
                    Rational
sigmaA
                    (Integer -> Coin
Coin Integer
totalStake)
                    Set (Credential 'Staking)
addrsRew
            ls :: Likelihood
ls =
              Natural -> Double -> EpochSize -> Likelihood
likelihood
                (forall a. a -> Maybe a -> a
fromMaybe Natural
0 Maybe Natural
blocksProduced)
                (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc Rational
sigma (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG))
                EpochSize
slotsPerEpoch
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
hk, Maybe (Map (Credential 'Staking) Coin)
rewardMap, Likelihood
ls)
      pv :: ProtVer
pv = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
      f :: [Map (Credential 'Staking) Coin] -> Map (Credential 'Staking) Coin
f =
        if ProtVer -> Bool
HardForks.aggregatedRewards ProtVer
pv
          then forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. Semigroup a => a -> a -> a
(<>)
          else forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      rewards' :: Map (Credential 'Staking) Coin
rewards' = [Map (Credential 'Staking) Coin] -> Map (Credential 'Staking) Coin
f forall a b. (a -> b) -> a -> b
$ 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(KeyHash 'StakePool
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 -> ShowS
[RewardUpdateOld] -> ShowS
RewardUpdateOld -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RewardUpdateOld] -> ShowS
$cshowList :: [RewardUpdateOld] -> ShowS
show :: RewardUpdateOld -> [Char]
$cshow :: RewardUpdateOld -> [Char]
showsPrec :: Int -> RewardUpdateOld -> ShowS
$cshowsPrec :: Int -> RewardUpdateOld -> ShowS
Show, RewardUpdateOld -> RewardUpdateOld -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardUpdateOld -> RewardUpdateOld -> Bool
$c/= :: RewardUpdateOld -> RewardUpdateOld -> Bool
== :: RewardUpdateOld -> RewardUpdateOld -> Bool
$c== :: RewardUpdateOld -> RewardUpdateOld -> Bool
Eq)

createRUpdOld ::
  forall era.
  EraGov era =>
  EpochSize ->
  BlocksMade ->
  EpochState era ->
  Coin ->
  ShelleyBase RewardUpdateOld
createRUpdOld :: forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ShelleyBase RewardUpdateOld
createRUpdOld EpochSize
slotsPerEpoch BlocksMade
b es :: EpochState era
es@(EpochState AccountState
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 = forall era. CertState era -> DState era
certDState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    rs :: Set (Credential 'Staking)
rs = forall k v. UView k v -> Set k
UM.domain forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds
    reserves :: Coin
reserves = AccountState -> Coin
asReserves AccountState
acnt
    totalStake :: Coin
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    pr :: PParams era
pr = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL

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

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

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

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

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

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

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

aggIncrementalRewardEvents ::
  [ChainEvent C] ->
  Map (Credential 'Staking) (Set Reward)
aggIncrementalRewardEvents :: [ChainEvent ShelleyEra] -> RewardEvent
aggIncrementalRewardEvents = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' 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 forall k a. Map k a
Map.empty
  where
    accum :: RewardEvent -> ChainEvent era -> RewardEvent
accum RewardEvent
ans (TickEvent (TickRupdEvent (RupdEvent EpochNo
_ RewardEvent
m))) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
m RewardEvent
ans
    accum RewardEvent
ans (TickEvent (TickNewEpochEvent (DeltaRewardEvent (RupdEvent EpochNo
_ RewardEvent
m)))) =
      forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
m RewardEvent
ans
    accum RewardEvent
ans ChainEvent era
_ = RewardEvent
ans

getMostRecentTotalRewardEvent ::
  [ChainEvent C] ->
  Map (Credential 'Staking) (Set Reward)
getMostRecentTotalRewardEvent :: [ChainEvent ShelleyEra] -> RewardEvent
getMostRecentTotalRewardEvent = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era} {era} {era}.
(Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era,
 Event (EraRule "TICK" era) ~ ShelleyTickEvent era) =>
RewardEvent -> ChainEvent era -> RewardEvent
accum forall k a. Map k a
Map.empty
  where
    accum :: RewardEvent -> ChainEvent era -> RewardEvent
accum RewardEvent
ans (TickEvent (TickNewEpochEvent (TotalRewardEvent EpochNo
_ RewardEvent
m))) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union 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, forall a. Monoid a => a
mempty)
complete (Pulsing RewardSnapShot
rewsnap Pulser
pulser) = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ (PulsingRewUpdate -> ShelleyBase (RewardUpdate, RewardEvent)
completeRupd (RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
pulser))

eventsMirrorRewards :: [ChainEvent C] -> NewEpochState C -> Property
eventsMirrorRewards :: [ChainEvent ShelleyEra] -> NewEpochState ShelleyEra -> Property
eventsMirrorRewards [ChainEvent ShelleyEra]
events NewEpochState ShelleyEra
nes = 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 forall era. NewEpochState era -> StrictMaybe PulsingRewUpdate
nesRu NewEpochState ShelleyEra
nes of
        StrictMaybe PulsingRewUpdate
SNothing -> (RewardEvent
total, RewardEvent
aggFilteredEvent)
        SJust PulsingRewUpdate
pulser ->
          ( forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union (RewardUpdate -> RewardEvent
rs RewardUpdate
completed) RewardEvent
total
          , forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union 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
_ = forall era.
EraGov era =>
RewardEvent -> EpochState era -> FilteredRewards era
filterAllRewards RewardEvent
aggevent (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 = forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
1 forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
message (Map a b
x forall a. (Eq a, Show a) => a -> a -> Property
=== Map a b
y)
      where
        message :: [Char]
message =
          [Char]
"events don't mirror rewards "
            forall a. [a] -> [a] -> [a]
++ forall a b.
(Terse a, Terse b, Ord a, Eq b) =>
[Char] -> Map a b -> Map a b -> [Char]
tersemapdiffs
              [Char]
"Map differences: aggregated filtered events on the left, computed on the right."
              Map a b
x
              Map a b
y

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

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

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

reward ::
  forall era.
  EraPParams era =>
  PParams era ->
  BlocksMade ->
  Coin ->
  Set (Credential 'Staking) ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool) PoolParams ->
  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) PoolParams
-> 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) PoolParams
poolParams
  Stake
stake
  VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
  Coin
totalStake = forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser
pulser
    where
      totalBlocks :: Natural
totalBlocks = 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 :: PoolParams -> Stake
stakeForPool PoolParams
pool = KeyHash 'StakePool
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Stake
-> Stake
poolStake (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs Stake
stake
      mkPoolRewardInfo' :: PoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfo' PoolParams
pool =
        forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) Coin
-> Coin
-> Coin
-> PoolParams
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
          PParams era
pp
          Coin
r
          (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Natural
b)
          Natural
totalBlocks
          (PoolParams -> Stake
stakeForPool PoolParams
pool)
          VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
          Map (KeyHash 'StakePool) Coin
stakePerPool
          Coin
totalStake
          Coin
activeStake
          PoolParams
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 =
              forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(a -> Maybe b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfo') VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams
          , fvDelegs :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
fvDelegs = VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
          , fvProtVer :: ProtVer
fvProtVer = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
          }
      pulser :: Pulser
      pulser :: Pulser
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 forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)

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

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

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