{-# 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.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 (stakePoolStateToPoolParams)
import Cardano.Ledger.State.UTxO hiding (balance)
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 -> SnapShot
snapShotFromInstantStake :: forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> 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} =
  SnapShot
    { $sel:ssStake:SnapShot :: Stake
ssStake = InstantStake era -> Accounts era -> Stake
forall era.
EraStake era =>
InstantStake era -> Accounts era -> Stake
resolveInstantStake InstantStake era
iStake Accounts era
accounts
    , $sel:ssDelegations:SnapShot :: 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
    , $sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams =
        Int
-> [(KeyHash 'StakePool, PoolParams)]
-> VMap VB VB (KeyHash 'StakePool) PoolParams
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 -> StakePoolState -> PoolParams
stakePoolStateToPoolParams KeyHash 'StakePool
poolId 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
      KeyHash 'StakePool
_ <- 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
      CompactForm Coin -> Maybe (CompactForm Coin)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompactForm Coin -> Maybe (CompactForm Coin))
-> CompactForm Coin -> Maybe (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$! AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL
    {-# INLINE getActiveBalance #-}
    -- Retain any non-zero balance
    getNonZeroActiveBalance :: AccountState era -> Maybe (CompactForm Coin)
getNonZeroActiveBalance AccountState era
accountState = do
      CompactForm Coin
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
      CompactForm Coin
balance CompactForm Coin -> Maybe () -> Maybe (CompactForm Coin)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CompactForm Coin
balance CompactForm Coin -> CompactForm Coin -> Bool
forall a. Ord a => a -> a -> Bool
> CompactForm Coin
forall a. Monoid a => a
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
      CompactForm Coin
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
      CompactForm Coin -> Maybe (CompactForm Coin)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompactForm Coin -> Maybe (CompactForm Coin))
-> CompactForm Coin -> Maybe (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$! CompactForm Coin
stake CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
balance
    {-# INLINE addInstantActiveStake #-}
{-# INLINEABLE resolveActiveInstantStakeCredentials #-}