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

module Cardano.Ledger.Conway.State.Stake (
  ConwayInstantStake (..),
  conwayInstantStakeCredentialsL,
  addConwayInstantStake,
  deleteConwayInstantStake,
  resolveConwayInstantStake,
)
where

import Cardano.Ledger.Address
import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
 )
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Conway.Era
import Cardano.Ledger.Conway.TxOut ()
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
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 qualified Data.VMap as VMap
import Data.Word (Word64)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

newtype ConwayInstantStake era = ConwayInstantStake
  { forall era.
ConwayInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake :: Map.Map (Credential 'Staking) (CompactForm Coin)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayInstantStake era) x -> ConwayInstantStake era
forall era x.
ConwayInstantStake era -> Rep (ConwayInstantStake era) x
$cto :: forall era x.
Rep (ConwayInstantStake era) x -> ConwayInstantStake era
$cfrom :: forall era x.
ConwayInstantStake era -> Rep (ConwayInstantStake era) x
Generic, Int -> ConwayInstantStake era -> ShowS
forall era. Int -> ConwayInstantStake era -> ShowS
forall era. [ConwayInstantStake era] -> ShowS
forall era. ConwayInstantStake era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayInstantStake era] -> ShowS
$cshowList :: forall era. [ConwayInstantStake era] -> ShowS
show :: ConwayInstantStake era -> String
$cshow :: forall era. ConwayInstantStake era -> String
showsPrec :: Int -> ConwayInstantStake era -> ShowS
$cshowsPrec :: forall era. Int -> ConwayInstantStake era -> ShowS
Show, ConwayInstantStake era -> ConwayInstantStake era -> Bool
forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c/= :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
== :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c== :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
Eq, ConwayInstantStake era -> ConwayInstantStake era -> Bool
ConwayInstantStake era -> ConwayInstantStake era -> Ordering
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
forall era. Eq (ConwayInstantStake 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.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Ordering
forall era.
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
min :: ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
$cmin :: forall era.
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
max :: ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
$cmax :: forall era.
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
>= :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c>= :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
> :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c> :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
<= :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c<= :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
< :: ConwayInstantStake era -> ConwayInstantStake era -> Bool
$c< :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Bool
compare :: ConwayInstantStake era -> ConwayInstantStake era -> Ordering
$ccompare :: forall era.
ConwayInstantStake era -> ConwayInstantStake era -> Ordering
Ord, ConwayInstantStake era -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ConwayInstantStake era] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (ConwayInstantStake era) -> Size
forall {era}. Typeable era => Typeable (ConwayInstantStake era)
forall era. Typeable era => ConwayInstantStake era -> Encoding
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ConwayInstantStake era] -> Size
forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (ConwayInstantStake era) -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ConwayInstantStake era] -> Size
$cencodedListSizeExpr :: forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ConwayInstantStake era] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (ConwayInstantStake era) -> Size
$cencodedSizeExpr :: forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (ConwayInstantStake era) -> Size
encCBOR :: ConwayInstantStake era -> Encoding
$cencCBOR :: forall era. Typeable era => ConwayInstantStake era -> Encoding
EncCBOR, ConwayInstantStake era -> ()
forall era. ConwayInstantStake era -> ()
forall a. (a -> ()) -> NFData a
rnf :: ConwayInstantStake era -> ()
$crnf :: forall era. ConwayInstantStake era -> ()
NFData, Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
Proxy (ConwayInstantStake era) -> String
forall era.
Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
forall era. Proxy (ConwayInstantStake era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (ConwayInstantStake era) -> String
$cshowTypeOf :: forall era. Proxy (ConwayInstantStake era) -> String
wNoThunks :: Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
Context -> ConwayInstantStake era -> IO (Maybe ThunkInfo)
NoThunks, ConwayInstantStake era
forall era. ConwayInstantStake era
forall a. a -> Default a
def :: ConwayInstantStake era
$cdef :: forall era. ConwayInstantStake era
Default, ConwayInstantStake era
[ConwayInstantStake era] -> ConwayInstantStake era
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
forall {era}. Semigroup (ConwayInstantStake era)
forall era. ConwayInstantStake era
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall era. [ConwayInstantStake era] -> ConwayInstantStake era
forall era.
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
mconcat :: [ConwayInstantStake era] -> ConwayInstantStake era
$cmconcat :: forall era. [ConwayInstantStake era] -> ConwayInstantStake era
mappend :: ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
$cmappend :: forall era.
ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
mempty :: ConwayInstantStake era
$cmempty :: forall era. ConwayInstantStake era
Monoid)

instance DecShareCBOR (ConwayInstantStake era) where
  type Share (ConwayInstantStake era) = Interns (Credential 'Staking)
  decShareCBOR :: forall s.
Share (ConwayInstantStake era)
-> Decoder s (ConwayInstantStake era)
decShareCBOR Share (ConwayInstantStake era)
credInterns = forall era.
Map (Credential 'Staking) (CompactForm Coin)
-> ConwayInstantStake era
ConwayInstantStake forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecShareCBOR a => Share a -> Decoder s a
decShareCBOR (Share (ConwayInstantStake era)
credInterns, forall a. Monoid a => a
mempty)

instance Semigroup (ConwayInstantStake era) where
  ConwayInstantStake Map (Credential 'Staking) (CompactForm Coin)
cs1 <> :: ConwayInstantStake era
-> ConwayInstantStake era -> ConwayInstantStake era
<> ConwayInstantStake Map (Credential 'Staking) (CompactForm Coin)
cs2 =
    forall era.
Map (Credential 'Staking) (CompactForm Coin)
-> ConwayInstantStake era
ConwayInstantStake (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)

instance ToJSON (ConwayInstantStake era) where
  toJSON :: ConwayInstantStake era -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ConwayInstantStake era -> [a]
toIncrementalStakePairs
  toEncoding :: ConwayInstantStake 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 => ConwayInstantStake era -> [a]
toIncrementalStakePairs

toIncrementalStakePairs :: KeyValue e a => ConwayInstantStake era -> [a]
toIncrementalStakePairs :: forall e a era. KeyValue e a => ConwayInstantStake era -> [a]
toIncrementalStakePairs iStake :: ConwayInstantStake era
iStake@(ConwayInstantStake Map (Credential 'Staking) (CompactForm Coin)
_) =
  let ConwayInstantStake {Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake :: forall era.
ConwayInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
..} = ConwayInstantStake 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)
cisCredentialStake
      ]

instance EraStake ConwayEra where
  type InstantStake ConwayEra = ConwayInstantStake ConwayEra
  instantStakeCredentialsL :: Lens'
  (InstantStake ConwayEra)
  (Map (Credential 'Staking) (CompactForm Coin))
instantStakeCredentialsL = forall era.
Lens'
  (ConwayInstantStake era)
  (Map (Credential 'Staking) (CompactForm Coin))
conwayInstantStakeCredentialsL
  addInstantStake :: UTxO ConwayEra -> InstantStake ConwayEra -> InstantStake ConwayEra
addInstantStake = forall era.
EraTxOut era =>
UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
addConwayInstantStake
  deleteInstantStake :: UTxO ConwayEra -> InstantStake ConwayEra -> InstantStake ConwayEra
deleteInstantStake = forall era.
EraTxOut era =>
UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
deleteConwayInstantStake
  resolveInstantStake :: InstantStake ConwayEra -> UMap -> Stake
resolveInstantStake = forall era.
(EraStake era, InstantStake era ~ ConwayInstantStake era) =>
ConwayInstantStake era -> UMap -> Stake
resolveConwayInstantStake

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

addConwayInstantStake ::
  EraTxOut era => UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
addConwayInstantStake :: forall era.
EraTxOut era =>
UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
addConwayInstantStake = forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
applyUTxOConwayInstantStake (coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Num a => a -> a -> a
(+) @Word64))

deleteConwayInstantStake ::
  EraTxOut era => UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
deleteConwayInstantStake :: forall era.
EraTxOut era =>
UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
deleteConwayInstantStake = forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
applyUTxOConwayInstantStake (coerce :: forall a b. Coercible a b => a -> b
coerce ((-) @Word64))

applyUTxOConwayInstantStake ::
  EraTxOut era =>
  (CompactForm Coin -> CompactForm Coin -> CompactForm Coin) ->
  UTxO era ->
  ConwayInstantStake era ->
  ConwayInstantStake era
applyUTxOConwayInstantStake :: forall era.
EraTxOut era =>
(CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era -> ConwayInstantStake era -> ConwayInstantStake era
applyUTxOConwayInstantStake CompactForm Coin -> CompactForm Coin -> CompactForm Coin
f (UTxO Map TxIn (TxOut era)
u) ConwayInstantStake era
instantInstantStake =
  forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' ConwayInstantStake era -> TxOut era -> ConwayInstantStake era
accum ConwayInstantStake era
instantInstantStake 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 :: ConwayInstantStake era -> TxOut era -> ConwayInstantStake era
accum ans :: ConwayInstantStake era
ans@(ConwayInstantStake {Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake :: forall era.
ConwayInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake}) 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
_ (StakeRefBase Credential 'Staking
stakingKeyHash) ->
              ConwayInstantStake
                { cisCredentialStake :: Map (Credential 'Staking) (CompactForm Coin)
cisCredentialStake = 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)
cisCredentialStake
                }
            Addr
_other -> ConwayInstantStake era
ans

-- The invariant in `InstantStake` is that stake is never zero.
resolveConwayInstantStake ::
  (EraStake era, InstantStake era ~ ConwayInstantStake era) =>
  ConwayInstantStake era -> UM.UMap -> Stake
resolveConwayInstantStake :: forall era.
(EraStake era, InstantStake era ~ ConwayInstantStake era) =>
ConwayInstantStake era -> UMap -> Stake
resolveConwayInstantStake ConwayInstantStake era
instantStake UMap
umap =
  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 era.
EraStake era =>
InstantStake era
-> UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials ConwayInstantStake era
instantStake UMap
umap
{-# INLINE resolveConwayInstantStake #-}