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

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.CertState (
  CertState (..),
  DState (..),
  InstantaneousRewards (..),
 )
import Cardano.Ledger.Coin (Coin (..), addDeltaCoin)
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  GenDelegs (..),
  KeyHash (..),
  KeyRole (..),
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState.Types
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..), coinBalance)
import Cardano.Ledger.Val ((<+>), (<->))
import Data.Default.Class (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 -> AccountState -> InstantaneousRewards c -> Coin
availableAfterMIR :: forall c. MIRPot -> AccountState -> InstantaneousRewards c -> Coin
availableAfterMIR MIRPot
ReservesMIR AccountState
as InstantaneousRewards c
ir =
  AccountState -> Coin
asReserves AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` forall c. InstantaneousRewards c -> DeltaCoin
deltaReserves InstantaneousRewards c
ir forall t. Val t => t -> t -> t
<-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
iRReserves InstantaneousRewards c
ir)
availableAfterMIR MIRPot
TreasuryMIR AccountState
as InstantaneousRewards c
ir =
  AccountState -> Coin
asTreasury AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` forall c. InstantaneousRewards c -> DeltaCoin
deltaTreasury InstantaneousRewards c
ir forall t. Val t => t -> t -> t
<-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
iRTreasury InstantaneousRewards c
ir)

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

getGKeys ::
  NewEpochState era ->
  Set (KeyHash 'Genesis (EraCrypto era))
getGKeys :: forall era.
NewEpochState era -> Set (KeyHash 'Genesis (EraCrypto era))
getGKeys NewEpochState era
nes = forall k a. Map k a -> Set k
Map.keysSet Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs
  where
    NewEpochState EpochNo
_ BlocksMade (EraCrypto era)
_ BlocksMade (EraCrypto era)
_ EpochState era
es StrictMaybe (PulsingRewUpdate (EraCrypto era))
_ PoolDistr (EraCrypto era)
_ StashedAVVMAddresses era
_ = NewEpochState era
nes
    EpochState AccountState
_ LedgerState era
ls SnapShots (EraCrypto era)
_ NonMyopic (EraCrypto era)
_ = EpochState era
es
    LedgerState UTxOState era
_ (CertState VState era
_ PState era
_ DState {dsGenDelegs :: forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs = (GenDelegs Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs)}) = LedgerState era
ls

-- | Creates the ledger state for an empty ledger which
--  contains the specified transaction outputs.
genesisState ::
  forall era.
  EraGov era =>
  Map (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era)) ->
  UTxO era ->
  LedgerState era
genesisState :: forall era.
EraGov era =>
Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> UTxO era -> LedgerState era
genesisState Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs0 UTxO era
utxo0 =
  forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState
    ( forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake (EraCrypto era)
-> Coin
-> UTxOState era
UTxOState
        UTxO era
utxo0
        (Integer -> Coin
Coin Integer
0)
        (Integer -> Coin
Coin Integer
0)
        forall era. EraGov era => GovState era
emptyGovState
        (forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake c
IStake forall a. Monoid a => a
mempty forall k a. Map k a
Map.empty)
        forall a. Monoid a => a
mempty
    )
    (forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def forall a. Default a => a
def DState era
dState)
  where
    dState :: DState era
    dState :: DState era
dState =
      DState
        { dsUnified :: UMap (EraCrypto era)
dsUnified = forall c. UMap c
UM.empty
        , dsFutureGenDelegs :: Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsFutureGenDelegs = forall k a. Map k a
Map.empty
        , dsGenDelegs :: GenDelegs (EraCrypto era)
dsGenDelegs = forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs0 :: GenDelegs (EraCrypto era)
        , dsIRewards :: InstantaneousRewards (EraCrypto era)
dsIRewards = 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 (EraCrypto era) ->
  LedgerState era ->
  NewEpochState era
updateNES :: forall era.
EraGov era =>
NewEpochState era
-> BlocksMade (EraCrypto era)
-> LedgerState era
-> NewEpochState era
updateNES
  oldNes :: NewEpochState era
oldNes@( NewEpochState
            EpochNo
_eL
            BlocksMade (EraCrypto era)
_bprev
            BlocksMade (EraCrypto era)
_
            es :: EpochState era
es@(EpochState AccountState
acnt LedgerState era
_ SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
nm)
            StrictMaybe (PulsingRewUpdate (EraCrypto era))
_ru
            PoolDistr (EraCrypto era)
_pd
            StashedAVVMAddresses era
_avvm
          )
  BlocksMade (EraCrypto era)
bcur
  LedgerState era
ls =
    let
      pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      pr :: PParams era
pr = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
     in
      NewEpochState era
oldNes
        { nesBcur :: BlocksMade (EraCrypto era)
nesBcur = BlocksMade (EraCrypto era)
bcur
        , nesEs :: EpochState era
nesEs =
            forall era.
AccountState
-> LedgerState era
-> SnapShots (EraCrypto era)
-> NonMyopic (EraCrypto era)
-> EpochState era
EpochState AccountState
acnt LedgerState era
ls SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
nm
              forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
              forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
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 {esAccountState :: AccountState
esAccountState = AccountState
acnt', esLState :: LedgerState era
esLState = LedgerState era
ls'}
  where
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    us :: UTxOState era
us = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
us
    (Map (TxIn (EraCrypto era)) (TxOut era)
redeemers, Map (TxIn (EraCrypto era)) (TxOut era)
nonredeemers) =
      forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall c. BootstrapAddress c -> Bool
isBootstrapRedeemer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe (BootstrapAddress (EraCrypto era)))
bootAddrTxOutF) Map (TxIn (EraCrypto era)) (TxOut era)
utxo
    acnt :: AccountState
acnt = forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    utxoR :: UTxO era
utxoR = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
redeemers :: UTxO era
    acnt' :: AccountState
acnt' =
      AccountState
acnt
        { asReserves :: Coin
asReserves = AccountState -> Coin
asReserves AccountState
acnt forall t. Val t => t -> t -> t
<+> forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO era
utxoR
        }
    us' :: UTxOState era
us' = UTxOState era
us {utxosUtxo :: UTxO era
utxosUtxo = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
nonredeemers :: UTxO era}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
us'}