{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.State.Stake (
  ShelleyInstantStake (..),
  shelleyInstantStakeCredentialsL,
  addShelleyInstantStake,
  deleteShelleyInstantStake,
  resolveShelleyInstantStake,
)
where

import Cardano.Ledger.Address
import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  decCBOR,
  decodeRecordNamed,
  encodeListLen,
 )
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.Era
import Cardano.Ledger.Shelley.TxOut ()
import Cardano.Ledger.State
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Coerce
import Data.Default (Default (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Typeable
import qualified Data.VMap as VMap
import Data.Word (Word64)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

data ShelleyInstantStake era = ShelleyInstantStake
  { forall era.
ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake :: !(Map.Map (Credential 'Staking) (CompactForm Coin))
  , forall era. ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
sisPtrStake :: !(Map.Map Ptr (CompactForm Coin))
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyInstantStake era) x -> ShelleyInstantStake era
forall era x.
ShelleyInstantStake era -> Rep (ShelleyInstantStake era) x
$cto :: forall era x.
Rep (ShelleyInstantStake era) x -> ShelleyInstantStake era
$cfrom :: forall era x.
ShelleyInstantStake era -> Rep (ShelleyInstantStake era) x
Generic, Int -> ShelleyInstantStake era -> ShowS
forall era. Int -> ShelleyInstantStake era -> ShowS
forall era. [ShelleyInstantStake era] -> ShowS
forall era. ShelleyInstantStake era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyInstantStake era] -> ShowS
$cshowList :: forall era. [ShelleyInstantStake era] -> ShowS
show :: ShelleyInstantStake era -> String
$cshow :: forall era. ShelleyInstantStake era -> String
showsPrec :: Int -> ShelleyInstantStake era -> ShowS
$cshowsPrec :: forall era. Int -> ShelleyInstantStake era -> ShowS
Show, ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c/= :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
== :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c== :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
Eq, ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
ShelleyInstantStake era -> ShelleyInstantStake era -> Ordering
forall era. Eq (ShelleyInstantStake era)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Ordering
forall era.
ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
min :: ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
$cmin :: forall era.
ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
max :: ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
$cmax :: forall era.
ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
>= :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c>= :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
> :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c> :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
<= :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c<= :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
< :: ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
$c< :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Bool
compare :: ShelleyInstantStake era -> ShelleyInstantStake era -> Ordering
$ccompare :: forall era.
ShelleyInstantStake era -> ShelleyInstantStake era -> Ordering
Ord)

instance NFData (ShelleyInstantStake era)
instance NoThunks (ShelleyInstantStake era)

instance Typeable era => EncCBOR (ShelleyInstantStake era) where
  encCBOR :: ShelleyInstantStake era -> Encoding
encCBOR (ShelleyInstantStake Map (Credential 'Staking) (CompactForm Coin)
credentialStake Map Ptr (CompactForm Coin)
ptrStake) =
    Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (Credential 'Staking) (CompactForm Coin)
credentialStake forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map Ptr (CompactForm Coin)
ptrStake

instance DecShareCBOR (ShelleyInstantStake era) where
  type Share (ShelleyInstantStake era) = Interns (Credential 'Staking)
  decShareCBOR :: forall s.
Share (ShelleyInstantStake era)
-> Decoder s (ShelleyInstantStake era)
decShareCBOR Share (ShelleyInstantStake era)
credInterns =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyInstantStake" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$ do
      Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake <- forall a s. DecShareCBOR a => Share a -> Decoder s a
decShareCBOR (Share (ShelleyInstantStake era)
credInterns, forall a. Monoid a => a
mempty)
      Map Ptr (CompactForm Coin)
sisPtrStake <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ShelleyInstantStake {Map (Credential 'Staking) (CompactForm Coin)
Map Ptr (CompactForm Coin)
sisPtrStake :: Map Ptr (CompactForm Coin)
sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
sisPtrStake :: Map Ptr (CompactForm Coin)
sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
..}

instance Semigroup (ShelleyInstantStake era) where
  ShelleyInstantStake Map (Credential 'Staking) (CompactForm Coin)
cs1 Map Ptr (CompactForm Coin)
ps1 <> :: ShelleyInstantStake era
-> ShelleyInstantStake era -> ShelleyInstantStake era
<> ShelleyInstantStake Map (Credential 'Staking) (CompactForm Coin)
cs2 Map Ptr (CompactForm Coin)
ps2 =
    forall era.
Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> ShelleyInstantStake era
ShelleyInstantStake (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map (Credential 'Staking) (CompactForm Coin)
cs1 Map (Credential 'Staking) (CompactForm Coin)
cs2) (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map Ptr (CompactForm Coin)
ps1 Map Ptr (CompactForm Coin)
ps2)

instance Monoid (ShelleyInstantStake era) where
  mempty :: ShelleyInstantStake era
mempty = forall era.
Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> ShelleyInstantStake era
ShelleyInstantStake forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

instance Default (ShelleyInstantStake era) where
  def :: ShelleyInstantStake era
def = forall a. Monoid a => a
mempty

instance ToJSON (ShelleyInstantStake era) where
  toJSON :: ShelleyInstantStake era -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ShelleyInstantStake era -> [a]
toIncrementalStakePairs
  toEncoding :: ShelleyInstantStake era -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ShelleyInstantStake era -> [a]
toIncrementalStakePairs

toIncrementalStakePairs :: KeyValue e a => ShelleyInstantStake era -> [a]
toIncrementalStakePairs :: forall e a era. KeyValue e a => ShelleyInstantStake era -> [a]
toIncrementalStakePairs iStake :: ShelleyInstantStake era
iStake@(ShelleyInstantStake Map (Credential 'Staking) (CompactForm Coin)
_ Map Ptr (CompactForm Coin)
_) =
  let ShelleyInstantStake {Map (Credential 'Staking) (CompactForm Coin)
Map Ptr (CompactForm Coin)
sisPtrStake :: Map Ptr (CompactForm Coin)
sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
sisPtrStake :: forall era. ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
sisCredentialStake :: forall era.
ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
..} = ShelleyInstantStake era
iStake -- guard against addition or removal of fields
   in [ Key
"credentials" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake
      , Key
"pointers" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Ptr (CompactForm Coin)
sisPtrStake
      ]

instance EraStake ShelleyEra where
  type InstantStake ShelleyEra = ShelleyInstantStake ShelleyEra
  instantStakeCredentialsL :: Lens'
  (InstantStake ShelleyEra)
  (Map (Credential 'Staking) (CompactForm Coin))
instantStakeCredentialsL = forall era.
Lens'
  (ShelleyInstantStake era)
  (Map (Credential 'Staking) (CompactForm Coin))
shelleyInstantStakeCredentialsL
  addInstantStake :: UTxO ShelleyEra
-> InstantStake ShelleyEra -> InstantStake ShelleyEra
addInstantStake = forall era.
EraTxOut era =>
UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
addShelleyInstantStake
  deleteInstantStake :: UTxO ShelleyEra
-> InstantStake ShelleyEra -> InstantStake ShelleyEra
deleteInstantStake = forall era.
EraTxOut era =>
UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
deleteShelleyInstantStake
  resolveInstantStake :: InstantStake ShelleyEra -> UMap -> Stake
resolveInstantStake = forall era.
(EraStake era, InstantStake era ~ ShelleyInstantStake era) =>
ShelleyInstantStake era -> UMap -> Stake
resolveShelleyInstantStake

shelleyInstantStakeCredentialsL ::
  Lens' (ShelleyInstantStake era) (Map.Map (Credential 'Staking) (CompactForm Coin))
shelleyInstantStakeCredentialsL :: forall era.
Lens'
  (ShelleyInstantStake era)
  (Map (Credential 'Staking) (CompactForm Coin))
shelleyInstantStakeCredentialsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake forall a b. (a -> b) -> a -> b
$ \ShelleyInstantStake era
is Map (Credential 'Staking) (CompactForm Coin)
m -> ShelleyInstantStake era
is {sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake = Map (Credential 'Staking) (CompactForm Coin)
m}

addShelleyInstantStake ::
  EraTxOut era => UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
addShelleyInstantStake :: forall era.
EraTxOut era =>
UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
addShelleyInstantStake = forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
applyUTxOShelleyInstantStake (coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Num a => a -> a -> a
(+) @Word64))

deleteShelleyInstantStake ::
  EraTxOut era => UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
deleteShelleyInstantStake :: forall era.
EraTxOut era =>
UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
deleteShelleyInstantStake = forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
applyUTxOShelleyInstantStake (coerce :: forall a b. Coercible a b => a -> b
coerce ((-) @Word64))

applyUTxOShelleyInstantStake ::
  EraTxOut era =>
  (CompactForm Coin -> CompactForm Coin -> CompactForm Coin) ->
  UTxO era ->
  ShelleyInstantStake era ->
  ShelleyInstantStake era
applyUTxOShelleyInstantStake :: forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ShelleyInstantStake era -> ShelleyInstantStake era
applyUTxOShelleyInstantStake CompactForm Coin -> CompactForm Coin -> CompactForm Coin
f (UTxO Map TxIn (TxOut era)
u) ShelleyInstantStake era
instantStake =
  forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' ShelleyInstantStake era -> TxOut era -> ShelleyInstantStake era
accum ShelleyInstantStake era
instantStake Map TxIn (TxOut era)
u
  where
    keepOrDeleteCompact :: CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
new = \case
      Maybe (CompactForm Coin)
Nothing ->
        case CompactForm Coin
new of
          CompactCoin Word64
0 -> forall a. Maybe a
Nothing
          CompactForm Coin
final -> forall a. a -> Maybe a
Just CompactForm Coin
final
      Just CompactForm Coin
old ->
        case CompactForm Coin
old CompactForm Coin -> CompactForm Coin -> CompactForm Coin
`f` CompactForm Coin
new of
          CompactCoin Word64
0 -> forall a. Maybe a
Nothing
          CompactForm Coin
final -> forall a. a -> Maybe a
Just CompactForm Coin
final
    accum :: ShelleyInstantStake era -> TxOut era -> ShelleyInstantStake era
accum ans :: ShelleyInstantStake era
ans@(ShelleyInstantStake {Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake :: forall era.
ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake, Map Ptr (CompactForm Coin)
sisPtrStake :: Map Ptr (CompactForm Coin)
sisPtrStake :: forall era. ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
sisPtrStake}) TxOut era
out =
      let cc :: CompactForm Coin
cc = TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL
       in case TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
            Addr Network
_ PaymentCredential
_ (StakeRefPtr Ptr
stakingPtr) ->
              ShelleyInstantStake era
ans
                { sisPtrStake :: Map Ptr (CompactForm Coin)
sisPtrStake = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
cc) Ptr
stakingPtr Map Ptr (CompactForm Coin)
sisPtrStake
                }
            Addr Network
_ PaymentCredential
_ (StakeRefBase Credential 'Staking
stakingKeyHash) ->
              ShelleyInstantStake era
ans
                { sisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
cc) Credential 'Staking
stakingKeyHash Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake
                }
            Addr
_other -> ShelleyInstantStake era
ans

-- The invariant in `InstantStake` is that stake is never zero.
resolveShelleyInstantStake ::
  (EraStake era, InstantStake era ~ ShelleyInstantStake era) =>
  ShelleyInstantStake era -> UM.UMap -> Stake
resolveShelleyInstantStake :: forall era.
(EraStake era, InstantStake era ~ ShelleyInstantStake era) =>
ShelleyInstantStake era -> UMap -> Stake
resolveShelleyInstantStake instantStake :: ShelleyInstantStake era
instantStake@ShelleyInstantStake {Map Ptr (CompactForm Coin)
sisPtrStake :: Map Ptr (CompactForm Coin)
sisPtrStake :: forall era. ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
sisPtrStake} umap :: UMap
umap@(UM.UMap Map (Credential 'Staking) UMElem
triplesMap Map Ptr (Credential 'Staking)
ptrMap) =
  VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
Stake forall a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap forall a b. (a -> b) -> a -> b
$ forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map (Credential 'Staking) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking) (CompactForm Coin)
addPtrStake Map (Credential 'Staking) (CompactForm Coin)
credentialStakeMap Map Ptr (CompactForm Coin)
sisPtrStake
  where
    !credentialStakeMap :: Map (Credential 'Staking) (CompactForm Coin)
credentialStakeMap = forall era.
EraStake era =>
InstantStake era
-> UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials ShelleyInstantStake era
instantStake UMap
umap
    addPtrStake :: Map (Credential 'Staking) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking) (CompactForm Coin)
addPtrStake !Map (Credential 'Staking) (CompactForm Coin)
acc Ptr
ptr CompactForm Coin
ptrStake = forall a. a -> Maybe a -> a
fromMaybe Map (Credential 'Staking) (CompactForm Coin)
acc forall a b. (a -> b) -> a -> b
$ do
      Credential 'Staking
cred <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr
ptr Map Ptr (Credential 'Staking)
ptrMap
      -- Ensure only active staking credential receive Ptr delegations
      RDPair
_ <- UMElem -> Maybe RDPair
UM.umElemRDActive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
cred Map (Credential 'Staking) UMElem
triplesMap
      let plusPtrStake :: Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
plusPtrStake =
            forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
              Maybe (CompactForm Coin)
Nothing -> CompactForm Coin
ptrStake
              Just CompactForm Coin
curStake -> CompactForm Coin
curStake forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
ptrStake
      -- 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
$! forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
plusPtrStake Credential 'Staking
cred Map (Credential 'Staking) (CompactForm Coin)
acc