{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : LedgerState
-- Description : Operational Rules
--
-- This module implements the operation rules for treating UTxO transactions ('Tx')
-- as state transformations on a ledger state ('LedgerState'),
-- as specified in /A Simplified Formal Specification of a UTxO Ledger/.
module Cardano.Ledger.Shelley.LedgerState
  ( AccountState (..),
    DPState (..),
    DState (..),
    emptyDState,
    rewards,
    delegations,
    ptrsMap,
    EpochState (..),
    UpecState (..),
    PulsingRewUpdate (..),
    FutureGenDeleg (..),
    InstantaneousRewards (..),
    KeyPairs,
    LedgerState (..),
    PPUPState (..),
    PState (..),
    RewardAccounts,
    RewardUpdate (..),
    RewardSnapShot (..),
    UTxOState (..),
    smartUTxOState,
    IncrementalStake (..),
    depositPoolChange,
    emptyRewardUpdate,
    pvCanFollow,
    reapRewards,
    availableAfterMIR,

    -- * Genesis State
    genesisState,

    -- * Validation
    WitHashes (..),
    nullWitHashes,
    diffWitHashes,
    minfee,
    txsizeBound,
    produced,
    consumed,
    witsFromTxWitnesses,
    propWits,

    -- * DelegationState
    keyRefunds,

    -- * Epoch boundary
    incrementalStakeDistr,
    updateStakeDistribution,
    applyRUpd,
    applyRUpd',
    filterAllRewards,
    createRUpd,
    completeRupd,
    startStep,
    pulseStep,
    completeStep,
    NewEpochState (NewEpochState, nesEL, nesEs, nesRu, nesPd, nesBprev, nesBcur),
    StashedAVVMAddresses,
    stashedAVVMAddresses,
    getGKeys,
    updateNES,
    circulation,

    -- * Decay
    decayFactor,

    -- * Remove Bootstrap Redeem Addresses
    returnRedeemAddrsToReserves,
    updateNonMyopic,
  )
where

import Cardano.Binary
  ( FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
  )
import Cardano.Ledger.Address (Addr (..), isBootstrapRedeemer)
import Cardano.Ledger.BaseTypes
  ( ActiveSlotCoeff,
    BlocksMade (..),
    BoundedRational (..),
    NonNegativeInterval,
    ProtVer (..),
    ShelleyBase,
    StrictMaybe (..),
    UnitInterval,
    activeSlotVal,
  )
import Cardano.Ledger.Coin
  ( Coin (..),
    DeltaCoin (..),
    addDeltaCoin,
    rationalToCoinViaFloor,
    toDeltaCoin,
  )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core (PParamsDelta)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (StakeRefBase, StakeRefPtr))
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Era (Era (..), getTxOutBootstrapAddress)
import Cardano.Ledger.Keys
  ( GenDelegPair (..),
    GenDelegs (..),
    KeyHash (..),
    KeyPair,
    KeyRole (..),
    asWitness,
  )
import Cardano.Ledger.PoolDistr (PoolDistr (..))
import Cardano.Ledger.SafeHash (HashAnnotated)
import Cardano.Ledger.Serialization (decodeRecordNamedT, mapFromCBOR, mapToCBOR)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Address.Bootstrap
  ( BootstrapWitness (..),
    bootstrapWitKeyHash,
  )
import Cardano.Ledger.Shelley.Constraints (TransValue)
import Cardano.Ledger.Shelley.Delegation.Certificates (DCert (..), isDeRegKey)
import Cardano.Ledger.Shelley.EpochBoundary
  ( SnapShot (..),
    SnapShots (..),
    Stake (..),
    sumAllStake,
    sumStakePerPool,
  )
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.PParams
  ( PParams,
    PParams' (..),
    ProposedPPUpdates (..),
    Update (..),
    emptyPPPUpdates,
  )
import Cardano.Ledger.Shelley.PoolRank
  ( Likelihood (..),
    NonMyopic (..),
    applyDecay,
    leaderProbability,
    likelihood,
  )
import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance (..))
import qualified Cardano.Ledger.Shelley.RewardProvenance as RP
import Cardano.Ledger.Shelley.RewardUpdate
  ( FreeVars (..),
    Pulser,
    PulsingRewUpdate (..),
    RewardAns (..),
    RewardEvent,
    RewardPulser (..),
    RewardSnapShot (..),
    RewardUpdate (..),
    emptyRewardUpdate,
  )
import Cardano.Ledger.Shelley.Rewards
  ( PoolRewardInfo (..),
    Reward (..),
    StakeShare (..),
    aggregateRewards,
    filterRewards,
    leaderRewardToGeneral,
    mkPoolRewardInfo,
    sumRewards,
  )
import Cardano.Ledger.Shelley.TxBody
  ( EraIndependentTxBody,
    MIRPot (..),
    PoolParams (..),
    Ptr (..),
    RewardAcnt (..),
    Wdrl (..),
    WitVKey (..),
    getRwdCred,
    witKeyHash,
  )
import Cardano.Ledger.Shelley.UTxO
  ( UTxO (..),
    balance,
    totalDeposits,
    txins,
    txouts,
  )
import Cardano.Ledger.Slot
  ( EpochNo (..),
    EpochSize (..),
    SlotNo (..),
  )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UnifiedMap (Trip (..), Triple, UMap (..), UnifiedMap, View (..), ViewMap)
import Cardano.Ledger.Val ((<+>), (<->), (<×>))
import qualified Cardano.Ledger.Val as Val
import Control.DeepSeq (NFData)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans
import Control.Provenance (ProvM, modifyM, runProvM)
import Control.SetAlgebra (dom, eval, (∈), (◁))
import Control.State.Transition (STS (State))
import Data.Coders
  ( Decode (From, RecD),
    decode,
    decodeRecordNamed,
    (<!),
  )
import Data.Default.Class (Default, def)
import Data.Foldable (fold, toList)
import Data.Group (Group, invert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Pulse (Pulsable (..), completeM)
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sharing
import Data.Typeable
import qualified Data.UMap as UM
import qualified Data.VMap as VMap
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import Lens.Micro (_1, _2)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)
import Quiet

-- | Representation of a list of pairs of key pairs, e.g., pay and stake keys
type KeyPairs crypto = [(KeyPair 'Payment crypto, KeyPair 'Staking crypto)]

type RewardAccounts crypto =
  Map (Credential 'Staking crypto) Coin

data FutureGenDeleg crypto = FutureGenDeleg
  { FutureGenDeleg crypto -> SlotNo
fGenDelegSlot :: !SlotNo,
    FutureGenDeleg crypto -> KeyHash 'Genesis crypto
fGenDelegGenKeyHash :: !(KeyHash 'Genesis crypto)
  }
  deriving (Int -> FutureGenDeleg crypto -> ShowS
[FutureGenDeleg crypto] -> ShowS
FutureGenDeleg crypto -> String
(Int -> FutureGenDeleg crypto -> ShowS)
-> (FutureGenDeleg crypto -> String)
-> ([FutureGenDeleg crypto] -> ShowS)
-> Show (FutureGenDeleg crypto)
forall crypto. Int -> FutureGenDeleg crypto -> ShowS
forall crypto. [FutureGenDeleg crypto] -> ShowS
forall crypto. FutureGenDeleg crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureGenDeleg crypto] -> ShowS
$cshowList :: forall crypto. [FutureGenDeleg crypto] -> ShowS
show :: FutureGenDeleg crypto -> String
$cshow :: forall crypto. FutureGenDeleg crypto -> String
showsPrec :: Int -> FutureGenDeleg crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> FutureGenDeleg crypto -> ShowS
Show, FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
(FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> Eq (FutureGenDeleg crypto)
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c/= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
== :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c== :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
Eq, Eq (FutureGenDeleg crypto)
Eq (FutureGenDeleg crypto)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto
    -> FutureGenDeleg crypto -> FutureGenDeleg crypto)
-> (FutureGenDeleg crypto
    -> FutureGenDeleg crypto -> FutureGenDeleg crypto)
-> Ord (FutureGenDeleg crypto)
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
forall crypto. Eq (FutureGenDeleg crypto)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
min :: FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
$cmin :: forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
max :: FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
$cmax :: forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
>= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c>= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
> :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c> :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
<= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c<= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
< :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c< :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
compare :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
$ccompare :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
$cp1Ord :: forall crypto. Eq (FutureGenDeleg crypto)
Ord, (forall x. FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x)
-> (forall x.
    Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto)
-> Generic (FutureGenDeleg crypto)
forall x. Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
forall x. FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
forall crypto x.
FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
$cto :: forall crypto x.
Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
$cfrom :: forall crypto x.
FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
Generic)

instance NoThunks (FutureGenDeleg crypto)

instance NFData (FutureGenDeleg crypto)

instance CC.Crypto crypto => ToCBOR (FutureGenDeleg crypto) where
  toCBOR :: FutureGenDeleg crypto -> Encoding
toCBOR (FutureGenDeleg SlotNo
a KeyHash 'Genesis crypto
b) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SlotNo
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'Genesis crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash 'Genesis crypto
b

instance CC.Crypto crypto => FromCBOR (FutureGenDeleg crypto) where
  fromCBOR :: Decoder s (FutureGenDeleg crypto)
fromCBOR =
    Text
-> (FutureGenDeleg crypto -> Int)
-> Decoder s (FutureGenDeleg crypto)
-> Decoder s (FutureGenDeleg crypto)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"FutureGenDeleg" (Int -> FutureGenDeleg crypto -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (FutureGenDeleg crypto)
 -> Decoder s (FutureGenDeleg crypto))
-> Decoder s (FutureGenDeleg crypto)
-> Decoder s (FutureGenDeleg crypto)
forall a b. (a -> b) -> a -> b
$
      SlotNo -> KeyHash 'Genesis crypto -> FutureGenDeleg crypto
forall crypto.
SlotNo -> KeyHash 'Genesis crypto -> FutureGenDeleg crypto
FutureGenDeleg (SlotNo -> KeyHash 'Genesis crypto -> FutureGenDeleg crypto)
-> Decoder s SlotNo
-> Decoder s (KeyHash 'Genesis crypto -> FutureGenDeleg crypto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNo
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (KeyHash 'Genesis crypto -> FutureGenDeleg crypto)
-> Decoder s (KeyHash 'Genesis crypto)
-> Decoder s (FutureGenDeleg crypto)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (KeyHash 'Genesis crypto)
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | InstantaneousRewards captures the pending changes to the ledger
-- state caused by MIR certificates. It consists of two mappings,
-- the rewards which will be paid out from the reserves and the rewards
-- which will be paid out from the treasury. It also consists of
-- two coin values which represent the transfer of coins from
-- one pot to the other pot.
-- NOTE that the following property should always hold:
--   deltaReserves + deltaTreasury = 0
data InstantaneousRewards crypto = InstantaneousRewards
  { InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
iRReserves :: !(Map (Credential 'Staking crypto) Coin),
    InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
iRTreasury :: !(Map (Credential 'Staking crypto) Coin),
    InstantaneousRewards crypto -> DeltaCoin
deltaReserves :: !DeltaCoin,
    InstantaneousRewards crypto -> DeltaCoin
deltaTreasury :: !DeltaCoin
  }
  deriving (Int -> InstantaneousRewards crypto -> ShowS
[InstantaneousRewards crypto] -> ShowS
InstantaneousRewards crypto -> String
(Int -> InstantaneousRewards crypto -> ShowS)
-> (InstantaneousRewards crypto -> String)
-> ([InstantaneousRewards crypto] -> ShowS)
-> Show (InstantaneousRewards crypto)
forall crypto. Int -> InstantaneousRewards crypto -> ShowS
forall crypto. [InstantaneousRewards crypto] -> ShowS
forall crypto. InstantaneousRewards crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantaneousRewards crypto] -> ShowS
$cshowList :: forall crypto. [InstantaneousRewards crypto] -> ShowS
show :: InstantaneousRewards crypto -> String
$cshow :: forall crypto. InstantaneousRewards crypto -> String
showsPrec :: Int -> InstantaneousRewards crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> InstantaneousRewards crypto -> ShowS
Show, InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
(InstantaneousRewards crypto
 -> InstantaneousRewards crypto -> Bool)
-> (InstantaneousRewards crypto
    -> InstantaneousRewards crypto -> Bool)
-> Eq (InstantaneousRewards crypto)
forall crypto.
InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
$c/= :: forall crypto.
InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
== :: InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
$c== :: forall crypto.
InstantaneousRewards crypto -> InstantaneousRewards crypto -> Bool
Eq, (forall x.
 InstantaneousRewards crypto -> Rep (InstantaneousRewards crypto) x)
-> (forall x.
    Rep (InstantaneousRewards crypto) x -> InstantaneousRewards crypto)
-> Generic (InstantaneousRewards crypto)
forall x.
Rep (InstantaneousRewards crypto) x -> InstantaneousRewards crypto
forall x.
InstantaneousRewards crypto -> Rep (InstantaneousRewards crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (InstantaneousRewards crypto) x -> InstantaneousRewards crypto
forall crypto x.
InstantaneousRewards crypto -> Rep (InstantaneousRewards crypto) x
$cto :: forall crypto x.
Rep (InstantaneousRewards crypto) x -> InstantaneousRewards crypto
$cfrom :: forall crypto x.
InstantaneousRewards crypto -> Rep (InstantaneousRewards crypto) x
Generic)

-- | This function returns the coin balance of a given pot, either the
-- reserves or the treasury, after the instantaneous rewards and pot
-- transfers are accounted for.
availableAfterMIR :: MIRPot -> AccountState -> InstantaneousRewards crypto -> Coin
availableAfterMIR :: MIRPot -> AccountState -> InstantaneousRewards crypto -> Coin
availableAfterMIR MIRPot
ReservesMIR AccountState
as InstantaneousRewards crypto
ir =
  AccountState -> Coin
_reserves AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards crypto -> DeltaCoin
forall crypto. InstantaneousRewards crypto -> DeltaCoin
deltaReserves InstantaneousRewards crypto
ir Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Map (Credential 'Staking crypto) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
forall crypto.
InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
iRReserves InstantaneousRewards crypto
ir)
availableAfterMIR MIRPot
TreasuryMIR AccountState
as InstantaneousRewards crypto
ir =
  AccountState -> Coin
_treasury AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards crypto -> DeltaCoin
forall crypto. InstantaneousRewards crypto -> DeltaCoin
deltaTreasury InstantaneousRewards crypto
ir Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Map (Credential 'Staking crypto) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
forall crypto.
InstantaneousRewards crypto
-> Map (Credential 'Staking crypto) Coin
iRTreasury InstantaneousRewards crypto
ir)

instance NoThunks (InstantaneousRewards crypto)

instance NFData (InstantaneousRewards crypto)

instance CC.Crypto crypto => ToCBOR (InstantaneousRewards crypto) where
  toCBOR :: InstantaneousRewards crypto -> Encoding
toCBOR (InstantaneousRewards Map (Credential 'Staking crypto) Coin
irR Map (Credential 'Staking crypto) Coin
irT DeltaCoin
dR DeltaCoin
dT) =
    Word -> Encoding
encodeListLen Word
4 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking crypto) Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map (Credential 'Staking crypto) Coin
irR Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking crypto) Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map (Credential 'Staking crypto) Coin
irT Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DeltaCoin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DeltaCoin
dR Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DeltaCoin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DeltaCoin
dT

instance CC.Crypto crypto => FromSharedCBOR (InstantaneousRewards crypto) where
  type Share (InstantaneousRewards crypto) = Interns (Credential 'Staking crypto)
  fromSharedPlusCBOR :: StateT
  (Share (InstantaneousRewards crypto))
  (Decoder s)
  (InstantaneousRewards crypto)
fromSharedPlusCBOR = do
    Text
-> (InstantaneousRewards crypto -> Int)
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"InstantaneousRewards" (Int -> InstantaneousRewards crypto -> Int
forall a b. a -> b -> a
const Int
4) (StateT
   (Interns (Credential 'Staking crypto))
   (Decoder s)
   (InstantaneousRewards crypto)
 -> StateT
      (Interns (Credential 'Staking crypto))
      (Decoder s)
      (InstantaneousRewards crypto))
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
forall a b. (a -> b) -> a -> b
$ do
      Map (Credential 'Staking crypto) Coin
irR <- Lens'
  (Interns (Credential 'Staking crypto))
  (Share (Map (Credential 'Staking crypto) Coin))
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (Map (Credential 'Staking crypto) Coin)
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR (Lens'
  (Interns (Credential 'Staking crypto), Interns Coin)
  (Interns (Credential 'Staking crypto))
-> Lens'
     (Interns (Credential 'Staking crypto))
     (Interns (Credential 'Staking crypto))
-> Lens'
     (Interns (Credential 'Staking crypto))
     (Interns (Credential 'Staking crypto), Interns Coin)
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (Credential 'Staking crypto), Interns Coin)
  (Interns (Credential 'Staking crypto))
_1 forall a. a -> a
Lens'
  (Interns (Credential 'Staking crypto))
  (Interns (Credential 'Staking crypto))
id)
      Map (Credential 'Staking crypto) Coin
irT <- Lens'
  (Interns (Credential 'Staking crypto))
  (Share (Map (Credential 'Staking crypto) Coin))
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (Map (Credential 'Staking crypto) Coin)
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR (Lens'
  (Interns (Credential 'Staking crypto), Interns Coin)
  (Interns (Credential 'Staking crypto))
-> Lens'
     (Interns (Credential 'Staking crypto))
     (Interns (Credential 'Staking crypto))
-> Lens'
     (Interns (Credential 'Staking crypto))
     (Interns (Credential 'Staking crypto), Interns Coin)
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (Credential 'Staking crypto), Interns Coin)
  (Interns (Credential 'Staking crypto))
_1 forall a. a -> a
Lens'
  (Interns (Credential 'Staking crypto))
  (Interns (Credential 'Staking crypto))
id)
      DeltaCoin
dR <- Decoder s DeltaCoin
-> StateT
     (Interns (Credential 'Staking crypto)) (Decoder s) DeltaCoin
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s DeltaCoin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DeltaCoin
dT <- Decoder s DeltaCoin
-> StateT
     (Interns (Credential 'Staking crypto)) (Decoder s) DeltaCoin
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s DeltaCoin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      InstantaneousRewards crypto
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstantaneousRewards crypto
 -> StateT
      (Interns (Credential 'Staking crypto))
      (Decoder s)
      (InstantaneousRewards crypto))
-> InstantaneousRewards crypto
-> StateT
     (Interns (Credential 'Staking crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards crypto
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards crypto
InstantaneousRewards Map (Credential 'Staking crypto) Coin
irR Map (Credential 'Staking crypto) Coin
irT DeltaCoin
dR DeltaCoin
dT

-- | State of staking pool delegations and rewards
data DState crypto = DState
  { -- | Unified Reward Maps
    DState crypto -> UnifiedMap crypto
_unified :: !(UnifiedMap crypto),
    -- | Future genesis key delegations
    DState crypto -> Map (FutureGenDeleg crypto) (GenDelegPair crypto)
_fGenDelegs :: !(Map (FutureGenDeleg crypto) (GenDelegPair crypto)),
    -- | Genesis key delegations
    DState crypto -> GenDelegs crypto
_genDelegs :: !(GenDelegs crypto),
    -- | Instantaneous Rewards
    DState crypto -> InstantaneousRewards crypto
_irwd :: !(InstantaneousRewards crypto)
  }
  deriving (Int -> DState crypto -> ShowS
[DState crypto] -> ShowS
DState crypto -> String
(Int -> DState crypto -> ShowS)
-> (DState crypto -> String)
-> ([DState crypto] -> ShowS)
-> Show (DState crypto)
forall crypto. Int -> DState crypto -> ShowS
forall crypto. [DState crypto] -> ShowS
forall crypto. DState crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DState crypto] -> ShowS
$cshowList :: forall crypto. [DState crypto] -> ShowS
show :: DState crypto -> String
$cshow :: forall crypto. DState crypto -> String
showsPrec :: Int -> DState crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> DState crypto -> ShowS
Show, DState crypto -> DState crypto -> Bool
(DState crypto -> DState crypto -> Bool)
-> (DState crypto -> DState crypto -> Bool) -> Eq (DState crypto)
forall crypto. DState crypto -> DState crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DState crypto -> DState crypto -> Bool
$c/= :: forall crypto. DState crypto -> DState crypto -> Bool
== :: DState crypto -> DState crypto -> Bool
$c== :: forall crypto. DState crypto -> DState crypto -> Bool
Eq, (forall x. DState crypto -> Rep (DState crypto) x)
-> (forall x. Rep (DState crypto) x -> DState crypto)
-> Generic (DState crypto)
forall x. Rep (DState crypto) x -> DState crypto
forall x. DState crypto -> Rep (DState crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (DState crypto) x -> DState crypto
forall crypto x. DState crypto -> Rep (DState crypto) x
$cto :: forall crypto x. Rep (DState crypto) x -> DState crypto
$cfrom :: forall crypto x. DState crypto -> Rep (DState crypto) x
Generic)

-- ========================
-- Virtual selectors, which get the appropriate view from a DState from the embedded UnifiedMap

rewards :: DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards :: DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards (DState UnifiedMap crypto
unified Map (FutureGenDeleg crypto) (GenDelegPair crypto)
_ GenDelegs crypto
_ InstantaneousRewards crypto
_) = UnifiedMap crypto
-> ViewMap crypto (Credential 'Staking crypto) Coin
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr coin
Rewards UnifiedMap crypto
unified

delegations ::
  DState crypto ->
  ViewMap crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegations :: DState crypto
-> ViewMap
     crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegations (DState UnifiedMap crypto
unified Map (FutureGenDeleg crypto) (GenDelegPair crypto)
_ GenDelegs crypto
_ InstantaneousRewards crypto
_) = UnifiedMap crypto
-> ViewMap
     crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr pl
Delegations UnifiedMap crypto
unified

-- | get the actual ptrs map, we don't need a view
ptrsMap :: DState crypto -> Map Ptr (Credential 'Staking crypto)
ptrsMap :: DState crypto -> Map Ptr (Credential 'Staking crypto)
ptrsMap (DState (UnifiedMap Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
_ Map Ptr (Credential 'Staking crypto)
ptrmap) Map (FutureGenDeleg crypto) (GenDelegPair crypto)
_ GenDelegs crypto
_ InstantaneousRewards crypto
_) = Map Ptr (Credential 'Staking crypto)
ptrmap

-- =======================
-- CBOR instances

instance NoThunks (DState crypto)

instance NFData (DState crypto)

instance CC.Crypto crypto => ToCBOR (DState crypto) where
  toCBOR :: DState crypto -> Encoding
toCBOR (DState UnifiedMap crypto
unified Map (FutureGenDeleg crypto) (GenDelegPair crypto)
fgs GenDelegs crypto
gs InstantaneousRewards crypto
ir) =
    Word -> Encoding
encodeListLen Word
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UnifiedMap crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UnifiedMap crypto
unified
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (FutureGenDeleg crypto) (GenDelegPair crypto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (FutureGenDeleg crypto) (GenDelegPair crypto)
fgs
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> GenDelegs crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR GenDelegs crypto
gs
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> InstantaneousRewards crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR InstantaneousRewards crypto
ir

instance CC.Crypto crypto => FromSharedCBOR (DState crypto) where
  type
    Share (DState crypto) =
      (Interns (Credential 'Staking crypto), Interns (KeyHash 'StakePool crypto))
  fromSharedPlusCBOR :: StateT (Share (DState crypto)) (Decoder s) (DState crypto)
fromSharedPlusCBOR = do
    Text
-> (DState crypto -> Int)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"DState" (Int -> DState crypto -> Int
forall a b. a -> b -> a
const Int
4) (StateT
   (Interns (Credential 'Staking crypto),
    Interns (KeyHash 'StakePool crypto))
   (Decoder s)
   (DState crypto)
 -> StateT
      (Interns (Credential 'Staking crypto),
       Interns (KeyHash 'StakePool crypto))
      (Decoder s)
      (DState crypto))
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
forall a b. (a -> b) -> a -> b
$ do
      UnifiedMap crypto
unified <- StateT
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Decoder s)
  (UnifiedMap crypto)
forall a s. FromSharedCBOR a => StateT (Share a) (Decoder s) a
fromSharedPlusCBOR
      Map (FutureGenDeleg crypto) (GenDelegPair crypto)
fgs <- Decoder s (Map (FutureGenDeleg crypto) (GenDelegPair crypto))
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (Map (FutureGenDeleg crypto) (GenDelegPair crypto))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (Map (FutureGenDeleg crypto) (GenDelegPair crypto))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      GenDelegs crypto
gs <- Decoder s (GenDelegs crypto)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (GenDelegs crypto)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (GenDelegs crypto)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      InstantaneousRewards crypto
ir <- Lens'
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Share (InstantaneousRewards crypto))
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (InstantaneousRewards crypto)
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Share (InstantaneousRewards crypto))
_1
      DState crypto
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DState crypto
 -> StateT
      (Interns (Credential 'Staking crypto),
       Interns (KeyHash 'StakePool crypto))
      (Decoder s)
      (DState crypto))
-> DState crypto
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DState crypto)
forall a b. (a -> b) -> a -> b
$ UnifiedMap crypto
-> Map (FutureGenDeleg crypto) (GenDelegPair crypto)
-> GenDelegs crypto
-> InstantaneousRewards crypto
-> DState crypto
forall crypto.
UnifiedMap crypto
-> Map (FutureGenDeleg crypto) (GenDelegPair crypto)
-> GenDelegs crypto
-> InstantaneousRewards crypto
-> DState crypto
DState UnifiedMap crypto
unified Map (FutureGenDeleg crypto) (GenDelegPair crypto)
fgs GenDelegs crypto
gs InstantaneousRewards crypto
ir

-- | Current state of staking pools and their certificate counters.
data PState crypto = PState
  { -- | The pool parameters.
    PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams :: !(Map (KeyHash 'StakePool crypto) (PoolParams crypto)),
    -- | The future pool parameters.
    PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams :: !(Map (KeyHash 'StakePool crypto) (PoolParams crypto)),
    -- | A map of retiring stake pools to the epoch when they retire.
    PState crypto -> Map (KeyHash 'StakePool crypto) EpochNo
_retiring :: !(Map (KeyHash 'StakePool crypto) EpochNo)
  }
  deriving (Int -> PState crypto -> ShowS
[PState crypto] -> ShowS
PState crypto -> String
(Int -> PState crypto -> ShowS)
-> (PState crypto -> String)
-> ([PState crypto] -> ShowS)
-> Show (PState crypto)
forall crypto. Int -> PState crypto -> ShowS
forall crypto. [PState crypto] -> ShowS
forall crypto. PState crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PState crypto] -> ShowS
$cshowList :: forall crypto. [PState crypto] -> ShowS
show :: PState crypto -> String
$cshow :: forall crypto. PState crypto -> String
showsPrec :: Int -> PState crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> PState crypto -> ShowS
Show, PState crypto -> PState crypto -> Bool
(PState crypto -> PState crypto -> Bool)
-> (PState crypto -> PState crypto -> Bool) -> Eq (PState crypto)
forall crypto. PState crypto -> PState crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PState crypto -> PState crypto -> Bool
$c/= :: forall crypto. PState crypto -> PState crypto -> Bool
== :: PState crypto -> PState crypto -> Bool
$c== :: forall crypto. PState crypto -> PState crypto -> Bool
Eq, (forall x. PState crypto -> Rep (PState crypto) x)
-> (forall x. Rep (PState crypto) x -> PState crypto)
-> Generic (PState crypto)
forall x. Rep (PState crypto) x -> PState crypto
forall x. PState crypto -> Rep (PState crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (PState crypto) x -> PState crypto
forall crypto x. PState crypto -> Rep (PState crypto) x
$cto :: forall crypto x. Rep (PState crypto) x -> PState crypto
$cfrom :: forall crypto x. PState crypto -> Rep (PState crypto) x
Generic)

instance NoThunks (PState crypto)

instance NFData (PState crypto)

instance CC.Crypto crypto => ToCBOR (PState crypto) where
  toCBOR :: PState crypto -> Encoding
toCBOR (PState Map (KeyHash 'StakePool crypto) (PoolParams crypto)
a Map (KeyHash 'StakePool crypto) (PoolParams crypto)
b Map (KeyHash 'StakePool crypto) EpochNo
c) =
    Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool crypto) (PoolParams crypto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool crypto) (PoolParams crypto)
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool crypto) (PoolParams crypto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool crypto) (PoolParams crypto)
b Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool crypto) EpochNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool crypto) EpochNo
c

instance CC.Crypto crypto => FromSharedCBOR (PState crypto) where
  type
    Share (PState crypto) =
      Interns (KeyHash 'StakePool crypto)
  fromSharedPlusCBOR :: StateT (Share (PState crypto)) (Decoder s) (PState crypto)
fromSharedPlusCBOR = Text
-> (PState crypto -> Int)
-> StateT
     (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
-> StateT
     (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"PState" (Int -> PState crypto -> Int
forall a b. a -> b -> a
const Int
3) (StateT
   (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
 -> StateT
      (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto))
-> StateT
     (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
-> StateT
     (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
forall a b. (a -> b) -> a -> b
$ do
    Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams <- Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Share (Map (KeyHash 'StakePool crypto) (PoolParams crypto)))
-> StateT
     (Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (Map (KeyHash 'StakePool crypto) (PoolParams crypto))
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR (Lens'
  (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
  (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
  (Interns (KeyHash 'StakePool crypto))
_1 forall a. a -> a
Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Interns (KeyHash 'StakePool crypto))
id)
    Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams <- Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Share (Map (KeyHash 'StakePool crypto) (PoolParams crypto)))
-> StateT
     (Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (Map (KeyHash 'StakePool crypto) (PoolParams crypto))
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR (Lens'
  (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
  (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (KeyHash 'StakePool crypto), Interns (PoolParams crypto))
  (Interns (KeyHash 'StakePool crypto))
_1 forall a. a -> a
Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Interns (KeyHash 'StakePool crypto))
id)
    Map (KeyHash 'StakePool crypto) EpochNo
_retiring <- Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Share (Map (KeyHash 'StakePool crypto) EpochNo))
-> StateT
     (Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (Map (KeyHash 'StakePool crypto) EpochNo)
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR (Lens'
  (Interns (KeyHash 'StakePool crypto), Interns EpochNo)
  (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto))
-> Lens'
     (Interns (KeyHash 'StakePool crypto))
     (Interns (KeyHash 'StakePool crypto), Interns EpochNo)
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (KeyHash 'StakePool crypto), Interns EpochNo)
  (Interns (KeyHash 'StakePool crypto))
_1 forall a. a -> a
Lens'
  (Interns (KeyHash 'StakePool crypto))
  (Interns (KeyHash 'StakePool crypto))
id)
    PState crypto
-> StateT
     (Interns (KeyHash 'StakePool crypto)) (Decoder s) (PState crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PState :: forall crypto.
Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) EpochNo
-> PState crypto
PState {Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams :: Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams :: Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams, Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams :: Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams :: Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams, Map (KeyHash 'StakePool crypto) EpochNo
_retiring :: Map (KeyHash 'StakePool crypto) EpochNo
_retiring :: Map (KeyHash 'StakePool crypto) EpochNo
_retiring}

-- | The state associated with the current stake delegation.
data DPState crypto = DPState
  { DPState crypto -> DState crypto
dpsDState :: !(DState crypto),
    DPState crypto -> PState crypto
dpsPState :: !(PState crypto)
  }
  deriving (Int -> DPState crypto -> ShowS
[DPState crypto] -> ShowS
DPState crypto -> String
(Int -> DPState crypto -> ShowS)
-> (DPState crypto -> String)
-> ([DPState crypto] -> ShowS)
-> Show (DPState crypto)
forall crypto. Int -> DPState crypto -> ShowS
forall crypto. [DPState crypto] -> ShowS
forall crypto. DPState crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DPState crypto] -> ShowS
$cshowList :: forall crypto. [DPState crypto] -> ShowS
show :: DPState crypto -> String
$cshow :: forall crypto. DPState crypto -> String
showsPrec :: Int -> DPState crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> DPState crypto -> ShowS
Show, DPState crypto -> DPState crypto -> Bool
(DPState crypto -> DPState crypto -> Bool)
-> (DPState crypto -> DPState crypto -> Bool)
-> Eq (DPState crypto)
forall crypto. DPState crypto -> DPState crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DPState crypto -> DPState crypto -> Bool
$c/= :: forall crypto. DPState crypto -> DPState crypto -> Bool
== :: DPState crypto -> DPState crypto -> Bool
$c== :: forall crypto. DPState crypto -> DPState crypto -> Bool
Eq, (forall x. DPState crypto -> Rep (DPState crypto) x)
-> (forall x. Rep (DPState crypto) x -> DPState crypto)
-> Generic (DPState crypto)
forall x. Rep (DPState crypto) x -> DPState crypto
forall x. DPState crypto -> Rep (DPState crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (DPState crypto) x -> DPState crypto
forall crypto x. DPState crypto -> Rep (DPState crypto) x
$cto :: forall crypto x. Rep (DPState crypto) x -> DPState crypto
$cfrom :: forall crypto x. DPState crypto -> Rep (DPState crypto) x
Generic)

instance NoThunks (DPState crypto)

instance NFData (DPState crypto)

instance
  CC.Crypto crypto =>
  ToCBOR (DPState crypto)
  where
  toCBOR :: DPState crypto -> Encoding
toCBOR DPState {PState crypto
dpsPState :: PState crypto
dpsPState :: forall crypto. DPState crypto -> PState crypto
dpsPState, DState crypto
dpsDState :: DState crypto
dpsDState :: forall crypto. DPState crypto -> DState crypto
dpsDState} =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PState crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PState crypto
dpsPState -- We get better sharing when encoding pstate before dstate
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DState crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DState crypto
dpsDState

instance CC.Crypto crypto => FromSharedCBOR (DPState crypto) where
  type
    Share (DPState crypto) =
      ( Interns (Credential 'Staking crypto),
        Interns (KeyHash 'StakePool crypto)
      )
  fromSharedPlusCBOR :: StateT (Share (DPState crypto)) (Decoder s) (DPState crypto)
fromSharedPlusCBOR = Text
-> (DPState crypto -> Int)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DPState crypto)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DPState crypto)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"DPState" (Int -> DPState crypto -> Int
forall a b. a -> b -> a
const Int
2) (StateT
   (Interns (Credential 'Staking crypto),
    Interns (KeyHash 'StakePool crypto))
   (Decoder s)
   (DPState crypto)
 -> StateT
      (Interns (Credential 'Staking crypto),
       Interns (KeyHash 'StakePool crypto))
      (Decoder s)
      (DPState crypto))
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DPState crypto)
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DPState crypto)
forall a b. (a -> b) -> a -> b
$ do
    PState crypto
dpsPState <- Lens'
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Share (PState crypto))
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (PState crypto)
forall b bs s.
FromSharedCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
fromSharedPlusLensCBOR forall s t a b. Field2 s t a b => Lens s t a b
Lens'
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Share (PState crypto))
_2
    DState crypto
dpsDState <- StateT
  (Interns (Credential 'Staking crypto),
   Interns (KeyHash 'StakePool crypto))
  (Decoder s)
  (DState crypto)
forall a s. FromSharedCBOR a => StateT (Share a) (Decoder s) a
fromSharedPlusCBOR
    DPState crypto
-> StateT
     (Interns (Credential 'Staking crypto),
      Interns (KeyHash 'StakePool crypto))
     (Decoder s)
     (DPState crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPState :: forall crypto. DState crypto -> PState crypto -> DPState crypto
DPState {PState crypto
dpsPState :: PState crypto
dpsPState :: PState crypto
dpsPState, DState crypto
dpsDState :: DState crypto
dpsDState :: DState crypto
dpsDState}

data AccountState = AccountState
  { AccountState -> Coin
_treasury :: !Coin,
    AccountState -> Coin
_reserves :: !Coin
  }
  deriving (Int -> AccountState -> ShowS
[AccountState] -> ShowS
AccountState -> String
(Int -> AccountState -> ShowS)
-> (AccountState -> String)
-> ([AccountState] -> ShowS)
-> Show AccountState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccountState] -> ShowS
$cshowList :: [AccountState] -> ShowS
show :: AccountState -> String
$cshow :: AccountState -> String
showsPrec :: Int -> AccountState -> ShowS
$cshowsPrec :: Int -> AccountState -> ShowS
Show, AccountState -> AccountState -> Bool
(AccountState -> AccountState -> Bool)
-> (AccountState -> AccountState -> Bool) -> Eq AccountState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccountState -> AccountState -> Bool
$c/= :: AccountState -> AccountState -> Bool
== :: AccountState -> AccountState -> Bool
$c== :: AccountState -> AccountState -> Bool
Eq, (forall x. AccountState -> Rep AccountState x)
-> (forall x. Rep AccountState x -> AccountState)
-> Generic AccountState
forall x. Rep AccountState x -> AccountState
forall x. AccountState -> Rep AccountState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AccountState x -> AccountState
$cfrom :: forall x. AccountState -> Rep AccountState x
Generic)

instance ToCBOR AccountState where
  toCBOR :: AccountState -> Encoding
toCBOR (AccountState Coin
t Coin
r) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
t Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
r

instance FromCBOR AccountState where
  fromCBOR :: Decoder s AccountState
fromCBOR =
    Text
-> (AccountState -> Int)
-> Decoder s AccountState
-> Decoder s AccountState
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"AccountState" (Int -> AccountState -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s AccountState -> Decoder s AccountState)
-> Decoder s AccountState -> Decoder s AccountState
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> AccountState
AccountState (Coin -> Coin -> AccountState)
-> Decoder s Coin -> Decoder s (Coin -> AccountState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Coin -> AccountState)
-> Decoder s Coin -> Decoder s AccountState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance NoThunks AccountState

instance NFData AccountState

data EpochState era = EpochState
  { EpochState era -> AccountState
esAccountState :: !AccountState,
    EpochState era -> SnapShots (Crypto era)
esSnapshots :: !(SnapShots (Crypto era)),
    EpochState era -> LedgerState era
esLState :: !(LedgerState era),
    EpochState era -> PParams era
esPrevPp :: !(Core.PParams era),
    EpochState era -> PParams era
esPp :: !(Core.PParams era),
    -- | This field, esNonMyopic, does not appear in the formal spec
    -- and is not a part of the protocol. It is only used for providing
    -- data to the stake pool ranking calculation @getNonMyopicMemberRewards@.
    -- See https://hydra.iohk.io/job/Cardano/cardano-ledger/specs.pool-ranking/latest/download-by-type/doc-pdf/pool-ranking
    EpochState era -> NonMyopic (Crypto era)
esNonMyopic :: !(NonMyopic (Crypto era))
  }
  deriving ((forall x. EpochState era -> Rep (EpochState era) x)
-> (forall x. Rep (EpochState era) x -> EpochState era)
-> Generic (EpochState era)
forall x. Rep (EpochState era) x -> EpochState era
forall x. EpochState era -> Rep (EpochState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (EpochState era) x -> EpochState era
forall era x. EpochState era -> Rep (EpochState era) x
$cto :: forall era x. Rep (EpochState era) x -> EpochState era
$cfrom :: forall era x. EpochState era -> Rep (EpochState era) x
Generic)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Show (Core.TxOut era),
    Show (Core.PParams era),
    Show (State (Core.EraRule "PPUP" era))
  ) =>
  Show (EpochState era)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Eq (Core.TxOut era),
    Eq (Core.PParams era),
    Eq (State (Core.EraRule "PPUP" era))
  ) =>
  Eq (EpochState era)

instance
  ( Era era,
    NoThunks (Core.TxOut era),
    NoThunks (State (Core.EraRule "PPUP" era)),
    NoThunks (Core.Value era),
    NoThunks (Core.PParams era),
    ToCBOR (Core.TxBody era),
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.Value era)
  ) =>
  NoThunks (EpochState era)

instance
  ( Era era,
    NFData (Core.TxOut era),
    NFData (Core.PParams era),
    NFData (State (Core.EraRule "PPUP" era))
  ) =>
  NFData (EpochState era)

instance
  ( Era era,
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.PParams era),
    ToCBOR (State (Core.EraRule "PPUP" era))
  ) =>
  ToCBOR (EpochState era)
  where
  toCBOR :: EpochState era -> Encoding
toCBOR EpochState {AccountState
esAccountState :: AccountState
esAccountState :: forall era. EpochState era -> AccountState
esAccountState, LedgerState era
esLState :: LedgerState era
esLState :: forall era. EpochState era -> LedgerState era
esLState, SnapShots (Crypto era)
esSnapshots :: SnapShots (Crypto era)
esSnapshots :: forall era. EpochState era -> SnapShots (Crypto era)
esSnapshots, PParams era
esPrevPp :: PParams era
esPrevPp :: forall era. EpochState era -> PParams era
esPrevPp, PParams era
esPp :: PParams era
esPp :: forall era. EpochState era -> PParams era
esPp, NonMyopic (Crypto era)
esNonMyopic :: NonMyopic (Crypto era)
esNonMyopic :: forall era. EpochState era -> NonMyopic (Crypto era)
esNonMyopic} =
    Word -> Encoding
encodeListLen Word
6
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AccountState -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AccountState
esAccountState
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LedgerState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR LedgerState era
esLState -- We get better sharing when encoding ledger state before snaphots
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapShots (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapShots (Crypto era)
esSnapshots
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PParams era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PParams era
esPrevPp
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PParams era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PParams era
esPp
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NonMyopic (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NonMyopic (Crypto era)
esNonMyopic

instance
  ( FromCBOR (Core.PParams era),
    TransValue FromCBOR era,
    HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era),
    FromSharedCBOR (Core.TxOut era),
    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
    FromCBOR (State (Core.EraRule "PPUP" era)),
    Era era
  ) =>
  FromCBOR (EpochState era)
  where
  fromCBOR :: Decoder s (EpochState era)
fromCBOR =
    Text
-> (EpochState era -> Int)
-> Decoder s (EpochState era)
-> Decoder s (EpochState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"EpochState" (Int -> EpochState era -> Int
forall a b. a -> b -> a
const Int
6) (Decoder s (EpochState era) -> Decoder s (EpochState era))
-> Decoder s (EpochState era) -> Decoder s (EpochState era)
forall a b. (a -> b) -> a -> b
$
      (StateT
   (Interns (Credential 'Staking (Crypto era)),
    Interns (KeyHash 'StakePool (Crypto era)))
   (Decoder s)
   (EpochState era)
 -> (Interns (Credential 'Staking (Crypto era)),
     Interns (KeyHash 'StakePool (Crypto era)))
 -> Decoder s (EpochState era))
-> (Interns (Credential 'Staking (Crypto era)),
    Interns (KeyHash 'StakePool (Crypto era)))
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (EpochState era)
-> Decoder s (EpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Decoder s)
  (EpochState era)
-> (Interns (Credential 'Staking (Crypto era)),
    Interns (KeyHash 'StakePool (Crypto era)))
-> Decoder s (EpochState era)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Interns (Credential 'Staking (Crypto era)),
 Interns (KeyHash 'StakePool (Crypto era)))
forall a. Monoid a => a
mempty (StateT
   (Interns (Credential 'Staking (Crypto era)),
    Interns (KeyHash 'StakePool (Crypto era)))
   (Decoder s)
   (EpochState era)
 -> Decoder s (EpochState era))
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (EpochState era)
-> Decoder s (EpochState era)
forall a b. (a -> b) -> a -> b
$ do
        AccountState
esAccountState <- Decoder s AccountState
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     AccountState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s AccountState
forall a s. FromCBOR a => Decoder s a
fromCBOR
        LedgerState era
esLState <- StateT
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Decoder s)
  (LedgerState era)
forall a s. FromSharedCBOR a => StateT (Share a) (Decoder s) a
fromSharedPlusCBOR
        SnapShots (Crypto era)
esSnapshots <- StateT
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Decoder s)
  (SnapShots (Crypto era))
forall a s. FromSharedCBOR a => StateT (Share a) (Decoder s) a
fromSharedPlusCBOR
        PParams era
esPrevPp <- Decoder s (PParams era)
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (PParams era)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (PParams era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
        PParams era
esPp <- Decoder s (PParams era)
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (PParams era)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (PParams era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
        NonMyopic (Crypto era)
esNonMyopic <- SimpleGetter
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Share (NonMyopic (Crypto era)))
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (NonMyopic (Crypto era))
forall b bs s.
FromSharedCBOR b =>
SimpleGetter bs (Share b) -> StateT bs (Decoder s) b
fromSharedLensCBOR SimpleGetter
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Share (NonMyopic (Crypto era)))
forall s t a b. Field2 s t a b => Lens s t a b
_2
        EpochState era
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (EpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState :: forall era.
AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
EpochState {AccountState
esAccountState :: AccountState
esAccountState :: AccountState
esAccountState, SnapShots (Crypto era)
esSnapshots :: SnapShots (Crypto era)
esSnapshots :: SnapShots (Crypto era)
esSnapshots, LedgerState era
esLState :: LedgerState era
esLState :: LedgerState era
esLState, PParams era
esPrevPp :: PParams era
esPrevPp :: PParams era
esPrevPp, PParams era
esPp :: PParams era
esPp :: PParams era
esPp, NonMyopic (Crypto era)
esNonMyopic :: NonMyopic (Crypto era)
esNonMyopic :: NonMyopic (Crypto era)
esNonMyopic}

data UpecState era = UpecState
  { -- | Current protocol parameters.
    UpecState era -> PParams era
currentPp :: !(Core.PParams era),
    -- | State of the protocol update transition system.
    UpecState era -> State (EraRule "PPUP" era)
ppupState :: !(State (Core.EraRule "PPUP" era))
  }

deriving stock instance
  ( Show (State (Core.EraRule "PPUP" era)),
    Show (Core.PParams era)
  ) =>
  Show (UpecState era)

data PPUPState era = PPUPState
  { PPUPState era -> ProposedPPUpdates era
proposals :: !(ProposedPPUpdates era),
    PPUPState era -> ProposedPPUpdates era
futureProposals :: !(ProposedPPUpdates era)
  }
  deriving ((forall x. PPUPState era -> Rep (PPUPState era) x)
-> (forall x. Rep (PPUPState era) x -> PPUPState era)
-> Generic (PPUPState era)
forall x. Rep (PPUPState era) x -> PPUPState era
forall x. PPUPState era -> Rep (PPUPState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PPUPState era) x -> PPUPState era
forall era x. PPUPState era -> Rep (PPUPState era) x
$cto :: forall era x. Rep (PPUPState era) x -> PPUPState era
$cfrom :: forall era x. PPUPState era -> Rep (PPUPState era) x
Generic)

deriving instance Show (PParamsDelta era) => Show (PPUPState era)

deriving instance Eq (PParamsDelta era) => Eq (PPUPState era)

deriving instance NFData (PParamsDelta era) => NFData (PPUPState era)

instance NoThunks (PParamsDelta era) => NoThunks (PPUPState era)

instance (Era era, ToCBOR (PParamsDelta era)) => ToCBOR (PPUPState era) where
  toCBOR :: PPUPState era -> Encoding
toCBOR (PPUPState ProposedPPUpdates era
ppup ProposedPPUpdates era
fppup) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProposedPPUpdates era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ProposedPPUpdates era
ppup Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProposedPPUpdates era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ProposedPPUpdates era
fppup

instance
  (Era era, FromCBOR (PParamsDelta era)) =>
  FromCBOR (PPUPState era)
  where
  fromCBOR :: Decoder s (PPUPState era)
fromCBOR =
    Decode ('Closed 'Dense) (PPUPState era)
-> Decoder s (PPUPState era)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (PPUPState era)
 -> Decoder s (PPUPState era))
-> Decode ('Closed 'Dense) (PPUPState era)
-> Decoder s (PPUPState era)
forall a b. (a -> b) -> a -> b
$
      (ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era)
-> Decode
     ('Closed 'Dense)
     (ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era)
forall t. t -> Decode ('Closed 'Dense) t
RecD ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
forall era.
ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
PPUPState
        Decode
  ('Closed 'Dense)
  (ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era)
-> Decode ('Closed Any) (ProposedPPUpdates era)
-> Decode ('Closed 'Dense) (ProposedPPUpdates era -> PPUPState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (ProposedPPUpdates era)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode ('Closed 'Dense) (ProposedPPUpdates era -> PPUPState era)
-> Decode ('Closed Any) (ProposedPPUpdates era)
-> Decode ('Closed 'Dense) (PPUPState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (ProposedPPUpdates era)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From

pvCanFollow :: ProtVer -> StrictMaybe ProtVer -> Bool
pvCanFollow :: ProtVer -> StrictMaybe ProtVer -> Bool
pvCanFollow ProtVer
_ StrictMaybe ProtVer
SNothing = Bool
True
pvCanFollow (ProtVer Natural
m Natural
n) (SJust (ProtVer Natural
m' Natural
n')) =
  (Natural
m Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Natural
0) (Natural, Natural) -> (Natural, Natural) -> Bool
forall a. Eq a => a -> a -> Bool
== (Natural
m', Natural
n') Bool -> Bool -> Bool
|| (Natural
m, Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) (Natural, Natural) -> (Natural, Natural) -> Bool
forall a. Eq a => a -> a -> Bool
== (Natural
m', Natural
n')

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

-- | Incremental Stake, Stake along with possible missed coins from danging Ptrs.
--   Transactions can use Ptrs to refer to a stake credential in a TxOut. The Ptr
--   does not have to point to anything until the epoch boundary, when we compute
--   rewards and aggregate staking information for ranking. This is unusual but legal.
--   In a non incremental system, we use whatever 'legal' Ptrs exist at the epoch
--   boundary. Here we are computing things incrementally, so we need to remember Ptrs
--   that might point to something by the time the epoch boundary is reached. When
--   the epoch boundary is reached we 'resolve' these pointers, to see if any have
--   become non-dangling since the time they were first used in the incremental computation.
data IncrementalStake crypto = IStake
  { IncrementalStake crypto -> Map (Credential 'Staking crypto) Coin
credMap :: !(Map (Credential 'Staking crypto) Coin),
    IncrementalStake crypto -> Map Ptr Coin
ptrMap :: !(Map Ptr Coin)
  }
  deriving ((forall x.
 IncrementalStake crypto -> Rep (IncrementalStake crypto) x)
-> (forall x.
    Rep (IncrementalStake crypto) x -> IncrementalStake crypto)
-> Generic (IncrementalStake crypto)
forall x.
Rep (IncrementalStake crypto) x -> IncrementalStake crypto
forall x.
IncrementalStake crypto -> Rep (IncrementalStake crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (IncrementalStake crypto) x -> IncrementalStake crypto
forall crypto x.
IncrementalStake crypto -> Rep (IncrementalStake crypto) x
$cto :: forall crypto x.
Rep (IncrementalStake crypto) x -> IncrementalStake crypto
$cfrom :: forall crypto x.
IncrementalStake crypto -> Rep (IncrementalStake crypto) x
Generic, Int -> IncrementalStake crypto -> ShowS
[IncrementalStake crypto] -> ShowS
IncrementalStake crypto -> String
(Int -> IncrementalStake crypto -> ShowS)
-> (IncrementalStake crypto -> String)
-> ([IncrementalStake crypto] -> ShowS)
-> Show (IncrementalStake crypto)
forall crypto. Int -> IncrementalStake crypto -> ShowS
forall crypto. [IncrementalStake crypto] -> ShowS
forall crypto. IncrementalStake crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IncrementalStake crypto] -> ShowS
$cshowList :: forall crypto. [IncrementalStake crypto] -> ShowS
show :: IncrementalStake crypto -> String
$cshow :: forall crypto. IncrementalStake crypto -> String
showsPrec :: Int -> IncrementalStake crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> IncrementalStake crypto -> ShowS
Show, IncrementalStake crypto -> IncrementalStake crypto -> Bool
(IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> Eq (IncrementalStake crypto)
forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c/= :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
== :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c== :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
Eq, Eq (IncrementalStake crypto)
Eq (IncrementalStake crypto)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Ordering)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> (IncrementalStake crypto -> IncrementalStake crypto -> Bool)
-> (IncrementalStake crypto
    -> IncrementalStake crypto -> IncrementalStake crypto)
-> (IncrementalStake crypto
    -> IncrementalStake crypto -> IncrementalStake crypto)
-> Ord (IncrementalStake crypto)
IncrementalStake crypto -> IncrementalStake crypto -> Bool
IncrementalStake crypto -> IncrementalStake crypto -> Ordering
IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
forall crypto. Eq (IncrementalStake crypto)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Ordering
forall crypto.
IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
min :: IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
$cmin :: forall crypto.
IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
max :: IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
$cmax :: forall crypto.
IncrementalStake crypto
-> IncrementalStake crypto -> IncrementalStake crypto
>= :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c>= :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
> :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c> :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
<= :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c<= :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
< :: IncrementalStake crypto -> IncrementalStake crypto -> Bool
$c< :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Bool
compare :: IncrementalStake crypto -> IncrementalStake crypto -> Ordering
$ccompare :: forall crypto.
IncrementalStake crypto -> IncrementalStake crypto -> Ordering
$cp1Ord :: forall crypto. Eq (IncrementalStake crypto)
Ord, Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
Proxy (IncrementalStake crypto) -> String
(Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo))
-> (Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo))
-> (Proxy (IncrementalStake crypto) -> String)
-> NoThunks (IncrementalStake crypto)
forall crypto.
Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
forall crypto. Proxy (IncrementalStake crypto) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (IncrementalStake crypto) -> String
$cshowTypeOf :: forall crypto. Proxy (IncrementalStake crypto) -> String
wNoThunks :: Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall crypto.
Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
noThunks :: Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
$cnoThunks :: forall crypto.
Context -> IncrementalStake crypto -> IO (Maybe ThunkInfo)
NoThunks, IncrementalStake crypto -> ()
(IncrementalStake crypto -> ()) -> NFData (IncrementalStake crypto)
forall crypto. IncrementalStake crypto -> ()
forall a. (a -> ()) -> NFData a
rnf :: IncrementalStake crypto -> ()
$crnf :: forall crypto. IncrementalStake crypto -> ()
NFData)

instance CC.Crypto crypto => ToCBOR (IncrementalStake crypto) where
  toCBOR :: IncrementalStake crypto -> Encoding
toCBOR (IStake Map (Credential 'Staking crypto) Coin
st Map Ptr Coin
dangle) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking crypto) Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map (Credential 'Staking crypto) Coin
st Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map Ptr Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map Ptr Coin
dangle

instance CC.Crypto crypto => FromSharedCBOR (IncrementalStake crypto) where
  type Share (IncrementalStake crypto) = Interns (Credential 'Staking crypto)
  fromSharedCBOR :: Share (IncrementalStake crypto)
-> Decoder s (IncrementalStake crypto)
fromSharedCBOR Share (IncrementalStake crypto)
credInterns = do
    Text
-> (IncrementalStake crypto -> Int)
-> Decoder s (IncrementalStake crypto)
-> Decoder s (IncrementalStake crypto)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Stake" (Int -> IncrementalStake crypto -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (IncrementalStake crypto)
 -> Decoder s (IncrementalStake crypto))
-> Decoder s (IncrementalStake crypto)
-> Decoder s (IncrementalStake crypto)
forall a b. (a -> b) -> a -> b
$ do
      Map (Credential 'Staking crypto) Coin
stake <- Share (Map (Credential 'Staking crypto) Coin)
-> Decoder s (Map (Credential 'Staking crypto) Coin)
forall a s. FromSharedCBOR a => Share a -> Decoder s a
fromSharedCBOR (Interns (Credential 'Staking crypto)
Share (IncrementalStake crypto)
credInterns, Interns Coin
forall a. Monoid a => a
mempty)
      Map Ptr Coin
dangle <- Decoder s (Map Ptr Coin)
forall a b s.
(Ord a, FromCBOR a, FromCBOR b) =>
Decoder s (Map a b)
mapFromCBOR
      IncrementalStake crypto -> Decoder s (IncrementalStake crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IncrementalStake crypto -> Decoder s (IncrementalStake crypto))
-> IncrementalStake crypto -> Decoder s (IncrementalStake crypto)
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake Map (Credential 'Staking crypto) Coin
stake Map Ptr Coin
dangle

instance Semigroup (IncrementalStake c) where
  (IStake Map (Credential 'Staking c) Coin
a Map Ptr Coin
b) <> :: IncrementalStake c -> IncrementalStake c -> IncrementalStake c
<> (IStake Map (Credential 'Staking c) Coin
c Map Ptr Coin
d) = Map (Credential 'Staking c) Coin
-> Map Ptr Coin -> IncrementalStake c
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake ((Coin -> Coin -> Coin)
-> Map (Credential 'Staking c) Coin
-> Map (Credential 'Staking c) Coin
-> Map (Credential 'Staking c) Coin
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>) Map (Credential 'Staking c) Coin
a Map (Credential 'Staking c) Coin
c) ((Coin -> Coin -> Coin)
-> Map Ptr Coin -> Map Ptr Coin -> Map Ptr Coin
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>) Map Ptr Coin
b Map Ptr Coin
d)

instance Monoid (IncrementalStake c) where
  mempty :: IncrementalStake c
mempty = Map (Credential 'Staking c) Coin
-> Map Ptr Coin -> IncrementalStake c
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake Map (Credential 'Staking c) Coin
forall k a. Map k a
Map.empty Map Ptr Coin
forall k a. Map k a
Map.empty

instance Data.Group.Group (IncrementalStake c) where
  invert :: IncrementalStake c -> IncrementalStake c
invert (IStake Map (Credential 'Staking c) Coin
m1 Map Ptr Coin
m2) = Map (Credential 'Staking c) Coin
-> Map Ptr Coin -> IncrementalStake c
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake ((Coin -> Coin)
-> Map (Credential 'Staking c) Coin
-> Map (Credential 'Staking c) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Coin -> Coin
forall m. Group m => m -> m
invert Map (Credential 'Staking c) Coin
m1) ((Coin -> Coin) -> Map Ptr Coin -> Map Ptr Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Coin -> Coin
forall m. Group m => m -> m
invert Map Ptr Coin
m2)

instance Default (IncrementalStake c) where
  def :: IncrementalStake c
def = Map (Credential 'Staking c) Coin
-> Map Ptr Coin -> IncrementalStake c
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake Map (Credential 'Staking c) Coin
forall k a. Map k a
Map.empty Map Ptr Coin
forall k a. Map k a
Map.empty

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

-- | There is a serious invariant that we must maintain in the UTxOState.
--   Given (UTxOState utxo _ _ _ istake) it must be the case that
--   istake == (updateStakeDistribution (UTxO Map.empty) (UTxO Map.empty) utxo)
--   Of course computing the RHS of the above equality can be very expensive, so we only
--   use this route in the testing function smartUTxO. But we are very carefull, wherever
--   we update the UTxO, we carefully make INCREMENTAL changes to istake to maintain
--   this invariant. This happens in the UTxO rule.
data UTxOState era = UTxOState
  { UTxOState era -> UTxO era
_utxo :: !(UTxO era),
    UTxOState era -> Coin
_deposited :: !Coin,
    UTxOState era -> Coin
_fees :: !Coin,
    UTxOState era -> State (EraRule "PPUP" era)
_ppups :: !(State (Core.EraRule "PPUP" era)),
    UTxOState era -> IncrementalStake (Crypto era)
_stakeDistro :: !(IncrementalStake (Crypto era))
  }
  deriving ((forall x. UTxOState era -> Rep (UTxOState era) x)
-> (forall x. Rep (UTxOState era) x -> UTxOState era)
-> Generic (UTxOState era)
forall x. Rep (UTxOState era) x -> UTxOState era
forall x. UTxOState era -> Rep (UTxOState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (UTxOState era) x -> UTxOState era
forall era x. UTxOState era -> Rep (UTxOState era) x
$cto :: forall era x. Rep (UTxOState era) x -> UTxOState era
$cfrom :: forall era x. UTxOState era -> Rep (UTxOState era) x
Generic)

instance
  ( Era era,
    NFData (Core.TxOut era),
    NFData (State (Core.EraRule "PPUP" era))
  ) =>
  NFData (UTxOState era)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Show (Core.TxOut era),
    Show (State (Core.EraRule "PPUP" era))
  ) =>
  Show (UTxOState era)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Eq (Core.TxOut era),
    Eq (State (Core.EraRule "PPUP" era))
  ) =>
  Eq (UTxOState era)

instance
  ( Era era,
    NoThunks (Core.TxOut era),
    NoThunks (State (Core.EraRule "PPUP" era)),
    NoThunks (Core.Value era),
    ToCBOR (Core.TxBody era),
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.Value era)
  ) =>
  NoThunks (UTxOState era)

instance
  ( Era era,
    ToCBOR (Core.TxOut era),
    ToCBOR (State (Core.EraRule "PPUP" era))
  ) =>
  ToCBOR (UTxOState era)
  where
  toCBOR :: UTxOState era -> Encoding
toCBOR (UTxOState UTxO era
ut Coin
dp Coin
fs State (EraRule "PPUP" era)
us IncrementalStake (Crypto era)
sd) =
    Word -> Encoding
encodeListLen Word
5 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxO era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UTxO era
ut Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
dp Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
fs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State (EraRule "PPUP" era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR State (EraRule "PPUP" era)
us Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> IncrementalStake (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR IncrementalStake (Crypto era)
sd

instance
  ( TransValue FromCBOR era,
    FromCBOR (State (Core.EraRule "PPUP" era)),
    FromSharedCBOR (Core.TxOut era),
    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
    HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era)
  ) =>
  FromSharedCBOR (UTxOState era)
  where
  type
    Share (UTxOState era) =
      Interns (Credential 'Staking (Crypto era))
  fromSharedCBOR :: Share (UTxOState era) -> Decoder s (UTxOState era)
fromSharedCBOR Share (UTxOState era)
credInterns =
    Text
-> (UTxOState era -> Int)
-> Decoder s (UTxOState era)
-> Decoder s (UTxOState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"UTxOState" (Int -> UTxOState era -> Int
forall a b. a -> b -> a
const Int
5) (Decoder s (UTxOState era) -> Decoder s (UTxOState era))
-> Decoder s (UTxOState era) -> Decoder s (UTxOState era)
forall a b. (a -> b) -> a -> b
$ do
      UTxO era
_utxo <- Share (UTxO era) -> Decoder s (UTxO era)
forall a s. FromSharedCBOR a => Share a -> Decoder s a
fromSharedCBOR Share (UTxO era)
Share (UTxOState era)
credInterns
      Coin
_deposited <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Coin
_fees <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      State (EraRule "PPUP" era)
_ppups <- Decoder s (State (EraRule "PPUP" era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      IncrementalStake (Crypto era)
_stakeDistro <- Share (IncrementalStake (Crypto era))
-> Decoder s (IncrementalStake (Crypto era))
forall a s. FromSharedCBOR a => Share a -> Decoder s a
fromSharedCBOR Share (UTxOState era)
Share (IncrementalStake (Crypto era))
credInterns
      UTxOState era -> Decoder s (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOState :: forall era.
UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
UTxOState {UTxO era
_utxo :: UTxO era
_utxo :: UTxO era
_utxo, Coin
_deposited :: Coin
_deposited :: Coin
_deposited, Coin
_fees :: Coin
_fees :: Coin
_fees, State (EraRule "PPUP" era)
_ppups :: State (EraRule "PPUP" era)
_ppups :: State (EraRule "PPUP" era)
_ppups, IncrementalStake (Crypto era)
_stakeDistro :: IncrementalStake (Crypto era)
_stakeDistro :: IncrementalStake (Crypto era)
_stakeDistro}

-- | New Epoch state and environment
data NewEpochState era = NewEpochState
  { -- | Last epoch
    NewEpochState era -> EpochNo
nesEL :: !EpochNo,
    -- | Blocks made before current epoch
    NewEpochState era -> BlocksMade (Crypto era)
nesBprev :: !(BlocksMade (Crypto era)),
    -- | Blocks made in current epoch
    NewEpochState era -> BlocksMade (Crypto era)
nesBcur :: !(BlocksMade (Crypto era)),
    -- | Epoch state before current
    NewEpochState era -> EpochState era
nesEs :: !(EpochState era),
    -- | Possible reward update
    NewEpochState era -> StrictMaybe (PulsingRewUpdate (Crypto era))
nesRu :: !(StrictMaybe (PulsingRewUpdate (Crypto era))),
    -- | Stake distribution within the stake pool
    NewEpochState era -> PoolDistr (Crypto era)
nesPd :: !(PoolDistr (Crypto era)),
    -- | AVVM addresses to be removed at the end of the Shelley era. Note that
    -- the existence of this field is a hack, related to the transition of UTxO
    -- to disk. We remove AVVM addresses from the UTxO on the Shelley/Allegra
    -- boundary. However, by this point the UTxO will be moved to disk, and
    -- hence doing a scan of the UTxO for AVVM addresses will be expensive. Our
    -- solution to this is to do a scan of the UTxO on the Byron/Shelley
    -- boundary (since Byron UTxO are still on disk), stash the results here,
    -- and then remove them at the Shelley/Allegra boundary.
    --
    -- This is very much an awkward implementation hack, and hence we hide it
    -- from as many places as possible.
    NewEpochState era -> StashedAVVMAddresses era
stashedAVVMAddresses :: !(StashedAVVMAddresses era)
  }
  deriving ((forall x. NewEpochState era -> Rep (NewEpochState era) x)
-> (forall x. Rep (NewEpochState era) x -> NewEpochState era)
-> Generic (NewEpochState era)
forall x. Rep (NewEpochState era) x -> NewEpochState era
forall x. NewEpochState era -> Rep (NewEpochState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (NewEpochState era) x -> NewEpochState era
forall era x. NewEpochState era -> Rep (NewEpochState era) x
$cto :: forall era x. Rep (NewEpochState era) x -> NewEpochState era
$cfrom :: forall era x. NewEpochState era -> Rep (NewEpochState era) x
Generic)

type family StashedAVVMAddresses era where
  StashedAVVMAddresses (ShelleyEra c) = UTxO (ShelleyEra c)
  StashedAVVMAddresses _ = ()

deriving stock instance
  ( CC.Crypto (Crypto era),
    Show (Core.TxOut era),
    Show (Core.PParams era),
    Show (State (Core.EraRule "PPUP" era)),
    Show (StashedAVVMAddresses era)
  ) =>
  Show (NewEpochState era)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Eq (Core.TxOut era),
    Eq (Core.PParams era),
    Eq (State (Core.EraRule "PPUP" era)),
    Eq (StashedAVVMAddresses era)
  ) =>
  Eq (NewEpochState era)

instance
  ( Era era,
    NFData (Core.TxOut era),
    NFData (Core.PParams era),
    NFData (State (Core.EraRule "PPUP" era)),
    NFData (StashedAVVMAddresses era)
  ) =>
  NFData (NewEpochState era)

instance
  ( Era era,
    NoThunks (Core.TxOut era),
    NoThunks (Core.PParams era),
    NoThunks (State (Core.EraRule "PPUP" era)),
    NoThunks (Core.Value era),
    NoThunks (StashedAVVMAddresses era),
    ToCBOR (Core.TxBody era),
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.Value era)
  ) =>
  NoThunks (NewEpochState era)

instance
  ( Era era,
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.PParams era),
    ToCBOR (State (Core.EraRule "PPUP" era)),
    ToCBOR (StashedAVVMAddresses era)
  ) =>
  ToCBOR (NewEpochState era)
  where
  toCBOR :: NewEpochState era -> Encoding
toCBOR (NewEpochState EpochNo
e BlocksMade (Crypto era)
bp BlocksMade (Crypto era)
bc EpochState era
es StrictMaybe (PulsingRewUpdate (Crypto era))
ru PoolDistr (Crypto era)
pd StashedAVVMAddresses era
av) =
    Word -> Encoding
encodeListLen Word
7
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR EpochNo
e
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlocksMade (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR BlocksMade (Crypto era)
bp
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlocksMade (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR BlocksMade (Crypto era)
bc
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR EpochState era
es
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StrictMaybe (PulsingRewUpdate (Crypto era)) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR StrictMaybe (PulsingRewUpdate (Crypto era))
ru
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PoolDistr (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PoolDistr (Crypto era)
pd
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StashedAVVMAddresses era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR StashedAVVMAddresses era
av

instance
  ( Era era,
    FromCBOR (Core.PParams era),
    FromSharedCBOR (Core.TxOut era),
    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
    FromCBOR (Core.Value era),
    FromCBOR (State (Core.EraRule "PPUP" era)),
    FromCBOR (StashedAVVMAddresses era)
  ) =>
  FromCBOR (NewEpochState era)
  where
  fromCBOR :: Decoder s (NewEpochState era)
fromCBOR = do
    Decode ('Closed 'Dense) (NewEpochState era)
-> Decoder s (NewEpochState era)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (NewEpochState era)
 -> Decoder s (NewEpochState era))
-> Decode ('Closed 'Dense) (NewEpochState era)
-> Decoder s (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
      (EpochNo
 -> BlocksMade (Crypto era)
 -> BlocksMade (Crypto era)
 -> EpochState era
 -> StrictMaybe (PulsingRewUpdate (Crypto era))
 -> PoolDistr (Crypto era)
 -> StashedAVVMAddresses era
 -> NewEpochState era)
-> Decode
     ('Closed 'Dense)
     (EpochNo
      -> BlocksMade (Crypto era)
      -> BlocksMade (Crypto era)
      -> EpochState era
      -> StrictMaybe (PulsingRewUpdate (Crypto era))
      -> PoolDistr (Crypto era)
      -> StashedAVVMAddresses era
      -> NewEpochState era)
forall t. t -> Decode ('Closed 'Dense) t
RecD EpochNo
-> BlocksMade (Crypto era)
-> BlocksMade (Crypto era)
-> EpochState era
-> StrictMaybe (PulsingRewUpdate (Crypto era))
-> PoolDistr (Crypto era)
-> StashedAVVMAddresses era
-> NewEpochState era
forall era.
EpochNo
-> BlocksMade (Crypto era)
-> BlocksMade (Crypto era)
-> EpochState era
-> StrictMaybe (PulsingRewUpdate (Crypto era))
-> PoolDistr (Crypto era)
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
        Decode
  ('Closed 'Dense)
  (EpochNo
   -> BlocksMade (Crypto era)
   -> BlocksMade (Crypto era)
   -> EpochState era
   -> StrictMaybe (PulsingRewUpdate (Crypto era))
   -> PoolDistr (Crypto era)
   -> StashedAVVMAddresses era
   -> NewEpochState era)
-> Decode ('Closed Any) EpochNo
-> Decode
     ('Closed 'Dense)
     (BlocksMade (Crypto era)
      -> BlocksMade (Crypto era)
      -> EpochState era
      -> StrictMaybe (PulsingRewUpdate (Crypto era))
      -> PoolDistr (Crypto era)
      -> StashedAVVMAddresses era
      -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) EpochNo
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (BlocksMade (Crypto era)
   -> BlocksMade (Crypto era)
   -> EpochState era
   -> StrictMaybe (PulsingRewUpdate (Crypto era))
   -> PoolDistr (Crypto era)
   -> StashedAVVMAddresses era
   -> NewEpochState era)
-> Decode ('Closed Any) (BlocksMade (Crypto era))
-> Decode
     ('Closed 'Dense)
     (BlocksMade (Crypto era)
      -> EpochState era
      -> StrictMaybe (PulsingRewUpdate (Crypto era))
      -> PoolDistr (Crypto era)
      -> StashedAVVMAddresses era
      -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (BlocksMade (Crypto era))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (BlocksMade (Crypto era)
   -> EpochState era
   -> StrictMaybe (PulsingRewUpdate (Crypto era))
   -> PoolDistr (Crypto era)
   -> StashedAVVMAddresses era
   -> NewEpochState era)
-> Decode ('Closed Any) (BlocksMade (Crypto era))
-> Decode
     ('Closed 'Dense)
     (EpochState era
      -> StrictMaybe (PulsingRewUpdate (Crypto era))
      -> PoolDistr (Crypto era)
      -> StashedAVVMAddresses era
      -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (BlocksMade (Crypto era))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (EpochState era
   -> StrictMaybe (PulsingRewUpdate (Crypto era))
   -> PoolDistr (Crypto era)
   -> StashedAVVMAddresses era
   -> NewEpochState era)
-> Decode ('Closed Any) (EpochState era)
-> Decode
     ('Closed 'Dense)
     (StrictMaybe (PulsingRewUpdate (Crypto era))
      -> PoolDistr (Crypto era)
      -> StashedAVVMAddresses era
      -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (EpochState era)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (StrictMaybe (PulsingRewUpdate (Crypto era))
   -> PoolDistr (Crypto era)
   -> StashedAVVMAddresses era
   -> NewEpochState era)
-> Decode
     ('Closed Any) (StrictMaybe (PulsingRewUpdate (Crypto era)))
-> Decode
     ('Closed 'Dense)
     (PoolDistr (Crypto era)
      -> StashedAVVMAddresses era -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (PoolDistr (Crypto era)
   -> StashedAVVMAddresses era -> NewEpochState era)
-> Decode ('Closed Any) (PoolDistr (Crypto era))
-> Decode
     ('Closed 'Dense) (StashedAVVMAddresses era -> NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (PoolDistr (Crypto era))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense) (StashedAVVMAddresses era -> NewEpochState era)
-> Decode ('Closed Any) (StashedAVVMAddresses era)
-> Decode ('Closed 'Dense) (NewEpochState era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (StashedAVVMAddresses era)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From

getGKeys ::
  NewEpochState era ->
  Set (KeyHash 'Genesis (Crypto era))
getGKeys :: NewEpochState era -> Set (KeyHash 'Genesis (Crypto era))
getGKeys NewEpochState era
nes = Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Set (KeyHash 'Genesis (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs
  where
    NewEpochState EpochNo
_ BlocksMade (Crypto era)
_ BlocksMade (Crypto era)
_ EpochState era
es StrictMaybe (PulsingRewUpdate (Crypto era))
_ PoolDistr (Crypto era)
_ StashedAVVMAddresses era
_ = NewEpochState era
nes
    EpochState AccountState
_ SnapShots (Crypto era)
_ LedgerState era
ls PParams era
_ PParams era
_ NonMyopic (Crypto era)
_ = EpochState era
es
    LedgerState UTxOState era
_ (DPState (DState UnifiedMap (Crypto era)
_ Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
_ (GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs) InstantaneousRewards (Crypto era)
_) PState (Crypto era)
_) = LedgerState era
ls

-- | The state associated with a 'Ledger'.
data LedgerState era = LedgerState
  { -- | The current unspent transaction outputs.
    LedgerState era -> UTxOState era
lsUTxOState :: !(UTxOState era),
    -- | The current delegation state
    LedgerState era -> DPState (Crypto era)
lsDPState :: !(DPState (Crypto era))
  }
  deriving ((forall x. LedgerState era -> Rep (LedgerState era) x)
-> (forall x. Rep (LedgerState era) x -> LedgerState era)
-> Generic (LedgerState era)
forall x. Rep (LedgerState era) x -> LedgerState era
forall x. LedgerState era -> Rep (LedgerState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (LedgerState era) x -> LedgerState era
forall era x. LedgerState era -> Rep (LedgerState era) x
$cto :: forall era x. Rep (LedgerState era) x -> LedgerState era
$cfrom :: forall era x. LedgerState era -> Rep (LedgerState era) x
Generic)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Show (Core.TxOut era),
    Show (State (Core.EraRule "PPUP" era))
  ) =>
  Show (LedgerState era)

deriving stock instance
  ( CC.Crypto (Crypto era),
    Eq (Core.TxOut era),
    Eq (State (Core.EraRule "PPUP" era))
  ) =>
  Eq (LedgerState era)

instance
  ( Era era,
    NoThunks (Core.TxOut era),
    NoThunks (State (Core.EraRule "PPUP" era)),
    NoThunks (Core.Value era),
    ToCBOR (Core.TxBody era),
    ToCBOR (Core.TxOut era),
    ToCBOR (Core.Value era)
  ) =>
  NoThunks (LedgerState era)

instance
  ( Era era,
    NFData (Core.TxOut era),
    NFData (State (Core.EraRule "PPUP" era))
  ) =>
  NFData (LedgerState era)

instance
  ( Era era,
    ToCBOR (Core.TxOut era),
    ToCBOR (State (Core.EraRule "PPUP" era))
  ) =>
  ToCBOR (LedgerState era)
  where
  toCBOR :: LedgerState era -> Encoding
toCBOR LedgerState {UTxOState era
lsUTxOState :: UTxOState era
lsUTxOState :: forall era. LedgerState era -> UTxOState era
lsUTxOState, DPState (Crypto era)
lsDPState :: DPState (Crypto era)
lsDPState :: forall era. LedgerState era -> DPState (Crypto era)
lsDPState} =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DPState (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DPState (Crypto era)
lsDPState -- encode delegation state first to improve sharing
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxOState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UTxOState era
lsUTxOState

instance
  ( Era era,
    HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era),
    FromCBOR (Core.Value era),
    FromSharedCBOR (Core.TxOut era),
    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
    FromCBOR (State (Core.EraRule "PPUP" era))
  ) =>
  FromSharedCBOR (LedgerState era)
  where
  type
    Share (LedgerState era) =
      (Interns (Credential 'Staking (Crypto era)), Interns (KeyHash 'StakePool (Crypto era)))
  fromSharedPlusCBOR :: StateT (Share (LedgerState era)) (Decoder s) (LedgerState era)
fromSharedPlusCBOR =
    Text
-> (LedgerState era -> Int)
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (LedgerState era)
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (LedgerState era)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"LedgerState" (Int -> LedgerState era -> Int
forall a b. a -> b -> a
const Int
2) (StateT
   (Interns (Credential 'Staking (Crypto era)),
    Interns (KeyHash 'StakePool (Crypto era)))
   (Decoder s)
   (LedgerState era)
 -> StateT
      (Interns (Credential 'Staking (Crypto era)),
       Interns (KeyHash 'StakePool (Crypto era)))
      (Decoder s)
      (LedgerState era))
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (LedgerState era)
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (LedgerState era)
forall a b. (a -> b) -> a -> b
$ do
      DPState (Crypto era)
lsDPState <- StateT
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Decoder s)
  (DPState (Crypto era))
forall a s. FromSharedCBOR a => StateT (Share a) (Decoder s) a
fromSharedPlusCBOR
      UTxOState era
lsUTxOState <- SimpleGetter
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Share (UTxOState era))
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (UTxOState era)
forall b bs s.
FromSharedCBOR b =>
SimpleGetter bs (Share b) -> StateT bs (Decoder s) b
fromSharedLensCBOR SimpleGetter
  (Interns (Credential 'Staking (Crypto era)),
   Interns (KeyHash 'StakePool (Crypto era)))
  (Share (UTxOState era))
forall s t a b. Field1 s t a b => Lens s t a b
_1
      LedgerState era
-> StateT
     (Interns (Credential 'Staking (Crypto era)),
      Interns (KeyHash 'StakePool (Crypto era)))
     (Decoder s)
     (LedgerState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerState :: forall era.
UTxOState era -> DPState (Crypto era) -> LedgerState era
LedgerState {UTxOState era
lsUTxOState :: UTxOState era
lsUTxOState :: UTxOState era
lsUTxOState, DPState (Crypto era)
lsDPState :: DPState (Crypto era)
lsDPState :: DPState (Crypto era)
lsDPState}

-- | Creates the ledger state for an empty ledger which
--  contains the specified transaction outputs.
genesisState ::
  Default (State (Core.EraRule "PPUP" era)) =>
  Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)) ->
  UTxO era ->
  LedgerState era
genesisState :: Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> UTxO era -> LedgerState era
genesisState Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs0 UTxO era
utxo0 =
  UTxOState era -> DPState (Crypto era) -> LedgerState era
forall era.
UTxOState era -> DPState (Crypto era) -> LedgerState era
LedgerState
    ( UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
forall era.
UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
UTxOState
        UTxO era
utxo0
        (Integer -> Coin
Coin Integer
0)
        (Integer -> Coin
Coin Integer
0)
        State (EraRule "PPUP" era)
forall a. Default a => a
def
        (Map (Credential 'Staking (Crypto era)) Coin
-> Map Ptr Coin -> IncrementalStake (Crypto era)
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake Map (Credential 'Staking (Crypto era)) Coin
forall a. Monoid a => a
mempty Map Ptr Coin
forall k a. Map k a
Map.empty)
    )
    (DState (Crypto era) -> PState (Crypto era) -> DPState (Crypto era)
forall crypto. DState crypto -> PState crypto -> DPState crypto
DPState DState (Crypto era)
dState PState (Crypto era)
forall a. Default a => a
def)
  where
    dState :: DState (Crypto era)
dState = DState (Crypto era)
forall a. Default a => a
def {_genDelegs :: GenDelegs (Crypto era)
_genDelegs = Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs0}

-- | Convenience Function to bound the txsize function.
-- | It can be helpful for coin selection.
txsizeBound ::
  forall era out tx.
  ( HasField "outputs" (Core.TxBody era) (StrictSeq out),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "body" tx (Core.TxBody era),
    HasField "txsize" tx Integer
  ) =>
  Proxy era ->
  tx ->
  Integer
txsizeBound :: Proxy era -> tx -> Integer
txsizeBound Proxy era
Proxy tx
tx = Integer
numInputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
inputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
numOutputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
outputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
rest
  where
    uint :: Integer
uint = Integer
5
    smallArray :: Integer
smallArray = Integer
1
    hashLen :: Integer
hashLen = Integer
32
    hashObj :: Integer
hashObj = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashLen
    addrHashLen :: Integer
addrHashLen = Integer
28
    addrHeader :: Integer
addrHeader = Integer
1
    address :: Integer
address = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
addrHeader Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
addrHashLen
    txbody :: TxBody era
txbody = tx -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" tx
tx
    numInputs :: Integer
numInputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (TxBody era -> Int) -> TxBody era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TxIn (Crypto era)) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set (TxIn (Crypto era)) -> Int)
-> (TxBody era -> Set (TxIn (Crypto era))) -> TxBody era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "inputs" r a => r -> a
getField @"inputs" (TxBody era -> Integer) -> TxBody era -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody
    inputSize :: Integer
inputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashObj
    numOutputs :: Integer
numOutputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (TxBody era -> Int) -> TxBody era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq out -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (StrictSeq out -> Int)
-> (TxBody era -> StrictSeq out) -> TxBody era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "outputs" r a => r -> a
getField @"outputs" (TxBody era -> Integer) -> TxBody era -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody
    outputSize :: Integer
outputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
address
    rest :: Integer
rest = tx -> Integer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txsize" tx
tx

-- | Minimum fee calculation
minfee ::
  ( HasField "_minfeeA" pp Natural,
    HasField "_minfeeB" pp Natural,
    HasField "txsize" tx Integer
  ) =>
  pp ->
  tx ->
  Coin
minfee :: pp -> tx -> Coin
minfee pp
pp tx
tx =
  Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$
    Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (pp -> Natural
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_minfeeA" pp
pp)
      Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* tx -> Integer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txsize" tx
tx Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (pp -> Natural
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_minfeeB" pp
pp)

-- | Compute the lovelace which are created by the transaction
produced ::
  forall era pp.
  ( Era era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "_keyDeposit" pp Coin,
    HasField "_poolDeposit" pp Coin
  ) =>
  pp ->
  (KeyHash 'StakePool (Crypto era) -> Bool) ->
  Core.TxBody era ->
  Core.Value era
produced :: pp
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> TxBody era
-> Value era
produced pp
pp KeyHash 'StakePool (Crypto era) -> Bool
isNewPool TxBody era
tx =
  UTxO era -> Value era
forall era. Era era => UTxO era -> Value era
balance (TxBody era -> UTxO era
forall era. Era era => TxBody era -> UTxO era
txouts TxBody era
tx)
    Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t. Val t => Coin -> t
Val.inject
      ( TxBody era -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txfee" TxBody era
tx
          Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> pp
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> [DCert (Crypto era)]
-> Coin
forall pp crypto.
(HasField "_poolDeposit" pp Coin,
 HasField "_keyDeposit" pp Coin) =>
pp -> (KeyHash 'StakePool crypto -> Bool) -> [DCert crypto] -> Coin
totalDeposits pp
pp KeyHash 'StakePool (Crypto era) -> Bool
isNewPool (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)])
-> StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
tx)
      )

-- | Compute the key deregistration refunds in a transaction
keyRefunds ::
  ( HasField "certs" txb (StrictSeq (DCert crypto)),
    HasField "_keyDeposit" pp Coin
  ) =>
  pp ->
  txb ->
  Coin
keyRefunds :: pp -> txb -> Coin
keyRefunds pp
pp txb
tx = [DCert crypto] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DCert crypto]
deregistrations Int -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> pp -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_keyDeposit" pp
pp
  where
    deregistrations :: [DCert crypto]
deregistrations = (DCert crypto -> Bool) -> [DCert crypto] -> [DCert crypto]
forall a. (a -> Bool) -> [a] -> [a]
filter DCert crypto -> Bool
forall crypto. DCert crypto -> Bool
isDeRegKey (StrictSeq (DCert crypto) -> [DCert crypto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert crypto) -> [DCert crypto])
-> StrictSeq (DCert crypto) -> [DCert crypto]
forall a b. (a -> b) -> a -> b
$ txb -> StrictSeq (DCert crypto)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" txb
tx)

-- | Compute the lovelace which are destroyed by the transaction
consumed ::
  forall era pp.
  ( Era era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "_keyDeposit" pp Coin
  ) =>
  pp ->
  UTxO era ->
  Core.TxBody era ->
  Core.Value era
consumed :: pp -> UTxO era -> TxBody era -> Value era
consumed pp
pp (UTxO Map (TxIn (Crypto era)) (TxOut era)
u) TxBody era
tx =
  {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -}
  (Value era -> TxIn (Crypto era) -> Value era)
-> Value era -> Set (TxIn (Crypto era)) -> Value era
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Value era -> TxIn (Crypto era) -> Value era
lookupAddTxOut Value era
forall a. Monoid a => a
mempty (TxBody era -> Set (TxIn (Crypto era))
forall era.
HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))) =>
TxBody era -> Set (TxIn (Crypto era))
txins @era TxBody era
tx)
    Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> Coin -> Value era
forall t. Val t => Coin -> t
Val.inject (Coin
refunds Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
withdrawals)
  where
    lookupAddTxOut :: Value era -> TxIn (Crypto era) -> Value era
lookupAddTxOut Value era
acc TxIn (Crypto era)
txin = Value era
-> (TxOut era -> Value era) -> Maybe (TxOut era) -> Value era
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value era
acc (Value era -> TxOut era -> Value era
forall t r. (Val t, HasField "value" r t) => t -> r -> t
addTxOut Value era
acc) (Maybe (TxOut era) -> Value era) -> Maybe (TxOut era) -> Value era
forall a b. (a -> b) -> a -> b
$ TxIn (Crypto era)
-> Map (TxIn (Crypto era)) (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (Crypto era)
txin Map (TxIn (Crypto era)) (TxOut era)
u
    addTxOut :: t -> r -> t
addTxOut !t
b r
out = r -> t
forall k (x :: k) r a. HasField x r a => r -> a
getField @"value" r
out t -> t -> t
forall t. Val t => t -> t -> t
<+> t
b
    refunds :: Coin
refunds = pp -> TxBody era -> Coin
forall txb crypto pp.
(HasField "certs" txb (StrictSeq (DCert crypto)),
 HasField "_keyDeposit" pp Coin) =>
pp -> txb -> Coin
keyRefunds pp
pp TxBody era
tx
    withdrawals :: Coin
withdrawals = Map (RewardAcnt (Crypto era)) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (RewardAcnt (Crypto era)) Coin -> Coin)
-> (Wdrl (Crypto era) -> Map (RewardAcnt (Crypto era)) Coin)
-> Wdrl (Crypto era)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wdrl (Crypto era) -> Map (RewardAcnt (Crypto era)) Coin
forall crypto. Wdrl crypto -> Map (RewardAcnt crypto) Coin
unWdrl (Wdrl (Crypto era) -> Coin) -> Wdrl (Crypto era) -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody era -> Wdrl (Crypto era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wdrls" TxBody era
tx

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

newtype WitHashes crypto = WitHashes
  {WitHashes crypto -> Set (KeyHash 'Witness crypto)
unWitHashes :: Set (KeyHash 'Witness crypto)}
  deriving (WitHashes crypto -> WitHashes crypto -> Bool
(WitHashes crypto -> WitHashes crypto -> Bool)
-> (WitHashes crypto -> WitHashes crypto -> Bool)
-> Eq (WitHashes crypto)
forall crypto. WitHashes crypto -> WitHashes crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WitHashes crypto -> WitHashes crypto -> Bool
$c/= :: forall crypto. WitHashes crypto -> WitHashes crypto -> Bool
== :: WitHashes crypto -> WitHashes crypto -> Bool
$c== :: forall crypto. WitHashes crypto -> WitHashes crypto -> Bool
Eq, (forall x. WitHashes crypto -> Rep (WitHashes crypto) x)
-> (forall x. Rep (WitHashes crypto) x -> WitHashes crypto)
-> Generic (WitHashes crypto)
forall x. Rep (WitHashes crypto) x -> WitHashes crypto
forall x. WitHashes crypto -> Rep (WitHashes crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (WitHashes crypto) x -> WitHashes crypto
forall crypto x. WitHashes crypto -> Rep (WitHashes crypto) x
$cto :: forall crypto x. Rep (WitHashes crypto) x -> WitHashes crypto
$cfrom :: forall crypto x. WitHashes crypto -> Rep (WitHashes crypto) x
Generic)
  deriving (Int -> WitHashes crypto -> ShowS
[WitHashes crypto] -> ShowS
WitHashes crypto -> String
(Int -> WitHashes crypto -> ShowS)
-> (WitHashes crypto -> String)
-> ([WitHashes crypto] -> ShowS)
-> Show (WitHashes crypto)
forall crypto. Int -> WitHashes crypto -> ShowS
forall crypto. [WitHashes crypto] -> ShowS
forall crypto. WitHashes crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WitHashes crypto] -> ShowS
$cshowList :: forall crypto. [WitHashes crypto] -> ShowS
show :: WitHashes crypto -> String
$cshow :: forall crypto. WitHashes crypto -> String
showsPrec :: Int -> WitHashes crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> WitHashes crypto -> ShowS
Show) via Quiet (WitHashes crypto)

instance NoThunks (WitHashes crypto)

-- | Check if a set of witness hashes is empty.
nullWitHashes :: WitHashes crypto -> Bool
nullWitHashes :: WitHashes crypto -> Bool
nullWitHashes (WitHashes Set (KeyHash 'Witness crypto)
a) = Set (KeyHash 'Witness crypto) -> Bool
forall a. Set a -> Bool
Set.null Set (KeyHash 'Witness crypto)
a

-- | Extract the difference between two sets of witness hashes.
diffWitHashes :: WitHashes crypto -> WitHashes crypto -> WitHashes crypto
diffWitHashes :: WitHashes crypto -> WitHashes crypto -> WitHashes crypto
diffWitHashes (WitHashes Set (KeyHash 'Witness crypto)
x) (WitHashes Set (KeyHash 'Witness crypto)
x') =
  Set (KeyHash 'Witness crypto) -> WitHashes crypto
forall crypto. Set (KeyHash 'Witness crypto) -> WitHashes crypto
WitHashes (Set (KeyHash 'Witness crypto)
x Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (KeyHash 'Witness crypto)
x')

-- | Extract the witness hashes from the Transaction.
witsFromTxWitnesses ::
  ( Era era,
    HasField "addrWits" tx (Set (WitVKey 'Witness (Crypto era))),
    HasField "bootWits" tx (Set (BootstrapWitness (Crypto era)))
  ) =>
  tx ->
  WitHashes (Crypto era)
witsFromTxWitnesses :: tx -> WitHashes (Crypto era)
witsFromTxWitnesses tx
coreTx =
  Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era)
forall crypto. Set (KeyHash 'Witness crypto) -> WitHashes crypto
WitHashes (Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era))
-> Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era)
forall a b. (a -> b) -> a -> b
$
    (WitVKey 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era))
-> Set (WitVKey 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WitVKey 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (kr :: KeyRole) crypto.
WitVKey kr crypto -> KeyHash 'Witness crypto
witKeyHash Set (WitVKey 'Witness (Crypto era))
addWits
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (BootstrapWitness (Crypto era) -> KeyHash 'Witness (Crypto era))
-> Set (BootstrapWitness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map BootstrapWitness (Crypto era) -> KeyHash 'Witness (Crypto era)
forall crypto.
Crypto crypto =>
BootstrapWitness crypto -> KeyHash 'Witness crypto
bootstrapWitKeyHash Set (BootstrapWitness (Crypto era))
bsWits
  where
    bsWits :: Set (BootstrapWitness (Crypto era))
bsWits = tx -> Set (BootstrapWitness (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"bootWits" tx
coreTx
    addWits :: Set (WitVKey 'Witness (Crypto era))
addWits = tx -> Set (WitVKey 'Witness (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"addrWits" tx
coreTx

-- | Calculate the set of hash keys of the required witnesses for update
-- proposals.
propWits ::
  Maybe (Update era) ->
  GenDelegs (Crypto era) ->
  Set (KeyHash 'Witness (Crypto era))
propWits :: Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
propWits Maybe (Update era)
Nothing GenDelegs (Crypto era)
_ = Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty
propWits (Just (Update (ProposedPPUpdates Map (KeyHash 'Genesis (Crypto era)) (PParamsDelta era)
pup) EpochNo
_)) (GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs) =
  (KeyHash 'GenesisDelegate (Crypto era)
 -> KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'GenesisDelegate (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'GenesisDelegate (Crypto era)
-> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (Set (KeyHash 'GenesisDelegate (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> ([KeyHash 'GenesisDelegate (Crypto era)]
    -> Set (KeyHash 'GenesisDelegate (Crypto era)))
-> [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'GenesisDelegate (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'GenesisDelegate (Crypto era)]
 -> Set (KeyHash 'Witness (Crypto era)))
-> [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
-> [KeyHash 'GenesisDelegate (Crypto era)]
forall k a. Map k a -> [a]
Map.elems Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
updateKeys
  where
    updateKeys' :: Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
updateKeys' = Exp
  (Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
forall s t. Embed s t => Exp t -> s
eval (Map (KeyHash 'Genesis (Crypto era)) (PParamsDelta era)
-> Set (KeyHash 'Genesis (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis (Crypto era)) (PParamsDelta era)
pup Set (KeyHash 'Genesis (Crypto era))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Exp
     (Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs)
    updateKeys :: Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
updateKeys = (GenDelegPair (Crypto era)
 -> KeyHash 'GenesisDelegate (Crypto era))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Map
     (KeyHash 'Genesis (Crypto era))
     (KeyHash 'GenesisDelegate (Crypto era))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GenDelegPair (Crypto era) -> KeyHash 'GenesisDelegate (Crypto era)
forall crypto.
GenDelegPair crypto -> KeyHash 'GenesisDelegate crypto
genDelegKeyHash Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
updateKeys'

-- Functions for stake delegation model

-- | Calculate the change to the deposit pool for a given transaction.
depositPoolChange ::
  ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era)))
  ) =>
  LedgerState era ->
  PParams era ->
  Core.TxBody era ->
  Coin
depositPoolChange :: LedgerState era -> PParams era -> TxBody era -> Coin
depositPoolChange LedgerState era
ls PParams era
pp TxBody era
tx = (Coin
currentPool Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
txDeposits) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
txRefunds
  where
    -- Note that while (currentPool + txDeposits) >= txRefunds,
    -- it could be that txDeposits < txRefunds. We keep the parenthesis above
    -- to emphasize this point.

    currentPool :: Coin
currentPool = (UTxOState era -> Coin
forall era. UTxOState era -> Coin
_deposited (UTxOState era -> Coin)
-> (LedgerState era -> UTxOState era) -> LedgerState era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState) LedgerState era
ls
    pools :: Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
pools = PState (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams (PState (Crypto era)
 -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)))
-> (LedgerState era -> PState (Crypto era))
-> LedgerState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPState (Crypto era) -> PState (Crypto era)
forall crypto. DPState crypto -> PState crypto
dpsPState (DPState (Crypto era) -> PState (Crypto era))
-> (LedgerState era -> DPState (Crypto era))
-> LedgerState era
-> PState (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> DPState (Crypto era)
forall era. LedgerState era -> DPState (Crypto era)
lsDPState (LedgerState era
 -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)))
-> LedgerState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
forall a b. (a -> b) -> a -> b
$ LedgerState era
ls
    txDeposits :: Coin
txDeposits =
      PParams era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> [DCert (Crypto era)]
-> Coin
forall pp crypto.
(HasField "_poolDeposit" pp Coin,
 HasField "_keyDeposit" pp Coin) =>
pp -> (KeyHash 'StakePool crypto -> Bool) -> [DCert crypto] -> Coin
totalDeposits PParams era
pp (KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
pools) (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)])
-> StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
tx)
    txRefunds :: Coin
txRefunds = PParams era -> TxBody era -> Coin
forall txb crypto pp.
(HasField "certs" txb (StrictSeq (DCert crypto)),
 HasField "_keyDeposit" pp Coin) =>
pp -> txb -> Coin
keyRefunds PParams era
pp TxBody era
tx

reapRewards ::
  UnifiedMap crypto ->
  RewardAccounts crypto ->
  UnifiedMap crypto
reapRewards :: UnifiedMap crypto -> RewardAccounts crypto -> UnifiedMap crypto
reapRewards (UnifiedMap Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
tmap Map Ptr (Credential 'Staking crypto)
ptrmap) RewardAccounts crypto
withdrawals = Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
-> Map Ptr (Credential 'Staking crypto) -> UnifiedMap crypto
forall coin cred pool ptr.
Map cred (Trip coin ptr pool)
-> Map ptr cred -> UMap coin cred pool ptr
UnifiedMap ((Credential 'Staking crypto
 -> Trip Coin Ptr (KeyHash 'StakePool crypto)
 -> Trip Coin Ptr (KeyHash 'StakePool crypto))
-> Map
     (Credential 'Staking crypto)
     (Trip Coin Ptr (KeyHash 'StakePool crypto))
-> Map
     (Credential 'Staking crypto)
     (Trip Coin Ptr (KeyHash 'StakePool crypto))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Credential 'Staking crypto
-> Trip Coin Ptr (KeyHash 'StakePool crypto)
-> Trip Coin Ptr (KeyHash 'StakePool crypto)
g Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
tmap) Map Ptr (Credential 'Staking crypto)
ptrmap
  where
    g :: Credential 'Staking crypto
-> Trip Coin Ptr (KeyHash 'StakePool crypto)
-> Trip Coin Ptr (KeyHash 'StakePool crypto)
g Credential 'Staking crypto
k (Triple StrictMaybe Coin
x Set Ptr
y StrictMaybe (KeyHash 'StakePool crypto)
z) = StrictMaybe Coin
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool crypto)
-> Trip Coin Ptr (KeyHash 'StakePool crypto)
forall coin ptr pool.
StrictMaybe coin
-> Set ptr -> StrictMaybe pool -> Trip coin ptr pool
Triple ((Coin -> Coin) -> StrictMaybe Coin -> StrictMaybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Credential 'Staking crypto -> Coin -> Coin
removeRewards Credential 'Staking crypto
k) StrictMaybe Coin
x) Set Ptr
y StrictMaybe (KeyHash 'StakePool crypto)
z
    removeRewards :: Credential 'Staking crypto -> Coin -> Coin
removeRewards Credential 'Staking crypto
k Coin
v = if Credential 'Staking crypto
k Credential 'Staking crypto -> RewardAccounts crypto -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` RewardAccounts crypto
withdrawals then Integer -> Coin
Coin Integer
0 else Coin
v

---------------------------------
-- epoch boundary calculations --
---------------------------------

compactCoinOrError :: Coin -> CompactForm Coin
compactCoinOrError :: Coin -> CompactForm Coin
compactCoinOrError Coin
c =
  case Coin -> Maybe (CompactForm Coin)
forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Coin
c of
    Maybe (CompactForm Coin)
Nothing -> String -> CompactForm Coin
forall a. HasCallStack => String -> a
error (String -> CompactForm Coin) -> String -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ String
"Invalid ADA value in staking: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show Coin
c
    Just CompactForm Coin
compactCoin -> CompactForm Coin
compactCoin

-- ==============================
-- operations on IncrementalStake

-- | Incrementally add the inserts 'utxoAdd' and the deletes 'utxoDel' to the IncrementalStake.
updateStakeDistribution ::
  ( Era era
  ) =>
  IncrementalStake (Crypto era) ->
  UTxO era ->
  UTxO era ->
  IncrementalStake (Crypto era)
updateStakeDistribution :: IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
updateStakeDistribution IncrementalStake (Crypto era)
incStake0 UTxO era
utxoDel UTxO era
utxoAdd = IncrementalStake (Crypto era)
incStake2
  where
    incStake1 :: IncrementalStake (Crypto era)
incStake1 = (Coin -> Coin)
-> UTxO era
-> IncrementalStake (Crypto era)
-> IncrementalStake (Crypto era)
forall era.
Era era =>
(Coin -> Coin)
-> UTxO era
-> IncrementalStake (Crypto era)
-> IncrementalStake (Crypto era)
incrementalAggregateUtxoCoinByCredential Coin -> Coin
forall a. a -> a
id UTxO era
utxoAdd IncrementalStake (Crypto era)
incStake0
    incStake2 :: IncrementalStake (Crypto era)
incStake2 = (Coin -> Coin)
-> UTxO era
-> IncrementalStake (Crypto era)
-> IncrementalStake (Crypto era)
forall era.
Era era =>
(Coin -> Coin)
-> UTxO era
-> IncrementalStake (Crypto era)
-> IncrementalStake (Crypto era)
incrementalAggregateUtxoCoinByCredential Coin -> Coin
forall m. Group m => m -> m
invert UTxO era
utxoDel IncrementalStake (Crypto era)
incStake1

-- | Incrementally sum up all the Coin for each staking Credential, use different 'mode' operations
--   for UTxO that are inserts (id) and UTxO that are deletes (invert). Never store a (Coin 0) balance,
--   since these do not occur in the non-incremental style that works directly from the whole UTxO.
--   This function has a non-incremental analog 'aggregateUtxoCoinByCredential' . In this incremental
--   version we expect the size of the UTxO to be fairly small. I.e the number of inputs and outputs
--   in a transaction, which is aways < 4096, not millions, and very often < 10).
incrementalAggregateUtxoCoinByCredential ::
  forall era.
  Era era =>
  (Coin -> Coin) ->
  UTxO era ->
  IncrementalStake (Crypto era) ->
  IncrementalStake (Crypto era)
incrementalAggregateUtxoCoinByCredential :: (Coin -> Coin)
-> UTxO era
-> IncrementalStake (Crypto era)
-> IncrementalStake (Crypto era)
incrementalAggregateUtxoCoinByCredential Coin -> Coin
mode (UTxO Map (TxIn (Crypto era)) (TxOut era)
u) IncrementalStake (Crypto era)
initial =
  (IncrementalStake (Crypto era)
 -> TxOut era -> IncrementalStake (Crypto era))
-> IncrementalStake (Crypto era)
-> Map (TxIn (Crypto era)) (TxOut era)
-> IncrementalStake (Crypto era)
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' IncrementalStake (Crypto era)
-> TxOut era -> IncrementalStake (Crypto era)
accum IncrementalStake (Crypto era)
initial Map (TxIn (Crypto era)) (TxOut era)
u
  where
    keepOrDelete :: Coin -> Maybe Coin -> Maybe Coin
keepOrDelete Coin
new Maybe Coin
Nothing =
      case Coin -> Coin
mode Coin
new of
        Coin Integer
0 -> Maybe Coin
forall a. Maybe a
Nothing
        Coin
final -> Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
final
    keepOrDelete Coin
new (Just Coin
old) =
      case Coin -> Coin
mode Coin
new Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
old of
        Coin Integer
0 -> Maybe Coin
forall a. Maybe a
Nothing
        Coin
final -> Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
final
    accum :: IncrementalStake (Crypto era)
-> TxOut era -> IncrementalStake (Crypto era)
accum ans :: IncrementalStake (Crypto era)
ans@(IStake Map (Credential 'Staking (Crypto era)) Coin
stake Map Ptr Coin
ptrs) TxOut era
out =
      let c :: Coin
c = Value era -> Coin
forall t. Val t => t -> Coin
Val.coin (TxOut era -> Value era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"value" TxOut era
out)
       in case TxOut era -> Addr (Crypto era)
forall e. Era e => TxOut e -> Addr (Crypto e)
getTxOutAddr TxOut era
out of
            Addr Network
_ PaymentCredential (Crypto era)
_ (StakeRefPtr Ptr
p) -> Map (Credential 'Staking (Crypto era)) Coin
-> Map Ptr Coin -> IncrementalStake (Crypto era)
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake Map (Credential 'Staking (Crypto era)) Coin
stake ((Maybe Coin -> Maybe Coin) -> Ptr -> Map Ptr Coin -> Map Ptr Coin
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Coin -> Maybe Coin -> Maybe Coin
keepOrDelete Coin
c) Ptr
p Map Ptr Coin
ptrs)
            Addr Network
_ PaymentCredential (Crypto era)
_ (StakeRefBase Credential 'Staking (Crypto era)
hk) -> Map (Credential 'Staking (Crypto era)) Coin
-> Map Ptr Coin -> IncrementalStake (Crypto era)
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin -> IncrementalStake crypto
IStake ((Maybe Coin -> Maybe Coin)
-> Credential 'Staking (Crypto era)
-> Map (Credential 'Staking (Crypto era)) Coin
-> Map (Credential 'Staking (Crypto era)) Coin
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Coin -> Maybe Coin -> Maybe Coin
keepOrDelete Coin
c) Credential 'Staking (Crypto era)
hk Map (Credential 'Staking (Crypto era)) Coin
stake) Map Ptr Coin
ptrs
            Addr (Crypto era)
_other -> IncrementalStake (Crypto era)
ans

-- A TxOut has 4 different shapes, depending on the shape of its embedded Addr.
-- Credentials are stored in only 2 of the 4 cases.
-- 1) TxOut (Addr _ _ (StakeRefBase cred)) coin   -> HERE
-- 2) TxOut (Addr _ _ (StakeRefPtr ptr)) coin     -> HERE
-- 3) TxOut (Addr _ _ StakeRefNull) coin          -> NOT HERE
-- 4) TxOut (AddrBootstrap _) coin                -> NOT HERE

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

-- | Compute the current state distribution by using the IncrementalStake,

-- | This computes the stake distribution using IncrementalStake (which is an
--   aggregate of the current UTxO) and UnifiedMap (which tracks Coin,
--   Delegations, and Ptrs simultaneously).  Note that logically:
--   1) IncrementalStake = (credStake, ptrStake)
--   2) UnifiedMap = (rewards, activeDelegs, ptrmap :: Map ptr cred)
--
--   Using this scheme the logic can do 3 things in one go, without touching the UTxO.
--   1) Resolve Pointers
--   2) Throw away things not actively delegated
--   3) Add up the coin
--
--   The Stake distribution function (Map cred coin) (the first component of a SnapShot)
--   is defined by this SetAlgebra expression:
--   (dom activeDelegs) ◁ (aggregate+ (credStake ∪ ptrStake ∪ rewards))
--
--   We can apply meaning preserving operations to get equivalent expressions
--
--   (dom activeDelegs) ◁ (aggregate+ (credStake ∪ ptrStake ∪ rewards))
--   aggregate+ (dom activeDelegs ◁ (credStake ∪ ptrStake ∪ rewards))
--   aggregate+ ((dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake) ∪ (dom activeDelegs ◁ rewards))
--
--   We will compute this in several steps
--   step1 = (dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake)
--   step2 =  aggregate (dom activeDelegs ◁ rewards) step1
--   This function has a non-incremental analog, 'stakeDistr', mosty used in tests, which does use the UTxO.
incrementalStakeDistr ::
  forall crypto.
  IncrementalStake crypto ->
  DState crypto ->
  PState crypto ->
  SnapShot crypto
incrementalStakeDistr :: IncrementalStake crypto
-> DState crypto -> PState crypto -> SnapShot crypto
incrementalStakeDistr IncrementalStake crypto
incstake DState crypto
ds PState crypto
ps =
  Stake crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
-> SnapShot crypto
forall crypto.
Stake crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
-> SnapShot crypto
SnapShot
    (VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> Stake crypto
forall crypto.
VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> Stake crypto
Stake (VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
 -> Stake crypto)
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> Stake crypto
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking crypto) (CompactForm Coin)
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap (Coin -> CompactForm Coin
compactCoinOrError (Coin -> CompactForm Coin)
-> Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) (CompactForm Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Credential 'Staking crypto) Coin
step2))
    VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegs
    (Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (KeyHash 'StakePool crypto) (PoolParams crypto)
poolParams)
  where
    UnifiedMap Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
tripmap Map Ptr (Credential 'Staking crypto)
ptrmap = DState crypto
-> UMap
     Coin (Credential 'Staking crypto) (KeyHash 'StakePool crypto) Ptr
forall crypto. DState crypto -> UnifiedMap crypto
_unified DState crypto
ds
    PState Map (KeyHash 'StakePool crypto) (PoolParams crypto)
poolParams Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_ Map (KeyHash 'StakePool crypto) EpochNo
_ = PState crypto
ps
    delegs :: VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegs = View
  Coin
  (Credential 'Staking crypto)
  (KeyHash 'StakePool crypto)
  Ptr
  (Credential 'Staking crypto)
  (KeyHash 'StakePool crypto)
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
forall cred coin pool ptr k v.
Ord cred =>
View coin cred pool ptr k v -> VMap VB VB k v
UM.viewToVMap (DState crypto
-> View
     Coin
     (Credential 'Staking crypto)
     (KeyHash 'StakePool crypto)
     Ptr
     (Credential 'Staking crypto)
     (KeyHash 'StakePool crypto)
forall crypto.
DState crypto
-> ViewMap
     crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegations DState crypto
ds)
    -- A credential is active, only if it is being delegated
    step1 :: Map (Credential 'Staking crypto) Coin
step1 = (Credential 'Staking crypto -> Bool)
-> Map Ptr (Credential 'Staking crypto)
-> IncrementalStake crypto
-> Map (Credential 'Staking crypto) Coin
forall crypto.
(Credential 'Staking crypto -> Bool)
-> Map Ptr (Credential 'Staking crypto)
-> IncrementalStake crypto
-> Map (Credential 'Staking crypto) Coin
resolveActiveIncrementalPtrs (Credential 'Staking crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Bool
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k) =>
k -> VMap kv vv k v -> Bool
`VMap.member` VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegs) Map Ptr (Credential 'Staking crypto)
ptrmap IncrementalStake crypto
incstake
    step2 :: Map (Credential 'Staking crypto) Coin
step2 = Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
-> Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
forall k crypto.
Ord k =>
Map k (Triple crypto) -> Map k Coin -> Map k Coin
aggregateActiveStake Map
  (Credential 'Staking crypto)
  (Trip Coin Ptr (KeyHash 'StakePool crypto))
tripmap Map (Credential 'Staking crypto) Coin
step1

-- | Resolve inserts and deletes which were indexed by Ptrs, by looking them
--   up in 'ptrs' and combining the result of the lookup with the ordinary stake.
--   keep ony the active credentials.
--   This is  step1 = (dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake)
resolveActiveIncrementalPtrs ::
  (Credential 'Staking crypto -> Bool) ->
  Map Ptr (Credential 'Staking crypto) ->
  IncrementalStake crypto ->
  Map (Credential 'Staking crypto) Coin
resolveActiveIncrementalPtrs :: (Credential 'Staking crypto -> Bool)
-> Map Ptr (Credential 'Staking crypto)
-> IncrementalStake crypto
-> Map (Credential 'Staking crypto) Coin
resolveActiveIncrementalPtrs Credential 'Staking crypto -> Bool
isActive Map Ptr (Credential 'Staking crypto)
ptrMap (IStake Map (Credential 'Staking crypto) Coin
credStake Map Ptr Coin
ptrStake) =
  (Map (Credential 'Staking crypto) Coin
 -> Ptr -> Coin -> Map (Credential 'Staking crypto) Coin)
-> Map (Credential 'Staking crypto) Coin
-> Map Ptr Coin
-> Map (Credential 'Staking crypto) Coin
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map (Credential 'Staking crypto) Coin
-> Ptr -> Coin -> Map (Credential 'Staking crypto) Coin
accum Map (Credential 'Staking crypto) Coin
step1A Map Ptr Coin
ptrStake -- step1A  ∪ (dom activeDelegs ◁ ptrStake)
  where
    -- (dom activeDelegs ◁ credStake)
    step1A :: Map (Credential 'Staking crypto) Coin
step1A = (Credential 'Staking crypto -> Coin -> Bool)
-> Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Credential 'Staking crypto
k Coin
_ -> Credential 'Staking crypto -> Bool
isActive Credential 'Staking crypto
k) Map (Credential 'Staking crypto) Coin
credStake
    accum :: Map (Credential 'Staking crypto) Coin
-> Ptr -> Coin -> Map (Credential 'Staking crypto) Coin
accum Map (Credential 'Staking crypto) Coin
ans Ptr
ptr Coin
coin =
      case Ptr
-> Map Ptr (Credential 'Staking crypto)
-> Maybe (Credential 'Staking crypto)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr
ptr Map Ptr (Credential 'Staking crypto)
ptrMap of -- Map ptrs to Credentials
        Maybe (Credential 'Staking crypto)
Nothing -> Map (Credential 'Staking crypto) Coin
ans
        Just Credential 'Staking crypto
cred ->
          if Credential 'Staking crypto -> Bool
isActive Credential 'Staking crypto
cred
            then (Coin -> Coin -> Coin)
-> Credential 'Staking crypto
-> Coin
-> Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) 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
(<>) Credential 'Staking crypto
cred Coin
coin Map (Credential 'Staking crypto) Coin
ans
            else Map (Credential 'Staking crypto) Coin
ans

-- | Aggregate active stake by merging two maps. The triple map from the
--   UnifiedMap, and the IncrementalStake Only keep the active stake. Active can
--   be determined if there is a (SJust deleg) in the Triple.  This is step2 =
--   aggregate (dom activeDelegs ◁ rewards) step1
aggregateActiveStake :: Ord k => Map k (Triple crypto) -> Map k Coin -> Map k Coin
aggregateActiveStake :: Map k (Triple crypto) -> Map k Coin -> Map k Coin
aggregateActiveStake Map k (Triple crypto)
tripmap Map k Coin
incremental =
  (k -> Triple crypto -> Coin -> Maybe Coin)
-> (Map k (Triple crypto) -> Map k Coin)
-> (Map k Coin -> Map k Coin)
-> Map k (Triple crypto)
-> Map k Coin
-> Map k Coin
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
    -- How to merge the ranges of the two maps where they have a common key. Below
    -- 'coin1' and 'coin2' have the same key, '_k', and the stake is active if the delegation is SJust
    (\k
_k Triple crypto
trip Coin
coin2 -> (Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
coin2) (Coin -> Coin) -> Maybe Coin -> Maybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Triple crypto -> Maybe Coin
forall coin ptr pool. Trip coin ptr pool -> Maybe coin
UM.tripRewardActiveDelegation Triple crypto
trip)
    -- what to do when a key appears just in 'tripmap', we only add the coin if the key is active
    ((Triple crypto -> Maybe Coin)
-> Map k (Triple crypto) -> Map k Coin
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Triple crypto -> Maybe Coin
forall coin ptr pool. Trip coin ptr pool -> Maybe coin
UM.tripRewardActiveDelegation)
    -- what to do when a key is only in 'incremental', keep everything, because at
    -- the call site of aggregateActiveStake, the arg 'incremental' is filtered by
    -- 'resolveActiveIncrementalPtrs' which guarantees that only active stake is included.
    Map k Coin -> Map k Coin
forall a. a -> a
id
    Map k (Triple crypto)
tripmap
    Map k Coin
incremental

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

-- | A valid (or self-consistent) UTxOState{_utxo, _deposited, _fees, _ppups, _stakeDistro}
--   maintains an invariant between the _utxo and _stakeDistro fields. the _stakeDistro field is
--   the aggregation of Coin over the StakeReferences in the UTxO. It can be computed by a pure
--   function from the _utxo field. In some situations, mostly unit or example tests, or when
--   initializing a small UTxO, we want to create a UTxOState that computes the _stakeDistro from
--   the _utxo. This is aways safe to do, but if the _utxo field is big, this can be very expensive,
--   which defeats the purpose of memoizing the _stakeDistro field. So use of this function should be
--   restricted to tests and initializations, where the invariant should be maintained.
smartUTxOState ::
  ( Era era
  ) =>
  UTxO era ->
  Coin ->
  Coin ->
  State (Core.EraRule "PPUP" era) ->
  UTxOState era
smartUTxOState :: UTxO era
-> Coin -> Coin -> State (EraRule "PPUP" era) -> UTxOState era
smartUTxOState UTxO era
utxo Coin
c1 Coin
c2 State (EraRule "PPUP" era)
st =
  UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
forall era.
UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
UTxOState
    UTxO era
utxo
    Coin
c1
    Coin
c2
    State (EraRule "PPUP" era)
st
    (IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
updateStakeDistribution IncrementalStake (Crypto era)
forall a. Monoid a => a
mempty UTxO era
forall a. Monoid a => a
mempty UTxO era
utxo)

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

-- | Apply a reward update
applyRUpd ::
  ( HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  RewardUpdate (Crypto era) ->
  EpochState era ->
  EpochState era
applyRUpd :: RewardUpdate (Crypto era) -> EpochState era -> EpochState era
applyRUpd RewardUpdate (Crypto era)
ru EpochState era
es =
  let (EpochState era
es', Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
_, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
_, Set (Credential 'Staking (Crypto era))
_) = RewardUpdate (Crypto era)
-> EpochState era
-> (EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)))
forall era.
HasField "_protocolVersion" (PParams era) ProtVer =>
RewardUpdate (Crypto era)
-> EpochState era
-> (EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)))
applyRUpd' RewardUpdate (Crypto era)
ru EpochState era
es
   in EpochState era
es'

applyRUpd' ::
  ( HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  RewardUpdate (Crypto era) ->
  EpochState era ->
  ( EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era))
  )
applyRUpd' :: RewardUpdate (Crypto era)
-> EpochState era
-> (EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)))
applyRUpd'
  RewardUpdate (Crypto era)
ru
  es :: EpochState era
es@(EpochState AccountState
as SnapShots (Crypto era)
ss LedgerState era
ls PParams era
pr PParams era
pp NonMyopic (Crypto era)
_nm) =
    (AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
forall era.
AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
EpochState AccountState
as' SnapShots (Crypto era)
ss LedgerState era
ls' PParams era
pr PParams era
pp NonMyopic (Crypto era)
nm', Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
registered, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored, Set (Credential 'Staking (Crypto era))
unregistered)
    where
      utxoState_ :: UTxOState era
utxoState_ = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
      delegState :: DPState (Crypto era)
delegState = LedgerState era -> DPState (Crypto era)
forall era. LedgerState era -> DPState (Crypto era)
lsDPState LedgerState era
ls
      dState :: DState (Crypto era)
dState = DPState (Crypto era) -> DState (Crypto era)
forall crypto. DPState crypto -> DState crypto
dpsDState DPState (Crypto era)
delegState
      (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
registered, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored, Set (Credential 'Staking (Crypto era))
unregistered, Coin
totalUnregistered) =
        Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> EpochState era
-> (Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)), Coin)
forall era.
HasField "_protocolVersion" (PParams era) ProtVer =>
Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> EpochState era
-> (Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)), Coin)
filterAllRewards (RewardUpdate (Crypto era)
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
forall crypto.
RewardUpdate crypto
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
rs RewardUpdate (Crypto era)
ru) EpochState era
es
      registeredAggregated :: Map (Credential 'Staking (Crypto era)) Coin
registeredAggregated = PParams era
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Map (Credential 'Staking (Crypto era)) Coin
forall crypto pp.
HasField "_protocolVersion" pp ProtVer =>
pp
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> Map (Credential 'Staking crypto) Coin
aggregateRewards PParams era
pp Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
registered
      as' :: AccountState
as' =
        AccountState
as
          { _treasury :: Coin
_treasury = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
_treasury AccountState
as) (RewardUpdate (Crypto era) -> DeltaCoin
forall crypto. RewardUpdate crypto -> DeltaCoin
deltaT RewardUpdate (Crypto era)
ru) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
totalUnregistered,
            _reserves :: Coin
_reserves = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
_reserves AccountState
as) (RewardUpdate (Crypto era) -> DeltaCoin
forall crypto. RewardUpdate crypto -> DeltaCoin
deltaR RewardUpdate (Crypto era)
ru)
          }
      ls' :: LedgerState era
ls' =
        LedgerState era
ls
          { lsUTxOState :: UTxOState era
lsUTxOState =
              UTxOState era
utxoState_ {_fees :: Coin
_fees = UTxOState era -> Coin
forall era. UTxOState era -> Coin
_fees UTxOState era
utxoState_ Coin -> DeltaCoin -> Coin
`addDeltaCoin` RewardUpdate (Crypto era) -> DeltaCoin
forall crypto. RewardUpdate crypto -> DeltaCoin
deltaF RewardUpdate (Crypto era)
ru},
            lsDPState :: DPState (Crypto era)
lsDPState =
              DPState (Crypto era)
delegState
                { dpsDState :: DState (Crypto era)
dpsDState =
                    DState (Crypto era)
dState
                      { _unified :: UnifiedMap (Crypto era)
_unified = (DState (Crypto era)
-> ViewMap (Crypto era) (Credential 'Staking (Crypto era)) Coin
forall crypto.
DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards DState (Crypto era)
dState ViewMap (Crypto era) (Credential 'Staking (Crypto era)) Coin
-> Map (Credential 'Staking (Crypto era)) Coin
-> UnifiedMap (Crypto era)
forall cred coin pool ptr k.
(Ord cred, Monoid coin) =>
View coin cred pool ptr k coin
-> Map k coin -> UMap coin cred pool ptr
UM.∪+ Map (Credential 'Staking (Crypto era)) Coin
registeredAggregated)
                      }
                }
          }
      nm' :: NonMyopic (Crypto era)
nm' = RewardUpdate (Crypto era) -> NonMyopic (Crypto era)
forall crypto. RewardUpdate crypto -> NonMyopic crypto
nonMyopic RewardUpdate (Crypto era)
ru

filterAllRewards ::
  ( HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) ->
  EpochState era ->
  ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)),
    Coin
  )
filterAllRewards :: Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> EpochState era
-> (Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)), Coin)
filterAllRewards Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
rs' (EpochState AccountState
_as SnapShots (Crypto era)
_ss LedgerState era
ls PParams era
pr PParams era
_pp NonMyopic (Crypto era)
_nm) =
  (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
registered, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored, Set (Credential 'Staking (Crypto era))
unregistered, Coin
totalUnregistered)
  where
    delegState :: DPState (Crypto era)
delegState = LedgerState era -> DPState (Crypto era)
forall era. LedgerState era -> DPState (Crypto era)
lsDPState LedgerState era
ls
    dState :: DState (Crypto era)
dState = DPState (Crypto era) -> DState (Crypto era)
forall crypto. DPState crypto -> DState crypto
dpsDState DPState (Crypto era)
delegState
    (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
regRU, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
unregRU) =
      (Credential 'Staking (Crypto era)
 -> Set (Reward (Crypto era)) -> Bool)
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> (Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
        (\Credential 'Staking (Crypto era)
k Set (Reward (Crypto era))
_ -> Exp Bool -> Bool
forall s t. Embed s t => Exp t -> s
eval (Credential 'Staking (Crypto era)
k Credential 'Staking (Crypto era)
-> Exp (Sett (Credential 'Staking (Crypto era)) ()) -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
∈ ViewMap (Crypto era) (Credential 'Staking (Crypto era)) Coin
-> Exp (Sett (Credential 'Staking (Crypto era)) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom (DState (Crypto era)
-> ViewMap (Crypto era) (Credential 'Staking (Crypto era)) Coin
forall crypto.
DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards DState (Crypto era)
dState)))
        Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
rs'
    totalUnregistered :: Coin
totalUnregistered = Map (Credential 'Staking (Crypto era)) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential 'Staking (Crypto era)) Coin -> Coin)
-> Map (Credential 'Staking (Crypto era)) Coin -> Coin
forall a b. (a -> b) -> a -> b
$ PParams era
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Map (Credential 'Staking (Crypto era)) Coin
forall crypto pp.
HasField "_protocolVersion" pp ProtVer =>
pp
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> Map (Credential 'Staking crypto) Coin
aggregateRewards PParams era
pr Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
unregRU
    unregistered :: Set (Credential 'Staking (Crypto era))
unregistered = Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Set (Credential 'Staking (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
unregRU
    (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
registered, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored) = PParams era
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> (Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall crypto pp.
HasField "_protocolVersion" pp ProtVer =>
pp
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> (Map (Credential 'Staking crypto) (Set (Reward crypto)),
    Map (Credential 'Staking crypto) (Set (Reward crypto)))
filterRewards PParams era
pr Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
regRU

decayFactor :: Float
decayFactor :: Float
decayFactor = Float
0.9

updateNonMyopic ::
  NonMyopic crypto ->
  Coin ->
  Map (KeyHash 'StakePool crypto) Likelihood ->
  NonMyopic crypto
updateNonMyopic :: NonMyopic crypto
-> Coin
-> Map (KeyHash 'StakePool crypto) Likelihood
-> NonMyopic crypto
updateNonMyopic NonMyopic crypto
nm Coin
rPot Map (KeyHash 'StakePool crypto) Likelihood
newLikelihoods =
  NonMyopic crypto
nm
    { likelihoodsNM :: Map (KeyHash 'StakePool crypto) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool crypto) Likelihood
updatedLikelihoods,
      rewardPotNM :: Coin
rewardPotNM = Coin
rPot
    }
  where
    history :: Map (KeyHash 'StakePool crypto) Likelihood
history = NonMyopic crypto -> Map (KeyHash 'StakePool crypto) Likelihood
forall crypto.
NonMyopic crypto -> Map (KeyHash 'StakePool crypto) Likelihood
likelihoodsNM NonMyopic crypto
nm
    performance :: KeyHash 'StakePool crypto -> Likelihood -> Likelihood
performance KeyHash 'StakePool crypto
kh Likelihood
newPerf =
      Likelihood
-> (Likelihood -> Likelihood) -> Maybe Likelihood -> Likelihood
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        Likelihood
forall a. Monoid a => a
mempty
        (Float -> Likelihood -> Likelihood
applyDecay Float
decayFactor)
        (KeyHash 'StakePool crypto
-> Map (KeyHash 'StakePool crypto) Likelihood -> Maybe Likelihood
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool crypto
kh Map (KeyHash 'StakePool crypto) Likelihood
history)
        Likelihood -> Likelihood -> Likelihood
forall a. Semigroup a => a -> a -> a
<> Likelihood
newPerf
    updatedLikelihoods :: Map (KeyHash 'StakePool crypto) Likelihood
updatedLikelihoods = (KeyHash 'StakePool crypto -> Likelihood -> Likelihood)
-> Map (KeyHash 'StakePool crypto) Likelihood
-> Map (KeyHash 'StakePool crypto) Likelihood
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey KeyHash 'StakePool crypto -> Likelihood -> Likelihood
performance Map (KeyHash 'StakePool crypto) Likelihood
newLikelihoods

-- =============================
-- To prevent a huge pause, at the stability point, we spread out the
-- Calculation of rewards over many blocks. We do this in 3 phases. Phase 1
-- of a reward upate is a pure computation, computing some parameters which
-- become fixed at the time when we reach the stability point. One of these
-- parameters is a Pulser, i.e. a computation that when pulseM'ed computes
-- a portion of what is required, so that the whole compuation can be spread out in time.

-- | The EpochState has a field which is (Core.PParams era). We need these
--     fields, a subset of the fields in PParams, in: startStep and createRUpd.
type UsesPP era =
  ( HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_tau" (Core.PParams era) UnitInterval,
    HasField "_a0" (Core.PParams era) NonNegativeInterval,
    HasField "_rho" (Core.PParams era) UnitInterval,
    HasField "_nOpt" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer
  )

-- | Assemble the components for, and then create, a Pulser.
startStep ::
  forall era.
  UsesPP era =>
  EpochSize ->
  BlocksMade (Crypto era) ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
startStep :: EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
startStep EpochSize
slotsPerEpoch b :: BlocksMade (Crypto era)
b@(BlocksMade Map (KeyHash 'StakePool (Crypto era)) Natural
b') es :: EpochState era
es@(EpochState AccountState
acnt SnapShots (Crypto era)
ss LedgerState era
ls PParams era
pr PParams era
_ NonMyopic (Crypto era)
nm) Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam =
  let SnapShot Stake (Crypto era)
stake' VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
delegs' VMap
  VB VB (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
poolParams = SnapShots (Crypto era) -> SnapShot (Crypto era)
forall crypto. SnapShots crypto -> SnapShot crypto
_pstakeGo SnapShots (Crypto era)
ss
      numStakeCreds, k :: Rational
      numStakeCreds :: Rational
numStakeCreds = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
-> Int
forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size (VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
 -> Int)
-> VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
-> Int
forall a b. (a -> b) -> a -> b
$ Stake (Crypto era)
-> VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
forall crypto.
Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
unStake Stake (Crypto era)
stake')
      k :: Rational
k = Word64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
secparam

      -- We expect approximately 10k-many blocks to be produced each epoch.
      -- The reward calculation begins (4k/f)-many slots into the epoch,
      -- and we guarantee that it ends (2k/f)-many slots before the end
      -- of the epoch (to allow tools such as db-sync to see the reward
      -- values in advance of them being applied to the ledger state).
      --
      -- Therefore to evenly space out the reward calculation, we divide
      -- the number of stake credentials by 4k in order to determine how many
      -- stake credential rewards we should calculate each block.
      -- If it does not finish in this amount of time, the calculation is
      -- forced to completion.
      pulseSize :: Int
pulseSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational
numStakeCreds Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
4 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
k)))

      -- We now compute the amount of total rewards that can potentially be given
      -- out this epoch, and the adjustments to the reserves and the treasury.
      Coin Integer
reserves = AccountState -> Coin
_reserves AccountState
acnt
      ds :: DState (Crypto era)
ds = DPState (Crypto era) -> DState (Crypto era)
forall crypto. DPState crypto -> DState crypto
dpsDState (DPState (Crypto era) -> DState (Crypto era))
-> DPState (Crypto era) -> DState (Crypto era)
forall a b. (a -> b) -> a -> b
$ LedgerState era -> DPState (Crypto era)
forall era. LedgerState era -> DPState (Crypto era)
lsDPState LedgerState era
ls
      -- reserves and rewards change
      deltaR1 :: Coin
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 -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_rho" PParams era
pr)
            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 :: Rational
d = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pr)
      expectedBlocks :: Integer
expectedBlocks =
        Rational -> Integer
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
      blocksMade :: Integer
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 (Crypto era)) 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 (Crypto era)) Natural
b' :: Integer
      eta :: Rational
eta
        | UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pr) 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 Integer
rPot = SnapShots (Crypto era) -> Coin
forall crypto. SnapShots crypto -> Coin
_feeSS SnapShots (Crypto era)
ss Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
deltaR1
      deltaT1 :: Integer
deltaT1 = Rational -> Integer
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 -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_tau" PParams era
pr) 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 :: Coin
_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

      -- We now compute stake pool specific values that are needed for computing
      -- member and leader rewards.
      activestake :: Coin
activestake = Stake (Crypto era) -> Coin
forall crypto. Stake crypto -> Coin
sumAllStake Stake (Crypto era)
stake'
      totalStake :: Coin
totalStake = EpochState era -> Coin -> Coin
forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
      stakePerPool :: Map (KeyHash 'StakePool (Crypto era)) Coin
stakePerPool = VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
-> Stake (Crypto era) -> Map (KeyHash 'StakePool (Crypto era)) Coin
forall crypto.
VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Stake crypto -> Map (KeyHash 'StakePool crypto) Coin
sumStakePerPool VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
delegs' Stake (Crypto era)
stake'
      mkPoolRewardInfoCurry :: PoolParams (Crypto era)
-> Either StakeShare (PoolRewardInfo (Crypto era))
mkPoolRewardInfoCurry =
        PParams era
-> Coin
-> BlocksMade (Crypto era)
-> Natural
-> Stake (Crypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
-> Map (KeyHash 'StakePool (Crypto era)) Coin
-> Coin
-> Coin
-> PoolParams (Crypto era)
-> Either StakeShare (PoolRewardInfo (Crypto era))
forall era.
(HasField "_d" (PParams era) UnitInterval,
 HasField "_a0" (PParams era) NonNegativeInterval,
 HasField "_nOpt" (PParams era) Natural) =>
PParams era
-> Coin
-> BlocksMade (Crypto era)
-> Natural
-> Stake (Crypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
-> Map (KeyHash 'StakePool (Crypto era)) Coin
-> Coin
-> Coin
-> PoolParams (Crypto era)
-> Either StakeShare (PoolRewardInfo (Crypto era))
mkPoolRewardInfo
          PParams era
pr
          Coin
_R
          BlocksMade (Crypto era)
b
          (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
blocksMade)
          Stake (Crypto era)
stake'
          VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
delegs'
          Map (KeyHash 'StakePool (Crypto era)) Coin
stakePerPool
          Coin
totalStake
          Coin
activestake

      -- We map over the registered stake pools to compute the revelant
      -- stake pool specific values.
      allPoolInfo :: VMap
  VB
  VB
  (KeyHash 'StakePool (Crypto era))
  (Either StakeShare (PoolRewardInfo (Crypto era)))
allPoolInfo = (PoolParams (Crypto era)
 -> Either StakeShare (PoolRewardInfo (Crypto era)))
-> VMap
     VB VB (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (Crypto era))
     (Either StakeShare (PoolRewardInfo (Crypto era)))
forall (vv :: * -> *) a b (kv :: * -> *) k.
(Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map PoolParams (Crypto era)
-> Either StakeShare (PoolRewardInfo (Crypto era))
mkPoolRewardInfoCurry VMap
  VB VB (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
poolParams

      -- Stake pools that do not produce any blocks get no rewards,
      -- but some information is still needed from non-block-producing
      -- pools for the ranking algorithm used by the wallets.
      blockProducingPoolInfo :: Map (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
blockProducingPoolInfo = VMap
  VB
  VB
  (KeyHash 'StakePool (Crypto era))
  (PoolRewardInfo (Crypto era))
-> Map
     (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
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 (Crypto era))
   (PoolRewardInfo (Crypto era))
 -> Map
      (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era)))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (Crypto era))
     (PoolRewardInfo (Crypto era))
-> Map
     (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
forall a b. (a -> b) -> a -> b
$ (Either StakeShare (PoolRewardInfo (Crypto era))
 -> Maybe (PoolRewardInfo (Crypto era)))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (Crypto era))
     (Either StakeShare (PoolRewardInfo (Crypto era)))
-> VMap
     VB
     VB
     (KeyHash 'StakePool (Crypto era))
     (PoolRewardInfo (Crypto era))
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 (Crypto era)))
-> (PoolRewardInfo (Crypto era)
    -> Maybe (PoolRewardInfo (Crypto era)))
-> Either StakeShare (PoolRewardInfo (Crypto era))
-> Maybe (PoolRewardInfo (Crypto era))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (PoolRewardInfo (Crypto era))
-> StakeShare -> Maybe (PoolRewardInfo (Crypto era))
forall a b. a -> b -> a
const Maybe (PoolRewardInfo (Crypto era))
forall a. Maybe a
Nothing) PoolRewardInfo (Crypto era) -> Maybe (PoolRewardInfo (Crypto era))
forall a. a -> Maybe a
Just) VMap
  VB
  VB
  (KeyHash 'StakePool (Crypto era))
  (Either StakeShare (PoolRewardInfo (Crypto era)))
allPoolInfo

      getSigma :: PoolRewardInfo crypto -> Rational
getSigma = StakeShare -> Rational
unStakeShare (StakeShare -> Rational)
-> (PoolRewardInfo crypto -> StakeShare)
-> PoolRewardInfo crypto
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo crypto -> StakeShare
forall crypto. PoolRewardInfo crypto -> StakeShare
poolRelativeStake
      makeLikelihoods :: Either StakeShare (PoolRewardInfo (Crypto era)) -> Likelihood
makeLikelihoods = \case
        -- This pool produced no blocks this epoch
        Left (StakeShare Rational
sigma) ->
          Natural -> Double -> EpochSize -> Likelihood
likelihood
            Natural
0
            (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc Rational
sigma (UnitInterval -> Double) -> UnitInterval -> Double
forall a b. (a -> b) -> a -> b
$ PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pr)
            EpochSize
slotsPerEpoch
        -- This pool produced at least one block this epoch
        Right PoolRewardInfo (Crypto era)
info ->
          Natural -> Double -> EpochSize -> Likelihood
likelihood
            (PoolRewardInfo (Crypto era) -> Natural
forall crypto. PoolRewardInfo crypto -> Natural
poolBlocks PoolRewardInfo (Crypto era)
info)
            (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc (PoolRewardInfo (Crypto era) -> Rational
forall crypto. PoolRewardInfo crypto -> Rational
getSigma PoolRewardInfo (Crypto era)
info) (UnitInterval -> Double) -> UnitInterval -> Double
forall a b. (a -> b) -> a -> b
$ PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pr)
            EpochSize
slotsPerEpoch
      newLikelihoods :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods = VMap VB VB (KeyHash 'StakePool (Crypto era)) Likelihood
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
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 (Crypto era)) Likelihood
 -> Map (KeyHash 'StakePool (Crypto era)) Likelihood)
-> VMap VB VB (KeyHash 'StakePool (Crypto era)) Likelihood
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall a b. (a -> b) -> a -> b
$ (Either StakeShare (PoolRewardInfo (Crypto era)) -> Likelihood)
-> VMap
     VB
     VB
     (KeyHash 'StakePool (Crypto era))
     (Either StakeShare (PoolRewardInfo (Crypto era)))
-> VMap VB VB (KeyHash 'StakePool (Crypto era)) Likelihood
forall (vv :: * -> *) a b (kv :: * -> *) k.
(Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map Either StakeShare (PoolRewardInfo (Crypto era)) -> Likelihood
makeLikelihoods VMap
  VB
  VB
  (KeyHash 'StakePool (Crypto era))
  (Either StakeShare (PoolRewardInfo (Crypto era)))
allPoolInfo

      -- We now compute the leader rewards for each stake pool.
      collectLRs :: Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> PoolRewardInfo (Crypto era)
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
collectLRs Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
acc PoolRewardInfo (Crypto era)
poolRI =
        let rewardAcnt :: Credential 'Staking (Crypto era)
rewardAcnt = RewardAcnt (Crypto era) -> Credential 'Staking (Crypto era)
forall crypto. RewardAcnt crypto -> Credential 'Staking crypto
getRwdCred (RewardAcnt (Crypto era) -> Credential 'Staking (Crypto era))
-> (PoolRewardInfo (Crypto era) -> RewardAcnt (Crypto era))
-> PoolRewardInfo (Crypto era)
-> Credential 'Staking (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams (Crypto era) -> RewardAcnt (Crypto era)
forall crypto. PoolParams crypto -> RewardAcnt crypto
_poolRAcnt (PoolParams (Crypto era) -> RewardAcnt (Crypto era))
-> (PoolRewardInfo (Crypto era) -> PoolParams (Crypto era))
-> PoolRewardInfo (Crypto era)
-> RewardAcnt (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo (Crypto era) -> PoolParams (Crypto era)
forall crypto. PoolRewardInfo crypto -> PoolParams crypto
poolPs (PoolRewardInfo (Crypto era) -> Credential 'Staking (Crypto era))
-> PoolRewardInfo (Crypto era) -> Credential 'Staking (Crypto era)
forall a b. (a -> b) -> a -> b
$ PoolRewardInfo (Crypto era)
poolRI
            packageLeaderReward :: PoolRewardInfo c -> Set (Reward c)
packageLeaderReward = Reward c -> Set (Reward c)
forall a. a -> Set a
Set.singleton (Reward c -> Set (Reward c))
-> (PoolRewardInfo c -> Reward c)
-> PoolRewardInfo c
-> Set (Reward c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeaderOnlyReward c -> Reward c
forall c. LeaderOnlyReward c -> Reward c
leaderRewardToGeneral (LeaderOnlyReward c -> Reward c)
-> (PoolRewardInfo c -> LeaderOnlyReward c)
-> PoolRewardInfo c
-> Reward c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo c -> LeaderOnlyReward c
forall crypto. PoolRewardInfo crypto -> LeaderOnlyReward crypto
poolLeaderReward
         in if PParams era -> Bool
forall pp. HasField "_protocolVersion" pp ProtVer => pp -> Bool
HardForks.forgoRewardPrefilter PParams era
pr Bool -> Bool -> Bool
|| Credential 'Staking (Crypto era)
rewardAcnt Credential 'Staking (Crypto era)
-> View
     Coin
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
     Ptr
     (Credential 'Staking (Crypto era))
     Coin
-> Bool
forall cr ptr k coin pool v.
(Ord cr, Ord ptr) =>
k -> View coin cr pool ptr k v -> Bool
`UM.member` DState (Crypto era)
-> View
     Coin
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
     Ptr
     (Credential 'Staking (Crypto era))
     Coin
forall crypto.
DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards DState (Crypto era)
ds
              then
                (Set (Reward (Crypto era))
 -> Set (Reward (Crypto era)) -> Set (Reward (Crypto era)))
-> Credential 'Staking (Crypto era)
-> Set (Reward (Crypto era))
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
                  Set (Reward (Crypto era))
-> Set (Reward (Crypto era)) -> Set (Reward (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
Set.union
                  Credential 'Staking (Crypto era)
rewardAcnt
                  (PoolRewardInfo (Crypto era) -> Set (Reward (Crypto era))
forall c. PoolRewardInfo c -> Set (Reward c)
packageLeaderReward PoolRewardInfo (Crypto era)
poolRI)
                  Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
acc
              else Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
acc

      -- The data in 'RewardSnapShot' will be used to finish up the reward calculation
      -- once all the member rewards are complete.
      rewsnap :: RewardSnapShot (Crypto era)
rewsnap =
        RewardSnapShot :: forall crypto.
Coin
-> ProtVer
-> NonMyopic crypto
-> Coin
-> Coin
-> Coin
-> Map (KeyHash 'StakePool crypto) Likelihood
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> RewardSnapShot crypto
RewardSnapShot
          { rewFees :: Coin
rewFees = SnapShots (Crypto era) -> Coin
forall crypto. SnapShots crypto -> Coin
_feeSS SnapShots (Crypto era)
ss,
            rewprotocolVersion :: ProtVer
rewprotocolVersion = PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
pr,
            rewNonMyopic :: NonMyopic (Crypto era)
rewNonMyopic = NonMyopic (Crypto era)
nm,
            rewDeltaR1 :: Coin
rewDeltaR1 = Coin
deltaR1,
            rewR :: Coin
rewR = Coin
_R,
            rewDeltaT1 :: Coin
rewDeltaT1 = Integer -> Coin
Coin Integer
deltaT1,
            rewLikelihoods :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods,
            rewLeaders :: Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
rewLeaders = (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
 -> PoolRewardInfo (Crypto era)
 -> Map
      (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Map
     (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> PoolRewardInfo (Crypto era)
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
collectLRs Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
forall a. Monoid a => a
mempty Map (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
blockProducingPoolInfo
          }

      -- The data in 'FreeVars' to supply individual stake pool members with
      -- the neccessary information to compute their individual rewards.
      free :: FreeVars (Crypto era)
free =
        VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
-> Set (Credential 'Staking (Crypto era))
-> Integer
-> ProtVer
-> Map
     (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
-> FreeVars (Crypto era)
forall crypto.
VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Set (Credential 'Staking crypto)
-> Integer
-> ProtVer
-> Map (KeyHash 'StakePool crypto) (PoolRewardInfo crypto)
-> FreeVars crypto
FreeVars
          VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
delegs'
          (View
  Coin
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
  Ptr
  (Credential 'Staking (Crypto era))
  Coin
-> Set (Credential 'Staking (Crypto era))
forall cr coin pool ptr k v.
Ord cr =>
View coin cr pool ptr k v -> Set k
UM.domain (View
   Coin
   (Credential 'Staking (Crypto era))
   (KeyHash 'StakePool (Crypto era))
   Ptr
   (Credential 'Staking (Crypto era))
   Coin
 -> Set (Credential 'Staking (Crypto era)))
-> View
     Coin
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
     Ptr
     (Credential 'Staking (Crypto era))
     Coin
-> Set (Credential 'Staking (Crypto era))
forall a b. (a -> b) -> a -> b
$ DState (Crypto era)
-> View
     Coin
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
     Ptr
     (Credential 'Staking (Crypto era))
     Coin
forall crypto.
DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
rewards DState (Crypto era)
ds)
          (Coin -> Integer
unCoin Coin
totalStake)
          (PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
pr)
          Map (KeyHash 'StakePool (Crypto era)) (PoolRewardInfo (Crypto era))
blockProducingPoolInfo
      pulser :: Pulser (Crypto era)
      pulser :: Pulser (Crypto era)
pulser =
        Int
-> FreeVars (Crypto era)
-> VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
-> RewardAns (Crypto era)
-> Pulser (Crypto era)
forall ans c (m :: * -> *).
(ans ~ RewardAns c, m ~ ShelleyBase) =>
Int
-> FreeVars c
-> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> ans
-> RewardPulser c m ans
RSLP
          Int
pulseSize
          FreeVars (Crypto era)
free
          (Stake (Crypto era)
-> VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
forall crypto.
Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
unStake Stake (Crypto era)
stake')
          (Map (Credential 'Staking (Crypto era)) (Reward (Crypto era))
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> RewardAns (Crypto era)
forall c.
Map (Credential 'Staking c) (Reward c)
-> RewardEvent c -> RewardAns c
RewardAns Map (Credential 'Staking (Crypto era)) (Reward (Crypto era))
forall k a. Map k a
Map.empty Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
forall k a. Map k a
Map.empty)
      provenance :: RewardProvenance (Crypto era)
provenance =
        RewardProvenance (Crypto era)
forall a. Default a => a
def
          { spe :: Word64
spe = case EpochSize
slotsPerEpoch of EpochSize Word64
n -> Word64
n,
            blocks :: BlocksMade (Crypto era)
blocks = BlocksMade (Crypto era)
b,
            blocksCount :: Integer
blocksCount = Integer
blocksMade,
            maxLL :: Coin
maxLL = Coin
maxSupply,
            deltaR1 :: Coin
deltaR1 = Coin
deltaR1,
            r :: Coin
RP.r = Coin
_R,
            totalStake :: Coin
RP.totalStake = Coin
totalStake,
            activeStake :: Coin
RP.activeStake = Coin
activestake,
            d :: Rational
d = Rational
d,
            expBlocks :: Integer
expBlocks = Integer
expectedBlocks,
            eta :: Rational
eta = Rational
eta,
            rPot :: Coin
rPot = Integer -> Coin
Coin Integer
rPot,
            deltaT1 :: Coin
deltaT1 = Integer -> Coin
Coin Integer
deltaT1
            -- The reward provenance is in the process of being deprecated,
            -- some fields are not populated anymore, such as the pool provenance
            -- and the desireabilities.
          }
   in (RewardSnapShot (Crypto era)
-> Pulser (Crypto era) -> PulsingRewUpdate (Crypto era)
forall crypto.
RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
Pulsing RewardSnapShot (Crypto era)
rewsnap Pulser (Crypto era)
pulser, RewardProvenance (Crypto era)
provenance)

-- Phase 2

-- | Run the pulser for a bit. If is has nothing left to do, complete it.
pulseStep ::
  PulsingRewUpdate crypto ->
  ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
pulseStep :: PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
pulseStep (Complete RewardUpdate crypto
r) = (PulsingRewUpdate crypto, RewardEvent crypto)
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate crypto -> PulsingRewUpdate crypto
forall crypto. RewardUpdate crypto -> PulsingRewUpdate crypto
Complete RewardUpdate crypto
r, RewardEvent crypto
forall a. Monoid a => a
mempty)
pulseStep p :: PulsingRewUpdate crypto
p@(Pulsing RewardSnapShot crypto
_ Pulser crypto
pulser) | Pulser crypto -> Bool
forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
Pulsable pulse =>
pulse m ans -> Bool
done Pulser crypto
pulser = PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
forall crypto.
PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
completeStep PulsingRewUpdate crypto
p
pulseStep (Pulsing RewardSnapShot crypto
rewsnap Pulser crypto
pulser) = do
  -- The pulser might compute provenance, but using pulseM here does not compute it
  p2 :: Pulser crypto
p2@(RSLP Int
_ FreeVars crypto
_ VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
_ (RewardAns Map (Credential 'Staking crypto) (Reward crypto)
_ RewardEvent crypto
event)) <- Pulser crypto -> ShelleyBase (Pulser crypto)
forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m (pulse m ans)
pulseM Pulser crypto
pulser
  (PulsingRewUpdate crypto, RewardEvent crypto)
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
forall crypto.
RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
Pulsing RewardSnapShot crypto
rewsnap Pulser crypto
p2, RewardEvent crypto
event)

-- Phase 3

completeStep ::
  PulsingRewUpdate crypto ->
  ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
completeStep :: PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
completeStep (Complete RewardUpdate crypto
r) = (PulsingRewUpdate crypto, RewardEvent crypto)
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate crypto -> PulsingRewUpdate crypto
forall crypto. RewardUpdate crypto -> PulsingRewUpdate crypto
Complete RewardUpdate crypto
r, RewardEvent crypto
forall a. Monoid a => a
mempty)
completeStep (Pulsing RewardSnapShot crypto
rewsnap Pulser crypto
pulser) = do
  (RewardUpdate crypto
p2, !RewardEvent crypto
event) <- ProvM
  (RewardProvenance crypto)
  ShelleyBase
  (RewardUpdate crypto, RewardEvent crypto)
-> ShelleyBase (RewardUpdate crypto, RewardEvent crypto)
forall (m :: * -> *) s b. Monad m => ProvM s m b -> m b
runProvM (PulsingRewUpdate crypto
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
forall crypto.
PulsingRewUpdate crypto
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
completeRupd (RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
forall crypto.
RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
Pulsing RewardSnapShot crypto
rewsnap Pulser crypto
pulser))
  (PulsingRewUpdate crypto, RewardEvent crypto)
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate crypto -> PulsingRewUpdate crypto
forall crypto. RewardUpdate crypto -> PulsingRewUpdate crypto
Complete RewardUpdate crypto
p2, RewardEvent crypto
event)

-- | Phase 3 of reward update has several parts
--   a) completeM the pulser (in case there are still computions to run)
--   b) Combine the pulser provenance with the RewardProvenance
--   c) Construct the final RewardUpdate
--   d) Add the leader rewards to both the events and the computed Rewards
completeRupd ::
  PulsingRewUpdate crypto ->
  ProvM (RewardProvenance crypto) ShelleyBase (RewardUpdate crypto, RewardEvent crypto)
completeRupd :: PulsingRewUpdate crypto
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
completeRupd (Complete RewardUpdate crypto
x) = (RewardUpdate crypto, RewardEvent crypto)
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate crypto
x, RewardEvent crypto
forall a. Monoid a => a
mempty)
completeRupd
  ( Pulsing
      rewsnap :: RewardSnapShot crypto
rewsnap@RewardSnapShot
        { rewDeltaR1 :: forall crypto. RewardSnapShot crypto -> Coin
rewDeltaR1 = Coin
deltaR1,
          rewFees :: forall crypto. RewardSnapShot crypto -> Coin
rewFees = Coin
feesSS,
          rewR :: forall crypto. RewardSnapShot crypto -> Coin
rewR = Coin
oldr,
          rewDeltaT1 :: forall crypto. RewardSnapShot crypto -> Coin
rewDeltaT1 = (Coin Integer
deltaT1),
          rewNonMyopic :: forall crypto. RewardSnapShot crypto -> NonMyopic crypto
rewNonMyopic = NonMyopic crypto
nm,
          rewLikelihoods :: forall crypto.
RewardSnapShot crypto -> Map (KeyHash 'StakePool crypto) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool crypto) Likelihood
newLikelihoods,
          rewLeaders :: forall crypto.
RewardSnapShot crypto
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
rewLeaders = RewardEvent crypto
lrewards
        }
      pulser :: Pulser crypto
pulser@(RSLP Int
_size FreeVars crypto
_free VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
_source (RewardAns Map (Credential 'Staking crypto) (Reward crypto)
prev RewardEvent crypto
_now)) -- If prev is Map.empty, we have never pulsed.
    ) = do
    RewardAns Map (Credential 'Staking crypto) (Reward crypto)
rs_ RewardEvent crypto
events <- ShelleyBase (RewardAns crypto)
-> ProvM (RewardProvenance crypto) ShelleyBase (RewardAns crypto)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Pulser crypto -> ShelleyBase (RewardAns crypto)
forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser crypto
pulser)
    let rs' :: RewardEvent crypto
rs' = (Reward crypto -> Set (Reward crypto))
-> Map (Credential 'Staking crypto) (Reward crypto)
-> RewardEvent crypto
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Reward crypto -> Set (Reward crypto)
forall a. a -> Set a
Set.singleton Map (Credential 'Staking crypto) (Reward crypto)
rs_
    let rs'' :: RewardEvent crypto
rs'' = (Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto))
-> RewardEvent crypto -> RewardEvent crypto -> RewardEvent crypto
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent crypto
rs' RewardEvent crypto
lrewards
    let !events' :: RewardEvent crypto
events' = (Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto))
-> RewardEvent crypto -> RewardEvent crypto -> RewardEvent crypto
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent crypto
events RewardEvent crypto
lrewards

    let deltaR2 :: Coin
deltaR2 = Coin
oldr Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> RewardSnapShot crypto -> RewardEvent crypto -> Coin
forall crypto pp.
HasField "_protocolVersion" pp ProtVer =>
pp
-> Map (Credential 'Staking crypto) (Set (Reward crypto)) -> Coin
sumRewards RewardSnapShot crypto
rewsnap RewardEvent crypto
rs''
    (RewardProvenance crypto -> RewardProvenance crypto)
-> ProvM (RewardProvenance crypto) ShelleyBase ()
forall (m :: * -> *) t. Monad m => (t -> t) -> ProvM t m ()
modifyM (\RewardProvenance crypto
rp -> RewardProvenance crypto
rp {deltaR2 :: Coin
deltaR2 = Coin
deltaR2})
    let neverpulsed :: Bool
neverpulsed = Map (Credential 'Staking crypto) (Reward crypto) -> Bool
forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking crypto) (Reward crypto)
prev
        !newevent :: RewardEvent crypto
newevent =
          if Bool
neverpulsed -- If we have never pulsed then everything in the computed needs to added to the event
            then (Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto))
-> RewardEvent crypto -> RewardEvent crypto -> RewardEvent crypto
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Reward crypto) -> Set (Reward crypto) -> Set (Reward crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent crypto
rs' RewardEvent crypto
events'
            else RewardEvent crypto
events'
    (RewardUpdate crypto, RewardEvent crypto)
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( RewardUpdate :: forall crypto.
DeltaCoin
-> DeltaCoin
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> DeltaCoin
-> NonMyopic crypto
-> RewardUpdate crypto
RewardUpdate
          { deltaT :: DeltaCoin
deltaT = Integer -> DeltaCoin
DeltaCoin Integer
deltaT1,
            deltaR :: DeltaCoin
deltaR = DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
deltaR1) DeltaCoin -> DeltaCoin -> DeltaCoin
forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
deltaR2,
            rs :: RewardEvent crypto
rs = RewardEvent crypto
rs'',
            deltaF :: DeltaCoin
deltaF = DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
feesSS),
            nonMyopic :: NonMyopic crypto
nonMyopic = NonMyopic crypto
-> Coin
-> Map (KeyHash 'StakePool crypto) Likelihood
-> NonMyopic crypto
forall crypto.
NonMyopic crypto
-> Coin
-> Map (KeyHash 'StakePool crypto) Likelihood
-> NonMyopic crypto
updateNonMyopic NonMyopic crypto
nm Coin
oldr Map (KeyHash 'StakePool crypto) Likelihood
newLikelihoods
          },
        RewardEvent crypto
newevent
      )

-- | To create a reward update, run all 3 phases
--   This function is not used in the rules, so it ignores RewardEvents
createRUpd ::
  forall era.
  (UsesPP era) =>
  EpochSize ->
  BlocksMade (Crypto era) ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  ProvM (RewardProvenance (Crypto era)) ShelleyBase (RewardUpdate (Crypto era))
createRUpd :: EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era))
createRUpd EpochSize
slotsPerEpoch BlocksMade (Crypto era)
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam = do
  let (PulsingRewUpdate (Crypto era)
step1, RewardProvenance (Crypto era)
initialProvenance) = EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
forall era.
UsesPP era =>
EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
startStep EpochSize
slotsPerEpoch BlocksMade (Crypto era)
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam
  (RewardProvenance (Crypto era) -> RewardProvenance (Crypto era))
-> ProvM (RewardProvenance (Crypto era)) ShelleyBase ()
forall (m :: * -> *) t. Monad m => (t -> t) -> ProvM t m ()
modifyM (\RewardProvenance (Crypto era)
_ -> RewardProvenance (Crypto era)
initialProvenance)
  (PulsingRewUpdate (Crypto era)
step2, RewardEvent (Crypto era)
_event) <- ReaderT
  Globals
  Identity
  (PulsingRewUpdate (Crypto era), RewardEvent (Crypto era))
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (PulsingRewUpdate (Crypto era), RewardEvent (Crypto era))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PulsingRewUpdate (Crypto era)
-> ReaderT
     Globals
     Identity
     (PulsingRewUpdate (Crypto era), RewardEvent (Crypto era))
forall crypto.
PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
pulseStep PulsingRewUpdate (Crypto era)
step1)
  case PulsingRewUpdate (Crypto era)
step2 of
    (Complete RewardUpdate (Crypto era)
r) -> RewardUpdate (Crypto era)
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardUpdate (Crypto era)
r
    (Pulsing RewardSnapShot (Crypto era)
rewsnap Pulser (Crypto era)
pulser) -> (RewardUpdate (Crypto era), RewardEvent (Crypto era))
-> RewardUpdate (Crypto era)
forall a b. (a, b) -> a
fst ((RewardUpdate (Crypto era), RewardEvent (Crypto era))
 -> RewardUpdate (Crypto era))
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era), RewardEvent (Crypto era))
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PulsingRewUpdate (Crypto era)
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era), RewardEvent (Crypto era))
forall crypto.
PulsingRewUpdate crypto
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
completeRupd (RewardSnapShot (Crypto era)
-> Pulser (Crypto era) -> PulsingRewUpdate (Crypto era)
forall crypto.
RewardSnapShot crypto -> Pulser crypto -> PulsingRewUpdate crypto
Pulsing RewardSnapShot (Crypto era)
rewsnap Pulser (Crypto era)
pulser)

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

-- | Calculate the current circulation
--
-- This is used in the rewards calculation, and for API endpoints for pool ranking.
circulation :: EpochState era -> Coin -> Coin
circulation :: EpochState era -> Coin -> Coin
circulation (EpochState AccountState
acnt SnapShots (Crypto era)
_ LedgerState era
_ PParams era
_ PParams era
_ NonMyopic (Crypto era)
_) Coin
supply =
  Coin
supply Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> AccountState -> Coin
_reserves AccountState
acnt

-- | Update new epoch state
updateNES ::
  NewEpochState era ->
  BlocksMade (Crypto era) ->
  LedgerState era ->
  NewEpochState era
updateNES :: NewEpochState era
-> BlocksMade (Crypto era) -> LedgerState era -> NewEpochState era
updateNES
  oldNes :: NewEpochState era
oldNes@( NewEpochState
             EpochNo
_eL
             BlocksMade (Crypto era)
_bprev
             BlocksMade (Crypto era)
_
             (EpochState AccountState
acnt SnapShots (Crypto era)
ss LedgerState era
_ PParams era
pr PParams era
pp NonMyopic (Crypto era)
nm)
             StrictMaybe (PulsingRewUpdate (Crypto era))
_ru
             PoolDistr (Crypto era)
_pd
             StashedAVVMAddresses era
_avvm
           )
  BlocksMade (Crypto era)
bcur
  LedgerState era
ls =
    NewEpochState era
oldNes
      { nesBcur :: BlocksMade (Crypto era)
nesBcur = BlocksMade (Crypto era)
bcur,
        nesEs :: EpochState era
nesEs = AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
forall era.
AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
EpochState AccountState
acnt SnapShots (Crypto era)
ss LedgerState era
ls PParams era
pr PParams era
pp NonMyopic (Crypto era)
nm
      }

returnRedeemAddrsToReserves ::
  forall era.
  Era era =>
  EpochState era ->
  EpochState era
returnRedeemAddrsToReserves :: EpochState era -> EpochState era
returnRedeemAddrsToReserves EpochState era
es = EpochState era
es {esAccountState :: AccountState
esAccountState = AccountState
acnt', esLState :: LedgerState era
esLState = LedgerState era
ls'}
  where
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    us :: UTxOState era
us = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    UTxO Map (TxIn (Crypto era)) (TxOut era)
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
_utxo UTxOState era
us
    (Map (TxIn (Crypto era)) (TxOut era)
redeemers, Map (TxIn (Crypto era)) (TxOut era)
nonredeemers) =
      (TxOut era -> Bool)
-> Map (TxIn (Crypto era)) (TxOut era)
-> (Map (TxIn (Crypto era)) (TxOut era),
    Map (TxIn (Crypto era)) (TxOut era))
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Bool
-> (BootstrapAddress (Crypto era) -> Bool)
-> Maybe (BootstrapAddress (Crypto era))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False BootstrapAddress (Crypto era) -> Bool
forall crypto. BootstrapAddress crypto -> Bool
isBootstrapRedeemer (Maybe (BootstrapAddress (Crypto era)) -> Bool)
-> (TxOut era -> Maybe (BootstrapAddress (Crypto era)))
-> TxOut era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut era -> Maybe (BootstrapAddress (Crypto era))
forall era.
Era era =>
TxOut era -> Maybe (BootstrapAddress (Crypto era))
getTxOutBootstrapAddress) Map (TxIn (Crypto era)) (TxOut era)
utxo
    acnt :: AccountState
acnt = EpochState era -> AccountState
forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    utxoR :: UTxO era
utxoR = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
redeemers :: UTxO era
    acnt' :: AccountState
acnt' =
      AccountState
acnt
        { _reserves :: Coin
_reserves = AccountState -> Coin
_reserves AccountState
acnt Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Value era -> Coin
forall t. Val t => t -> Coin
Val.coin (UTxO era -> Value era
forall era. Era era => UTxO era -> Value era
balance UTxO era
utxoR)
        }
    us' :: UTxOState era
us' = UTxOState era
us {_utxo :: UTxO era
_utxo = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
nonredeemers :: UTxO era}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
us'}

--------------------------------------------------------------------------------
-- Default instances
--------------------------------------------------------------------------------

instance Default (PPUPState era) where
  def :: PPUPState era
def = ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
forall era.
ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
PPUPState ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates

instance
  (Default (State (Core.EraRule "PPUP" era)), CC.Crypto (Crypto era)) =>
  Default (UTxOState era)
  where
  def :: UTxOState era
def = UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
forall era.
UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
UTxOState UTxO era
forall a. Monoid a => a
mempty Coin
forall a. Monoid a => a
mempty Coin
forall a. Monoid a => a
mempty State (EraRule "PPUP" era)
forall a. Default a => a
def IncrementalStake (Crypto era)
forall a. Monoid a => a
mempty

instance
  (Default (LedgerState era), Default (Core.PParams era)) =>
  Default (EpochState era)
  where
  def :: EpochState era
def = AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
forall era.
AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
EpochState AccountState
forall a. Default a => a
def SnapShots (Crypto era)
forall a. Default a => a
def LedgerState era
forall a. Default a => a
def PParams era
forall a. Default a => a
def PParams era
forall a. Default a => a
def NonMyopic (Crypto era)
forall a. Default a => a
def

instance Default (UTxOState era) => Default (LedgerState era) where
  def :: LedgerState era
def = UTxOState era -> DPState (Crypto era) -> LedgerState era
forall era.
UTxOState era -> DPState (Crypto era) -> LedgerState era
LedgerState UTxOState era
forall a. Default a => a
def DPState (Crypto era)
forall a. Default a => a
def

instance Default (DPState crypto) where
  def :: DPState crypto
def = DState crypto -> PState crypto -> DPState crypto
forall crypto. DState crypto -> PState crypto -> DPState crypto
DPState DState crypto
forall a. Default a => a
def PState crypto
forall a. Default a => a
def

instance Default (InstantaneousRewards crypto) where
  def :: InstantaneousRewards crypto
def = Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards crypto
forall crypto.
Map (Credential 'Staking crypto) Coin
-> Map (Credential 'Staking crypto) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards crypto
InstantaneousRewards Map (Credential 'Staking crypto) Coin
forall k a. Map k a
Map.empty Map (Credential 'Staking crypto) Coin
forall k a. Map k a
Map.empty DeltaCoin
forall a. Monoid a => a
mempty DeltaCoin
forall a. Monoid a => a
mempty

instance Default (DState crypto) where
  def :: DState crypto
def = DState crypto
forall crypto. DState crypto
emptyDState

emptyDState :: (DState crypto)
emptyDState :: DState crypto
emptyDState =
  UnifiedMap crypto
-> Map (FutureGenDeleg crypto) (GenDelegPair crypto)
-> GenDelegs crypto
-> InstantaneousRewards crypto
-> DState crypto
forall crypto.
UnifiedMap crypto
-> Map (FutureGenDeleg crypto) (GenDelegPair crypto)
-> GenDelegs crypto
-> InstantaneousRewards crypto
-> DState crypto
DState
    UnifiedMap crypto
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty
    Map (FutureGenDeleg crypto) (GenDelegPair crypto)
forall k a. Map k a
Map.empty
    (Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
forall k a. Map k a
Map.empty)
    InstantaneousRewards crypto
forall a. Default a => a
def

instance Default (PState crypto) where
  def :: PState crypto
def =
    Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) EpochNo
-> PState crypto
forall crypto.
Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
-> Map (KeyHash 'StakePool crypto) EpochNo
-> PState crypto
PState Map (KeyHash 'StakePool crypto) (PoolParams crypto)
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool crypto) (PoolParams crypto)
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool crypto) EpochNo
forall k a. Map k a
Map.empty

instance Default AccountState where
  def :: AccountState
def = Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)