{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-- TODO: submit a ghc bug report
-- some GHC bug wrongfully complains about CanGetInstantStake constraint being redundant.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Cardano.Ledger.State.Stake (
  EraStake (..),
  CanGetInstantStake (..),
  CanSetInstantStake (..),
  snapShotFromInstantStake,
  resolveActiveInstantStakeCredentials,
)
where

import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
 )
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.State.CertState (DState (..), PState (..))
import Cardano.Ledger.State.SnapShots
import Cardano.Ledger.State.UTxO
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Data.Aeson (ToJSON)
import Data.Default (Default)
import Data.Functor.Identity
import Data.Kind (Type)
import qualified Data.Map.Merge.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.VMap as VMap
import Lens.Micro
import NoThunks.Class (NoThunks)

class
  ( Era era
  , Eq (InstantStake era)
  , Show (InstantStake era)
  , Monoid (InstantStake era)
  , Default (InstantStake era)
  , NFData (InstantStake era)
  , NoThunks (InstantStake era)
  , ToJSON (InstantStake era)
  , EncCBOR (InstantStake era)
  , DecShareCBOR (InstantStake era)
  , Share (InstantStake era) ~ Interns (Credential 'Staking)
  ) =>
  EraStake era
  where
  -- | This is the current stake in the system. The important part of this stake is that not all of
  -- it is active. Any stake credential that is not registred will not contribute to the active
  -- stake, however it will be part of the instant stake. Throughout an epoch it is not relevant
  -- which part of the stake is active, because it is only when we take the snaphot that we resolve
  -- all the active stake.
  type InstantStake era = (r :: Type) | r -> era

  instantStakeCredentialsL :: Lens' (InstantStake era) (Map (Credential 'Staking) (CompactForm Coin))

  -- | Add new UTxO to the `InstantStake`. This is invoked for every new TxOut that is added to the
  -- ledger state
  addInstantStake :: UTxO era -> InstantStake era -> InstantStake era

  -- | Delete spent UTxO from the `InstantStake`. This is invoked for every TxOut that is removed
  -- from the ledger state
  deleteInstantStake :: UTxO era -> InstantStake era -> InstantStake era

  -- TODO: This functionality will be removed and switched to use a pulser

  -- | Using known stake credential registrations and delegations resolve the instant stake into a
  -- `Stake` that will be used for `SnapShot` creation by `snapShotFromInstantStake`.
  resolveInstantStake :: InstantStake era -> UM.UMap -> Stake

snapShotFromInstantStake :: EraStake era => InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake :: forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
iStake DState era
dState PState {Map (KeyHash 'StakePool) PoolParams
psStakePoolParams :: forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams} =
  Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> SnapShot
SnapShot Stake
stake VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs (forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (KeyHash 'StakePool) PoolParams
psStakePoolParams)
  where
    !stake :: Stake
stake = forall era. EraStake era => InstantStake era -> UMap -> Stake
resolveInstantStake InstantStake era
iStake UMap
um
    !delegs :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs = forall k v. UView k v -> VMap VB VB k v
UM.unUnifyToVMap (UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
um)
    !um :: UMap
um = forall era. DState era -> UMap
dsUnified DState era
dState
{-# INLINEABLE snapShotFromInstantStake #-}

class CanGetInstantStake t where
  instantStakeG :: SimpleGetter (t era) (InstantStake era)
  default instantStakeG :: CanSetInstantStake t => SimpleGetter (t era) (InstantStake era)
  instantStakeG = forall (t :: * -> *) era.
CanSetInstantStake t =>
Lens' (t era) (InstantStake era)
instantStakeL
  {-# INLINE instantStakeG #-}

class CanGetInstantStake t => CanSetInstantStake t where
  instantStakeL :: Lens' (t era) (InstantStake era)

-- | This is the total active stake including the rewards, but ignoring all the stake coming from
-- the pointers. Where "active" stake means any stake credential that is registered and delegated to
-- a stake pool.
resolveActiveInstantStakeCredentials ::
  EraStake era =>
  InstantStake era -> UM.UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials :: forall era.
EraStake era =>
InstantStake era
-> UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials InstantStake era
instantStake (UM.UMap Map (Credential 'Staking) UMElem
triplesMap Map Ptr (Credential 'Staking)
_) =
  forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
    forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing -- ignore non-registered stake credentials
    (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Map.mapMaybeMissing (forall a b. a -> b -> a
const UMElem -> Maybe (CompactForm Coin)
getNonZeroActiveReward)) -- use the reward amount, unless it is zero
    (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
Map.zipWithMaybeAMatched forall {p}.
p
-> CompactForm Coin
-> UMElem
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake) -- combine the stake with the reward amount
    (InstantStake era
instantStake forall s a. s -> Getting a s a -> a
^. forall era.
EraStake era =>
Lens'
  (InstantStake era) (Map (Credential 'Staking) (CompactForm Coin))
instantStakeCredentialsL)
    Map (Credential 'Staking) UMElem
triplesMap
  where
    -- Retain any non-zero reward
    getActiveReward :: UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem = do
      RDPair
rd <- UMElem -> Maybe RDPair
UM.umElemRDActive UMElem
umElem
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! RDPair -> CompactForm Coin
UM.rdReward RDPair
rd
    {-# INLINE getActiveReward #-}
    getNonZeroActiveReward :: UMElem -> Maybe (CompactForm Coin)
getNonZeroActiveReward UMElem
umElem = do
      CompactForm Coin
reward <- UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem
      CompactForm Coin
reward forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CompactForm Coin
reward forall a. Ord a => a -> a -> Bool
> forall a. Monoid a => a
mempty)
    {-# INLINE getNonZeroActiveReward #-}
    -- Adds instant stake to any active staking credential
    addInstantActiveStake :: p
-> CompactForm Coin
-> UMElem
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake p
_ CompactForm Coin
stake UMElem
umElem = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ do
      CompactForm Coin
reward <- UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem
      -- instant stake is guaranteed to be non-zero due to minUTxO, so no need to guard against mempty
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! CompactForm Coin
stake forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
reward
    {-# INLINE addInstantActiveStake #-}
{-# INLINEABLE resolveActiveInstantStakeCredentials #-}