{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.CertState (
  CertState (..),
  CommitteeAuthorization (..),
  DState (..),
  PState (..),
  VState (..),
  InstantaneousRewards (..),
  FutureGenDeleg (..),
  Anchor (..),
  DRepState (..),
  DRep (..),
  CommitteeState (..),
  authorizedHotCommitteeCredentials,
  AnchorData,
  lookupDepositDState,
  lookupRewardDState,
  rewards,
  delegations,
  ptrsMap,
  payPoolDeposit,
  refundPoolDeposit,
  obligationCertState,
  Obligations (..),
  sumObligation,
  certsTotalDepositsTxBody,
  certsTotalRefundsTxBody,
  -- Lenses
  certDStateL,
  certPStateL,
  certVStateL,
  dsUnifiedL,
  dsGenDelegsL,
  dsIRewardsL,
  dsFutureGenDelegsL,
  psStakePoolParamsL,
  psFutureStakePoolParamsL,
  psRetiringL,
  psDepositsL,
  vsDRepsL,
  vsCommitteeStateL,
  vsNumDormantEpochsL,
  vsActualDRepExpiry,
  csCommitteeCredsL,
  lookupDepositVState,
)
where

import Cardano.Ledger.BaseTypes (Anchor (..), AnchorData, StrictMaybe, binOpEpochNo)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  ToCBOR (..),
  decNoShareCBOR,
  decSharePlusCBOR,
  decSharePlusLensCBOR,
  decodeRecordNamed,
  decodeRecordNamedT,
  encodeListLen,
  toMemptyLens,
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (
  Coin (..),
  DeltaCoin (..),
 )
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), Ptr, StakeCredential)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.DRep (DRep (..), DRepState (..))
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  GenDelegs (..),
  KeyHash (..),
  KeyRole (..),
 )
import Cardano.Ledger.PoolParams (PoolParams)
import Cardano.Ledger.Slot (
  EpochNo (..),
  SlotNo (..),
 )
import Cardano.Ledger.UMap (RDPair (..), UMap (UMap), UView (RewDepUView, SPoolUView))
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData (..))
import Control.Monad.Trans
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default.Class (Default (def))
import qualified Data.Foldable as F
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Typeable
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (^.), _1, _2)
import NoThunks.Class (NoThunks (..))

-- ======================================

data FutureGenDeleg c = FutureGenDeleg
  { forall c. FutureGenDeleg c -> SlotNo
fGenDelegSlot :: !SlotNo
  , forall c. FutureGenDeleg c -> KeyHash 'Genesis c
fGenDelegGenKeyHash :: !(KeyHash 'Genesis c)
  }
  deriving (Int -> FutureGenDeleg c -> ShowS
forall c. Int -> FutureGenDeleg c -> ShowS
forall c. [FutureGenDeleg c] -> ShowS
forall c. FutureGenDeleg c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureGenDeleg c] -> ShowS
$cshowList :: forall c. [FutureGenDeleg c] -> ShowS
show :: FutureGenDeleg c -> String
$cshow :: forall c. FutureGenDeleg c -> String
showsPrec :: Int -> FutureGenDeleg c -> ShowS
$cshowsPrec :: forall c. Int -> FutureGenDeleg c -> ShowS
Show, FutureGenDeleg c -> FutureGenDeleg c -> Bool
forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c/= :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
== :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c== :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
Eq, FutureGenDeleg c -> FutureGenDeleg c -> Bool
FutureGenDeleg c -> FutureGenDeleg c -> Ordering
forall c. Eq (FutureGenDeleg c)
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 c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
forall c. FutureGenDeleg c -> FutureGenDeleg c -> Ordering
forall c. FutureGenDeleg c -> FutureGenDeleg c -> FutureGenDeleg c
min :: FutureGenDeleg c -> FutureGenDeleg c -> FutureGenDeleg c
$cmin :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> FutureGenDeleg c
max :: FutureGenDeleg c -> FutureGenDeleg c -> FutureGenDeleg c
$cmax :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> FutureGenDeleg c
>= :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c>= :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
> :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c> :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
<= :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c<= :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
< :: FutureGenDeleg c -> FutureGenDeleg c -> Bool
$c< :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Bool
compare :: FutureGenDeleg c -> FutureGenDeleg c -> Ordering
$ccompare :: forall c. FutureGenDeleg c -> FutureGenDeleg c -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (FutureGenDeleg c) x -> FutureGenDeleg c
forall c x. FutureGenDeleg c -> Rep (FutureGenDeleg c) x
$cto :: forall c x. Rep (FutureGenDeleg c) x -> FutureGenDeleg c
$cfrom :: forall c x. FutureGenDeleg c -> Rep (FutureGenDeleg c) x
Generic)

instance NoThunks (FutureGenDeleg c)

instance NFData (FutureGenDeleg c)

instance Crypto c => EncCBOR (FutureGenDeleg c) where
  encCBOR :: FutureGenDeleg c -> Encoding
encCBOR (FutureGenDeleg SlotNo
a KeyHash 'Genesis c
b) =
    Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SlotNo
a forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'Genesis c
b

instance Crypto c => DecCBOR (FutureGenDeleg c) where
  decCBOR :: forall s. Decoder s (FutureGenDeleg c)
decCBOR =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"FutureGenDeleg" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$
      forall c. SlotNo -> KeyHash 'Genesis c -> FutureGenDeleg c
FutureGenDeleg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR

instance Crypto c => ToJSON (FutureGenDeleg c) where
  toJSON :: FutureGenDeleg c -> Value
toJSON FutureGenDeleg c
fGenDeleg =
    [Pair] -> Value
object
      [ Key
"fGenDelegSlot" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall c. FutureGenDeleg c -> SlotNo
fGenDelegSlot FutureGenDeleg c
fGenDeleg
      , Key
"fGenDelegGenKeyHash" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall c. FutureGenDeleg c -> KeyHash 'Genesis c
fGenDelegGenKeyHash FutureGenDeleg c
fGenDeleg
      ]

-- | InstantaneousRewards captures the pending changes to the ledger
-- state caused by MIR certificates. It consists of two mappings,
-- the rewards which will be paid out from the reserves and the rewards
-- which will be paid out from the treasury. It also consists of
-- two coin values which represent the transfer of coins from
-- one pot to the other pot.
-- NOTE that the following property should always hold:
--   deltaReserves + deltaTreasury = 0
data InstantaneousRewards c = InstantaneousRewards
  { forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
iRReserves :: !(Map (Credential 'Staking c) Coin)
  , forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
iRTreasury :: !(Map (Credential 'Staking c) Coin)
  , forall c. InstantaneousRewards c -> DeltaCoin
deltaReserves :: !DeltaCoin
  , forall c. InstantaneousRewards c -> DeltaCoin
deltaTreasury :: !DeltaCoin
  }
  deriving (Int -> InstantaneousRewards c -> ShowS
forall c. Int -> InstantaneousRewards c -> ShowS
forall c. [InstantaneousRewards c] -> ShowS
forall c. InstantaneousRewards c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantaneousRewards c] -> ShowS
$cshowList :: forall c. [InstantaneousRewards c] -> ShowS
show :: InstantaneousRewards c -> String
$cshow :: forall c. InstantaneousRewards c -> String
showsPrec :: Int -> InstantaneousRewards c -> ShowS
$cshowsPrec :: forall c. Int -> InstantaneousRewards c -> ShowS
Show, InstantaneousRewards c -> InstantaneousRewards c -> Bool
forall c. InstantaneousRewards c -> InstantaneousRewards c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstantaneousRewards c -> InstantaneousRewards c -> Bool
$c/= :: forall c. InstantaneousRewards c -> InstantaneousRewards c -> Bool
== :: InstantaneousRewards c -> InstantaneousRewards c -> Bool
$c== :: forall c. InstantaneousRewards c -> InstantaneousRewards c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (InstantaneousRewards c) x -> InstantaneousRewards c
forall c x.
InstantaneousRewards c -> Rep (InstantaneousRewards c) x
$cto :: forall c x.
Rep (InstantaneousRewards c) x -> InstantaneousRewards c
$cfrom :: forall c x.
InstantaneousRewards c -> Rep (InstantaneousRewards c) x
Generic)

instance NoThunks (InstantaneousRewards c)

instance NFData (InstantaneousRewards c)

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

toInstantaneousRewardsPair :: (KeyValue e a, Crypto c) => InstantaneousRewards c -> [a]
toInstantaneousRewardsPair :: forall e a c.
(KeyValue e a, Crypto c) =>
InstantaneousRewards c -> [a]
toInstantaneousRewardsPair InstantaneousRewards {Map (Credential 'Staking c) Coin
DeltaCoin
deltaTreasury :: DeltaCoin
deltaReserves :: DeltaCoin
iRTreasury :: Map (Credential 'Staking c) Coin
iRReserves :: Map (Credential 'Staking c) Coin
deltaTreasury :: forall c. InstantaneousRewards c -> DeltaCoin
deltaReserves :: forall c. InstantaneousRewards c -> DeltaCoin
iRTreasury :: forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
iRReserves :: forall c.
InstantaneousRewards c -> Map (Credential 'Staking c) Coin
..} =
  [ Key
"iRReserves" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'Staking c) Coin
iRReserves
  , Key
"iRTreasury" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'Staking c) Coin
iRTreasury
  , Key
"deltaReserves" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DeltaCoin
deltaReserves
  , Key
"deltaTreasury" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DeltaCoin
deltaTreasury
  ]

-- | The state used by the DELEG rule, which roughly tracks stake
-- delegation and some governance features.
data DState era = DState
  { forall era. DState era -> UMap (EraCrypto era)
dsUnified :: !(UMap (EraCrypto era))
  -- ^ Unified Reward Maps. This contains the reward map (which is the source
  -- of truth regarding the registered stake credentials, the deposit map,
  -- the delegation map, and the stake credential pointer map.
  , forall era.
DState era
-> Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsFutureGenDelegs :: !(Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era)))
  -- ^ Future genesis key delegations
  , forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs :: !(GenDelegs (EraCrypto era))
  -- ^ Genesis key delegations
  , forall era. DState era -> InstantaneousRewards (EraCrypto era)
dsIRewards :: !(InstantaneousRewards (EraCrypto era))
  -- ^ Instantaneous Rewards
  }
  deriving (Int -> DState era -> ShowS
forall era. Int -> DState era -> ShowS
forall era. [DState era] -> ShowS
forall era. DState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DState era] -> ShowS
$cshowList :: forall era. [DState era] -> ShowS
show :: DState era -> String
$cshow :: forall era. DState era -> String
showsPrec :: Int -> DState era -> ShowS
$cshowsPrec :: forall era. Int -> DState era -> ShowS
Show, DState era -> DState era -> Bool
forall era. DState era -> DState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DState era -> DState era -> Bool
$c/= :: forall era. DState era -> DState era -> Bool
== :: DState era -> DState era -> Bool
$c== :: forall era. DState era -> DState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (DState era) x -> DState era
forall era x. DState era -> Rep (DState era) x
$cto :: forall era x. Rep (DState era) x -> DState era
$cfrom :: forall era x. DState era -> Rep (DState era) x
Generic)

instance NoThunks (DState era)

instance NFData (DState era)

instance (Era era, EncCBOR (InstantaneousRewards (EraCrypto era))) => EncCBOR (DState era) where
  encCBOR :: DState era -> Encoding
encCBOR (DState UMap (EraCrypto era)
unified Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
fgs GenDelegs (EraCrypto era)
gs InstantaneousRewards (EraCrypto era)
ir) =
    Word -> Encoding
encodeListLen Word
4
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR UMap (EraCrypto era)
unified
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
fgs
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR GenDelegs (EraCrypto era)
gs
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR InstantaneousRewards (EraCrypto era)
ir

instance (Era era, DecShareCBOR (InstantaneousRewards (EraCrypto era))) => DecShareCBOR (DState era) where
  type
    Share (DState era) =
      (Interns (Credential 'Staking (EraCrypto era)), Interns (KeyHash 'StakePool (EraCrypto era)))
  decSharePlusCBOR :: forall s. StateT (Share (DState era)) (Decoder s) (DState era)
decSharePlusCBOR =
    forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"DState" (forall a b. a -> b -> a
const Int
4) forall a b. (a -> b) -> a -> b
$ do
      UMap (EraCrypto era)
unified <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
      Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
fgs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecCBOR a => Decoder s a
decCBOR
      GenDelegs (EraCrypto era)
gs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecCBOR a => Decoder s a
decCBOR
      InstantaneousRewards (EraCrypto era)
ir <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall s t a b. Field1 s t a b => Lens s t a b
_1
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
UMap (EraCrypto era)
-> Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> GenDelegs (EraCrypto era)
-> InstantaneousRewards (EraCrypto era)
-> DState era
DState UMap (EraCrypto era)
unified Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
fgs GenDelegs (EraCrypto era)
gs InstantaneousRewards (EraCrypto era)
ir

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

toDStatePair :: (KeyValue e a, Era era) => DState era -> [a]
toDStatePair :: forall e a era. (KeyValue e a, Era era) => DState era -> [a]
toDStatePair DState {Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
GenDelegs (EraCrypto era)
UMap (EraCrypto era)
InstantaneousRewards (EraCrypto era)
dsIRewards :: InstantaneousRewards (EraCrypto era)
dsGenDelegs :: GenDelegs (EraCrypto era)
dsFutureGenDelegs :: Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsUnified :: UMap (EraCrypto era)
dsIRewards :: forall era. DState era -> InstantaneousRewards (EraCrypto era)
dsGenDelegs :: forall era. DState era -> GenDelegs (EraCrypto era)
dsFutureGenDelegs :: forall era.
DState era
-> Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsUnified :: forall era. DState era -> UMap (EraCrypto era)
..} =
  [ Key
"unified" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UMap (EraCrypto era)
dsUnified
  , Key
"fGenDelegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall k a. Map k a -> [(k, a)]
Map.toList Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsFutureGenDelegs
  , Key
"genDelegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GenDelegs (EraCrypto era)
dsGenDelegs
  , Key
"irwd" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= InstantaneousRewards (EraCrypto era)
dsIRewards
  ]

-- | Function that looks up the deposit for currently delegated staking credential
lookupDepositDState :: DState era -> (StakeCredential (EraCrypto era) -> Maybe Coin)
lookupDepositDState :: forall era.
DState era -> StakeCredential (EraCrypto era) -> Maybe Coin
lookupDepositDState DState era
dstate =
  let currentRewardDeposits :: UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
currentRewardDeposits = forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap (EraCrypto era)
dsUnified DState era
dstate
   in \Credential 'Staking (EraCrypto era)
k -> do
        RDPair CompactForm Coin
_ CompactForm Coin
deposit <- forall k c v. k -> UView c k v -> Maybe v
UM.lookup Credential 'Staking (EraCrypto era)
k UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
currentRewardDeposits
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
deposit

-- | Function that looks up curret reward for the delegated staking credential.
lookupRewardDState :: DState era -> (StakeCredential (EraCrypto era) -> Maybe Coin)
lookupRewardDState :: forall era.
DState era -> StakeCredential (EraCrypto era) -> Maybe Coin
lookupRewardDState DState era
dstate =
  let currentRewardDeposits :: UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
currentRewardDeposits = forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap (EraCrypto era)
dsUnified DState era
dstate
   in \Credential 'Staking (EraCrypto era)
k -> do
        RDPair CompactForm Coin
reward CompactForm Coin
_ <- forall k c v. k -> UView c k v -> Maybe v
UM.lookup Credential 'Staking (EraCrypto era)
k UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
currentRewardDeposits
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
reward

-- | The state used by the POOL rule, which tracks stake pool information.
data PState era = PState
  { forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
  -- ^ The stake pool parameters.
  , forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
  -- ^ The future stake pool parameters.
  -- Changes to existing stake pool parameters are staged in order
  -- to give delegators time to react to changes.
  -- See section 11.2, "Example Illustration of the Reward Cycle",
  -- of the Shelley Ledger Specification for a sequence diagram.
  , forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring :: !(Map (KeyHash 'StakePool (EraCrypto era)) EpochNo)
  -- ^ A map of retiring stake pools to the epoch when they retire.
  , forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits :: !(Map (KeyHash 'StakePool (EraCrypto era)) Coin)
  -- ^ A map of the deposits for each pool
  }
  deriving (Int -> PState era -> ShowS
forall era. Int -> PState era -> ShowS
forall era. [PState era] -> ShowS
forall era. PState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PState era] -> ShowS
$cshowList :: forall era. [PState era] -> ShowS
show :: PState era -> String
$cshow :: forall era. PState era -> String
showsPrec :: Int -> PState era -> ShowS
$cshowsPrec :: forall era. Int -> PState era -> ShowS
Show, PState era -> PState era -> Bool
forall era. PState era -> PState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PState era -> PState era -> Bool
$c/= :: forall era. PState era -> PState era -> Bool
== :: PState era -> PState era -> Bool
$c== :: forall era. PState era -> PState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PState era) x -> PState era
forall era x. PState era -> Rep (PState era) x
$cto :: forall era x. Rep (PState era) x -> PState era
$cfrom :: forall era x. PState era -> Rep (PState era) x
Generic)

instance NoThunks (PState era)

instance NFData (PState era)

instance Era era => EncCBOR (PState era) where
  encCBOR :: PState era -> Encoding
encCBOR (PState Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
a Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
b Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
c Map (KeyHash 'StakePool (EraCrypto era)) Coin
d) =
    Word -> Encoding
encodeListLen Word
4 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
a forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
b forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
c forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool (EraCrypto era)) Coin
d

instance Era era => DecShareCBOR (PState era) where
  type Share (PState era) = Interns (KeyHash 'StakePool (EraCrypto era))
  decSharePlusCBOR :: forall s. StateT (Share (PState era)) (Decoder s) (PState era)
decSharePlusCBOR = forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"PState" (forall a b. a -> b -> a
const Int
4) forall a b. (a -> b) -> a -> b
$ do
    Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
    Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
    Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
    Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure PState {Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams, Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams, Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring :: Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring :: Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring, Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits}

instance (Era era, DecShareCBOR (PState era)) => DecCBOR (PState era) where
  decCBOR :: forall s. Decoder s (PState era)
decCBOR = forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

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

toPStatePair :: (KeyValue e a, Era era) => PState era -> [a]
toPStatePair :: forall e a era. (KeyValue e a, Era era) => PState era -> [a]
toPStatePair PState {Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
Map (KeyHash 'StakePool (EraCrypto era)) Coin
Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psRetiring :: Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psFutureStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psDeposits :: forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psRetiring :: forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psFutureStakePoolParams :: forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams :: forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
..} =
  [ Key
"stakePoolParams" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams
  , Key
"futureStakePoolParams" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams
  , Key
"retiring" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring
  , Key
"deposits" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits
  ]

data CommitteeAuthorization c
  = -- | Member authorized with a Hot credential acting on behalf of their Cold credential
    CommitteeHotCredential !(Credential 'HotCommitteeRole c)
  | -- | Member resigned with a potential explanation in Anchor
    CommitteeMemberResigned !(StrictMaybe (Anchor c))
  deriving (CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c/= :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
== :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c== :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
Eq, CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
CommitteeAuthorization c -> CommitteeAuthorization c -> Ordering
forall c. Eq (CommitteeAuthorization c)
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 c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Ordering
forall c.
CommitteeAuthorization c
-> CommitteeAuthorization c -> CommitteeAuthorization c
min :: CommitteeAuthorization c
-> CommitteeAuthorization c -> CommitteeAuthorization c
$cmin :: forall c.
CommitteeAuthorization c
-> CommitteeAuthorization c -> CommitteeAuthorization c
max :: CommitteeAuthorization c
-> CommitteeAuthorization c -> CommitteeAuthorization c
$cmax :: forall c.
CommitteeAuthorization c
-> CommitteeAuthorization c -> CommitteeAuthorization c
>= :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c>= :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
> :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c> :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
<= :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c<= :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
< :: CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
$c< :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Bool
compare :: CommitteeAuthorization c -> CommitteeAuthorization c -> Ordering
$ccompare :: forall c.
CommitteeAuthorization c -> CommitteeAuthorization c -> Ordering
Ord, Int -> CommitteeAuthorization c -> ShowS
forall c. Int -> CommitteeAuthorization c -> ShowS
forall c. [CommitteeAuthorization c] -> ShowS
forall c. CommitteeAuthorization c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommitteeAuthorization c] -> ShowS
$cshowList :: forall c. [CommitteeAuthorization c] -> ShowS
show :: CommitteeAuthorization c -> String
$cshow :: forall c. CommitteeAuthorization c -> String
showsPrec :: Int -> CommitteeAuthorization c -> ShowS
$cshowsPrec :: forall c. Int -> CommitteeAuthorization c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (CommitteeAuthorization c) x -> CommitteeAuthorization c
forall c x.
CommitteeAuthorization c -> Rep (CommitteeAuthorization c) x
$cto :: forall c x.
Rep (CommitteeAuthorization c) x -> CommitteeAuthorization c
$cfrom :: forall c x.
CommitteeAuthorization c -> Rep (CommitteeAuthorization c) x
Generic, forall c. Crypto c => [CommitteeAuthorization c] -> Encoding
forall c. Crypto c => [CommitteeAuthorization c] -> Value
forall c. Crypto c => CommitteeAuthorization c -> Bool
forall c. Crypto c => CommitteeAuthorization c -> Encoding
forall c. Crypto c => CommitteeAuthorization c -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: CommitteeAuthorization c -> Bool
$comitField :: forall c. Crypto c => CommitteeAuthorization c -> Bool
toEncodingList :: [CommitteeAuthorization c] -> Encoding
$ctoEncodingList :: forall c. Crypto c => [CommitteeAuthorization c] -> Encoding
toJSONList :: [CommitteeAuthorization c] -> Value
$ctoJSONList :: forall c. Crypto c => [CommitteeAuthorization c] -> Value
toEncoding :: CommitteeAuthorization c -> Encoding
$ctoEncoding :: forall c. Crypto c => CommitteeAuthorization c -> Encoding
toJSON :: CommitteeAuthorization c -> Value
$ctoJSON :: forall c. Crypto c => CommitteeAuthorization c -> Value
ToJSON)

instance NoThunks (CommitteeAuthorization c)
instance Crypto c => NFData (CommitteeAuthorization c)

instance Crypto c => EncCBOR (CommitteeAuthorization c) where
  encCBOR :: CommitteeAuthorization c -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      CommitteeHotCredential Credential 'HotCommitteeRole c
cred -> forall t. t -> Word -> Encode 'Open t
Sum forall c.
Credential 'HotCommitteeRole c -> CommitteeAuthorization c
CommitteeHotCredential Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'HotCommitteeRole c
cred
      CommitteeMemberResigned StrictMaybe (Anchor c)
anchor -> forall t. t -> Word -> Encode 'Open t
Sum forall c. StrictMaybe (Anchor c) -> CommitteeAuthorization c
CommitteeMemberResigned Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe (Anchor c)
anchor

instance Crypto c => DecCBOR (CommitteeAuthorization c) where
  decCBOR :: forall s. Decoder s (CommitteeAuthorization c)
decCBOR =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"CommitteeAuthorization" forall a b. (a -> b) -> a -> b
$ \case
      Word
0 -> forall t. t -> Decode 'Open t
SumD forall c.
Credential 'HotCommitteeRole c -> CommitteeAuthorization c
CommitteeHotCredential forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      Word
1 -> forall t. t -> Decode 'Open t
SumD forall c. StrictMaybe (Anchor c) -> CommitteeAuthorization c
CommitteeMemberResigned forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      Word
k -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
k

newtype CommitteeState era = CommitteeState
  { forall era.
CommitteeState era
-> Map
     (Credential 'ColdCommitteeRole (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds ::
      Map
        (Credential 'ColdCommitteeRole (EraCrypto era))
        (CommitteeAuthorization (EraCrypto era))
  }
  deriving (CommitteeState era -> CommitteeState era -> Bool
forall era. CommitteeState era -> CommitteeState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommitteeState era -> CommitteeState era -> Bool
$c/= :: forall era. CommitteeState era -> CommitteeState era -> Bool
== :: CommitteeState era -> CommitteeState era -> Bool
$c== :: forall era. CommitteeState era -> CommitteeState era -> Bool
Eq, CommitteeState era -> CommitteeState era -> Bool
CommitteeState era -> CommitteeState era -> Ordering
CommitteeState era -> CommitteeState era -> CommitteeState era
forall era. Eq (CommitteeState 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. CommitteeState era -> CommitteeState era -> Bool
forall era. CommitteeState era -> CommitteeState era -> Ordering
forall era.
CommitteeState era -> CommitteeState era -> CommitteeState era
min :: CommitteeState era -> CommitteeState era -> CommitteeState era
$cmin :: forall era.
CommitteeState era -> CommitteeState era -> CommitteeState era
max :: CommitteeState era -> CommitteeState era -> CommitteeState era
$cmax :: forall era.
CommitteeState era -> CommitteeState era -> CommitteeState era
>= :: CommitteeState era -> CommitteeState era -> Bool
$c>= :: forall era. CommitteeState era -> CommitteeState era -> Bool
> :: CommitteeState era -> CommitteeState era -> Bool
$c> :: forall era. CommitteeState era -> CommitteeState era -> Bool
<= :: CommitteeState era -> CommitteeState era -> Bool
$c<= :: forall era. CommitteeState era -> CommitteeState era -> Bool
< :: CommitteeState era -> CommitteeState era -> Bool
$c< :: forall era. CommitteeState era -> CommitteeState era -> Bool
compare :: CommitteeState era -> CommitteeState era -> Ordering
$ccompare :: forall era. CommitteeState era -> CommitteeState era -> Ordering
Ord, Int -> CommitteeState era -> ShowS
forall era. Int -> CommitteeState era -> ShowS
forall era. [CommitteeState era] -> ShowS
forall era. CommitteeState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommitteeState era] -> ShowS
$cshowList :: forall era. [CommitteeState era] -> ShowS
show :: CommitteeState era -> String
$cshow :: forall era. CommitteeState era -> String
showsPrec :: Int -> CommitteeState era -> ShowS
$cshowsPrec :: forall era. Int -> CommitteeState era -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CommitteeState era) x -> CommitteeState era
forall era x. CommitteeState era -> Rep (CommitteeState era) x
$cto :: forall era x. Rep (CommitteeState era) x -> CommitteeState era
$cfrom :: forall era x. CommitteeState era -> Rep (CommitteeState era) x
Generic)

-- | Extract all unique hot credential authorizations for the current committee.  Note
-- that there is no unique mapping from Hot to Cold credential, therefore we produce a
-- Set, instead of a Map.
authorizedHotCommitteeCredentials ::
  CommitteeState era -> Set.Set (Credential 'HotCommitteeRole (EraCrypto era))
authorizedHotCommitteeCredentials :: forall era.
CommitteeState era
-> Set (Credential 'HotCommitteeRole (EraCrypto era))
authorizedHotCommitteeCredentials CommitteeState {Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds :: Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds :: forall era.
CommitteeState era
-> Map
     (Credential 'ColdCommitteeRole (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds} =
  let toHotCredSet :: Set (Credential 'HotCommitteeRole c)
-> CommitteeAuthorization c -> Set (Credential 'HotCommitteeRole c)
toHotCredSet Set (Credential 'HotCommitteeRole c)
acc = \case
        CommitteeHotCredential Credential 'HotCommitteeRole c
hotCred -> forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'HotCommitteeRole c
hotCred Set (Credential 'HotCommitteeRole c)
acc
        CommitteeMemberResigned {} -> Set (Credential 'HotCommitteeRole c)
acc
   in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {c}.
Set (Credential 'HotCommitteeRole c)
-> CommitteeAuthorization c -> Set (Credential 'HotCommitteeRole c)
toHotCredSet forall a. Set a
Set.empty Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds

instance NoThunks (CommitteeState era)
instance Default (CommitteeState era)

instance Era era => NFData (CommitteeState era)

deriving newtype instance Era era => EncCBOR (CommitteeState era)

-- TODO: Implement sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
instance Era era => DecShareCBOR (CommitteeState era) where
  decShareCBOR :: forall s.
Share (CommitteeState era) -> Decoder s (CommitteeState era)
decShareCBOR Share (CommitteeState era)
_ = forall era.
Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
-> CommitteeState era
CommitteeState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

instance Era era => DecCBOR (CommitteeState era) where
  decCBOR :: forall s. Decoder s (CommitteeState era)
decCBOR = forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

deriving newtype instance Era era => ToJSON (CommitteeState era)

instance Era era => ToCBOR (CommitteeState era) where
  toCBOR :: CommitteeState era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

-- | The state that tracks the voting entities (DReps and Constitutional Committee members)
data VState era = VState
  { forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps ::
      !( Map
          (Credential 'DRepRole (EraCrypto era))
          (DRepState (EraCrypto era))
       )
  , forall era. VState era -> CommitteeState era
vsCommitteeState :: !(CommitteeState era)
  , forall era. VState era -> EpochNo
vsNumDormantEpochs :: EpochNo
  -- ^ Number of contiguous epochs in which there are exactly zero
  -- active governance proposals to vote on. It is incremented in every
  -- EPOCH rule if the number of active governance proposals to vote on
  -- continues to be zero. It is reset to zero when a new governance
  -- action is successfully proposed. We need this counter in order to
  -- bump DRep expiries through dormant periods when DReps do not have
  -- an opportunity to vote on anything.
  }
  deriving (Int -> VState era -> ShowS
forall era. Int -> VState era -> ShowS
forall era. [VState era] -> ShowS
forall era. VState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VState era] -> ShowS
$cshowList :: forall era. [VState era] -> ShowS
show :: VState era -> String
$cshow :: forall era. VState era -> String
showsPrec :: Int -> VState era -> ShowS
$cshowsPrec :: forall era. Int -> VState era -> ShowS
Show, VState era -> VState era -> Bool
forall era. VState era -> VState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VState era -> VState era -> Bool
$c/= :: forall era. VState era -> VState era -> Bool
== :: VState era -> VState era -> Bool
$c== :: forall era. VState era -> VState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (VState era) x -> VState era
forall era x. VState era -> Rep (VState era) x
$cto :: forall era x. Rep (VState era) x -> VState era
$cfrom :: forall era x. VState era -> Rep (VState era) x
Generic)

-- | Function that looks up the deposit for currently registered DRep
lookupDepositVState :: VState era -> Credential 'DRepRole (EraCrypto era) -> Maybe Coin
lookupDepositVState :: forall era.
VState era -> Credential 'DRepRole (EraCrypto era) -> Maybe Coin
lookupDepositVState VState era
vstate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. DRepState c -> Coin
drepDeposit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (VState era
vstate forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL)

instance Default (VState era) where
  def :: VState era
def = forall era.
Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> CommitteeState era -> EpochNo -> VState era
VState forall a. Default a => a
def forall a. Default a => a
def (Word64 -> EpochNo
EpochNo Word64
0)

instance Typeable (EraCrypto era) => NoThunks (VState era)

instance Era era => NFData (VState era)

-- TODO: Implement sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
instance Era era => DecShareCBOR (VState era) where
  decShareCBOR :: forall s. Share (VState era) -> Decoder s (VState era)
decShareCBOR Share (VState era)
_ =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Decode ('Closed 'Dense) t
RecD forall era.
Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> CommitteeState era -> EpochNo -> VState era
VState
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance Era era => DecCBOR (VState era) where
  decCBOR :: forall s. Decoder s (VState era)
decCBOR = forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

instance Era era => EncCBOR (VState era) where
  encCBOR :: VState era -> Encoding
encCBOR VState {Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
EpochNo
CommitteeState era
vsNumDormantEpochs :: EpochNo
vsCommitteeState :: CommitteeState era
vsDReps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsNumDormantEpochs :: forall era. VState era -> EpochNo
vsCommitteeState :: forall era. VState era -> CommitteeState era
vsDReps :: forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
..} =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec (forall era.
Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> CommitteeState era -> EpochNo -> VState era
VState @era)
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To CommitteeState era
vsCommitteeState
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
vsNumDormantEpochs

-- | The state associated with the DELPL rule, which combines the DELEG rule
-- and the POOL rule.
data CertState era = CertState
  { forall era. CertState era -> VState era
certVState :: !(VState era)
  , forall era. CertState era -> PState era
certPState :: !(PState era)
  , forall era. CertState era -> DState era
certDState :: !(DState era)
  }
  deriving (Int -> CertState era -> ShowS
forall era. Int -> CertState era -> ShowS
forall era. [CertState era] -> ShowS
forall era. CertState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertState era] -> ShowS
$cshowList :: forall era. [CertState era] -> ShowS
show :: CertState era -> String
$cshow :: forall era. CertState era -> String
showsPrec :: Int -> CertState era -> ShowS
$cshowsPrec :: forall era. Int -> CertState era -> ShowS
Show, CertState era -> CertState era -> Bool
forall era. CertState era -> CertState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertState era -> CertState era -> Bool
$c/= :: forall era. CertState era -> CertState era -> Bool
== :: CertState era -> CertState era -> Bool
$c== :: forall era. CertState era -> CertState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CertState era) x -> CertState era
forall era x. CertState era -> Rep (CertState era) x
$cto :: forall era x. Rep (CertState era) x -> CertState era
$cfrom :: forall era x. CertState era -> Rep (CertState era) x
Generic)

instance Typeable (EraCrypto era) => NoThunks (CertState era)

instance Era era => NFData (CertState era)

instance Crypto c => EncCBOR (InstantaneousRewards c) where
  encCBOR :: InstantaneousRewards c -> Encoding
encCBOR (InstantaneousRewards Map (Credential 'Staking c) Coin
irR Map (Credential 'Staking c) Coin
irT DeltaCoin
dR DeltaCoin
dT) =
    Word -> Encoding
encodeListLen Word
4 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (Credential 'Staking c) Coin
irR forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (Credential 'Staking c) Coin
irT forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR DeltaCoin
dR forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR DeltaCoin
dT

instance Crypto c => DecShareCBOR (InstantaneousRewards c) where
  type Share (InstantaneousRewards c) = Interns (Credential 'Staking c)
  decSharePlusCBOR :: forall s.
StateT
  (Share (InstantaneousRewards c))
  (Decoder s)
  (InstantaneousRewards c)
decSharePlusCBOR =
    forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"InstantaneousRewards" (forall a b. a -> b -> a
const Int
4) forall a b. (a -> b) -> a -> b
$ do
      Map (Credential 'Staking c) Coin
irR <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
      Map (Credential 'Staking c) Coin
irT <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
      DeltaCoin
dR <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecCBOR a => Decoder s a
decCBOR
      DeltaCoin
dT <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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
$ forall c.
Map (Credential 'Staking c) Coin
-> Map (Credential 'Staking c) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards c
InstantaneousRewards Map (Credential 'Staking c) Coin
irR Map (Credential 'Staking c) Coin
irT DeltaCoin
dR DeltaCoin
dT

instance Era era => EncCBOR (CertState era) where
  encCBOR :: CertState era -> Encoding
encCBOR CertState {PState era
certPState :: PState era
certPState :: forall era. CertState era -> PState era
certPState, DState era
certDState :: DState era
certDState :: forall era. CertState era -> DState era
certDState, VState era
certVState :: VState era
certVState :: forall era. CertState era -> VState era
certVState} =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VState era
certVState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR PState era
certPState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR DState era
certDState

instance Era era => DecShareCBOR (CertState era) where
  type
    Share (CertState era) =
      (Interns (Credential 'Staking (EraCrypto era)), Interns (KeyHash 'StakePool (EraCrypto era)))
  decSharePlusCBOR :: forall s.
StateT (Share (CertState era)) (Decoder s) (CertState era)
decSharePlusCBOR = forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"CertState" (forall a b. a -> b -> a
const Int
3) forall a b. (a -> b) -> a -> b
$ do
    VState era
certVState <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR -- TODO: add sharing of DRep credentials
    PState era
certPState <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall s t a b. Field2 s t a b => Lens s t a b
_2
    DState era
certDState <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    forall (f :: * -> *) a. Applicative f => a -> f a
pure CertState {PState era
certPState :: PState era
certPState :: PState era
certPState, DState era
certDState :: DState era
certDState :: DState era
certDState, VState era
certVState :: VState era
certVState :: VState era
certVState}

instance Default (CertState era) where
  def :: CertState era
def = forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def forall a. Default a => a
def forall a. Default a => a
def

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

toCertStatePairs :: (KeyValue e a, Era era) => CertState era -> [a]
toCertStatePairs :: forall e a era. (KeyValue e a, Era era) => CertState era -> [a]
toCertStatePairs CertState {VState era
PState era
DState era
certDState :: DState era
certPState :: PState era
certVState :: VState era
certDState :: forall era. CertState era -> DState era
certPState :: forall era. CertState era -> PState era
certVState :: forall era. CertState era -> VState era
..} =
  [ Key
"dstate" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DState era
certDState
  , Key
"pstate" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PState era
certPState
  ]

instance Default (InstantaneousRewards c) where
  def :: InstantaneousRewards c
def = forall c.
Map (Credential 'Staking c) Coin
-> Map (Credential 'Staking c) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards c
InstantaneousRewards forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance Default (DState era) where
  def :: DState era
def =
    forall era.
UMap (EraCrypto era)
-> Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> GenDelegs (EraCrypto era)
-> InstantaneousRewards (EraCrypto era)
-> DState era
DState
      forall c. UMap c
UM.empty
      forall k a. Map k a
Map.empty
      (forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs forall k a. Map k a
Map.empty)
      forall a. Default a => a
def

instance Default (PState c) where
  def :: PState c
def =
    forall era.
Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
-> Map (KeyHash 'StakePool (EraCrypto era)) Coin
-> PState era
PState forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

rewards :: DState era -> UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards :: forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards = forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap (EraCrypto era)
dsUnified

delegations ::
  DState era ->
  UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era))
delegations :: forall era.
DState era
-> UView
     (EraCrypto era)
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
delegations = forall c.
UMap c -> UView c (Credential 'Staking c) (KeyHash 'StakePool c)
SPoolUView forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap (EraCrypto era)
dsUnified

-- | get the actual ptrs map, we don't need a view
ptrsMap :: DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap :: forall era.
DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap (DState {dsUnified :: forall era. DState era -> UMap (EraCrypto era)
dsUnified = UMap Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
_ Map Ptr (Credential 'Staking (EraCrypto era))
ptrmap}) = Map Ptr (Credential 'Staking (EraCrypto era))
ptrmap

-- ==========================================================
-- Functions that handle Deposits

-- | One only pays a deposit on the initial pool registration. So return the
--   the Deposits unchanged if the keyhash already exists. There are legal
--   situations where a pool may be registered multiple times.
payPoolDeposit ::
  EraPParams era =>
  KeyHash 'StakePool (EraCrypto era) ->
  PParams era ->
  PState era ->
  PState era
payPoolDeposit :: forall era.
EraPParams era =>
KeyHash 'StakePool (EraCrypto era)
-> PParams era -> PState era -> PState era
payPoolDeposit KeyHash 'StakePool (EraCrypto era)
keyhash PParams era
pp PState era
pstate = PState era
pstate {psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits = Map (KeyHash 'StakePool (EraCrypto era)) Coin
newpool}
  where
    pool :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool = forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits PState era
pstate
    !deposit :: Coin
deposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL
    newpool :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
newpool
      | forall k a. Ord k => k -> Map k a -> Bool
Map.notMember KeyHash 'StakePool (EraCrypto era)
keyhash Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool (EraCrypto era)
keyhash Coin
deposit Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool
      | Bool
otherwise = Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool

refundPoolDeposit :: KeyHash 'StakePool (EraCrypto era) -> PState era -> (Coin, PState era)
refundPoolDeposit :: forall era.
KeyHash 'StakePool (EraCrypto era)
-> PState era -> (Coin, PState era)
refundPoolDeposit KeyHash 'StakePool (EraCrypto era)
keyhash PState era
pstate = (Coin
coin, PState era
pstate {psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits = Map (KeyHash 'StakePool (EraCrypto era)) Coin
newpool})
  where
    pool :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool = forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits PState era
pstate
    (Coin
coin, Map (KeyHash 'StakePool (EraCrypto era)) Coin
newpool) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
keyhash Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool of
      Just Coin
c -> (Coin
c, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool (EraCrypto era)
keyhash Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool)
      Maybe Coin
Nothing -> (forall a. Monoid a => a
mempty, Map (KeyHash 'StakePool (EraCrypto era)) Coin
pool)

-- | A composite of all the Deposits the system is obligated to eventually pay back.
data Obligations = Obligations
  { Obligations -> Coin
oblStake :: !Coin
  , Obligations -> Coin
oblPool :: !Coin
  , Obligations -> Coin
oblDRep :: !Coin
  , Obligations -> Coin
oblProposal :: !Coin
  }
  deriving (Obligations -> Obligations -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Obligations -> Obligations -> Bool
$c/= :: Obligations -> Obligations -> Bool
== :: Obligations -> Obligations -> Bool
$c== :: Obligations -> Obligations -> Bool
Eq, Eq Obligations
Obligations -> Obligations -> Bool
Obligations -> Obligations -> Ordering
Obligations -> Obligations -> Obligations
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
min :: Obligations -> Obligations -> Obligations
$cmin :: Obligations -> Obligations -> Obligations
max :: Obligations -> Obligations -> Obligations
$cmax :: Obligations -> Obligations -> Obligations
>= :: Obligations -> Obligations -> Bool
$c>= :: Obligations -> Obligations -> Bool
> :: Obligations -> Obligations -> Bool
$c> :: Obligations -> Obligations -> Bool
<= :: Obligations -> Obligations -> Bool
$c<= :: Obligations -> Obligations -> Bool
< :: Obligations -> Obligations -> Bool
$c< :: Obligations -> Obligations -> Bool
compare :: Obligations -> Obligations -> Ordering
$ccompare :: Obligations -> Obligations -> Ordering
Ord, forall x. Rep Obligations x -> Obligations
forall x. Obligations -> Rep Obligations x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Obligations x -> Obligations
$cfrom :: forall x. Obligations -> Rep Obligations x
Generic)

instance NFData Obligations

-- | Calculate total possible refunds in the system that are related to certificates
--
-- There is an invariant that the sum of all the fields should be the same as the
-- utxosDeposited field of the UTxOState. Note that this does not depend upon the current
-- values of the Key and Pool deposits of the PParams.
obligationCertState :: CertState era -> Obligations
obligationCertState :: forall era. CertState era -> Obligations
obligationCertState (CertState VState {Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps :: forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps} PState {Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits :: forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits} DState {UMap (EraCrypto era)
dsUnified :: UMap (EraCrypto era)
dsUnified :: forall era. DState era -> UMap (EraCrypto era)
dsUnified}) =
  let accum :: Coin -> DRepState c -> Coin
accum Coin
ans DRepState c
drepState = Coin
ans forall a. Semigroup a => a -> a -> a
<> forall c. DRepState c -> Coin
drepDeposit DRepState c
drepState
   in Obligations
        { oblStake :: Coin
oblStake = forall a. Compactible a => CompactForm a -> a
UM.fromCompact (forall c k. UView c k RDPair -> CompactForm Coin
UM.sumDepositUView (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
dsUnified))
        , oblPool :: Coin
oblPool = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall a. Semigroup a => a -> a -> a
(<>) (Integer -> Coin
Coin Integer
0) Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits
        , oblDRep :: Coin
oblDRep = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {c}. Coin -> DRepState c -> Coin
accum (Integer -> Coin
Coin Integer
0) Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps
        , oblProposal :: Coin
oblProposal = Integer -> Coin
Coin Integer
0
        }

sumObligation :: Obligations -> Coin
sumObligation :: Obligations -> Coin
sumObligation Obligations
x = Obligations -> Coin
oblStake Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblPool Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblDRep Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblProposal Obligations
x

instance Semigroup Obligations where
  Obligations
x <> :: Obligations -> Obligations -> Obligations
<> Obligations
y =
    Obligations
      { oblStake :: Coin
oblStake = Obligations -> Coin
oblStake Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblStake Obligations
y
      , oblPool :: Coin
oblPool = Obligations -> Coin
oblPool Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblPool Obligations
y
      , oblDRep :: Coin
oblDRep = Obligations -> Coin
oblDRep Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblDRep Obligations
y
      , oblProposal :: Coin
oblProposal = Obligations -> Coin
oblProposal Obligations
x forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
oblProposal Obligations
y
      }

instance Monoid Obligations where
  mempty :: Obligations
mempty = Obligations {oblStake :: Coin
oblStake = Integer -> Coin
Coin Integer
0, oblPool :: Coin
oblPool = Integer -> Coin
Coin Integer
0, oblDRep :: Coin
oblDRep = Integer -> Coin
Coin Integer
0, oblProposal :: Coin
oblProposal = Integer -> Coin
Coin Integer
0}

instance Show Obligations where
  show :: Obligations -> String
show Obligations
x =
    Context -> String
unlines
      [ String
"Total Obligations = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Obligations -> Coin
sumObligation Obligations
x)
      , String
"   Stake deposits = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Obligations -> Coin
oblStake Obligations
x)
      , String
"   Pool deposits = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Obligations -> Coin
oblPool Obligations
x)
      , String
"   DRep deposits = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Obligations -> Coin
oblDRep Obligations
x)
      , String
"   Proposal deposits = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Obligations -> Coin
oblProposal Obligations
x)
      ]

-- | Compute the total deposits from the Certs of a TxBody.
--
-- This is the contribution of a TxBody towards the deposit pot (utxosDeposit field of
-- the UTxOState) of the system
certsTotalDepositsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody era -> Coin
certsTotalDepositsTxBody :: forall era.
EraTxBody era =>
PParams era -> CertState era -> TxBody era -> Coin
certsTotalDepositsTxBody PParams era
pp CertState {PState era
certPState :: PState era
certPState :: forall era. CertState era -> PState era
certPState} =
  forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Coin
getTotalDepositsTxBody PParams era
pp (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams PState era
certPState)

-- | Compute the total refunds from the Certs of a TxBody.
--
-- This is the contribution of a TxBody towards the total 'Obligations' of the system
-- See `Obligations` and `obligationCertState` for more information.
certsTotalRefundsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody era -> Coin
certsTotalRefundsTxBody :: forall era.
EraTxBody era =>
PParams era -> CertState era -> TxBody era -> Coin
certsTotalRefundsTxBody PParams era
pp CertState {DState era
certDState :: DState era
certDState :: forall era. CertState era -> DState era
certDState, VState era
certVState :: VState era
certVState :: forall era. CertState era -> VState era
certVState} =
  forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking (EraCrypto era) -> Maybe Coin)
-> (Credential 'DRepRole (EraCrypto era) -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp (forall era.
DState era -> StakeCredential (EraCrypto era) -> Maybe Coin
lookupDepositDState DState era
certDState) (forall era.
VState era -> Credential 'DRepRole (EraCrypto era) -> Maybe Coin
lookupDepositVState VState era
certVState)

-- =======================================================
-- Lenses for CertState and its subsidiary types

-- ========================================
-- CertState

certDStateL :: Lens' (CertState era) (DState era)
certDStateL :: forall era. Lens' (CertState era) (DState era)
certDStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. CertState era -> DState era
certDState (\CertState era
ds DState era
u -> CertState era
ds {certDState :: DState era
certDState = DState era
u})

certPStateL :: Lens' (CertState era) (PState era)
certPStateL :: forall era. Lens' (CertState era) (PState era)
certPStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. CertState era -> PState era
certPState (\CertState era
ds PState era
u -> CertState era
ds {certPState :: PState era
certPState = PState era
u})

certVStateL :: Lens' (CertState era) (VState era)
certVStateL :: forall era. Lens' (CertState era) (VState era)
certVStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. CertState era -> VState era
certVState (\CertState era
ds VState era
u -> CertState era
ds {certVState :: VState era
certVState = VState era
u})

-- ===================================
-- DState

dsUnifiedL :: Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL :: forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. DState era -> UMap (EraCrypto era)
dsUnified (\DState era
ds UMap (EraCrypto era)
u -> DState era
ds {dsUnified :: UMap (EraCrypto era)
dsUnified = UMap (EraCrypto era)
u})

dsGenDelegsL :: Lens' (DState era) (GenDelegs (EraCrypto era))
dsGenDelegsL :: forall era. Lens' (DState era) (GenDelegs (EraCrypto era))
dsGenDelegsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs (\DState era
ds GenDelegs (EraCrypto era)
u -> DState era
ds {dsGenDelegs :: GenDelegs (EraCrypto era)
dsGenDelegs = GenDelegs (EraCrypto era)
u})

dsIRewardsL :: Lens' (DState era) (InstantaneousRewards (EraCrypto era))
dsIRewardsL :: forall era.
Lens' (DState era) (InstantaneousRewards (EraCrypto era))
dsIRewardsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. DState era -> InstantaneousRewards (EraCrypto era)
dsIRewards (\DState era
ds InstantaneousRewards (EraCrypto era)
u -> DState era
ds {dsIRewards :: InstantaneousRewards (EraCrypto era)
dsIRewards = InstantaneousRewards (EraCrypto era)
u})

dsFutureGenDelegsL ::
  Lens' (DState era) (Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era)))
dsFutureGenDelegsL :: forall era.
Lens'
  (DState era)
  (Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era)))
dsFutureGenDelegsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
DState era
-> Map
     (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsFutureGenDelegs (\DState era
ds Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
u -> DState era
ds {dsFutureGenDelegs :: Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
dsFutureGenDelegs = Map (FutureGenDeleg (EraCrypto era)) (GenDelegPair (EraCrypto era))
u})

-- ===================================
-- PState

psStakePoolParamsL ::
  Lens' (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psStakePoolParamsL :: forall era.
Lens'
  (PState era)
  (Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psStakePoolParamsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams (\PState era
ds Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
u -> PState era
ds {psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
u})

psFutureStakePoolParamsL ::
  Lens' (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psFutureStakePoolParamsL :: forall era.
Lens'
  (PState era)
  (Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psFutureStakePoolParamsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams (\PState era
ds Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
u -> PState era
ds {psFutureStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams = Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
u})

psRetiringL :: Lens' (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) EpochNo)
psRetiringL :: forall era.
Lens'
  (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) EpochNo)
psRetiringL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring (\PState era
ds Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
u -> PState era
ds {psRetiring :: Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
psRetiring = Map (KeyHash 'StakePool (EraCrypto era)) EpochNo
u})

psDepositsL :: Lens' (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) Coin)
psDepositsL :: forall era.
Lens' (PState era) (Map (KeyHash 'StakePool (EraCrypto era)) Coin)
psDepositsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
PState era -> Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits (\PState era
ds Map (KeyHash 'StakePool (EraCrypto era)) Coin
u -> PState era
ds {psDeposits :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
psDeposits = Map (KeyHash 'StakePool (EraCrypto era)) Coin
u})

-- ===================================
-- VState

vsDRepsL ::
  Lens' (VState era) (Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL :: forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps (\VState era
vs Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
u -> VState era
vs {vsDReps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps = Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
u})

vsCommitteeStateL :: Lens' (VState era) (CommitteeState era)
vsCommitteeStateL :: forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> CommitteeState era
vsCommitteeState (\VState era
vs CommitteeState era
u -> VState era
vs {vsCommitteeState :: CommitteeState era
vsCommitteeState = CommitteeState era
u})

vsNumDormantEpochsL :: Lens' (VState era) EpochNo
vsNumDormantEpochsL :: forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> EpochNo
vsNumDormantEpochs (\VState era
vs EpochNo
u -> VState era
vs {vsNumDormantEpochs :: EpochNo
vsNumDormantEpochs = EpochNo
u})

vsActualDRepExpiry :: Credential 'DRepRole (EraCrypto era) -> VState era -> Maybe EpochNo
vsActualDRepExpiry :: forall era.
Credential 'DRepRole (EraCrypto era) -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential 'DRepRole (EraCrypto era)
cred VState era
vs =
  (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo forall a. Num a => a -> a -> a
(+) (forall era. VState era -> EpochNo
vsNumDormantEpochs VState era
vs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. DRepState c -> EpochNo
drepExpiry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
cred (forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps VState era
vs)

csCommitteeCredsL ::
  Lens'
    (CommitteeState era)
    ( Map
        (Credential 'ColdCommitteeRole (EraCrypto era))
        (CommitteeAuthorization (EraCrypto era))
    )
csCommitteeCredsL :: forall era.
Lens'
  (CommitteeState era)
  (Map
     (Credential 'ColdCommitteeRole (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era)))
csCommitteeCredsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
CommitteeState era
-> Map
     (Credential 'ColdCommitteeRole (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds (\CommitteeState era
cs Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
u -> CommitteeState era
cs {csCommitteeCreds :: Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds = Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
u})