{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.Combinators
-- Description : Chain State Combinators
--
-- A collection of combinators for manipulating Chain State.
-- The idea is to provide a clear way of describing the
-- changes to the chain state when a block is processed.
module Test.Cardano.Ledger.Shelley.Examples.Combinators (
  evolveNonceFrozen,
  evolveNonceUnfrozen,
  newLab,
  feesAndKeyRefund,
  feesAndDeposits,
  newUTxO,
  newStakeCred,
  deregStakeCred,
  delegation,
  newPool,
  reregPool,
  updatePoolParams,
  stageRetirement,
  reapPool,
  mir,
  applyMIR,
  rewardUpdate,
  pulserUpdate,
  applyRewardUpdate,
  setPoolDistr,
  setOCertCounter,
  newSnapshot,
  incrBlockCount,
  newEpoch,
  setCurrentProposals,
  setFutureProposals,
  solidifyProposals,
  setPParams,
  setPrevPParams,
  setFutureGenDeleg,
  adoptFutureGenDeleg,
)
where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  Nonce (..),
  StrictMaybe (..),
  quorum,
  (⭒),
 )
import Cardano.Ledger.Block (Block (..), bheader)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), Ptr)
import Cardano.Ledger.EpochBoundary (SnapShot, SnapShots (..), calculatePoolDistr)
import Cardano.Ledger.Hashes (GenDelegPair, GenDelegs (..))
import Cardano.Ledger.PoolDistr (PoolDistr (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  CertState (..),
  DState (..),
  EpochState (..),
  FutureGenDeleg (..),
  InstantaneousRewards (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  PulsingRewUpdate (..),
  RewardUpdate (..),
  UTxOState (..),
  applyRUpd,
  curPParamsEpochStateL,
  delegations,
  futurePParamsEpochStateL,
  prevPParamsEpochStateL,
  rewards,
  updateStakeDistribution,
 )
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates)
import Cardano.Ledger.Shelley.Rules (emptyInstantaneousRewards, votedFuturePParams)
import Cardano.Ledger.UMap (
  RDPair (..),
  UView (PtrUView, RewDepUView, SPoolUView),
  fromCompact,
  unUView,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..), txins, txouts)
import Cardano.Ledger.Val ((<+>), (<->), (<×>))
import Cardano.Protocol.TPraos.BHeader (
  BHBody (..),
  BHeader,
  LastAppliedBlock (..),
  bhHash,
  bhbody,
  lastAppliedHash,
  prevHashToNonce,
 )
import Cardano.Slotting.Slot (EpochNo, WithOrigin (..))
import Data.Default (Default (..))
import Data.Foldable as F (fold, foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import Lens.Micro ((%~), (&), (.~), (^.))
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainState (..))
import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo, getBlockNonce, testGlobals)

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

-- | = Evolve Nonces - Frozen
--
-- Evolve the appropriate nonces under the assumption
-- that the candidate nonce is now frozen.
evolveNonceFrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceFrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceFrozen Nonce
n ChainState era
cs = ChainState era
cs {chainEvolvingNonce :: Nonce
chainEvolvingNonce = forall era. ChainState era -> Nonce
chainEvolvingNonce ChainState era
cs Nonce -> Nonce -> Nonce
⭒ Nonce
n}

-- | = Evolve Nonces - Unfrozen
--
-- Evolve the appropriate nonces under the assumption
-- that the candidate nonce is not frozen.
-- Note: do not use this function when crossing the epoch boundary,
-- instead use 'newEpoch'.
evolveNonceUnfrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceUnfrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceUnfrozen Nonce
n ChainState era
cs =
  ChainState era
cs
    { chainCandidateNonce :: Nonce
chainCandidateNonce = forall era. ChainState era -> Nonce
chainCandidateNonce ChainState era
cs Nonce -> Nonce -> Nonce
⭒ Nonce
n
    , chainEvolvingNonce :: Nonce
chainEvolvingNonce = forall era. ChainState era -> Nonce
chainEvolvingNonce ChainState era
cs Nonce -> Nonce -> Nonce
⭒ Nonce
n
    }

-- | = New 'LastAppliedBlock' (*NOT* on epoch boundaries)
--
-- Update the chain state with the details of 'LastAppliedBlock'
-- that occur when a new block is processed.
-- Note: do not use this function when crossing the epoch boundary,
-- instead use 'newEpoch'.
newLab ::
  forall era.
  Block (BHeader MockCrypto) era ->
  ChainState era ->
  ChainState era
newLab :: forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
newLab Block (BHeader MockCrypto) era
b ChainState era
cs =
  ChainState era
cs {chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainLastAppliedBlock = forall t. t -> WithOrigin t
At forall a b. (a -> b) -> a -> b
$ BlockNo -> SlotNo -> HashHeader -> LastAppliedBlock
LastAppliedBlock BlockNo
bn SlotNo
sn (forall c. Crypto c => BHeader c -> HashHeader
bhHash BHeader MockCrypto
bh)}
  where
    bh :: BHeader MockCrypto
bh = forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) era
b
    bn :: BlockNo
bn = forall c. BHBody c -> BlockNo
bheaderBlockNo forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
bh
    sn :: SlotNo
sn = forall c. BHBody c -> SlotNo
bheaderSlotNo forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
bh

-- | = Update Fees and Deposits
--
-- Update the fee pot and deposit pot with the new fees and deposits
-- adjust the deposit tables in the UTxOState and the CertState.
-- Notes
--   1) do not give this function duplicates in the 'stakes' or 'pools' inputs.
--   2) do not use this function when crossing the epoch boundary,
-- instead use 'newEpoch'.
feesAndDeposits ::
  forall era.
  EraPParams era =>
  PParams era ->
  Coin ->
  [Credential 'Staking] ->
  [PoolParams] ->
  ChainState era ->
  ChainState era
feesAndDeposits :: forall era.
EraPParams era =>
PParams era
-> Coin
-> [Credential 'Staking]
-> [PoolParams]
-> ChainState era
-> ChainState era
feesAndDeposits PParams era
ppEx Coin
newFees [Credential 'Staking]
stakes [PoolParams]
pools ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    CertState VState era
vstate PState era
pstate DState era
dstate = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxoSt' :: UTxOState era
utxoSt' =
      UTxOState era
utxoSt
        { utxosDeposited :: Coin
utxosDeposited =
            forall era. UTxOState era -> Coin
utxosDeposited UTxOState era
utxoSt
              forall t. Val t => t -> t -> t
<+> (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Credential 'Staking]
stakes forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
ppEx forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
              forall t. Val t => t -> t -> t
<+> (Integer
newcount forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
ppEx forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)
        , utxosFees :: Coin
utxosFees = forall era. UTxOState era -> Coin
utxosFees UTxOState era
utxoSt forall t. Val t => t -> t -> t
<+> Coin
newFees
        }
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt', lsCertState :: CertState era
lsCertState = CertState era
dpstate'}
    -- Count the number of new pools, because we don't take a deposit for existing pools
    -- This strategy DOES NOT WORK if there are duplicate PoolParams in one call
    newcount :: Integer
newcount = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Integer -> PoolParams -> Integer
accum Integer
0 [PoolParams]
pools
    accum :: Integer -> PoolParams -> Integer
accum Integer
n PoolParams
x = if forall k a. Ord k => k -> Map k a -> Bool
Map.member (PoolParams -> KeyHash 'StakePool
ppId PoolParams
x) (forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits PState era
pstate) then (Integer
n :: Integer) else Integer
n forall a. Num a => a -> a -> a
+ Integer
1
    newDeposits :: Map (Credential 'Staking) (CompactForm Coin)
newDeposits =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\Credential 'Staking
cred -> (Credential 'Staking
cred, HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError (PParams era
ppEx forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL))) [Credential 'Staking]
stakes)
    newPools :: Map (KeyHash 'StakePool) Coin
newPools = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\PoolParams
p -> (PoolParams -> KeyHash 'StakePool
ppId PoolParams
p, PParams era
ppEx forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)) [PoolParams]
pools)
    dpstate' :: CertState era
dpstate' =
      forall era. VState era -> PState era -> DState era -> CertState era
CertState
        VState era
vstate
        PState era
pstate {psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\Coin
old Coin
_new -> Coin
old) Map (KeyHash 'StakePool) Coin
newPools (forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits PState era
pstate)}
        DState era
dstate {dsUnified :: UMap
dsUnified = forall k. UView k RDPair -> Map k (CompactForm Coin) -> UMap
UM.unionKeyDeposits (UMap -> UView (Credential 'Staking) RDPair
RewDepUView (forall era. DState era -> UMap
dsUnified DState era
dstate)) Map (Credential 'Staking) (CompactForm Coin)
newDeposits}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

feesAndKeyRefund ::
  forall era.
  Coin ->
  Credential 'Staking ->
  ChainState era ->
  ChainState era
feesAndKeyRefund :: forall era.
Coin -> Credential 'Staking -> ChainState era -> ChainState era
feesAndKeyRefund Coin
newFees Credential 'Staking
key ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    CertState VState era
_vstate PState era
pstate DState era
dstate = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    refund :: Coin
refund = case forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
key (UMap -> UView (Credential 'Staking) RDPair
RewDepUView (forall era. DState era -> UMap
dsUnified DState era
dstate)) of
      Maybe RDPair
Nothing -> Integer -> Coin
Coin Integer
0
      Just (RDPair CompactForm Coin
_ CompactForm Coin
ccoin) -> forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
ccoin
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxoSt' :: UTxOState era
utxoSt' =
      UTxOState era
utxoSt
        { utxosDeposited :: Coin
utxosDeposited = forall era. UTxOState era -> Coin
utxosDeposited UTxOState era
utxoSt forall t. Val t => t -> t -> t
<-> Coin
refund
        , utxosFees :: Coin
utxosFees = forall era. UTxOState era -> Coin
utxosFees UTxOState era
utxoSt forall t. Val t => t -> t -> t
<+> Coin
newFees
        }
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt', lsCertState :: CertState era
lsCertState = CertState era
dpstate'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}
    dpstate' :: CertState era
dpstate' = forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def PState era
pstate DState era
dstate {dsUnified :: UMap
dsUnified = forall k. (RDPair -> RDPair) -> k -> UView k RDPair -> UMap
UM.adjust RDPair -> RDPair
zeroD Credential 'Staking
key (UMap -> UView (Credential 'Staking) RDPair
RewDepUView (forall era. DState era -> UMap
dsUnified DState era
dstate))}
    zeroD :: RDPair -> RDPair
zeroD (RDPair CompactForm Coin
x CompactForm Coin
_) = CompactForm Coin -> CompactForm Coin -> RDPair
RDPair CompactForm Coin
x (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0)

-- | = Update the UTxO
--
-- Update the UTxO for given transaction body.
newUTxO ::
  forall era.
  (EraTx era, EraGov era) =>
  TxBody era ->
  ChainState era ->
  ChainState era
newUTxO :: forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
newUTxO TxBody era
txb ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxo :: Map TxIn (TxOut era)
utxo = forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall a b. (a -> b) -> a -> b
$ forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoSt
    utxoAdd :: UTxO era
utxoAdd = forall era. EraTxBody era => TxBody era -> UTxO era
txouts @era TxBody era
txb
    utxoToDel :: Map TxIn (TxOut era)
utxoToDel = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
utxo (forall era. EraTxBody era => TxBody era -> Set TxIn
txins @era TxBody era
txb)
    utxoWithout :: Map TxIn (TxOut era)
utxoWithout = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map TxIn (TxOut era)
utxo (forall era. EraTxBody era => TxBody era -> Set TxIn
txins @era TxBody era
txb)
    utxoDel :: UTxO era
utxoDel = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoToDel
    utxo' :: UTxO era
utxo' = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era)
utxoWithout forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxoAdd)
    sd' :: IncrementalStake
sd' =
      forall era.
EraTxOut era =>
PParams era
-> IncrementalStake -> UTxO era -> UTxO era -> IncrementalStake
updateStakeDistribution @era (EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL) (forall era. UTxOState era -> IncrementalStake
utxosStakeDistr UTxOState era
utxoSt) UTxO era
utxoDel UTxO era
utxoAdd
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosUtxo :: UTxO era
utxosUtxo = UTxO era
utxo', utxosStakeDistr :: IncrementalStake
utxosStakeDistr = IncrementalStake
sd'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = New Stake Credential
--
--   Add a newly registered stake credential, initialize the rdRewards component of the RDPair.
--   The rdDeposit component of the RDPair is set by 'feesAndDeposits'
newStakeCred ::
  forall era.
  Credential 'Staking ->
  Ptr ->
  ChainState era ->
  ChainState era
newStakeCred :: forall era.
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
newStakeCred Credential 'Staking
cred Ptr
ptr ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    ds' :: DState era
ds' =
      DState era
ds
        { dsUnified :: UMap
dsUnified =
            let um0 :: UMap
um0 = forall era. DState era -> UMap
dsUnified DState era
ds
                um1 :: UMap
um1 = forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
cred (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0) (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0)) (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
um0)
                um2 :: UMap
um2 = (UMap -> UView Ptr (Credential 'Staking)
PtrUView UMap
um1 forall k v. UView k v -> (k, v) -> UMap
UM.∪ (Ptr
ptr, Credential 'Staking
cred))
             in UMap
um2
        }
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = De-Register Stake Credential
--
-- De-register a stake credential and all associated data.
-- Be sure to run 'feesAndKeyRefund' before you run this
-- because this throws away the stored refund, which then
-- can't be used to balance the utxosDeposited field in 'feesAndKeyRefund'
deregStakeCred ::
  forall era.
  Credential 'Staking ->
  ChainState era ->
  ChainState era
deregStakeCred :: forall era. Credential 'Staking -> ChainState era -> ChainState era
deregStakeCred Credential 'Staking
cred ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    ds' :: DState era
ds' =
      DState era
ds
        { dsUnified :: UMap
dsUnified =
            let um0 :: UMap
um0 = forall era. DState era -> UMap
dsUnified DState era
ds
                um1 :: UMap
um1 = forall k v. k -> UView k v -> UMap
UM.delete Credential 'Staking
cred (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
um0)
                um2 :: UMap
um2 = UMap -> UView Ptr (Credential 'Staking)
PtrUView UMap
um1 forall k v. UView k v -> Set v -> UMap
UM.⋫ forall a. a -> Set a
Set.singleton Credential 'Staking
cred
                um3 :: UMap
um3 = forall k v. k -> UView k v -> UMap
UM.delete Credential 'Staking
cred (UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
SPoolUView UMap
um2)
             in UMap
um3
        }
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = New Delegation
--
-- Create a delegation from the given stake credential to the given
-- stake pool.
delegation ::
  forall era.
  Credential 'Staking ->
  KeyHash 'StakePool ->
  ChainState era ->
  ChainState era
delegation :: forall era.
Credential 'Staking
-> KeyHash 'StakePool -> ChainState era -> ChainState era
delegation Credential 'Staking
cred KeyHash 'StakePool
pool ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    ds' :: DState era
ds' =
      DState era
ds
        { dsUnified :: UMap
dsUnified = forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
cred KeyHash 'StakePool
pool (forall era.
DState era -> UView (Credential 'Staking) (KeyHash 'StakePool)
delegations DState era
ds)
        }
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = New Stake Pool
--
-- Add a newly registered stake pool
newPool ::
  forall era.
  PoolParams ->
  ChainState era ->
  ChainState era
newPool :: forall era. PoolParams -> ChainState era -> ChainState era
newPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = forall era. CertState era -> PState era
certPState CertState era
dps
    ps' :: PState era
ps' =
      PState era
ps
        { psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) PoolParams
pool (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
ps)
        }
    dps' :: CertState era
dps' = CertState era
dps {certPState :: PState era
certPState = PState era
ps'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Re-Register Stake Pool
reregPool ::
  forall era.
  PoolParams ->
  ChainState era ->
  ChainState era
reregPool :: forall era. PoolParams -> ChainState era -> ChainState era
reregPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = forall era. CertState era -> PState era
certPState CertState era
dps
    ps' :: PState era
ps' =
      PState era
ps
        { psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) PoolParams
pool (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
ps)
        }
    dps' :: CertState era
dps' = CertState era
dps {certPState :: PState era
certPState = PState era
ps'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Re-Register Stake Pool
updatePoolParams ::
  forall era.
  PoolParams ->
  ChainState era ->
  ChainState era
updatePoolParams :: forall era. PoolParams -> ChainState era -> ChainState era
updatePoolParams PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = forall era. CertState era -> PState era
certPState CertState era
dps
    ps' :: PState era
ps' =
      PState era
ps
        { psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) PoolParams
pool (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
ps)
        , psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
ps)
        }
    dps' :: CertState era
dps' = CertState era
dps {certPState :: PState era
certPState = PState era
ps'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Pool Retirement
--
-- Stage a stake pool for retirement.
stageRetirement ::
  forall era.
  KeyHash 'StakePool ->
  EpochNo ->
  ChainState era ->
  ChainState era
stageRetirement :: forall era.
KeyHash 'StakePool -> EpochNo -> ChainState era -> ChainState era
stageRetirement KeyHash 'StakePool
kh EpochNo
e ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = forall era. CertState era -> PState era
certPState CertState era
dps
    ps' :: PState era
ps' = PState era
ps {psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh EpochNo
e (forall era. PState era -> Map (KeyHash 'StakePool) EpochNo
psRetiring PState era
ps)}
    dps' :: CertState era
dps' = CertState era
dps {certPState :: PState era
certPState = PState era
ps'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Reap Pool
--
-- Remove a stake pool.
reapPool ::
  forall era.
  EraGov era =>
  PoolParams ->
  ChainState era ->
  ChainState era
reapPool :: forall era.
EraGov era =>
PoolParams -> ChainState era -> ChainState era
reapPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    kh :: KeyHash 'StakePool
kh = PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = forall era. CertState era -> PState era
certPState CertState era
dps
    ps' :: PState era
ps' =
      PState era
ps
        { psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool
kh (forall era. PState era -> Map (KeyHash 'StakePool) EpochNo
psRetiring PState era
ps)
        , psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool
kh (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
ps)
        , psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool
kh (forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits PState era
ps)
        }
    pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    RewardAccount Network
_ Credential 'Staking
rewardAddr = PoolParams -> RewardAccount
ppRewardAccount PoolParams
pool
    (UView (Credential 'Staking) RDPair
rewards', Coin
unclaimed) =
      case forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
rewardAddr (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds) of
        Maybe RDPair
Nothing -> (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds, PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)
        Just (UM.RDPair CompactForm Coin
ccoin CompactForm Coin
dep) ->
          ( forall k v. k -> v -> UView k v -> UView k v
UM.insert'
              Credential 'Staking
rewardAddr
              (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (CompactForm Coin -> CompactForm Coin -> CompactForm Coin
UM.addCompact CompactForm Coin
ccoin (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL))) CompactForm Coin
dep)
              (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds)
          , Integer -> Coin
Coin Integer
0
          )
    -- FIXME shouldn't we look up the pooldeposit here?
    umap1 :: UMap
umap1 = forall k v. UView k v -> UMap
unUView UView (Credential 'Staking) RDPair
rewards'
    umap2 :: UMap
umap2 = UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
umap1 forall k v. UView k v -> Set v -> UMap
UM.⋫ forall a. a -> Set a
Set.singleton KeyHash 'StakePool
kh
    ds' :: DState era
ds' = DState era
ds {dsUnified :: UMap
dsUnified = UMap
umap2}
    as :: AccountState
as = forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    as' :: AccountState
as' = AccountState
as {asTreasury :: Coin
asTreasury = AccountState -> Coin
asTreasury AccountState
as forall t. Val t => t -> t -> t
<+> Coin
unclaimed}
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosDeposited :: Coin
utxosDeposited = forall era. UTxOState era -> Coin
utxosDeposited UTxOState era
utxoSt forall t. Val t => t -> t -> t
<-> (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)}
    dps' :: CertState era
dps' = CertState era
dps {certPState :: PState era
certPState = PState era
ps', certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps', lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls', esAccountState :: AccountState
esAccountState = AccountState
as'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = MIR
--
-- Add a credential to the MIR mapping for the given pot (reserves or treasury)
mir ::
  forall era.
  Credential 'Staking ->
  MIRPot ->
  Coin ->
  ChainState era ->
  ChainState era
mir :: forall era.
Credential 'Staking
-> MIRPot -> Coin -> ChainState era -> ChainState era
mir Credential 'Staking
cred MIRPot
pot Coin
amnt ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    InstantaneousRewards
      { iRReserves :: InstantaneousRewards -> Map (Credential 'Staking) Coin
iRReserves = Map (Credential 'Staking) Coin
ir
      , iRTreasury :: InstantaneousRewards -> Map (Credential 'Staking) Coin
iRTreasury = Map (Credential 'Staking) Coin
it
      , deltaReserves :: InstantaneousRewards -> DeltaCoin
deltaReserves = DeltaCoin
dr
      , deltaTreasury :: InstantaneousRewards -> DeltaCoin
deltaTreasury = DeltaCoin
dt
      } = forall era. DState era -> InstantaneousRewards
dsIRewards DState era
ds
    irwd' :: InstantaneousRewards
irwd' = case MIRPot
pot of
      MIRPot
ReservesMIR -> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards
InstantaneousRewards (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred Coin
amnt Map (Credential 'Staking) Coin
ir) Map (Credential 'Staking) Coin
it DeltaCoin
dr DeltaCoin
dt
      MIRPot
TreasuryMIR -> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards
InstantaneousRewards Map (Credential 'Staking) Coin
ir (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'Staking
cred Coin
amnt Map (Credential 'Staking) Coin
it) DeltaCoin
dr DeltaCoin
dt
    ds' :: DState era
ds' = DState era
ds {dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
irwd'}
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Apply MIR
--
-- On the epoch boundary, reset the MIR mappings and augment the rewards.
applyMIR ::
  forall era.
  MIRPot ->
  Map (Credential 'Staking) Coin ->
  ChainState era ->
  ChainState era
applyMIR :: forall era.
MIRPot
-> Map (Credential 'Staking) Coin
-> ChainState era
-> ChainState era
applyMIR MIRPot
pot Map (Credential 'Staking) Coin
newrewards ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    tot :: Coin
tot = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential 'Staking) Coin
newrewards
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    ds' :: DState era
ds' =
      DState era
ds
        { dsUnified :: UMap
dsUnified = forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds UView (Credential 'Staking) RDPair
-> Map (Credential 'Staking) (CompactForm Coin) -> UMap
UM.∪+ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Map (Credential 'Staking) Coin
newrewards
        , dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
emptyInstantaneousRewards
        }
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    as :: AccountState
as = forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    as' :: AccountState
as' =
      if MIRPot
pot forall a. Eq a => a -> a -> Bool
== MIRPot
ReservesMIR
        then AccountState
as {asReserves :: Coin
asReserves = AccountState -> Coin
asReserves AccountState
as forall t. Val t => t -> t -> t
<-> Coin
tot}
        else AccountState
as {asTreasury :: Coin
asTreasury = AccountState -> Coin
asTreasury AccountState
as forall t. Val t => t -> t -> t
<-> Coin
tot}
    es' :: EpochState era
es' = EpochState era
es {esAccountState :: AccountState
esAccountState = AccountState
as', esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Reward Update
--
-- Update the chain state with the given reward update
rewardUpdate ::
  forall era.
  RewardUpdate ->
  ChainState era ->
  ChainState era
rewardUpdate :: forall era. RewardUpdate -> ChainState era -> ChainState era
rewardUpdate RewardUpdate
ru ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes' :: NewEpochState era
nes' = (forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. a -> StrictMaybe a
SJust (RewardUpdate -> PulsingRewUpdate
Complete RewardUpdate
ru)}

-- | = Pulser
--
-- Update the chain state with the given reward update pulser
pulserUpdate ::
  forall era.
  PulsingRewUpdate ->
  ChainState era ->
  ChainState era
pulserUpdate :: forall era. PulsingRewUpdate -> ChainState era -> ChainState era
pulserUpdate PulsingRewUpdate
p ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes' :: NewEpochState era
nes' = (forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
p}

-- | = Apply a Reward Update
--
-- Apply the given reward update to the chain state
applyRewardUpdate ::
  forall era.
  EraGov era =>
  RewardUpdate ->
  ChainState era ->
  ChainState era
applyRewardUpdate :: forall era.
EraGov era =>
RewardUpdate -> ChainState era -> ChainState era
applyRewardUpdate RewardUpdate
ru ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es' :: EpochState era
es' = forall era.
EraGov era =>
RewardUpdate -> EpochState era -> EpochState era
applyRUpd RewardUpdate
ru (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes)
    nes' :: NewEpochState era
nes' = (forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesEs :: EpochState era
nesEs = EpochState era
es', nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. StrictMaybe a
SNothing}

-- | = New Snapshot
--
-- Add a new snapshot and rotate the others
newSnapshot ::
  forall era.
  SnapShot ->
  Coin ->
  ChainState era ->
  ChainState era
newSnapshot :: forall era. SnapShot -> Coin -> ChainState era -> ChainState era
newSnapshot SnapShot
snap Coin
fee ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    SnapShots
      { $sel:ssStakeMark:SnapShots :: SnapShots -> SnapShot
ssStakeMark = SnapShot
ssMark
      , $sel:ssStakeSet:SnapShots :: SnapShots -> SnapShot
ssStakeSet = SnapShot
ssSet
      } = forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es
    snaps :: SnapShots
snaps =
      SnapShots
        { $sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark = SnapShot
snap
        , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
snap
        , $sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet = SnapShot
ssMark
        , $sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo = SnapShot
ssSet
        , $sel:ssFee:SnapShots :: Coin
ssFee = Coin
fee
        }
    es' :: EpochState era
es' = EpochState era
es {esSnapshots :: SnapShots
esSnapshots = SnapShots
snaps}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Set Pool Distribution
--
-- Set the stake pool distribution to the given one.
setPoolDistr ::
  forall era.
  PoolDistr ->
  ChainState era ->
  ChainState era
setPoolDistr :: forall era. PoolDistr -> ChainState era -> ChainState era
setPoolDistr PoolDistr
pd ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes' :: NewEpochState era
nes' = (forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesPd :: PoolDistr
nesPd = PoolDistr
pd}

-- | = Set Operation Certificate Counter
--
-- Set the operational certificates counter for a given stake pool.
setOCertCounter ::
  forall era.
  KeyHash 'BlockIssuer ->
  Word64 ->
  ChainState era ->
  ChainState era
setOCertCounter :: forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
setOCertCounter KeyHash 'BlockIssuer
kh Word64
n ChainState era
cs = ChainState era
cs {chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue = Map (KeyHash 'BlockIssuer) Word64
counters}
  where
    counters :: Map (KeyHash 'BlockIssuer) Word64
counters = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'BlockIssuer
kh Word64
n (forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue ChainState era
cs)

-- | = Increase Block Count
--
-- Record that the given stake pool (non-core node) produced a block.
incrBlockCount ::
  forall era.
  KeyHash 'StakePool ->
  ChainState era ->
  ChainState era
incrBlockCount :: forall era. KeyHash 'StakePool -> ChainState era -> ChainState era
incrBlockCount KeyHash 'StakePool
kh ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    BlocksMade Map (KeyHash 'StakePool) Natural
bs = forall era. NewEpochState era -> BlocksMade
nesBcur NewEpochState era
nes
    n :: Natural
n = Natural
1 forall a. Num a => a -> a -> a
+ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Natural
0 KeyHash 'StakePool
kh Map (KeyHash 'StakePool) Natural
bs
    bs' :: BlocksMade
bs' = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
kh Natural
n Map (KeyHash 'StakePool) Natural
bs
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesBcur :: BlocksMade
nesBcur = BlocksMade
bs'}

-- | = New Epoch
--
-- Update the new epoch number, set the nonces, set the last applied block,
-- and reset blocks made.
-- Note: This function subsumes the manipulations done by
-- 'newLab', 'evolveNonceUnfrozen', and 'evolveNonceFrozen'.
newEpoch ::
  forall era.
  (ProtVerAtMost era 6, EraGov era) =>
  Block (BHeader MockCrypto) era ->
  ChainState era ->
  ChainState era
newEpoch :: forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
newEpoch Block (BHeader MockCrypto) era
b ChainState era
cs = ChainState era
cs'
  where
    ChainState
      { chainNes :: forall era. ChainState era -> NewEpochState era
chainNes = NewEpochState era
nes
      , chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce = Nonce
evNonce
      , chainCandidateNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce = Nonce
cNonce
      , chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce = Nonce
pNonce
      , chainLastAppliedBlock :: forall era. ChainState era -> WithOrigin LastAppliedBlock
chainLastAppliedBlock = WithOrigin LastAppliedBlock
lab
      } = ChainState era
cs
    bh :: BHeader MockCrypto
bh = forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) era
b
    bn :: BlockNo
bn = forall c. BHBody c -> BlockNo
bheaderBlockNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto
bh
    sn :: SlotNo
sn = forall c. BHBody c -> SlotNo
bheaderSlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto
bh
    pp :: PParams era
pp = forall a s. Getting a s a -> s -> a
view forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs forall a b. (a -> b) -> a -> b
$ NewEpochState era
nes
    e :: EpochNo
e = SlotNo -> EpochNo
epochFromSlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. BHBody c -> SlotNo
bheaderSlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h era. Block h era -> h
bheader forall a b. (a -> b) -> a -> b
$ Block (BHeader MockCrypto) era
b
    nes' :: NewEpochState era
nes' =
      NewEpochState era
nes
        { nesEL :: EpochNo
nesEL = EpochNo
e
        , nesBprev :: BlocksMade
nesBprev = forall era. NewEpochState era -> BlocksMade
nesBcur NewEpochState era
nes
        , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty
        }
    n :: Nonce
n = forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) era
b
    cs' :: ChainState era
cs' =
      ChainState era
cs
        { chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'
        , chainEpochNonce :: Nonce
chainEpochNonce = Nonce
cNonce Nonce -> Nonce -> Nonce
⭒ Nonce
pNonce Nonce -> Nonce -> Nonce
⭒ (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL)
        , chainEvolvingNonce :: Nonce
chainEvolvingNonce = Nonce
evNonce Nonce -> Nonce -> Nonce
⭒ Nonce
n
        , chainCandidateNonce :: Nonce
chainCandidateNonce = Nonce
evNonce Nonce -> Nonce -> Nonce
⭒ Nonce
n
        , chainPrevEpochNonce :: Nonce
chainPrevEpochNonce = PrevHash -> Nonce
prevHashToNonce forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOrigin LastAppliedBlock -> PrevHash
lastAppliedHash forall a b. (a -> b) -> a -> b
$ WithOrigin LastAppliedBlock
lab
        , chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainLastAppliedBlock = forall t. t -> WithOrigin t
At forall a b. (a -> b) -> a -> b
$ BlockNo -> SlotNo -> HashHeader -> LastAppliedBlock
LastAppliedBlock BlockNo
bn SlotNo
sn (forall c. Crypto c => BHeader c -> HashHeader
bhHash BHeader MockCrypto
bh)
        }

-- | = Set Current Proposals
--
-- Set the current protocol parameter proposals.
setCurrentProposals ::
  forall era.
  (GovState era ~ ShelleyGovState era, EraPParams era) =>
  ProposedPPUpdates era ->
  ChainState era ->
  ChainState era
setCurrentProposals :: forall era.
(GovState era ~ ShelleyGovState era, EraPParams era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
setCurrentProposals ProposedPPUpdates era
ps ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    govState :: GovState era
govState = forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoSt
    pp :: PParams era
pp = forall era. ShelleyGovState era -> PParams era
sgsCurPParams GovState era
govState
    govState' :: ShelleyGovState era
govState' =
      GovState era
govState
        { sgsCurProposals :: ProposedPPUpdates era
sgsCurProposals = ProposedPPUpdates era
ps
        , sgsFuturePParams :: FuturePParams era
sgsFuturePParams =
            forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
ProposedPPUpdates era
-> PParams era -> Word64 -> Maybe (PParams era)
votedFuturePParams ProposedPPUpdates era
ps PParams era
pp (Globals -> Word64
quorum Globals
testGlobals)
        }
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosGovState :: GovState era
utxosGovState = ShelleyGovState era
govState'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Set Future Proposals
--
-- Set the future protocol parameter proposals.
setFutureProposals ::
  forall era.
  GovState era ~ ShelleyGovState era =>
  ProposedPPUpdates era ->
  ChainState era ->
  ChainState era
setFutureProposals :: forall era.
(GovState era ~ ShelleyGovState era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
setFutureProposals ProposedPPUpdates era
ps ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    govState :: GovState era
govState = forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoSt
    govState' :: ShelleyGovState era
govState' = GovState era
govState {sgsFutureProposals :: ProposedPPUpdates era
sgsFutureProposals = ProposedPPUpdates era
ps}
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosGovState :: GovState era
utxosGovState = ShelleyGovState era
govState'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

solidifyProposals ::
  forall era.
  EraGov era =>
  ChainState era ->
  ChainState era
solidifyProposals :: forall era. EraGov era => ChainState era -> ChainState era
solidifyProposals ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es}}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes forall a b. a -> (a -> b) -> b
& forall era.
EraGov era =>
Lens' (EpochState era) (FuturePParams era)
futurePParamsEpochStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall era. FuturePParams era -> FuturePParams era
solidifyFuturePParams

-- | = Set the Protocol Proposals
--
-- Set the protocol parameters.
setPParams ::
  forall era.
  EraGov era =>
  PParams era ->
  ChainState era ->
  ChainState era
setPParams :: forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
setPParams PParams era
pp ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    es' :: EpochState era
es' = EpochState era
es forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Set the Previous Protocol Proposals
--
-- Set the previous protocol parameters.
setPrevPParams ::
  forall era.
  EraGov era =>
  PParams era ->
  ChainState era ->
  ChainState era
setPrevPParams :: forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
setPrevPParams PParams era
pp ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    es' :: EpochState era
es' = EpochState era
es forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Set a future genesis delegation.
setFutureGenDeleg ::
  forall era.
  (FutureGenDeleg, GenDelegPair) ->
  ChainState era ->
  ChainState era
setFutureGenDeleg :: forall era.
(FutureGenDeleg, GenDelegPair) -> ChainState era -> ChainState era
setFutureGenDeleg (FutureGenDeleg
fg, GenDelegPair
gd) ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    ds' :: DState era
ds' = DState era
ds {dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FutureGenDeleg
fg GenDelegPair
gd (forall era. DState era -> Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs DState era
ds)}
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}

-- | = Set a future genesis delegation.
adoptFutureGenDeleg ::
  forall era.
  (FutureGenDeleg, GenDelegPair) ->
  ChainState era ->
  ChainState era
adoptFutureGenDeleg :: forall era.
(FutureGenDeleg, GenDelegPair) -> ChainState era -> ChainState era
adoptFutureGenDeleg (FutureGenDeleg
fg, GenDelegPair
gd) ChainState era
cs = ChainState era
cs {chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'}
  where
    nes :: NewEpochState era
nes = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = forall era. CertState era -> DState era
certDState CertState era
dps
    gds :: GenDelegs
gds = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FutureGenDeleg -> KeyHash 'Genesis
fGenDelegGenKeyHash FutureGenDeleg
fg) GenDelegPair
gd (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs (forall era. DState era -> GenDelegs
dsGenDelegs DState era
ds))
    ds' :: DState era
ds' =
      DState era
ds
        { dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FutureGenDeleg
fg (forall era. DState era -> Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs DState era
ds)
        , dsGenDelegs :: GenDelegs
dsGenDelegs = GenDelegs
gds
        }
    dps' :: CertState era
dps' = CertState era
dps {certDState :: DState era
certDState = DState era
ds'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState :: LedgerState era
esLState = LedgerState era
ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs :: EpochState era
nesEs = EpochState era
es'}