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