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

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

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

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

-- | = Evolve Nonces - Frozen
--
-- Evolve the appropriate nonces under the assumption
-- that the candidate nonce is now frozen.
evolveNonceFrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceFrozen :: forall era. Nonce -> ChainState era -> ChainState era
evolveNonceFrozen Nonce
n ChainState era
cs = ChainState era
cs {chainEvolvingNonce = 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
bheader 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

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

feesAndKeyRefund ::
  forall era.
  EraCertState era =>
  Coin ->
  Credential 'Staking ->
  ChainState era ->
  ChainState era
feesAndKeyRefund :: forall era.
EraCertState era =>
Coin -> Credential 'Staking -> ChainState era -> ChainState era
feesAndKeyRefund Coin
newFees Credential 'Staking
key ChainState era
cs = ChainState era
cs {chainNes = 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
    certState :: CertState era
certState = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    dstate :: DState era
dstate = CertState era
certState 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
    refund :: Coin
refund = case Credential 'Staking
-> UView (Credential 'Staking) RDPair -> Maybe RDPair
forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
key (UMap -> UView (Credential 'Staking) RDPair
RewDepUView (DState era -> UMap
forall era. DState era -> UMap
dsUnified DState era
dstate)) of
      Maybe RDPair
Nothing -> Integer -> Coin
Coin Integer
0
      Just (RDPair CompactForm Coin
_ CompactForm Coin
ccoin) -> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
ccoin
    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 <-> refund
        , utxosFees = utxosFees utxoSt <+> newFees
        }
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState = utxoSt', lsCertState = dpstate'}
    es' :: EpochState era
es' = EpochState era
es {esLState = ls'}
    nes' :: NewEpochState era
nes' = NewEpochState era
nes {nesEs = es'}
    dpstate' :: CertState era
dpstate' = CertState era
certState 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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> (UMap -> UMap) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((RDPair -> RDPair)
-> Credential 'Staking
-> UView (Credential 'Staking) RDPair
-> UMap
forall k. (RDPair -> RDPair) -> k -> UView k RDPair -> UMap
UM.adjust RDPair -> RDPair
zeroD Credential 'Staking
key (UView (Credential 'Staking) RDPair -> UMap)
-> (UMap -> UView (Credential 'Staking) RDPair) -> UMap -> UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UMap -> UView (Credential 'Staking) RDPair
RewDepUView)
    zeroD :: RDPair -> RDPair
zeroD (RDPair CompactForm Coin
x CompactForm Coin
_) = CompactForm Coin -> CompactForm Coin -> RDPair
RDPair CompactForm Coin
x (Word64 -> CompactForm Coin
CompactCoin Word64
0)

-- | = Update the UTxO
--
-- Update the UTxO for given transaction body.
newUTxO ::
  forall era.
  (EraTx era, EraStake era) =>
  TxBody era ->
  ChainState era ->
  ChainState era
newUTxO :: forall era.
(EraTx era, EraStake era) =>
TxBody era -> ChainState era -> ChainState era
newUTxO TxBody era
txb ChainState era
cs = ChainState era
cs {chainNes = 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. EraTxBody era => TxBody era -> UTxO era
txouts @era TxBody 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. EraTxBody era => TxBody era -> Set TxIn
txins @era TxBody 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. EraTxBody era => TxBody era -> Set TxIn
txins @era TxBody 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, initialize the rdRewards component of the RDPair.
--   The rdDeposit component of the RDPair is set by 'feesAndDeposits'
newStakeCred ::
  forall era.
  EraCertState era =>
  Credential 'Staking ->
  Ptr ->
  ChainState era ->
  ChainState era
newStakeCred :: forall era.
EraCertState era =>
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
newStakeCred Credential 'Staking
cred Ptr
ptr ChainState era
cs = ChainState era
cs {chainNes = 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
        { dsUnified =
            let um0 = DState era -> UMap
forall era. DState era -> UMap
dsUnified DState era
ds
                um1 = Credential 'Staking
-> RDPair -> UView (Credential 'Staking) RDPair -> UMap
forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
cred (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
CompactCoin Word64
0) (Word64 -> CompactForm Coin
CompactCoin Word64
0)) (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
um0)
                um2 = (UMap -> UView Ptr (Credential 'Staking)
PtrUView UMap
um1 UView Ptr (Credential 'Staking)
-> (Ptr, Credential 'Staking) -> UMap
forall k v. UView k v -> (k, v) -> UMap
UM.∪ (Ptr
ptr, Credential 'Staking
cred))
             in um2
        }
    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'}

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

-- | = New Delegation
--
-- Create a delegation from the given stake credential to the given
-- stake pool.
delegation ::
  forall era.
  EraCertState era =>
  Credential 'Staking ->
  KeyHash 'StakePool ->
  ChainState era ->
  ChainState era
delegation :: forall era.
EraCertState era =>
Credential 'Staking
-> KeyHash 'StakePool -> ChainState era -> ChainState era
delegation Credential 'Staking
cred KeyHash 'StakePool
pool ChainState era
cs = ChainState era
cs {chainNes = 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
        { dsUnified = UM.insert cred pool (delegations 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'}

-- | = New Stake Pool
--
-- Add a newly registered stake pool
newPool ::
  forall era.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
newPool :: forall era.
EraCertState era =>
PoolParams -> ChainState era -> ChainState era
newPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = 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
        { psStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams 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'}

-- | = Re-Register Stake Pool
reregPool ::
  forall era.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
reregPool :: forall era.
EraCertState era =>
PoolParams -> ChainState era -> ChainState era
reregPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = 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
        { psFutureStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams 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'}

-- | = Re-Register Stake Pool
updatePoolParams ::
  forall era.
  EraCertState era =>
  PoolParams ->
  ChainState era ->
  ChainState era
updatePoolParams :: forall era.
EraCertState era =>
PoolParams -> ChainState era -> ChainState era
updatePoolParams PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = 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
        { psStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams ps)
        , psFutureStakePoolParams = Map.delete (ppId pool) (psStakePoolParams 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) =>
  PoolParams ->
  ChainState era ->
  ChainState era
reapPool :: forall era.
(EraGov era, EraCertState era) =>
PoolParams -> ChainState era -> ChainState era
reapPool PoolParams
pool ChainState era
cs = ChainState era
cs {chainNes = nes'}
  where
    kh :: KeyHash 'StakePool
kh = PoolParams -> KeyHash 'StakePool
ppId PoolParams
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
    ps' :: PState era
ps' =
      PState era
ps
        { psRetiring = Map.delete kh (psRetiring ps)
        , psStakePoolParams = Map.delete kh (psStakePoolParams ps)
        , psDeposits = Map.delete kh (psDeposits 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
rewardAddr = PoolParams -> RewardAccount
ppRewardAccount PoolParams
pool
    (UView (Credential 'Staking) RDPair
rewards', Coin
unclaimed) =
      case Credential 'Staking
-> UView (Credential 'Staking) RDPair -> Maybe RDPair
forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
rewardAddr (DState era -> UView (Credential 'Staking) RDPair
forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds) of
        Maybe RDPair
Nothing -> (DState era -> UView (Credential 'Staking) RDPair
forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds, PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL)
        Just (UM.RDPair CompactForm Coin
ccoin CompactForm Coin
dep) ->
          ( Credential 'Staking
-> RDPair
-> UView (Credential 'Staking) RDPair
-> UView (Credential 'Staking) RDPair
forall k v. k -> v -> UView k v -> UView k v
UM.insert'
              Credential 'Staking
rewardAddr
              (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (CompactForm Coin -> CompactForm Coin -> CompactForm Coin
addCompactCoin CompactForm Coin
ccoin (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL))) CompactForm Coin
dep)
              (DState era -> UView (Credential 'Staking) RDPair
forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds)
          , Integer -> Coin
Coin Integer
0
          )
    -- FIXME shouldn't we look up the pooldeposit here?
    umap1 :: UMap
umap1 = UView (Credential 'Staking) RDPair -> UMap
forall k v. UView k v -> UMap
unUView UView (Credential 'Staking) RDPair
rewards'
    umap2 :: UMap
umap2 = UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
umap1 UView (Credential 'Staking) (KeyHash 'StakePool)
-> Set (KeyHash 'StakePool) -> UMap
forall k v. UView k v -> Set v -> UMap
UM.⋫ KeyHash 'StakePool -> Set (KeyHash 'StakePool)
forall a. a -> Set a
Set.singleton KeyHash 'StakePool
kh
    ds' :: DState era
ds' = DState era
ds {dsUnified = umap2}
    chainAccountState :: ChainAccountState
chainAccountState = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    chainAccountState' :: ChainAccountState
chainAccountState' = ChainAccountState
chainAccountState {casTreasury = casTreasury chainAccountState <+> 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
newrewards 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
newrewards
    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
        { dsUnified = rewards ds UM.∪+ Map.map compactCoinOrError newrewards
        , dsIRewards = emptyInstantaneousRewards
        }
    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
      { $sel:ssStakeMark:SnapShots :: SnapShots -> SnapShot
ssStakeMark = SnapShot
ssMark
      , $sel:ssStakeSet:SnapShots :: SnapShots -> SnapShot
ssStakeSet = SnapShot
ssSet
      } = EpochState era -> SnapShots
forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es
    snaps :: SnapShots
snaps =
      SnapShots
        { $sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark = SnapShot
snap
        , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
snap
        , $sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet = SnapShot
ssMark
        , $sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo = SnapShot
ssSet
        , $sel:ssFee:SnapShots :: Coin
ssFee = Coin
fee
        }
    es' :: EpochState era
es' = EpochState era
es {esSnapshots = 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.
  (ProtVerAtMost era 6, EraGov era) =>
  Block (BHeader MockCrypto) era ->
  ChainState era ->
  ChainState era
newEpoch :: forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
newEpoch Block (BHeader MockCrypto) era
b ChainState era
cs = ChainState era
cs'
  where
    ChainState
      { chainNes :: forall era. ChainState era -> NewEpochState era
chainNes = NewEpochState era
nes
      , chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce = Nonce
evNonce
      , chainCandidateNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce = Nonce
cNonce
      , chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce = Nonce
pNonce
      , chainLastAppliedBlock :: forall era. ChainState era -> WithOrigin LastAppliedBlock
chainLastAppliedBlock = WithOrigin LastAppliedBlock
lab
      } = ChainState era
cs
    bh :: BHeader MockCrypto
bh = Block (BHeader MockCrypto) era -> BHeader MockCrypto
forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) era
b
    bn :: BlockNo
bn = BHBody MockCrypto -> BlockNo
forall c. BHBody c -> BlockNo
bheaderBlockNo (BHBody MockCrypto -> BlockNo)
-> (BHeader MockCrypto -> BHBody MockCrypto)
-> BHeader MockCrypto
-> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody (BHeader MockCrypto -> BlockNo) -> BHeader MockCrypto -> BlockNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto
bh
    sn :: SlotNo
sn = BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> SlotNo)
-> (BHeader MockCrypto -> BHBody MockCrypto)
-> BHeader MockCrypto
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody (BHeader MockCrypto -> SlotNo) -> BHeader MockCrypto -> SlotNo
forall a b. (a -> b) -> a -> b
$ BHeader MockCrypto
bh
    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)
-> (Block (BHeader MockCrypto) era -> SlotNo)
-> Block (BHeader MockCrypto) era
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> SlotNo)
-> (Block (BHeader MockCrypto) era -> BHBody MockCrypto)
-> Block (BHeader MockCrypto) era
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody (BHeader MockCrypto -> BHBody MockCrypto)
-> (Block (BHeader MockCrypto) era -> BHeader MockCrypto)
-> Block (BHeader MockCrypto) era
-> BHBody MockCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (BHeader MockCrypto) era -> BHeader MockCrypto
forall h era. Block h era -> h
bheader (Block (BHeader MockCrypto) era -> EpochNo)
-> Block (BHeader MockCrypto) era -> EpochNo
forall a b. (a -> b) -> a -> b
$ Block (BHeader MockCrypto) era
b
    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
b
    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 bh)
        }

-- | = Set Current Proposals
--
-- Set the current protocol parameter proposals.
setCurrentProposals ::
  forall era.
  (GovState era ~ ShelleyGovState era, EraPParams era) =>
  ProposedPPUpdates era ->
  ChainState era ->
  ChainState era
setCurrentProposals :: forall era.
(GovState era ~ ShelleyGovState era, EraPParams era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
setCurrentProposals ProposedPPUpdates era
ps ChainState era
cs = ChainState era
cs {chainNes = 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 'Genesis) GenDelegPair -> GenDelegs
GenDelegs (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs)
-> Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
forall a b. (a -> b) -> a -> b
$ KeyHash 'Genesis
-> GenDelegPair
-> Map (KeyHash 'Genesis) GenDelegPair
-> Map (KeyHash 'Genesis) GenDelegPair
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FutureGenDeleg -> KeyHash 'Genesis
fGenDelegGenKeyHash FutureGenDeleg
fg) GenDelegPair
gd (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs (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'}