{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# 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.DRep (DRep (..), DRepState (..))
import Cardano.Ledger.Hashes (GenDelegPair (..), GenDelegs (..))
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 (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 GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (^.), _1, _2)
import NoThunks.Class (NoThunks (..))

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

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

instance NoThunks FutureGenDeleg

instance NFData FutureGenDeleg

instance EncCBOR FutureGenDeleg where
  encCBOR :: FutureGenDeleg -> Encoding
encCBOR (FutureGenDeleg SlotNo
a KeyHash 'Genesis
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
b

instance DecCBOR FutureGenDeleg where
  decCBOR :: forall s. Decoder s FutureGenDeleg
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
$
      SlotNo -> KeyHash 'Genesis -> FutureGenDeleg
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 ToJSON FutureGenDeleg where
  toJSON :: FutureGenDeleg -> Value
toJSON FutureGenDeleg
fGenDeleg =
    [Pair] -> Value
object
      [ Key
"fGenDelegSlot" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FutureGenDeleg -> SlotNo
fGenDelegSlot FutureGenDeleg
fGenDeleg
      , Key
"fGenDelegGenKeyHash" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FutureGenDeleg -> KeyHash 'Genesis
fGenDelegGenKeyHash FutureGenDeleg
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 = InstantaneousRewards
  { InstantaneousRewards -> Map (Credential 'Staking) Coin
iRReserves :: !(Map (Credential 'Staking) Coin)
  , InstantaneousRewards -> Map (Credential 'Staking) Coin
iRTreasury :: !(Map (Credential 'Staking) Coin)
  , InstantaneousRewards -> DeltaCoin
deltaReserves :: !DeltaCoin
  , InstantaneousRewards -> DeltaCoin
deltaTreasury :: !DeltaCoin
  }
  deriving (Int -> InstantaneousRewards -> ShowS
[InstantaneousRewards] -> ShowS
InstantaneousRewards -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantaneousRewards] -> ShowS
$cshowList :: [InstantaneousRewards] -> ShowS
show :: InstantaneousRewards -> String
$cshow :: InstantaneousRewards -> String
showsPrec :: Int -> InstantaneousRewards -> ShowS
$cshowsPrec :: Int -> InstantaneousRewards -> ShowS
Show, InstantaneousRewards -> InstantaneousRewards -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstantaneousRewards -> InstantaneousRewards -> Bool
$c/= :: InstantaneousRewards -> InstantaneousRewards -> Bool
== :: InstantaneousRewards -> InstantaneousRewards -> Bool
$c== :: InstantaneousRewards -> InstantaneousRewards -> Bool
Eq, forall x. Rep InstantaneousRewards x -> InstantaneousRewards
forall x. InstantaneousRewards -> Rep InstantaneousRewards x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InstantaneousRewards x -> InstantaneousRewards
$cfrom :: forall x. InstantaneousRewards -> Rep InstantaneousRewards x
Generic)

instance NoThunks InstantaneousRewards

instance NFData InstantaneousRewards

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

toInstantaneousRewardsPair :: KeyValue e a => InstantaneousRewards -> [a]
toInstantaneousRewardsPair :: forall e a. KeyValue e a => InstantaneousRewards -> [a]
toInstantaneousRewardsPair InstantaneousRewards {Map (Credential 'Staking) Coin
DeltaCoin
deltaTreasury :: DeltaCoin
deltaReserves :: DeltaCoin
iRTreasury :: Map (Credential 'Staking) Coin
iRReserves :: Map (Credential 'Staking) Coin
deltaTreasury :: InstantaneousRewards -> DeltaCoin
deltaReserves :: InstantaneousRewards -> DeltaCoin
iRTreasury :: InstantaneousRewards -> Map (Credential 'Staking) Coin
iRReserves :: InstantaneousRewards -> Map (Credential 'Staking) Coin
..} =
  [ Key
"iRReserves" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'Staking) Coin
iRReserves
  , Key
"iRTreasury" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'Staking) 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
dsUnified :: !UMap
  -- ^ 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 GenDelegPair
dsFutureGenDelegs :: !(Map FutureGenDeleg GenDelegPair)
  -- ^ Future genesis key delegations
  , forall era. DState era -> GenDelegs
dsGenDelegs :: !GenDelegs
  -- ^ Genesis key delegations
  , forall era. DState era -> InstantaneousRewards
dsIRewards :: !InstantaneousRewards
  -- ^ 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 (DState era) where
  encCBOR :: DState era -> Encoding
encCBOR (DState UMap
unified Map FutureGenDeleg GenDelegPair
fgs GenDelegs
gs InstantaneousRewards
ir) =
    Word -> Encoding
encodeListLen Word
4
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR UMap
unified
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map FutureGenDeleg GenDelegPair
fgs
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR GenDelegs
gs
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR InstantaneousRewards
ir

instance DecShareCBOR (DState era) where
  type Share (DState era) = (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
  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
unified <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
      Map FutureGenDeleg GenDelegPair
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
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
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
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState UMap
unified Map FutureGenDeleg GenDelegPair
fgs GenDelegs
gs InstantaneousRewards
ir

instance 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 => 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 => DState era -> [a]
toDStatePair

toDStatePair :: KeyValue e a => DState era -> [a]
toDStatePair :: forall e a era. KeyValue e a => DState era -> [a]
toDStatePair DState {Map FutureGenDeleg GenDelegPair
GenDelegs
UMap
InstantaneousRewards
dsIRewards :: InstantaneousRewards
dsGenDelegs :: GenDelegs
dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsUnified :: UMap
dsIRewards :: forall era. DState era -> InstantaneousRewards
dsGenDelegs :: forall era. DState era -> GenDelegs
dsFutureGenDelegs :: forall era. DState era -> Map FutureGenDeleg GenDelegPair
dsUnified :: forall era. DState era -> UMap
..} =
  [ Key
"unified" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UMap
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 GenDelegPair
dsFutureGenDelegs
  , Key
"genDelegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GenDelegs
dsGenDelegs
  , Key
"irwd" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= InstantaneousRewards
dsIRewards
  ]

-- | Function that looks up the deposit for currently delegated staking credential
lookupDepositDState :: DState era -> (StakeCredential -> Maybe Coin)
lookupDepositDState :: forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState DState era
dstate =
  let currentRewardDeposits :: UView (Credential 'Staking) RDPair
currentRewardDeposits = UMap -> UView (Credential 'Staking) RDPair
RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap
dsUnified DState era
dstate
   in \Credential 'Staking
k -> do
        RDPair CompactForm Coin
_ CompactForm Coin
deposit <- forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
k UView (Credential 'Staking) 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 -> Maybe Coin)
lookupRewardDState :: forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupRewardDState DState era
dstate =
  let currentRewardDeposits :: UView (Credential 'Staking) RDPair
currentRewardDeposits = UMap -> UView (Credential 'Staking) RDPair
RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap
dsUnified DState era
dstate
   in \Credential 'Staking
k -> do
        RDPair CompactForm Coin
reward CompactForm Coin
_ <- forall k v. k -> UView k v -> Maybe v
UM.lookup Credential 'Staking
k UView (Credential 'Staking) 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) PoolParams
psStakePoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  -- ^ The stake pool parameters.
  , forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  -- ^ 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) EpochNo
psRetiring :: !(Map (KeyHash 'StakePool) EpochNo)
  -- ^ A map of retiring stake pools to the epoch when they retire.
  , forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits :: !(Map (KeyHash 'StakePool) 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) PoolParams
a Map (KeyHash 'StakePool) PoolParams
b Map (KeyHash 'StakePool) EpochNo
c Map (KeyHash 'StakePool) Coin
d) =
    Word -> Encoding
encodeListLen Word
4 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool) PoolParams
a forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool) PoolParams
b forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool) EpochNo
c forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool) Coin
d

instance DecShareCBOR (PState era) where
  type Share (PState era) = Interns (KeyHash 'StakePool)
  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) PoolParams
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) PoolParams
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) 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) 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) PoolParams
psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams, Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams, Map (KeyHash 'StakePool) EpochNo
psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring, Map (KeyHash 'StakePool) Coin
psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits :: Map (KeyHash 'StakePool) 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 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 => 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 => PState era -> [a]
toPStatePair

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

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

instance NoThunks CommitteeAuthorization
instance NFData CommitteeAuthorization
instance ToJSON CommitteeAuthorization

instance EncCBOR CommitteeAuthorization where
  encCBOR :: CommitteeAuthorization -> 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
cred -> forall t. t -> Word -> Encode 'Open t
Sum Credential 'HotCommitteeRole -> CommitteeAuthorization
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
cred
      CommitteeMemberResigned StrictMaybe Anchor
anchor -> forall t. t -> Word -> Encode 'Open t
Sum StrictMaybe Anchor -> CommitteeAuthorization
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
anchor

instance DecCBOR CommitteeAuthorization where
  decCBOR :: forall s. Decoder s CommitteeAuthorization
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 Credential 'HotCommitteeRole -> CommitteeAuthorization
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 StrictMaybe Anchor -> CommitteeAuthorization
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) CommitteeAuthorization
csCommitteeCreds :: Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
  }
  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, CommitteeState era -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [CommitteeState era] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (CommitteeState era) -> Size
forall {era}. Typeable era => Typeable (CommitteeState era)
forall era. Typeable era => CommitteeState era -> Encoding
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [CommitteeState era] -> Size
forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (CommitteeState era) -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [CommitteeState era] -> Size
$cencodedListSizeExpr :: forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [CommitteeState era] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (CommitteeState era) -> Size
$cencodedSizeExpr :: forall era.
Typeable era =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (CommitteeState era) -> Size
encCBOR :: CommitteeState era -> Encoding
$cencCBOR :: forall era. Typeable era => CommitteeState era -> Encoding
EncCBOR, CommitteeState era -> ()
forall era. CommitteeState era -> ()
forall a. (a -> ()) -> NFData a
rnf :: CommitteeState era -> ()
$crnf :: forall era. CommitteeState era -> ()
NFData, CommitteeState era
forall era. CommitteeState era
forall a. a -> Default a
def :: CommitteeState era
$cdef :: forall era. CommitteeState era
Default, Context -> CommitteeState era -> IO (Maybe ThunkInfo)
Proxy (CommitteeState era) -> String
forall era. Context -> CommitteeState era -> IO (Maybe ThunkInfo)
forall era. Proxy (CommitteeState era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (CommitteeState era) -> String
$cshowTypeOf :: forall era. Proxy (CommitteeState era) -> String
wNoThunks :: Context -> CommitteeState era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era. Context -> CommitteeState era -> IO (Maybe ThunkInfo)
noThunks :: Context -> CommitteeState era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era. Context -> CommitteeState era -> IO (Maybe ThunkInfo)
NoThunks)

instance ToJSON (CommitteeState era)

-- | 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)
authorizedHotCommitteeCredentials :: forall era.
CommitteeState era -> Set (Credential 'HotCommitteeRole)
authorizedHotCommitteeCredentials CommitteeState {Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds :: Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds :: forall era.
CommitteeState era
-> Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds} =
  let toHotCredSet :: Set (Credential 'HotCommitteeRole)
-> CommitteeAuthorization -> Set (Credential 'HotCommitteeRole)
toHotCredSet Set (Credential 'HotCommitteeRole)
acc = \case
        CommitteeHotCredential Credential 'HotCommitteeRole
hotCred -> forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'HotCommitteeRole
hotCred Set (Credential 'HotCommitteeRole)
acc
        CommitteeMemberResigned {} -> Set (Credential 'HotCommitteeRole)
acc
   in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Set (Credential 'HotCommitteeRole)
-> CommitteeAuthorization -> Set (Credential 'HotCommitteeRole)
toHotCredSet forall a. Set a
Set.empty Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds

-- 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) CommitteeAuthorization
-> 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

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). In the formal ledger specification this type is called @GState@
data VState era = VState
  { forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps :: !(Map (Credential 'DRepRole) DRepState)
  , 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 -> Maybe Coin
lookupDepositVState :: forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState VState era
vstate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DRepState -> 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) DRepState)
vsDRepsL)

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

instance NoThunks (VState era)

instance 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) DRepState
-> 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) DRepState
EpochNo
CommitteeState era
vsNumDormantEpochs :: EpochNo
vsCommitteeState :: CommitteeState era
vsDReps :: Map (Credential 'DRepRole) DRepState
vsNumDormantEpochs :: forall era. VState era -> EpochNo
vsCommitteeState :: forall era. VState era -> CommitteeState era
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
..} =
    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) DRepState
-> 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) DRepState
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 NoThunks (CertState era)

instance NFData (CertState era)

instance EncCBOR InstantaneousRewards where
  encCBOR :: InstantaneousRewards -> Encoding
encCBOR (InstantaneousRewards Map (Credential 'Staking) Coin
irR Map (Credential 'Staking) 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) Coin
irR forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (Credential 'Staking) 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 DecShareCBOR InstantaneousRewards where
  type Share InstantaneousRewards = Interns (Credential 'Staking)
  decSharePlusCBOR :: forall s.
StateT
  (Share InstantaneousRewards) (Decoder s) InstantaneousRewards
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) 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) 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
$ Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards
InstantaneousRewards Map (Credential 'Staking) Coin
irR Map (Credential 'Staking) 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), Interns (KeyHash 'StakePool))
  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 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 => 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 => CertState era -> [a]
toCertStatePairs

toCertStatePairs :: KeyValue e a => CertState era -> [a]
toCertStatePairs :: forall e a era. KeyValue e a => 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 where
  def :: InstantaneousRewards
def = Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards
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
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState
      UMap
UM.empty
      forall k a. Map k a
Map.empty
      (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs forall k a. Map k a
Map.empty)
      forall a. Default a => a
def

instance Default (PState era) where
  def :: PState era
def =
    forall era.
Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) 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 (Credential 'Staking) RDPair
rewards :: forall era. DState era -> UView (Credential 'Staking) RDPair
rewards = UMap -> UView (Credential 'Staking) RDPair
RewDepUView forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap
dsUnified

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

-- | get the actual ptrs map, we don't need a view
ptrsMap :: DState era -> Map Ptr (Credential 'Staking)
ptrsMap :: forall era. DState era -> Map Ptr (Credential 'Staking)
ptrsMap (DState {dsUnified :: forall era. DState era -> UMap
dsUnified = UMap Map (Credential 'Staking) UMElem
_ Map Ptr (Credential 'Staking)
ptrmap}) = Map Ptr (Credential 'Staking)
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 ->
  PParams era ->
  PState era ->
  PState era
payPoolDeposit :: forall era.
EraPParams era =>
KeyHash 'StakePool -> PParams era -> PState era -> PState era
payPoolDeposit KeyHash 'StakePool
keyhash PParams era
pp PState era
pstate = PState era
pstate {psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = Map (KeyHash 'StakePool) Coin
newpool}
  where
    pool :: Map (KeyHash 'StakePool) Coin
pool = forall era. PState era -> Map (KeyHash 'StakePool) 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) Coin
newpool
      | forall k a. Ord k => k -> Map k a -> Bool
Map.notMember KeyHash 'StakePool
keyhash Map (KeyHash 'StakePool) Coin
pool = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
keyhash Coin
deposit Map (KeyHash 'StakePool) Coin
pool
      | Bool
otherwise = Map (KeyHash 'StakePool) Coin
pool

refundPoolDeposit :: KeyHash 'StakePool -> PState era -> (Coin, PState era)
refundPoolDeposit :: forall era. KeyHash 'StakePool -> PState era -> (Coin, PState era)
refundPoolDeposit KeyHash 'StakePool
keyhash PState era
pstate = (Coin
coin, PState era
pstate {psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = Map (KeyHash 'StakePool) Coin
newpool})
  where
    pool :: Map (KeyHash 'StakePool) Coin
pool = forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits PState era
pstate
    (Coin
coin, Map (KeyHash 'StakePool) Coin
newpool) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
keyhash Map (KeyHash 'StakePool) Coin
pool of
      Just Coin
c -> (Coin
c, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool
keyhash Map (KeyHash 'StakePool) Coin
pool)
      Maybe Coin
Nothing -> (forall a. Monoid a => a
mempty, Map (KeyHash 'StakePool) 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) DRepState
vsDReps :: Map (Credential 'DRepRole) DRepState
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps} PState {Map (KeyHash 'StakePool) Coin
psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits :: forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits} DState {UMap
dsUnified :: UMap
dsUnified :: forall era. DState era -> UMap
dsUnified}) =
  let accum :: Coin -> DRepState -> Coin
accum Coin
ans DRepState
drepState = Coin
ans forall a. Semigroup a => a -> a -> a
<> DRepState -> Coin
drepDeposit DRepState
drepState
   in Obligations
        { oblStake :: Coin
oblStake = forall a. Compactible a => CompactForm a -> a
UM.fromCompact (forall k. UView k RDPair -> CompactForm Coin
UM.sumDepositUView (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
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) Coin
psDeposits
        , oblDRep :: Coin
oblDRep = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Coin -> DRepState -> Coin
accum (Integer -> Coin
Coin Integer
0) Map (Credential 'DRepRole) DRepState
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 -> 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) PoolParams
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 -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp (forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState DState era
certDState) (forall era. VState era -> Credential 'DRepRole -> 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
dsUnifiedL :: forall era. Lens' (DState era) UMap
dsUnifiedL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. DState era -> UMap
dsUnified (\DState era
ds UMap
u -> DState era
ds {dsUnified :: UMap
dsUnified = UMap
u})

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

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

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

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

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

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

psRetiringL :: Lens' (PState era) (Map (KeyHash 'StakePool) EpochNo)
psRetiringL :: forall era. Lens' (PState era) (Map (KeyHash 'StakePool) 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) EpochNo
psRetiring (\PState era
ds Map (KeyHash 'StakePool) EpochNo
u -> PState era
ds {psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring = Map (KeyHash 'StakePool) EpochNo
u})

psDepositsL :: Lens' (PState era) (Map (KeyHash 'StakePool) Coin)
psDepositsL :: forall era. Lens' (PState era) (Map (KeyHash 'StakePool) 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) Coin
psDeposits (\PState era
ds Map (KeyHash 'StakePool) Coin
u -> PState era
ds {psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = Map (KeyHash 'StakePool) Coin
u})

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

vsDRepsL :: Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL :: forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps (\VState era
vs Map (Credential 'DRepRole) DRepState
u -> VState era
vs {vsDReps :: Map (Credential 'DRepRole) DRepState
vsDReps = Map (Credential 'DRepRole) DRepState
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 -> VState era -> Maybe EpochNo
vsActualDRepExpiry :: forall era. Credential 'DRepRole -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential 'DRepRole
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
. DRepState -> 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
cred (forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps VState era
vs)

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