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

-- | 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,
  addFees,
  newUTxO,
  newStakeCred,
  deregStakeCred,
  delegation,
  regPool,
  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 (..),
  Network,
  Nonce (..),
  StrictMaybe (..),
  quorum,
  (⭒),
 )
import Cardano.Ledger.Block (Block (..))
import Cardano.Ledger.Coin (
  Coin (..),
  compactCoinOrError,
 )
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential (..), Ptr)
import Cardano.Ledger.Hashes (GenDelegPair, GenDelegs (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PulsingRewUpdate (..),
  RewardUpdate (..),
  UTxOState (..),
  applyRUpd,
  curPParamsEpochStateL,
  esLStateL,
  futurePParamsEpochStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesEsL,
  prevPParamsEpochStateL,
  utxosDepositedL,
  utxosFeesL,
 )
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates)
import Cardano.Ledger.Shelley.Rules (emptyInstantaneousRewards, votedFuturePParams)
import Cardano.Ledger.Shelley.State
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 (fold)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
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 = chainEvolvingNonce cs ⭒ 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 = chainCandidateNonce cs ⭒ n
    , chainEvolvingNonce = chainEvolvingNonce cs ⭒ 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 = At $ LastAppliedBlock bn sn (bhHash bh)}
  where
    bh :: BHeader MockCrypto
bh = Block (BHeader MockCrypto) era -> BHeader MockCrypto
forall h era. Block h era -> h
blockHeader Block (BHeader MockCrypto) era
b
    bn :: BlockNo
bn = BHBody MockCrypto -> BlockNo
forall c. BHBody c -> BlockNo
bheaderBlockNo (BHBody MockCrypto -> BlockNo) -> BHBody MockCrypto -> BlockNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
bh
    sn :: SlotNo
sn = BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> SlotNo) -> BHBody MockCrypto -> SlotNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
bh

addFees ::
  Coin ->
  ChainState era ->
  ChainState era
addFees :: forall era. Coin -> ChainState era -> ChainState era
addFees Coin
newFees ChainState era
cs = ChainState era
cs {chainNes = nes}
  where
    nes :: NewEpochState era
nes =
      ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Coin -> Identity Coin)
    -> EpochState era -> Identity (EpochState era))
-> (Coin -> Identity Coin)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Coin -> Identity Coin)
    -> LedgerState era -> Identity (LedgerState era))
-> (Coin -> Identity Coin)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Coin -> Identity Coin)
    -> UTxOState era -> Identity (UTxOState era))
-> (Coin -> Identity Coin)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosFeesL ((Coin -> Identity Coin)
 -> NewEpochState era -> Identity (NewEpochState era))
-> Coin -> NewEpochState era -> NewEpochState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Coin
newFees

-- | = Update the UTxO
--
-- Update the UTxO for given transaction body.
newUTxO ::
  forall era.
  (EraTx era, EraStake era) =>
  TxBody TopTx era ->
  ChainState era ->
  ChainState era
newUTxO :: forall era.
(EraTx era, EraStake era) =>
TxBody TopTx era -> ChainState era -> ChainState era
newUTxO TxBody TopTx era
txb ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxo :: Map TxIn (TxOut era)
utxo = UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO era -> Map TxIn (TxOut era))
-> UTxO era -> Map TxIn (TxOut era)
forall a b. (a -> b) -> a -> b
$ UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoSt
    utxoAdd :: UTxO era
utxoAdd = forall era (l :: TxLevel).
EraTxBody era =>
TxBody l era -> UTxO era
txouts @era TxBody TopTx era
txb
    utxoToDel :: Map TxIn (TxOut era)
utxoToDel = Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
utxo (forall era (t :: TxLevel).
EraTxBody era =>
TxBody t era -> Set TxIn
txins @era TxBody TopTx era
txb)
    utxoWithout :: Map TxIn (TxOut era)
utxoWithout = Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map TxIn (TxOut era)
utxo (forall era (t :: TxLevel).
EraTxBody era =>
TxBody t era -> Set TxIn
txins @era TxBody TopTx era
txb)
    utxoDel :: UTxO era
utxoDel = Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoToDel
    utxo' :: UTxO era
utxo' = Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era)
utxoWithout Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxoAdd)
    is' :: InstantStake era
is' = UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
deleteInstantStake UTxO era
utxoDel (UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake UTxO era
utxoAdd (UTxOState era
utxoSt UTxOState era
-> Getting (InstantStake era) (UTxOState era) (InstantStake era)
-> InstantStake era
forall s a. s -> Getting a s a -> a
^. Getting (InstantStake era) (UTxOState era) (InstantStake era)
forall era. Lens' (UTxOState era) (InstantStake era)
forall (t :: * -> *) era.
CanSetInstantStake t =>
Lens' (t era) (InstantStake era)
instantStakeL))
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosUtxo = utxo', utxosInstantStake = is'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState = utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = es'}

-- | = New Stake Credential
--
--   Add a newly registered stake credential.
newStakeCred ::
  (EraCertState era, EraGov era, ShelleyEraAccounts era) =>
  Credential Staking ->
  Ptr ->
  ChainState era ->
  ChainState era
newStakeCred :: forall era.
(EraCertState era, EraGov era, ShelleyEraAccounts era) =>
Credential Staking -> Ptr -> ChainState era -> ChainState era
newStakeCred Credential Staking
cred Ptr
ptr ChainState era
cs = ChainState era
cs {chainNes = nes}
  where
    deposit :: Coin
deposit = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs NewEpochState era -> Getting Coin (NewEpochState era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const Coin (EpochState era))
-> NewEpochState era -> Const Coin (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const Coin (EpochState era))
 -> NewEpochState era -> Const Coin (NewEpochState era))
-> ((Coin -> Const Coin Coin)
    -> EpochState era -> Const Coin (EpochState era))
-> Getting Coin (NewEpochState era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const Coin (PParams era))
-> EpochState era -> Const Coin (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const Coin (PParams era))
 -> EpochState era -> Const Coin (EpochState era))
-> ((Coin -> Const Coin Coin)
    -> PParams era -> Const Coin (PParams era))
-> (Coin -> Const Coin Coin)
-> EpochState era
-> Const Coin (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> PParams era -> Const Coin (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
    nes :: NewEpochState era
nes =
      ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> EpochState era -> Identity (EpochState era))
-> (Accounts era -> Identity (Accounts era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> LedgerState era -> Identity (LedgerState era))
-> (Accounts era -> Identity (Accounts era))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Accounts era -> Identity (Accounts era))
    -> CertState era -> Identity (CertState era))
-> (Accounts era -> Identity (Accounts era))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Accounts era -> Identity (Accounts era))
    -> DState era -> Identity (DState era))
-> (Accounts era -> Identity (Accounts era))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
          ((Accounts era -> Identity (Accounts era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (Accounts era -> Accounts era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> Ptr
-> CompactForm Coin
-> Maybe (KeyHash StakePool)
-> Accounts era
-> Accounts era
forall era.
ShelleyEraAccounts era =>
Credential Staking
-> Ptr
-> CompactForm Coin
-> Maybe (KeyHash StakePool)
-> Accounts era
-> Accounts era
registerShelleyAccount Credential Staking
cred Ptr
ptr (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Coin
deposit) Maybe (KeyHash StakePool)
forall a. Maybe a
Nothing
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Coin -> Identity Coin)
    -> EpochState era -> Identity (EpochState era))
-> (Coin -> Identity Coin)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Coin -> Identity Coin)
    -> LedgerState era -> Identity (LedgerState era))
-> (Coin -> Identity Coin)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Coin -> Identity Coin)
    -> UTxOState era -> Identity (UTxOState era))
-> (Coin -> Identity Coin)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL ((Coin -> Identity Coin)
 -> NewEpochState era -> Identity (NewEpochState era))
-> Coin -> NewEpochState era -> NewEpochState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Coin
deposit

-- | = De-Register Stake Credential
--
-- De-register a stake credential and all associated data.
deregStakeCred ::
  (HasCallStack, EraCertState era, ShelleyEraAccounts era) =>
  Credential Staking ->
  ChainState era ->
  ChainState era
deregStakeCred :: forall era.
(HasCallStack, EraCertState era, ShelleyEraAccounts era) =>
Credential Staking -> ChainState era -> ChainState era
deregStakeCred Credential Staking
cred ChainState era
cs = ChainState era
cs {chainNes = nes}
  where
    nes :: NewEpochState era
nes =
      ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> EpochState era -> Identity (EpochState era))
-> (Accounts era -> Identity (Accounts era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> LedgerState era -> Identity (LedgerState era))
-> (Accounts era -> Identity (Accounts era))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Accounts era -> Identity (Accounts era))
    -> CertState era -> Identity (CertState era))
-> (Accounts era -> Identity (Accounts era))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Accounts era -> Identity (Accounts era))
    -> DState era -> Identity (DState era))
-> (Accounts era -> Identity (Accounts era))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> Accounts era -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Accounts era
accounts'
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Coin -> Identity Coin)
    -> EpochState era -> Identity (EpochState era))
-> (Coin -> Identity Coin)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Coin -> Identity Coin)
    -> LedgerState era -> Identity (LedgerState era))
-> (Coin -> Identity Coin)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Coin -> Identity Coin)
    -> UTxOState era -> Identity (UTxOState era))
-> (Coin -> Identity Coin)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL ((Coin -> Identity Coin)
 -> NewEpochState era -> Identity (NewEpochState era))
-> (Coin -> Coin) -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
refund)
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PState era -> Identity (PState era))
    -> EpochState era -> Identity (EpochState era))
-> (PState era -> Identity (PState era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((PState era -> Identity (PState era))
    -> LedgerState era -> Identity (LedgerState era))
-> (PState era -> Identity (PState era))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((PState era -> Identity (PState era))
    -> CertState era -> Identity (CertState era))
-> (PState era -> Identity (PState era))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (PState era -> PState era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PState era -> PState era
adjustPState
    accounts :: Accounts era
accounts =
      ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
        NewEpochState era
-> Getting (Accounts era) (NewEpochState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (Accounts era) (EpochState era))
-> NewEpochState era -> Const (Accounts era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (Accounts era) (EpochState era))
 -> NewEpochState era -> Const (Accounts era) (NewEpochState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> EpochState era -> Const (Accounts era) (EpochState era))
-> Getting (Accounts era) (NewEpochState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (Accounts era) (LedgerState era))
-> EpochState era -> Const (Accounts era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const (Accounts era) (LedgerState era))
 -> EpochState era -> Const (Accounts era) (EpochState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> LedgerState era -> Const (Accounts era) (LedgerState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> EpochState era
-> Const (Accounts era) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const (Accounts era) (CertState era))
-> LedgerState era -> Const (Accounts era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (Accounts era) (CertState era))
 -> LedgerState era -> Const (Accounts era) (LedgerState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> CertState era -> Const (Accounts era) (CertState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> LedgerState era
-> Const (Accounts era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> CertState era
-> Const (Accounts era) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    (Maybe (AccountState era)
mAccountState, Accounts era
accounts') =
      Credential Staking
-> Accounts era -> (Maybe (AccountState era), Accounts era)
forall era.
ShelleyEraAccounts era =>
Credential Staking
-> Accounts era -> (Maybe (AccountState era), Accounts era)
unregisterShelleyAccount Credential Staking
cred Accounts era
accounts
    refund :: Coin
refund = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Maybe (AccountState era) -> AccountState era
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (AccountState era)
mAccountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL)
    currentDeleg :: Maybe (KeyHash StakePool)
currentDeleg = Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Maybe (AccountState era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential Staking
cred (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL) Maybe (AccountState era)
-> (AccountState era -> Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL)
    adjustPState :: PState era -> PState era
adjustPState =
      (PState era -> PState era)
-> (KeyHash StakePool -> PState era -> PState era)
-> Maybe (KeyHash StakePool)
-> PState era
-> PState era
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        PState era -> PState era
forall a. a -> a
id
        (\KeyHash StakePool
oldPool -> (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Map (KeyHash StakePool) StakePoolState)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StakePoolState -> StakePoolState)
-> KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
-> StakePoolState -> Identity StakePoolState
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
 -> StakePoolState -> Identity StakePoolState)
-> (Set (Credential Staking) -> Set (Credential Staking))
-> StakePoolState
-> StakePoolState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.delete Credential Staking
cred) KeyHash StakePool
oldPool)
        Maybe (KeyHash StakePool)
currentDeleg

-- | = New Delegation
--
-- Create a delegation from the given stake credential to the given
-- stake pool.
delegation ::
  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
poolId ChainState era
cs = ChainState era
cs {chainNes = nes}
  where
    nes :: NewEpochState era
nes =
      ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Identity (Map (Credential Staking) (AccountState era)))
    -> EpochState era -> Identity (EpochState era))
-> (Map (Credential Staking) (AccountState era)
    -> Identity (Map (Credential Staking) (AccountState era)))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Identity (Map (Credential Staking) (AccountState era)))
    -> LedgerState era -> Identity (LedgerState era))
-> (Map (Credential Staking) (AccountState era)
    -> Identity (Map (Credential Staking) (AccountState era)))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Identity (Map (Credential Staking) (AccountState era)))
    -> CertState era -> Identity (CertState era))
-> (Map (Credential Staking) (AccountState era)
    -> Identity (Map (Credential Staking) (AccountState era)))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Identity (Map (Credential Staking) (AccountState era)))
    -> DState era -> Identity (DState era))
-> (Map (Credential Staking) (AccountState era)
    -> Identity (Map (Credential Staking) (AccountState era)))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> DState era -> Identity (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Identity (Map (Credential Staking) (AccountState era)))
    -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Identity (Map (Credential Staking) (AccountState era)))
-> DState era
-> Identity (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
          ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (AccountState era -> AccountState era)
-> Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Maybe (KeyHash StakePool) -> Identity (Maybe (KeyHash StakePool)))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL ((Maybe (KeyHash StakePool)
  -> Identity (Maybe (KeyHash StakePool)))
 -> AccountState era -> Identity (AccountState era))
-> Maybe (KeyHash StakePool)
-> AccountState era
-> AccountState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ KeyHash StakePool -> Maybe (KeyHash StakePool)
forall a. a -> Maybe a
Just KeyHash StakePool
poolId) Credential Staking
cred
        NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era -> Identity (EpochState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era -> Identity (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> CertState era -> Identity (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
          ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Map (KeyHash StakePool) StakePoolState)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StakePoolState -> StakePoolState)
-> KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
-> StakePoolState -> Identity StakePoolState
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
 -> StakePoolState -> Identity StakePoolState)
-> (Set (Credential Staking) -> Set (Credential Staking))
-> StakePoolState
-> StakePoolState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.insert Credential Staking
cred) KeyHash StakePool
poolId

-- | Register a stake pool.
regPool ::
  forall era.
  ( EraCertState era
  , EraGov era
  ) =>
  StakePoolParams ->
  ChainState era ->
  ChainState era
regPool :: forall era.
(EraCertState era, EraGov era) =>
StakePoolParams -> ChainState era -> ChainState era
regPool StakePoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = CertState era
dps CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    poolDeposit :: CompactForm Coin
poolDeposit = EpochState era
es EpochState era
-> Getting (CompactForm Coin) (EpochState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const (CompactForm Coin) (PParams era))
-> EpochState era -> Const (CompactForm Coin) (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const (CompactForm Coin) (PParams era))
 -> EpochState era -> Const (CompactForm Coin) (EpochState era))
-> ((CompactForm Coin
     -> Const (CompactForm Coin) (CompactForm Coin))
    -> PParams era -> Const (CompactForm Coin) (PParams era))
-> Getting (CompactForm Coin) (EpochState era) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompactForm Coin -> Const (CompactForm Coin) (CompactForm Coin))
-> PParams era -> Const (CompactForm Coin) (PParams era)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL
    ps' :: PState era
ps' =
      case KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
pool) (Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState)
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall a b. (a -> b) -> a -> b
$ PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
ps of
        Maybe StakePoolState
Nothing ->
          PState era
ps
            { psStakePools =
                Map.insert
                  (sppId pool)
                  (mkStakePoolState poolDeposit mempty pool)
                  (psStakePools ps)
            }
        Just StakePoolState
_ ->
          PState era
ps
            { psFutureStakePoolParams =
                Map.insert
                  (sppId pool)
                  pool
                  (psFutureStakePoolParams ps)
            }
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    ls'' :: LedgerState era
ls'' =
      LedgerState era
ls'
        LedgerState era
-> (LedgerState era -> LedgerState era) -> LedgerState era
forall a b. a -> (a -> b) -> b
& (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Coin -> Identity Coin)
    -> UTxOState era -> Identity (UTxOState era))
-> (Coin -> Identity Coin)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL
          ((Coin -> Identity Coin)
 -> LedgerState era -> Identity (LedgerState era))
-> Coin -> LedgerState era -> LedgerState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Coin -> (StakePoolState -> Coin) -> Maybe StakePoolState -> Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
poolDeposit) (Coin -> StakePoolState -> Coin
forall a b. a -> b -> a
const (Coin -> StakePoolState -> Coin) -> Coin -> StakePoolState -> Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
0) (KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
pool) (PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
ps))
    es' :: EpochState era
es' = EpochState era
es {esLState = ls''}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = es'}

-- | = Re-Register Stake Pool
updatePoolParams ::
  forall era.
  ( EraCertState era
  , EraGov era
  ) =>
  Network ->
  StakePoolParams ->
  ChainState era ->
  ChainState era
updatePoolParams :: forall era.
(EraCertState era, EraGov era) =>
Network -> StakePoolParams -> ChainState era -> ChainState era
updatePoolParams Network
network StakePoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = CertState era
dps CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    ps' :: PState era
ps' =
      PState era
ps
        { psStakePools =
            Map.insert
              (sppId pool)
              (mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) mempty pool)
              (psStakePools ps)
        , psFutureStakePoolParams =
            Map.mapMaybeWithKey
              ( \KeyHash StakePool
k StakePoolState
sps ->
                  if KeyHash StakePool
k KeyHash StakePool -> KeyHash StakePool -> Bool
forall a. Eq a => a -> a -> Bool
== StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
pool
                    then Maybe StakePoolParams
forall a. Maybe a
Nothing
                    else StakePoolParams -> Maybe StakePoolParams
forall a. a -> Maybe a
Just (StakePoolParams -> Maybe StakePoolParams)
-> StakePoolParams -> Maybe StakePoolParams
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
stakePoolStateToStakePoolParams KeyHash StakePool
k Network
network StakePoolState
sps
              )
              (psStakePools ps)
        }
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = CertState era
dps CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    ps' :: PState era
ps' = PState era
ps {psRetiring = Map.insert kh e (psRetiring ps)}
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = es'}

-- | = Reap Pool
--
-- Remove a stake pool.
reapPool ::
  forall era.
  (EraGov era, EraCertState era) =>
  StakePoolParams ->
  ChainState era ->
  ChainState era
reapPool :: forall era.
(EraGov era, EraCertState era) =>
StakePoolParams -> ChainState era -> ChainState era
reapPool StakePoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    poolId :: KeyHash StakePool
poolId = StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
pool
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ps :: PState era
ps = CertState era
dps CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    poolDeposit :: CompactForm Coin
poolDeposit = StakePoolState -> CompactForm Coin
spsDeposit (StakePoolState -> CompactForm Coin)
-> StakePoolState -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ Maybe StakePoolState -> StakePoolState
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StakePoolState -> StakePoolState)
-> Maybe StakePoolState -> StakePoolState
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
poolId (PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
ps)
    ps' :: PState era
ps' =
      PState era
ps
        { psRetiring = Map.delete poolId (psRetiring ps)
        , psStakePools = Map.delete poolId (psStakePools ps)
        , psVRFKeyHashes = Map.delete (sppVrf pool) (psVRFKeyHashes ps)
        }
    pp :: PParams era
pp = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    ds :: DState era
ds = CertState era
dps CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    RewardAccount Network
_ Credential Staking
poolAccountCred = StakePoolParams -> RewardAccount
sppRewardAccount StakePoolParams
pool
    accounts :: Accounts era
accounts = DState era
ds DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    (Accounts era
accounts', CompactForm Coin
unclaimed) =
      case Credential Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
poolAccountCred Accounts era
accounts of
        Maybe (AccountState era)
Nothing -> (Accounts era
accounts, CompactForm Coin
poolDeposit)
        Just AccountState era
accountState ->
          let accountState' :: AccountState era
accountState' = AccountState era
accountState AccountState era
-> (AccountState era -> AccountState era) -> AccountState era
forall a b. a -> (a -> b) -> b
& (CompactForm Coin -> Identity (CompactForm Coin))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> AccountState era -> Identity (AccountState era))
-> CompactForm Coin -> AccountState era -> AccountState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ CompactForm Coin
poolDeposit
           in ( Accounts era
accounts Accounts era -> (Accounts era -> Accounts era) -> Accounts era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> AccountState era
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential Staking
poolAccountCred AccountState era
accountState'
              , CompactForm Coin
forall a. Monoid a => a
mempty
              )
    delegsToClear :: Set (Credential Staking)
delegsToClear =
      (StakePoolState -> Set (Credential Staking))
-> Maybe StakePoolState -> Set (Credential Staking)
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap StakePoolState -> Set (Credential Staking)
spsDelegators (Maybe StakePoolState -> Set (Credential Staking))
-> Maybe StakePoolState -> Set (Credential Staking)
forall a b. (a -> b) -> a -> b
$
        KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
poolId (CertState era
dps CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL)
    ds' :: DState era
ds' = DState era
ds {dsAccounts = removeStakePoolDelegations delegsToClear accounts'}
    chainAccountState :: ChainAccountState
chainAccountState = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    chainAccountState' :: ChainAccountState
chainAccountState' = ChainAccountState
chainAccountState {casTreasury = casTreasury chainAccountState <+> fromCompact unclaimed}
    utxoSt :: UTxOState era
utxoSt = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosDeposited = utxosDeposited utxoSt <-> (pp ^. ppPoolDepositL)}
    dps' :: CertState era
dps' =
      CertState era
dps
        CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps'
        CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps', lsUTxOState = utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls', esChainAccountState = chainAccountState'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = CertState era
dps CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState 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
      } = DState era -> InstantaneousRewards
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 (Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert 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 (Credential Staking
-> Coin
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential Staking
cred Coin
amnt Map (Credential Staking) Coin
it) DeltaCoin
dr DeltaCoin
dt
    ds' :: DState era
ds' = DState era
ds {dsIRewards = irwd'}
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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
addBalances ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    tot :: Coin
tot = Map (Credential Staking) Coin -> Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) Coin
addBalances
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = CertState era
dps CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    ds' :: DState era
ds' =
      DState era
ds
        { dsIRewards = emptyInstantaneousRewards
        }
        DState era -> (DState era -> DState era) -> DState era
forall a b. a -> (a -> b) -> b
& (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> DState era -> Identity (DState era))
-> (Accounts era -> Accounts era) -> DState era -> DState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (Credential Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts ((Coin -> CompactForm Coin)
-> Map (Credential Staking) Coin
-> Map (Credential Staking) (CompactForm Coin)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Map (Credential Staking) Coin
addBalances)
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    chainAccountState :: ChainAccountState
chainAccountState = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    chainAccountState' :: ChainAccountState
chainAccountState' =
      if MIRPot
pot MIRPot -> MIRPot -> Bool
forall a. Eq a => a -> a -> Bool
== MIRPot
ReservesMIR
        then ChainAccountState
chainAccountState {casReserves = casReserves chainAccountState <-> tot}
        else ChainAccountState
chainAccountState {casTreasury = casTreasury chainAccountState <-> tot}
    es' :: EpochState era
es' = EpochState era
es {esChainAccountState = chainAccountState', esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes' :: NewEpochState era
nes' = (ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesRu = SJust (Complete 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 = nes'}
  where
    nes' :: NewEpochState era
nes' = (ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesRu = SJust 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es' :: EpochState era
es' = RewardUpdate -> EpochState era -> EpochState era
forall era.
(EraGov era, EraCertState era) =>
RewardUpdate -> EpochState era -> EpochState era
applyRUpd RewardUpdate
ru (NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes)
    nes' :: NewEpochState era
nes' = (ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesEs = es', nesRu = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    SnapShots
      { ssStakeMark :: SnapShots -> SnapShot
ssStakeMark = SnapShot
ssMark
      , ssStakeSet :: SnapShots -> SnapShot
ssStakeSet = SnapShot
ssSet
      } = EpochState era -> SnapShots
forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es
    snaps :: SnapShots
snaps =
      SnapShots
        { ssStakeMark :: SnapShot
ssStakeMark = SnapShot
snap
        , ssStakeMarkPoolDistr :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
snap
        , ssStakeSet :: SnapShot
ssStakeSet = SnapShot
ssMark
        , ssStakeGo :: SnapShot
ssStakeGo = SnapShot
ssSet
        , ssFee :: Coin
ssFee = Coin
fee
        }
    es' :: EpochState era
es' = EpochState era
es {esSnapshots = snaps}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes' :: NewEpochState era
nes' = (ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs) {nesPd = 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 = counters}
  where
    counters :: Map (KeyHash BlockIssuer) Word64
counters = KeyHash BlockIssuer
-> Word64
-> Map (KeyHash BlockIssuer) Word64
-> Map (KeyHash BlockIssuer) Word64
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash BlockIssuer
kh Word64
n (ChainState era -> Map (KeyHash BlockIssuer) Word64
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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    BlocksMade Map (KeyHash StakePool) Natural
bs = NewEpochState era -> BlocksMade
forall era. NewEpochState era -> BlocksMade
nesBcur NewEpochState era
nes
    n :: Natural
n = Natural
1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
-> KeyHash StakePool -> Map (KeyHash StakePool) Natural -> Natural
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 (Map (KeyHash StakePool) Natural -> BlocksMade)
-> Map (KeyHash StakePool) Natural -> BlocksMade
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> Natural
-> Map (KeyHash StakePool) Natural
-> Map (KeyHash StakePool) Natural
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 = 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.
  (AtMostEra "Alonzo" era, EraGov era) =>
  Block (BHeader MockCrypto) era ->
  ChainState era ->
  ChainState era
newEpoch :: forall era.
(AtMostEra "Alonzo" era, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
newEpoch block :: Block (BHeader MockCrypto) era
block@(Block {BHeader MockCrypto
blockHeader :: forall h era. Block h era -> h
blockHeader :: BHeader MockCrypto
blockHeader}) 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
    bn :: BlockNo
bn = BHBody MockCrypto -> BlockNo
forall c. BHBody c -> BlockNo
bheaderBlockNo (BHBody MockCrypto -> BlockNo) -> BHBody MockCrypto -> BlockNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
blockHeader
    sn :: SlotNo
sn = BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> SlotNo) -> BHBody MockCrypto -> SlotNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
blockHeader
    pp :: PParams era
pp = Getting (PParams era) (EpochState era) (PParams era)
-> EpochState era -> PParams era
forall a s. Getting a s a -> s -> a
view Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL (EpochState era -> PParams era)
-> (NewEpochState era -> EpochState era)
-> NewEpochState era
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs (NewEpochState era -> PParams era)
-> NewEpochState era -> PParams era
forall a b. (a -> b) -> a -> b
$ NewEpochState era
nes
    e :: EpochNo
e = SlotNo -> EpochNo
epochFromSlotNo (SlotNo -> EpochNo)
-> (BHBody MockCrypto -> SlotNo) -> BHBody MockCrypto -> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> EpochNo) -> BHBody MockCrypto -> EpochNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody BHeader MockCrypto
blockHeader
    nes' :: NewEpochState era
nes' =
      NewEpochState era
nes
        { nesEL = e
        , nesBprev = nesBcur nes
        , nesBcur = BlocksMade Map.empty
        }
    n :: Nonce
n = Block (BHeader MockCrypto) era -> Nonce
forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) era
block
    cs' :: ChainState era
cs' =
      ChainState era
cs
        { chainNes = nes'
        , chainEpochNonce = cNonce ⭒ pNonce ⭒ (pp ^. ppExtraEntropyL)
        , chainEvolvingNonce = evNonce ⭒ n
        , chainCandidateNonce = evNonce ⭒ n
        , chainPrevEpochNonce = prevHashToNonce . lastAppliedHash $ lab
        , chainLastAppliedBlock = At $ LastAppliedBlock bn sn (bhHash blockHeader)
        }

-- | = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    govState :: GovState era
govState = UTxOState era -> GovState era
forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoSt
    pp :: PParams era
pp = ShelleyGovState era -> PParams era
forall era. ShelleyGovState era -> PParams era
sgsCurPParams GovState era
ShelleyGovState era
govState
    govState' :: ShelleyGovState era
govState' =
      GovState era
govState
        { sgsCurProposals = ps
        , sgsFuturePParams =
            PotentialPParamsUpdate $ votedFuturePParams ps pp (quorum testGlobals)
        }
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosGovState = govState'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState = utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    utxoSt :: UTxOState era
utxoSt = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    govState :: GovState era
govState = UTxOState era -> GovState era
forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoSt
    govState' :: ShelleyGovState era
govState' = GovState era
govState {sgsFutureProposals = ps}
    utxoSt' :: UTxOState era
utxoSt' = UTxOState era
utxoSt {utxosGovState = govState'}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState = utxoSt'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes {nesEs = es}}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (FuturePParams era -> Identity (FuturePParams era))
-> EpochState era -> Identity (EpochState era)
forall era.
EraGov era =>
Lens' (EpochState era) (FuturePParams era)
Lens' (EpochState era) (FuturePParams era)
futurePParamsEpochStateL ((FuturePParams era -> Identity (FuturePParams era))
 -> EpochState era -> Identity (EpochState era))
-> (FuturePParams era -> FuturePParams era)
-> EpochState era
-> EpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ FuturePParams era -> FuturePParams era
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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    es' :: EpochState era
es' = EpochState era
es EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    es' :: EpochState era
es' = EpochState era
es EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = CertState era
dps CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    ds' :: DState era
ds' = DState era
ds {dsFutureGenDelegs = Map.insert fg gd (dsFutureGenDelegs ds)}
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = 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 = nes'}
  where
    nes :: NewEpochState era
nes = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
cs
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dps :: CertState era
dps = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    ds :: DState era
ds = CertState era
dps CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    gds :: GenDelegs
gds = Map (KeyHash GenesisRole) GenDelegPair -> GenDelegs
GenDelegs (Map (KeyHash GenesisRole) GenDelegPair -> GenDelegs)
-> Map (KeyHash GenesisRole) GenDelegPair -> GenDelegs
forall a b. (a -> b) -> a -> b
$ KeyHash GenesisRole
-> GenDelegPair
-> Map (KeyHash GenesisRole) GenDelegPair
-> Map (KeyHash GenesisRole) GenDelegPair
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FutureGenDeleg -> KeyHash GenesisRole
fGenDelegGenKeyHash FutureGenDeleg
fg) GenDelegPair
gd (GenDelegs -> Map (KeyHash GenesisRole) GenDelegPair
unGenDelegs (DState era -> GenDelegs
forall era. DState era -> GenDelegs
dsGenDelegs DState era
ds))
    ds' :: DState era
ds' =
      DState era
ds
        { dsFutureGenDelegs = Map.delete fg (dsFutureGenDelegs ds)
        , dsGenDelegs = gds
        }
    dps' :: CertState era
dps' = CertState era
dps CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
ds'
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsCertState = dps'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = es'}