{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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 (
  Stake (..),
  sumAllStake,
  sumAllStakeCompact,
  sumCredentialsCompactStake,
  EraStake (..),
  CanGetInstantStake (..),
  CanSetInstantStake (..),
  resolveActiveInstantStakeCredentials,
) where

import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
 )
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.State.Account
import Cardano.Ledger.State.UTxO
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Data.Aeson (ToJSON)
import Data.Default (Default)
import Data.Foldable (foldMap')
import Data.Functor.Identity
import Data.Kind (Type)
import qualified Data.Map.Merge.Strict as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.VMap (VB, VMap, VP)
import qualified Data.VMap as VMap
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks)

-- | Type of stake as map from staking credential to coins associated. Any staking credential that
-- has no stake will not appear in this Map, even if it is registered. For this reason, this data
-- type should not be used for infering whether credential is registered or not.
newtype Stake = Stake
  { Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake :: VMap VB VP (Credential Staking) (CompactForm Coin)
  }
  deriving (Int -> Stake -> ShowS
[Stake] -> ShowS
Stake -> String
(Int -> Stake -> ShowS)
-> (Stake -> String) -> ([Stake] -> ShowS) -> Show Stake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stake -> ShowS
showsPrec :: Int -> Stake -> ShowS
$cshow :: Stake -> String
show :: Stake -> String
$cshowList :: [Stake] -> ShowS
showList :: [Stake] -> ShowS
Show, Stake -> Stake -> Bool
(Stake -> Stake -> Bool) -> (Stake -> Stake -> Bool) -> Eq Stake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Stake -> Stake -> Bool
== :: Stake -> Stake -> Bool
$c/= :: Stake -> Stake -> Bool
/= :: Stake -> Stake -> Bool
Eq, Stake -> ()
(Stake -> ()) -> NFData Stake
forall a. (a -> ()) -> NFData a
$crnf :: Stake -> ()
rnf :: Stake -> ()
NFData, (forall x. Stake -> Rep Stake x)
-> (forall x. Rep Stake x -> Stake) -> Generic Stake
forall x. Rep Stake x -> Stake
forall x. Stake -> Rep Stake x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Stake -> Rep Stake x
from :: forall x. Stake -> Rep Stake x
$cto :: forall x. Rep Stake x -> Stake
to :: forall x. Rep Stake x -> Stake
Generic, [Stake] -> Value
[Stake] -> Encoding
Stake -> Bool
Stake -> Value
Stake -> Encoding
(Stake -> Value)
-> (Stake -> Encoding)
-> ([Stake] -> Value)
-> ([Stake] -> Encoding)
-> (Stake -> Bool)
-> ToJSON Stake
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Stake -> Value
toJSON :: Stake -> Value
$ctoEncoding :: Stake -> Encoding
toEncoding :: Stake -> Encoding
$ctoJSONList :: [Stake] -> Value
toJSONList :: [Stake] -> Value
$ctoEncodingList :: [Stake] -> Encoding
toEncodingList :: [Stake] -> Encoding
$comitField :: Stake -> Bool
omitField :: Stake -> Bool
ToJSON, Context -> Stake -> IO (Maybe ThunkInfo)
Proxy Stake -> String
(Context -> Stake -> IO (Maybe ThunkInfo))
-> (Context -> Stake -> IO (Maybe ThunkInfo))
-> (Proxy Stake -> String)
-> NoThunks Stake
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
noThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Stake -> String
showTypeOf :: Proxy Stake -> String
NoThunks, Stake -> Encoding
(Stake -> Encoding) -> EncCBOR Stake
forall a. (a -> Encoding) -> EncCBOR a
$cencCBOR :: Stake -> Encoding
encCBOR :: Stake -> Encoding
EncCBOR)

instance Monoid Stake where
  mempty :: Stake
mempty = VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
Stake VMap VB VP (Credential Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty

instance Semigroup Stake where
  Stake VMap VB VP (Credential Staking) (CompactForm Coin)
s1 <> :: Stake -> Stake -> Stake
<> Stake VMap VB VP (Credential Staking) (CompactForm Coin)
s2 = VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
Stake (VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake)
-> VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
forall a b. (a -> b) -> a -> b
$ (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
(v -> v -> v) -> VMap kv vv k v -> VMap kv vv k v -> VMap kv vv k v
VMap.unionWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) VMap VB VP (Credential Staking) (CompactForm Coin)
s1 VMap VB VP (Credential Staking) (CompactForm Coin)
s2

instance DecShareCBOR Stake where
  type Share Stake = Share (VMap VB VP (Credential Staking) (CompactForm Coin))
  getShare :: Stake -> Share Stake
getShare = VMap VB VP (Credential Staking) (CompactForm Coin)
-> Share (VMap VB VP (Credential Staking) (CompactForm Coin))
VMap VB VP (Credential Staking) (CompactForm Coin)
-> Interns (Credential Staking)
forall a. DecShareCBOR a => a -> Share a
getShare (VMap VB VP (Credential Staking) (CompactForm Coin)
 -> Interns (Credential Staking))
-> (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin))
-> Stake
-> Interns (Credential Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake
  decShareCBOR :: forall s. Share Stake -> Decoder s Stake
decShareCBOR = (VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake)
-> Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin))
-> Decoder s Stake
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
Stake (Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin))
 -> Decoder s Stake)
-> (Interns (Credential Staking)
    -> Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin)))
-> Interns (Credential Staking)
-> Decoder s Stake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Share (VMap VB VP (Credential Staking) (CompactForm Coin))
-> Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin))
Interns (Credential Staking)
-> Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin))
forall a s. DecShareCBOR a => Share a -> Decoder s a
forall s.
Share (VMap VB VP (Credential Staking) (CompactForm Coin))
-> Decoder s (VMap VB VP (Credential Staking) (CompactForm Coin))
decShareCBOR

sumAllStake :: Stake -> Coin
sumAllStake :: Stake -> Coin
sumAllStake = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (Stake -> CompactForm Coin) -> Stake -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> CompactForm Coin
sumAllStakeCompact
{-# INLINE sumAllStake #-}

sumAllStakeCompact :: Stake -> CompactForm Coin
sumAllStakeCompact :: Stake -> CompactForm Coin
sumAllStakeCompact = (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> CompactForm Coin
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> CompactForm Coin
forall (vv :: * -> *) v a (kv :: * -> *) k.
Vector vv v =>
(a -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldl CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) CompactForm Coin
forall a. Monoid a => a
mempty (VMap VB VP (Credential Staking) (CompactForm Coin)
 -> CompactForm Coin)
-> (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin))
-> Stake
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake
{-# INLINE sumAllStakeCompact #-}

sumCredentialsCompactStake :: Foldable f => Stake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactStake :: forall (f :: * -> *).
Foldable f =>
Stake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactStake (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
stake) = (Credential Staking -> CompactForm Coin)
-> f (Credential Staking) -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (CompactForm Coin -> Maybe (CompactForm Coin) -> CompactForm Coin
forall a. a -> Maybe a -> a
fromMaybe CompactForm Coin
forall a. Monoid a => a
mempty (Maybe (CompactForm Coin) -> CompactForm Coin)
-> (Credential Staking -> Maybe (CompactForm Coin))
-> Credential Staking
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Credential Staking
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> Maybe (CompactForm Coin)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
`VMap.lookup` VMap VB VP (Credential Staking) (CompactForm Coin)
stake))
{-# INLINE sumCredentialsCompactStake #-}

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
  -- `Cardano.Ledger.State.snapShotFromInstantStake`.
  resolveInstantStake :: InstantStake era -> Accounts era -> Stake

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 #-}