{-# 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 (..),
  CompactForm (CompactCoin),
  addCompactCoin,
  compactCoinOrError,
 )
import Cardano.Ledger.Credential (Credential (..), Ptr)
import Cardano.Ledger.Hashes (GenDelegPair, GenDelegs (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PulsingRewUpdate (..),
  RewardUpdate (..),
  UTxOState (..),
  applyRUpd,
  curPParamsEpochStateL,
  futurePParamsEpochStateL,
  prevPParamsEpochStateL,
 )
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates)
import Cardano.Ledger.Shelley.Rules (emptyInstantaneousRewards, votedFuturePParams)
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.UMap (
  RDPair (..),
  UView (PtrUView, RewDepUView, SPoolUView),
  fromCompact,
  unUView,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<+>), (<->), (<×>))
import Cardano.Protocol.TPraos.BHeader (
  BHBody (..),
  BHeader,
  LastAppliedBlock (..),
  bhHash,
  bhbody,
  lastAppliedHash,
  prevHashToNonce,
 )
import Cardano.Slotting.Slot (EpochNo, WithOrigin (..))
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. 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, EraCertState era) =>
  PParams era ->
  Coin ->
  [Credential 'Staking] ->
  [PoolParams] ->
  ChainState era ->
  ChainState era
feesAndDeposits :: forall era.
(EraPParams era, EraCertState 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 :: CertState era
certState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    pstate :: PState era
pstate = CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    dstate :: DState era
dstate = CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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
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.
EraCertState era =>
PState era -> DState era -> CertState era
mkShelleyCertState
        (PState era
pstate forall a b. a -> (a -> b) -> b
& forall era. Lens' (PState era) (Map (KeyHash 'StakePool) Coin)
psDepositsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ 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)
        (DState era
dstate forall a b. a -> (a -> b) -> b
& forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k. UView k RDPair -> Map k (CompactForm Coin) -> UMap
UM.unionKeyDeposits (UMap -> UView (Credential 'Staking) RDPair
RewDepUView (DState era
dstate forall s a. s -> Getting a s a -> a
^. forall era. Lens' (DState era) UMap
dsUnifiedL)) 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.
  EraCertState era =>
  Coin ->
  Credential 'Staking ->
  ChainState era ->
  ChainState era
feesAndKeyRefund :: forall era.
EraCertState 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 :: CertState era
certState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    dstate :: DState era
dstate = CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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' = CertState era
certState forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall k. (RDPair -> RDPair) -> k -> UView k RDPair -> UMap
UM.adjust RDPair -> RDPair
zeroD Credential 'Staking
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. UMap -> UView (Credential 'Staking) RDPair
RewDepUView)
    zeroD :: RDPair -> RDPair
zeroD (RDPair CompactForm Coin
x CompactForm Coin
_) = CompactForm Coin -> CompactForm Coin -> RDPair
RDPair CompactForm Coin
x (Word64 -> CompactForm Coin
CompactCoin Word64
0)

-- | = Update the UTxO
--
-- Update the UTxO for given transaction body.
newUTxO ::
  forall era.
  (EraTx era, EraStake era) =>
  TxBody era ->
  ChainState era ->
  ChainState era
newUTxO :: forall era.
(EraTx era, EraStake 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)
    is' :: InstantStake era
is' = forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
deleteInstantStake UTxO era
utxoDel (forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake UTxO era
utxoAdd (UTxOState era
utxoSt forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) era.
CanSetInstantStake t =>
Lens' (t era) (InstantStake era)
instantStakeL))
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosUtxo :: UTxO era
utxosUtxo = UTxO era
utxo', utxosInstantStake :: InstantStake era
utxosInstantStake = InstantStake era
is'}
    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.
  EraCertState era =>
  Credential 'Staking ->
  Ptr ->
  ChainState era ->
  ChainState era
newStakeCred :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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
CompactCoin Word64
0) (Word64 -> CompactForm Coin
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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  Credential 'Staking ->
  ChainState era ->
  ChainState era
deregStakeCred :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  Credential 'Staking ->
  KeyHash 'StakePool ->
  ChainState era ->
  ChainState era
delegation :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
newPool :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
reregPool :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
updatePoolParams :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  KeyHash 'StakePool ->
  EpochNo ->
  ChainState era ->
  ChainState era
stageRetirement :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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, EraCertState era) =>
  PoolParams ->
  ChainState era ->
  ChainState era
reapPool :: forall era.
(EraGov era, EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL
    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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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
addCompactCoin CompactForm Coin
ccoin (HasCallStack => Coin -> CompactForm Coin
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}
    chainAccountState :: ChainAccountState
chainAccountState = forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    chainAccountState' :: ChainAccountState
chainAccountState' = ChainAccountState
chainAccountState {casTreasury :: Coin
casTreasury = ChainAccountState -> Coin
casTreasury ChainAccountState
chainAccountState 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
        forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps'
        forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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', esChainAccountState :: ChainAccountState
esChainAccountState = ChainAccountState
chainAccountState'}
    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.
  EraCertState era =>
  Credential 'Staking ->
  MIRPot ->
  Coin ->
  ChainState era ->
  ChainState era
mir :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  MIRPot ->
  Map (Credential 'Staking) Coin ->
  ChainState era ->
  ChainState era
applyMIR :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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
compactCoinOrError Map (Credential 'Staking) Coin
newrewards
        , dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
emptyInstantaneousRewards
        }
    dps' :: CertState era
dps' = CertState era
dps forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState :: CertState era
lsCertState = CertState era
dps'}
    chainAccountState :: ChainAccountState
chainAccountState = forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    chainAccountState' :: ChainAccountState
chainAccountState' =
      if MIRPot
pot forall a. Eq a => a -> a -> Bool
== MIRPot
ReservesMIR
        then ChainAccountState
chainAccountState {casReserves :: Coin
casReserves = ChainAccountState -> Coin
casReserves ChainAccountState
chainAccountState forall t. Val t => t -> t -> t
<-> Coin
tot}
        else ChainAccountState
chainAccountState {casTreasury :: Coin
casTreasury = ChainAccountState -> Coin
casTreasury ChainAccountState
chainAccountState forall t. Val t => t -> t -> t
<-> Coin
tot}
    es' :: EpochState era
es' = EpochState era
es {esChainAccountState :: ChainAccountState
esChainAccountState = ChainAccountState
chainAccountState', 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, EraCertState era) =>
  RewardUpdate ->
  ChainState era ->
  ChainState era
applyRewardUpdate :: forall era.
(EraGov era, EraCertState 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, EraCertState 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. 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.
  EraCertState era =>
  (FutureGenDeleg, GenDelegPair) ->
  ChainState era ->
  ChainState era
setFutureGenDeleg :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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.
  EraCertState era =>
  (FutureGenDeleg, GenDelegPair) ->
  ChainState era ->
  ChainState era
adoptFutureGenDeleg :: forall era.
EraCertState 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 = CertState era
dps forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
    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 forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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'}