Skip to content

Commit 7469b0b

Browse files
aniketdaniketd
committed
Refactor to use pool-deposits from StakePoolState
1 parent 51b9f80 commit 7469b0b

File tree

24 files changed

+189
-184
lines changed

24 files changed

+189
-184
lines changed

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -113,7 +113,7 @@ module Cardano.Ledger.Shelley.LedgerState (
113113
psStakePoolsL,
114114
psFutureStakePoolsL,
115115
psRetiringL,
116-
psDepositsL,
116+
psDepositsG,
117117

118118
-- * Lenses from SnapShot(s)
119119
ssStakeMarkL,

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -236,7 +236,8 @@ poolDelegationTransition = do
236236
case Map.lookup ppId psStakePools of
237237
Nothing -> do
238238
tellEvent $ RegisterPool ppId
239-
pure $ ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams)
239+
pure $
240+
ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams)
240241
Just sps -> do
241242
tellEvent $ ReregisterPool ppId
242243
-- NOTE: The `ppId` is already registered, so we want to reregister
@@ -251,9 +252,10 @@ poolDelegationTransition = do
251252
-- has been removed from the registered pools). does it need to pay a
252253
-- new deposit (at the current deposit amount). But of course, if that
253254
-- has happened, we cannot be in this branch of the case statement.
254-
pure $ ps
255-
& psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState (sps ^. spsDepositL) poolParams)
256-
& psRetiringL %~ Map.delete ppId
255+
pure $
256+
ps
257+
& psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState (sps ^. spsDepositL) poolParams)
258+
& psRetiringL %~ Map.delete ppId
257259
RetirePool ppId e -> do
258260
Map.member ppId psStakePools ?! StakePoolNotRegisteredOnKeyPOOL ppId
259261
let maxEpoch = pp ^. ppEMaxL

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs‎

Lines changed: 63 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -16,11 +16,14 @@ module Cardano.Ledger.Shelley.Rules.PoolReap (
1616
ShelleyPOOLREAP,
1717
ShelleyPoolreapEvent (..),
1818
ShelleyPoolreapState (..),
19+
prCertStateL,
20+
prChainAccountStateL,
21+
prUTxOStateL,
1922
PredicateFailure,
2023
ShelleyPoolreapPredFailure,
2124
) where
2225

23-
import Cardano.Ledger.Address (RewardAccount, raCredential)
26+
import Cardano.Ledger.Address
2427
import Cardano.Ledger.BaseTypes (ShelleyBase)
2528
import Cardano.Ledger.Coin (Coin, CompactForm)
2629
import Cardano.Ledger.Compactible (fromCompact)
@@ -30,6 +33,7 @@ import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyPOOLREAP)
3033
import Cardano.Ledger.Shelley.LedgerState (
3134
UTxOState (..),
3235
allObligations,
36+
utxosDepositedL,
3337
utxosGovStateL,
3438
)
3539
import Cardano.Ledger.Shelley.LedgerState.Types (potEqualsObligation)
@@ -64,6 +68,15 @@ data ShelleyPoolreapState era = PoolreapState
6468
deriving stock instance
6569
(Show (UTxOState era), Show (CertState era)) => Show (ShelleyPoolreapState era)
6670

71+
prUTxOStateL :: Lens' (ShelleyPoolreapState era) (UTxOState era)
72+
prUTxOStateL = lens prUTxOSt $ \sprs x -> sprs {prUTxOSt = x}
73+
74+
prChainAccountStateL :: Lens' (ShelleyPoolreapState era) ChainAccountState
75+
prChainAccountStateL = lens prChainAccountState $ \sprs x -> sprs {prChainAccountState = x}
76+
77+
prCertStateL :: Lens' (ShelleyPoolreapState era) (CertState era)
78+
prCertStateL = lens prCertState $ \sprs x -> sprs {prCertState = x}
79+
6780
data ShelleyPoolreapPredFailure era -- No predicate failures
6881
deriving (Show, Eq, Generic)
6982

@@ -125,74 +138,78 @@ instance
125138

126139
poolReapTransition :: forall era. EraCertState era => TransitionRule (ShelleyPOOLREAP era)
127140
poolReapTransition = do
128-
TRC (_, PoolreapState us a cs0, e) <- judgmentContext
141+
TRC (_, prs, e) <- judgmentContext
129142
let
130-
ps0 = cs0 ^. certPStateL
131-
-- activate future stakePools
132-
ps =
133-
ps0
134-
{ psStakePools = Map.union (ps0 ^. psFutureStakePoolsL) (ps0 ^. psStakePoolsL)
135-
, psFutureStakePools = Map.empty
136-
}
137-
cs = cs0 & certPStateL .~ ps
138-
139-
ds = cs ^. certDStateL
143+
-- First, activate the future stake pools.
144+
cs0 = prs ^. prCertStateL
145+
cs =
146+
cs0
147+
& certPStateL %~ \ps0 ->
148+
ps0
149+
{ psStakePools = Map.union (ps0 ^. psFutureStakePoolsL) (ps0 ^. psStakePoolsL)
150+
, psFutureStakePools = Map.empty
151+
}
152+
140153
-- The set of pools retiring this epoch
141-
retired :: Set (KeyHash 'StakePool)
142-
retired = Set.fromDistinctAscList [k | (k, v) <- Map.toAscList (psRetiring ps), v == e]
143-
-- The Map of pools (retiring this epoch) to their deposits
144-
retiringDeposits, remainingDeposits :: Map.Map (KeyHash 'StakePool) (CompactForm Coin)
145-
(retiringDeposits, remainingDeposits) =
146-
Map.partitionWithKey (\k _ -> Set.member k retired) (spsDeposit <$> psStakePools ps)
147-
-- collect all accounts for stake pools that will retire
148-
retiredStakePoolAccounts :: Map.Map (KeyHash 'StakePool) RewardAccount
149-
retiredStakePoolAccounts = Map.map spsRewardAccount $ Map.restrictKeys (psStakePools ps) retired
150-
retiredStakePoolAccountsWithRefund :: Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin)
151-
retiredStakePoolAccountsWithRefund = Map.intersectionWith (,) retiredStakePoolAccounts retiringDeposits
152-
-- collect all of the potential refunds
153-
accountRefunds :: Map.Map (Credential 'Staking) (CompactForm Coin)
154-
accountRefunds =
154+
retiringKeyHashes :: Set (KeyHash 'StakePool)
155+
retiringKeyHashes =
156+
Set.fromDistinctAscList
157+
[ k
158+
| (k, v) <- Map.toAscList (cs ^. certPStateL . psRetiringL)
159+
, v == e
160+
]
161+
162+
retiringPools = Map.restrictKeys (cs ^. certPStateL . psStakePoolsL) retiringKeyHashes
163+
164+
retiringAccountRefunds :: Map.Map (Credential Staking) (CompactForm Coin)
165+
retiringAccountRefunds =
155166
Map.fromListWith (<>) $
156-
[(raCredential k, v) | (k, v) <- Map.elems retiredStakePoolAccountsWithRefund]
157-
accounts = ds ^. accountsL
158-
-- figure out whcich deposits can be refunded and which ones will be deposited into the treasury
159-
-- as unclaimed
167+
[ (sps ^. spsRewardAccountL . rewardAccountCredentialL, sps ^. spsDepositL)
168+
| sps <- Map.elems retiringPools
169+
]
170+
171+
-- Deposits that can be refunded and those that are unclaimed (to be deposited into the treasury).
160172
refunds, unclaimedDeposits :: Map.Map (Credential 'Staking) (CompactForm Coin)
161173
(refunds, unclaimedDeposits) =
162174
Map.partitionWithKey
163-
(\stakeCred _ -> isAccountRegistered stakeCred accounts) -- (k ∈ dom (rewards ds))
164-
accountRefunds
175+
(\stakeCred _ -> isAccountRegistered stakeCred $ cs ^. certDStateL . accountsL)
176+
retiringAccountRefunds
177+
165178
refunded = fold refunds
166179
unclaimed = fold unclaimedDeposits
167180

168181
tellEvent $
169182
let rewardAccountsWithPool =
170183
Map.foldlWithKey'
171-
( \acc sp (ra, coin) ->
172-
Map.insertWith (Map.unionWith (<>)) (raCredential ra) (Map.singleton sp coin) acc
184+
( \acc sp sps ->
185+
Map.insertWith
186+
(Map.unionWith (<>))
187+
(sps ^. spsRewardAccountL . rewardAccountCredentialL)
188+
(Map.singleton sp $ sps ^. spsDepositL)
189+
acc
173190
)
174191
Map.empty
175-
retiredStakePoolAccountsWithRefund
192+
retiringPools
176193
(refundPools', unclaimedPools') =
177194
Map.partitionWithKey
178-
(\cred _ -> isAccountRegistered cred accounts) -- (k ∈ dom (rewards ds))
195+
(\cred _ -> isAccountRegistered cred $ cs ^. certDStateL . accountsL)
179196
rewardAccountsWithPool
180197
in RetiredPools
181198
{ refundPools = refundPools'
182199
, unclaimedPools = unclaimedPools'
183200
, epochNo = e
184201
}
185202
pure $
186-
PoolreapState
187-
us {utxosDeposited = utxosDeposited us <-> fromCompact (unclaimed <> refunded)}
188-
a {casTreasury = casTreasury a <+> fromCompact unclaimed}
189-
( cs
190-
& certDStateL . accountsL
191-
%~ removeStakePoolDelegations retired . addToBalanceAccounts refunds
192-
& certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
193-
& certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
194-
& certPStateL . psDepositsCompactL .~ remainingDeposits
195-
)
203+
prs
204+
& prUTxOStateL . utxosDepositedL %~ (<-> fromCompact (unclaimed <> refunded))
205+
& prChainAccountStateL . casTreasuryL %~ (<+> fromCompact unclaimed)
206+
& prCertStateL
207+
.~ ( cs
208+
& certDStateL . accountsL
209+
%~ removeStakePoolDelegations retiringKeyHashes . addToBalanceAccounts refunds
210+
& certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retiringKeyHashes)
211+
& certPStateL . psRetiringL %~ (`Map.withoutKeys` retiringKeyHashes)
212+
)
196213

197214
renderPoolReapViolation ::
198215
( EraGov era

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Cardano.Ledger.Binary (
3030
encodeListLen,
3131
)
3232
import Cardano.Ledger.Coin (Coin (..))
33+
import Cardano.Ledger.Compactible (fromCompact)
3334
import Cardano.Ledger.Core
3435
import Cardano.Ledger.Credential (Credential (..))
3536
import Cardano.Ledger.Shelley.Era (ShelleyEra)
@@ -77,7 +78,8 @@ shelleyObligationCertState :: EraCertState era => CertState era -> Obligations
7778
shelleyObligationCertState certState =
7879
Obligations
7980
{ oblStake = sumDepositsAccounts (certState ^. certDStateL . accountsL)
80-
, oblPool = F.foldl' (<>) (Coin 0) (certState ^. certPStateL . psDepositsL)
81+
, oblPool =
82+
F.foldl' (<>) (Coin 0) (fromCompact . spsDeposit <$> certState ^. certPStateL . psStakePoolsL)
8183
, oblDRep = Coin 0
8284
, oblProposal = Coin 0
8385
}

‎eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -236,8 +236,8 @@ checkPreservation SourceSignalTarget {source, target, signal} count =
236236
oldCertState = lsCertState lsOld
237237
oldRetire = lsOld ^. lsCertStateL . certPStateL . psRetiringL
238238
newRetire = lsNew ^. lsCertStateL . certPStateL . psRetiringL
239-
oldPoolDeposit = lsOld ^. lsCertStateL . certPStateL . psDepositsL
240-
newPoolDeposit = lsNew ^. lsCertStateL . certPStateL . psDepositsL
239+
oldPoolDeposit = spsDeposit <$> lsOld ^. lsCertStateL . certPStateL . psStakePoolsL
240+
newPoolDeposit = spsDeposit <$> lsNew ^. lsCertStateL . certPStateL . psStakePoolsL
241241

242242
proposal = votedFuturePParams (sgsCurProposals . utxosGovState $ lsUTxOState lsOld) currPP 5
243243
obligationMsgs = case proposal of

‎eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -80,15 +80,15 @@ depositInvariant SourceSignalTarget {source = chainSt} =
8080
pstate = certState ^. certPStateL
8181
allDeposits = utxosDeposited utxost
8282
keyDeposits = sumDepositsAccounts (dstate ^. accountsL)
83-
poolDeposits = foldMap fromCompact (psDeposits pstate)
83+
poolDeposits = foldMap (fromCompact . spsDeposit) (psStakePools pstate)
8484
in counterexample
8585
( ansiDocToString . Pretty.vsep $
8686
[ "Deposit invariant fails:"
8787
, Pretty.indent 2 . Pretty.vsep . map Pretty.pretty $
8888
[ "All deposits = " ++ show allDeposits
8989
, "Key deposits = "
9090
++ show ((^. depositAccountStateL) <$> (dstate ^. accountsL . accountsMapL))
91-
, "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact <$> psDeposits pstate))
91+
, "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact . spsDeposit <$> psStakePools pstate))
9292
]
9393
]
9494
)

‎eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs‎

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Cardano.Protocol.TPraos.BHeader (bhbody, bheaderSlotNo)
2525
import Control.SetAlgebra (dom, eval, (∈), (∉))
2626
import qualified Data.Map.Strict as Map
2727
import qualified Data.Set as Set
28+
import Lens.Micro
2829
import Lens.Micro.Extras (view)
2930
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
3031
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
@@ -131,25 +132,27 @@ poolRegistrationProp
131132
, target = targetSt
132133
} =
133134
let hk = ppId poolParams
134-
reRegistration = eval (hk ∈ dom (psStakePools sourceSt))
135-
in if reRegistration
136-
then
135+
in case Map.lookup hk $ psStakePools sourceSt of
136+
Just sps ->
137137
conjoin
138138
[ counterexample
139139
"Pre-existing PoolParams must still be registered in pParams"
140140
(eval (hk ∈ dom (psStakePools targetSt)) :: Bool)
141141
, counterexample
142142
"New PoolParams are registered in future Params map"
143-
(Map.lookup hk (psFutureStakePools targetSt) === Just (mkStakePoolState poolParams))
143+
( Map.lookup hk (psFutureStakePools targetSt)
144+
=== Just (mkStakePoolState (sps ^. spsDepositL) poolParams)
145+
)
144146
, counterexample
145147
"PoolParams are removed in 'retiring'"
146148
(eval (hk ∉ dom (psRetiring targetSt)) :: Bool)
147149
]
148-
else -- first registration
150+
Nothing ->
151+
-- first registration
149152
conjoin
150153
[ counterexample
151154
"New PoolParams are registered in pParams"
152-
(Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState poolParams))
155+
(Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState mempty poolParams))
153156
, counterexample
154157
"PoolParams are not present in 'future pool params'"
155158
(eval (hk ∉ dom (psFutureStakePools targetSt)) :: Bool)

‎eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs‎

Lines changed: 28 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -156,14 +156,13 @@ addPoolDeposits ::
156156
ChainState era
157157
addPoolDeposits ppEx pools cs = cs {chainNes = nes}
158158
where
159-
curDeposits =
160-
chainNes cs ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psDepositsL
159+
curPools =
160+
chainNes cs ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL
161161
nes =
162162
chainNes cs
163-
& nesEsL . esLStateL . lsCertStateL . certPStateL . psDepositsL %~ Map.union newPools
164163
& nesEsL . esLStateL . lsUTxOStateL . utxosDepositedL <>~ (newPoolCount <×> ppEx ^. ppPoolDepositL)
165164
-- Count the number of new pools, because we don't take a deposit for existing pools
166-
newPools = ppEx ^. ppPoolDepositL <$ (fromElems ppId pools `Map.difference` curDeposits)
165+
newPools = ppEx ^. ppPoolDepositL <$ (fromElems ppId pools `Map.difference` curPools)
167166
newPoolCount = Map.size newPools
168167

169168
addFees ::
@@ -263,7 +262,9 @@ delegation cred poolId cs = cs {chainNes = nes}
263262
-- Add a newly registered stake pool
264263
newPool ::
265264
forall era.
266-
EraCertState era =>
265+
( EraCertState era
266+
, EraGov era
267+
) =>
267268
PoolParams ->
268269
ChainState era ->
269270
ChainState era
@@ -276,7 +277,11 @@ newPool pool cs = cs {chainNes = nes'}
276277
ps = dps ^. certPStateL
277278
ps' =
278279
ps
279-
{ psStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps)
280+
{ psStakePools =
281+
Map.insert
282+
(ppId pool)
283+
(mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) pool)
284+
(psStakePools ps)
280285
}
281286
dps' = dps & certPStateL .~ ps'
282287
ls' = ls {lsCertState = dps'}
@@ -286,7 +291,9 @@ newPool pool cs = cs {chainNes = nes'}
286291
-- | = Re-Register Stake Pool
287292
reregPool ::
288293
forall era.
289-
EraCertState era =>
294+
( EraCertState era
295+
, EraGov era
296+
) =>
290297
PoolParams ->
291298
ChainState era ->
292299
ChainState era
@@ -299,7 +306,11 @@ reregPool pool cs = cs {chainNes = nes'}
299306
ps = dps ^. certPStateL
300307
ps' =
301308
ps
302-
{ psFutureStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps)
309+
{ psFutureStakePools =
310+
Map.insert
311+
(ppId pool)
312+
(mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) pool)
313+
(psStakePools ps)
303314
}
304315
dps' = dps & certPStateL .~ ps'
305316
ls' = ls {lsCertState = dps'}
@@ -309,7 +320,9 @@ reregPool pool cs = cs {chainNes = nes'}
309320
-- | = Re-Register Stake Pool
310321
updatePoolParams ::
311322
forall era.
312-
EraCertState era =>
323+
( EraCertState era
324+
, EraGov era
325+
) =>
313326
PoolParams ->
314327
ChainState era ->
315328
ChainState era
@@ -322,7 +335,11 @@ updatePoolParams pool cs = cs {chainNes = nes'}
322335
ps = dps ^. certPStateL
323336
ps' =
324337
ps
325-
{ psStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps)
338+
{ psStakePools =
339+
Map.insert
340+
(ppId pool)
341+
(mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) pool)
342+
(psStakePools ps)
326343
, psFutureStakePools = Map.delete (ppId pool) (psStakePools ps)
327344
}
328345
dps' = dps & certPStateL .~ ps'
@@ -370,12 +387,11 @@ reapPool pool cs = cs {chainNes = nes'}
370387
ls = esLState es
371388
dps = lsCertState ls
372389
ps = dps ^. certPStateL
373-
poolDeposit = fromJust $ Map.lookup poolId (psDeposits ps)
390+
poolDeposit = spsDeposit $ fromJust $ Map.lookup poolId (psStakePools ps)
374391
ps' =
375392
ps
376393
{ psRetiring = Map.delete poolId (psRetiring ps)
377394
, psStakePools = Map.delete poolId (psStakePools ps)
378-
, psDeposits = Map.delete poolId (psDeposits ps)
379395
}
380396
pp = es ^. curPParamsEpochStateL
381397
ds = dps ^. certDStateL

‎libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ depositsMap certState props =
8888
, bimapMHSMap
8989
(fmap Agda.PoolDeposit . toSpecRep)
9090
toSpecRep
91-
(Agda.MkHSMap . Map.toList $ certState ^. certPStateL . psDepositsL)
91+
(Agda.MkHSMap . Map.toList $ fromCompact . spsDeposit <$> certState ^. certPStateL . psStakePoolsL)
9292
, bimapMHSMap
9393
(fmap Agda.DRepDeposit . toSpecRep)
9494
(toSpecRep . drepDeposit)

0 commit comments

Comments
 (0)