{-# 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 (..))
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 (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 -> Coin
availableAfterMIR :: MIRPot -> AccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
ReservesMIR AccountState
as InstantaneousRewards
ir =
  AccountState -> Coin
asReserves AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards -> DeltaCoin
deltaReserves InstantaneousRewards
ir forall t. Val t => t -> t -> t
<-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (InstantaneousRewards -> Map (Credential 'Staking) Coin
iRReserves InstantaneousRewards
ir)
availableAfterMIR MIRPot
TreasuryMIR AccountState
as InstantaneousRewards
ir =
  AccountState -> Coin
asTreasury AccountState
as Coin -> DeltaCoin -> Coin
`addDeltaCoin` InstantaneousRewards -> DeltaCoin
deltaTreasury InstantaneousRewards
ir forall t. Val t => t -> t -> t
<-> 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 ::
  NewEpochState era ->
  Set (KeyHash 'Genesis)
getGKeys :: forall era. NewEpochState era -> Set (KeyHash 'Genesis)
getGKeys NewEpochState era
nes = forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) GenDelegPair
genDelegs
  where
    NewEpochState EpochNo
_ BlocksMade
_ BlocksMade
_ EpochState era
es StrictMaybe PulsingRewUpdate
_ PoolDistr
_ StashedAVVMAddresses era
_ = NewEpochState era
nes
    EpochState AccountState
_ LedgerState era
ls SnapShots
_ NonMyopic
_ = EpochState era
es
    LedgerState UTxOState era
_ (CertState VState era
_ PState era
_ DState {dsGenDelegs :: forall era. DState era -> GenDelegs
dsGenDelegs = (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
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) GenDelegPair ->
  UTxO era ->
  LedgerState era
genesisState :: forall era.
EraGov era =>
Map (KeyHash 'Genesis) GenDelegPair -> UTxO era -> LedgerState era
genesisState Map (KeyHash 'Genesis) GenDelegPair
genDelegs0 UTxO era
utxo0 =
  forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState
    ( forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake
-> Coin
-> UTxOState era
UTxOState
        UTxO era
utxo0
        (Integer -> Coin
Coin Integer
0)
        (Integer -> Coin
Coin Integer
0)
        forall era. EraGov era => GovState era
emptyGovState
        (Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
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
dsUnified = UMap
UM.empty
        , dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = 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 = 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 AccountState
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 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
nesBcur = BlocksMade
bcur
        , nesEs :: EpochState era
nesEs =
            forall era.
AccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState AccountState
acnt LedgerState era
ls SnapShots
ss NonMyopic
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 (TxOut era)
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
us
    (Map TxIn (TxOut era)
redeemers, Map TxIn (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 BootstrapAddress -> 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)
bootAddrTxOutF) Map TxIn (TxOut era)
utxo
    acnt :: AccountState
acnt = forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    utxoR :: UTxO era
utxoR = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (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 (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
nonredeemers :: UTxO era}
    ls' :: LedgerState era
ls' = LedgerState era
ls {lsUTxOState :: UTxOState era
lsUTxOState = UTxOState era
us'}