{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.BaseTypes (Network)
import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
 )
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.State.Account
import Cardano.Ledger.State.CertState (DState (..), PState (..))
import Cardano.Ledger.State.SnapShots
import Cardano.Ledger.State.StakePool (stakePoolStateToStakePoolParams)
import Cardano.Ledger.State.UTxO
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.Map.Strict as Map
import qualified Data.VMap as VMap
import Lens.Micro
import NoThunks.Class (NoThunks)

class
  ( EraAccounts 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 -> Accounts era -> Stake

snapShotFromInstantStake ::
  forall era. EraStake era => InstantStake era -> DState era -> PState era -> Network -> SnapShot
snapShotFromInstantStake :: forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> Network -> SnapShot
snapShotFromInstantStake InstantStake era
iStake DState era
dState PState {Map (KeyHash StakePool) StakePoolState
psStakePools :: Map (KeyHash StakePool) StakePoolState
psStakePools :: forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools} Network
network =
  SnapShot
    { ssStake :: Stake
ssStake = InstantStake era -> Accounts era -> Stake
forall era.
EraStake era =>
InstantStake era -> Accounts era -> Stake
resolveInstantStake InstantStake era
iStake Accounts era
accounts
    , ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations = Int
-> [(Credential Staking, KeyHash StakePool)]
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Int -> [(k, v)] -> VMap kv vv k v
VMap.fromDistinctAscListN Int
delegsCount [(Credential Staking, KeyHash StakePool)]
delegsAscList
    , ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams =
        Int
-> [(KeyHash StakePool, StakePoolParams)]
-> VMap VB VB (KeyHash StakePool) StakePoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Int -> [(k, v)] -> VMap kv vv k v
VMap.fromDistinctAscListN
          (Map (KeyHash StakePool) StakePoolState -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash StakePool) StakePoolState
psStakePools)
          [ (KeyHash StakePool
poolId, KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
stakePoolStateToStakePoolParams KeyHash StakePool
poolId Network
network StakePoolState
ps)
          | (KeyHash StakePool
poolId, StakePoolState
ps) <- Map (KeyHash StakePool) StakePoolState
-> [(KeyHash StakePool, StakePoolState)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (KeyHash StakePool) StakePoolState
psStakePools
          ]
    }
  where
    accounts :: Accounts era
accounts = DState era -> Accounts era
forall era. DState era -> Accounts era
dsAccounts DState era
dState
    keepAndCountDelegations ::
      Credential Staking ->
      AccountState era ->
      ([(Credential Staking, KeyHash StakePool)], Int) ->
      ([(Credential Staking, KeyHash StakePool)], Int)
    keepAndCountDelegations :: Credential Staking
-> AccountState era
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> ([(Credential Staking, KeyHash StakePool)], Int)
keepAndCountDelegations Credential Staking
cred AccountState era
accountState acc :: ([(Credential Staking, KeyHash StakePool)], Int)
acc@(![(Credential Staking, KeyHash StakePool)]
delegs, !Int
count) =
      case AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL of
        Maybe (KeyHash StakePool)
Nothing -> ([(Credential Staking, KeyHash StakePool)], Int)
acc
        Just KeyHash StakePool
deleg -> ((Credential Staking
cred, KeyHash StakePool
deleg) (Credential Staking, KeyHash StakePool)
-> [(Credential Staking, KeyHash StakePool)]
-> [(Credential Staking, KeyHash StakePool)]
forall a. a -> [a] -> [a]
: [(Credential Staking, KeyHash StakePool)]
delegs, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    ([(Credential Staking, KeyHash StakePool)]
delegsAscList, Int
delegsCount) =
      (Credential Staking
 -> AccountState era
 -> ([(Credential Staking, KeyHash StakePool)], Int)
 -> ([(Credential Staking, KeyHash StakePool)], Int))
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> Map (Credential Staking) (AccountState era)
-> ([(Credential Staking, KeyHash StakePool)], Int)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Credential Staking
-> AccountState era
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> ([(Credential Staking, KeyHash StakePool)], Int)
keepAndCountDelegations ([], Int
0) (Map (Credential Staking) (AccountState era)
 -> ([(Credential Staking, KeyHash StakePool)], Int))
-> Map (Credential Staking) (AccountState era)
-> ([(Credential Staking, KeyHash StakePool)], Int)
forall a b. (a -> b) -> a -> b
$ Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
{-# INLINE snapShotFromInstantStake #-}

class CanGetInstantStake t where
  instantStakeG :: SimpleGetter (t era) (InstantStake era)
  default instantStakeG :: CanSetInstantStake t => SimpleGetter (t era) (InstantStake era)
  instantStakeG = (InstantStake era -> Const r (InstantStake era))
-> t era -> Const r (t era)
forall era. Lens' (t era) (InstantStake era)
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 ->
  Accounts era ->
  Map (Credential Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials :: forall era.
EraStake era =>
InstantStake era
-> Accounts era -> Map (Credential Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials InstantStake era
instantStake Accounts era
accounts =
  SimpleWhenMissing
  (Credential Staking) (CompactForm Coin) (CompactForm Coin)
-> SimpleWhenMissing
     (Credential Staking) (AccountState era) (CompactForm Coin)
-> SimpleWhenMatched
     (Credential Staking)
     (CompactForm Coin)
     (AccountState era)
     (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (CompactForm Coin)
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
    SimpleWhenMissing
  (Credential Staking) (CompactForm Coin) (CompactForm Coin)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing -- ignore non-registered stake credentials
    ((Credential Staking
 -> AccountState era -> Maybe (CompactForm Coin))
-> SimpleWhenMissing
     (Credential Staking) (AccountState era) (CompactForm Coin)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Map.mapMaybeMissing ((AccountState era -> Maybe (CompactForm Coin))
-> Credential Staking
-> AccountState era
-> Maybe (CompactForm Coin)
forall a b. a -> b -> a
const AccountState era -> Maybe (CompactForm Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
AccountState era -> Maybe (CompactForm Coin)
getNonZeroActiveBalance)) -- use the account balance, unless it is zero
    ((Credential Staking
 -> CompactForm Coin
 -> AccountState era
 -> Identity (Maybe (CompactForm Coin)))
-> SimpleWhenMatched
     (Credential Staking)
     (CompactForm Coin)
     (AccountState era)
     (CompactForm Coin)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
Map.zipWithMaybeAMatched Credential Staking
-> CompactForm Coin
-> AccountState era
-> Identity (Maybe (CompactForm Coin))
forall {era} {p}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
p
-> CompactForm Coin
-> AccountState era
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake) -- combine the stake with the account balance
    (InstantStake era
instantStake InstantStake era
-> Getting
     (Map (Credential Staking) (CompactForm Coin))
     (InstantStake era)
     (Map (Credential Staking) (CompactForm Coin))
-> Map (Credential Staking) (CompactForm Coin)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (CompactForm Coin))
  (InstantStake era)
  (Map (Credential Staking) (CompactForm Coin))
forall era.
EraStake era =>
Lens'
  (InstantStake era) (Map (Credential Staking) (CompactForm Coin))
Lens'
  (InstantStake era) (Map (Credential Staking) (CompactForm Coin))
instantStakeCredentialsL)
    (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)
  where
    -- Only return balance for accounts that have an active delegation to a stake pool.
    getActiveBalance :: AccountState era -> Maybe (CompactForm Coin)
getActiveBalance AccountState era
accountState = do
      _ <- AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL
      pure $! accountState ^. balanceAccountStateL
    {-# INLINE getActiveBalance #-}
    -- Retain any non-zero balance
    getNonZeroActiveBalance :: AccountState era -> Maybe (CompactForm Coin)
getNonZeroActiveBalance AccountState era
accountState = do
      balance <- AccountState era -> Maybe (CompactForm Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
AccountState era -> Maybe (CompactForm Coin)
getActiveBalance AccountState era
accountState
      balance <$ guard (balance > mempty)
    {-# INLINE getNonZeroActiveBalance #-}
    -- Adds instant stake to any active staking credential
    addInstantActiveStake :: p
-> CompactForm Coin
-> AccountState era
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake p
_ CompactForm Coin
stake AccountState era
accountState = Maybe (CompactForm Coin) -> Identity (Maybe (CompactForm Coin))
forall a. a -> Identity a
Identity (Maybe (CompactForm Coin) -> Identity (Maybe (CompactForm Coin)))
-> Maybe (CompactForm Coin) -> Identity (Maybe (CompactForm Coin))
forall a b. (a -> b) -> a -> b
$ do
      balance <- AccountState era -> Maybe (CompactForm Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
AccountState era -> Maybe (CompactForm Coin)
getActiveBalance AccountState era
accountState
      -- instant stake is guaranteed to be non-zero due to minUTxO, so no need to guard against mempty
      pure $! stake <> balance
    {-# INLINE addInstantActiveStake #-}
{-# INLINEABLE resolveActiveInstantStakeCredentials #-}