{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Cardano.Ledger.Shelley.LedgerState.NewEpochState (
  availableAfterMIR,
  getGKeys,
  genesisState,
  updateNES,
  returnRedeemAddrsToReserves,
) where

import Cardano.Ledger.Address (isBootstrapRedeemer)
import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
 )
import Cardano.Ledger.Coin (Coin (..), addDeltaCoin)
import Cardano.Ledger.Keys (GenDelegPair (..), GenDelegs (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState.Types
import Cardano.Ledger.State
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<+>), (<->))
import Data.Default (def)
import Data.Foldable (fold)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Extras (view)

-- | This function returns the coin balance of a given pot, either the
-- reserves or the treasury, after the instantaneous rewards and pot
-- transfers are accounted for.
availableAfterMIR :: MIRPot -> ChainAccountState -> InstantaneousRewards -> Coin
availableAfterMIR :: MIRPot -> ChainAccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
ReservesMIR ChainAccountState
as InstantaneousRewards
ir =
  ChainAccountState -> Coin
casReserves ChainAccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards -> DeltaCoin
deltaReserves InstantaneousRewards
ir Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> 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 (InstantaneousRewards -> Map (Credential 'Staking) Coin
iRReserves InstantaneousRewards
ir)
availableAfterMIR MIRPot
TreasuryMIR ChainAccountState
as InstantaneousRewards
ir =
  ChainAccountState -> Coin
casTreasury ChainAccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards -> DeltaCoin
deltaTreasury InstantaneousRewards
ir Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> 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 (InstantaneousRewards -> Map (Credential 'Staking) Coin
iRTreasury InstantaneousRewards
ir)

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

getGKeys ::
  EraCertState era =>
  NewEpochState era ->
  Set (KeyHash 'Genesis)
getGKeys :: forall era.
EraCertState era =>
NewEpochState era -> Set (KeyHash 'Genesis)
getGKeys NewEpochState era
nes = Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis)
forall k a. Map k a -> Set k
Map.keysSet (Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis))
-> Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis)
forall a b. (a -> b) -> a -> b
$ GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs (LedgerState era
ls LedgerState era
-> Getting GenDelegs (LedgerState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (CertState era -> Const GenDelegs (CertState era))
-> LedgerState era -> Const GenDelegs (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const GenDelegs (CertState era))
 -> LedgerState era -> Const GenDelegs (LedgerState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> CertState era -> Const GenDelegs (CertState era))
-> Getting GenDelegs (LedgerState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> CertState era
-> Const GenDelegs (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL)
  where
    NewEpochState EpochNo
_ BlocksMade
_ BlocksMade
_ EpochState era
es StrictMaybe PulsingRewUpdate
_ PoolDistr
_ StashedAVVMAddresses era
_ = NewEpochState era
nes
    EpochState ChainAccountState
_ LedgerState era
ls SnapShots
_ NonMyopic
_ = EpochState era
es

-- | Creates the ledger state for an empty ledger which
--  contains the specified transaction outputs.
genesisState ::
  forall era.
  (EraGov era, EraCertState era, EraStake era) =>
  Map (KeyHash 'Genesis) GenDelegPair ->
  UTxO era ->
  LedgerState era
genesisState :: forall era.
(EraGov era, EraCertState era, EraStake era) =>
Map (KeyHash 'Genesis) GenDelegPair -> UTxO era -> LedgerState era
genesisState Map (KeyHash 'Genesis) GenDelegPair
genDelegs0 UTxO era
utxo0 =
  UTxOState era -> CertState era -> LedgerState era
forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState
    ( UTxO era
-> Coin
-> Coin
-> GovState era
-> InstantStake era
-> Coin
-> UTxOState era
forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> InstantStake era
-> Coin
-> UTxOState era
UTxOState
        UTxO era
utxo0
        (Integer -> Coin
Coin Integer
0)
        (Integer -> Coin
Coin Integer
0)
        GovState era
forall era. EraGov era => GovState era
emptyGovState
        InstantStake era
forall a. Monoid a => a
mempty
        Coin
forall a. Monoid a => a
mempty
    )
    ( CertState era
forall a. Default a => a
def
        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
dState
    )
  where
    dState :: DState era
    dState :: DState era
dState =
      DState
        { dsUnified :: UMap
dsUnified = UMap
UM.empty
        , dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = Map FutureGenDeleg GenDelegPair
forall k a. Map k a
Map.empty
        , dsGenDelegs :: GenDelegs
dsGenDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs Map (KeyHash 'Genesis) GenDelegPair
genDelegs0 :: GenDelegs
        , dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
forall a. Default a => a
def
        }

-- Functions for stake delegation model

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

-- | Update new epoch state
updateNES ::
  EraGov era =>
  NewEpochState era ->
  BlocksMade ->
  LedgerState era ->
  NewEpochState era
updateNES :: forall era.
EraGov era =>
NewEpochState era
-> BlocksMade -> LedgerState era -> NewEpochState era
updateNES
  oldNes :: NewEpochState era
oldNes@( NewEpochState
             EpochNo
_eL
             BlocksMade
_bprev
             BlocksMade
_
             es :: EpochState era
es@(EpochState ChainAccountState
acnt LedgerState era
_ SnapShots
ss NonMyopic
nm)
             StrictMaybe PulsingRewUpdate
_ru
             PoolDistr
_pd
             StashedAVVMAddresses era
_avvm
           )
  BlocksMade
bcur
  LedgerState era
ls =
    let
      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
      pr :: PParams era
pr = 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)
prevPParamsEpochStateL
     in
      NewEpochState era
oldNes
        { nesBcur = bcur
        , nesEs =
            EpochState acnt ls ss nm
              & curPParamsEpochStateL .~ pp
              & prevPParamsEpochStateL .~ pr
        }

returnRedeemAddrsToReserves ::
  forall era.
  EraTxOut era =>
  EpochState era ->
  EpochState era
returnRedeemAddrsToReserves :: forall era. EraTxOut era => EpochState era -> EpochState era
returnRedeemAddrsToReserves EpochState era
es = EpochState era
es {esChainAccountState = acnt', esLState = ls'}
  where
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    us :: UTxOState era
us = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    UTxO Map TxIn (TxOut era)
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
us
    (Map TxIn (TxOut era)
redeemers, Map TxIn (TxOut era)
nonredeemers) =
      (TxOut era -> Bool)
-> Map TxIn (TxOut era)
-> (Map TxIn (TxOut era), Map TxIn (TxOut era))
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Bool
-> (BootstrapAddress -> Bool) -> Maybe BootstrapAddress -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False BootstrapAddress -> Bool
isBootstrapRedeemer (Maybe BootstrapAddress -> Bool)
-> (TxOut era -> Maybe BootstrapAddress) -> TxOut era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
-> TxOut era -> Maybe BootstrapAddress
forall a s. Getting a s a -> s -> a
view Getting
  (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF) Map TxIn (TxOut era)
utxo
    acnt :: ChainAccountState
acnt = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
es
    utxoR :: UTxO era
utxoR = Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
redeemers :: UTxO era
    acnt' :: ChainAccountState
acnt' =
      ChainAccountState
acnt
        { casReserves = casReserves acnt <+> sumCoinUTxO utxoR
        }
    us' :: UTxOState era
us' = UTxOState era
us {utxosUtxo = UTxO nonredeemers :: UTxO era}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState = us'}