Merge pull request #5232 from IntersectMBO/td/activate-future-stakepools-in-poolreap

Activate future stake pools in `PoolReap`

Author: lehins

eras/conway/impl/cardano-ledger-conway.cabal

@@ -113,7 +113,6 @@ library
     mtl,
     nothunks,
     plutus-ledger-api >=1.37,
-    set-algebra,
     small-steps >=1.1.2,
     text,
     transformers,

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs

@@ -95,7 +95,6 @@ import Cardano.Ledger.Slot (EpochNo)
 import Cardano.Ledger.Val (zero, (<->))
 import Control.DeepSeq (NFData)
 import Control.Monad (guard)
-import Control.SetAlgebra (eval, (⨃))
 import Control.State.Transition (
   Embed (..),
   STS (..),
@@ -297,20 +296,12 @@ epochTransition = do
       utxoState0 = lsUTxOState ledgerState0
       certState0 = ledgerState0 ^. lsCertStateL
       vState = certState0 ^. certVStateL
-      pState0 = certState0 ^. certPStateL
   snapshots1 <-
     trans @(EraRule "SNAP" era) $ TRC (SnapEnv ledgerState0 curPParams, snapshots0, ())
 
-  -- Activate future StakePools
-  let newStakePools = eval (psStakePools pState0 ⨃ psFutureStakePools pState0)
-      pState1 =
-        pState0
-          { psStakePools = newStakePools
-          , psFutureStakePools = Map.empty
-          }
   PoolreapState utxoState1 chainAccountState1 certState1 <-
     trans @(EraRule "POOLREAP" era) $
-      TRC ((), PoolreapState utxoState0 chainAccountState0 (certState0 & certPStateL .~ pState1), eNo)
+      TRC ((), PoolreapState utxoState0 chainAccountState0 certState0, eNo)
 
   let
     stakePoolDistr = ssStakeMarkPoolDistr snapshots1

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs

@@ -60,7 +60,6 @@ import Cardano.Ledger.Shelley.Rules.Upec (ShelleyUPEC, ShelleyUpecPredFailure, U
 import Cardano.Ledger.Slot (EpochNo)
 import Cardano.Ledger.State
 import Control.DeepSeq (NFData)
-import Control.SetAlgebra (eval, (⨃))
 import Control.State.Transition (
   Embed (..),
   STS (..),
@@ -70,7 +69,6 @@ import Control.State.Transition (
   trans,
  )
 import Data.Default (Default)
-import qualified Data.Map.Strict as Map
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -208,20 +206,12 @@ epochTransition = do
   let pp = es ^. curPParamsEpochStateL
       utxoSt = lsUTxOState ls
       certState = ls ^. lsCertStateL
-      pstate = certState ^. certPStateL
   ss' <-
     trans @(EraRule "SNAP" era) $ TRC (SnapEnv ls pp, ss, ())
 
-  let PState stakePools futureStakePools _ _ = pstate
-      ppp = eval (stakePools ⨃ futureStakePools)
-      pstate' =
-        pstate
-          { psStakePools = ppp
-          , psFutureStakePools = Map.empty
-          }
   PoolreapState utxoSt' chainAccountState' adjustedCertState <-
     trans @(EraRule "POOLREAP" era) $
-      TRC ((), PoolreapState utxoSt chainAccountState (certState & certPStateL .~ pstate'), e)
+      TRC ((), PoolreapState utxoSt chainAccountState certState, e)
 
   let ls' = ls {lsUTxOState = utxoSt', lsCertState = adjustedCertState}
 

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

@@ -50,13 +50,11 @@ import Cardano.Ledger.Shelley.Era (
   ShelleyPOOL,
   hardforkAlonzoValidatePoolRewardAccountNetID,
  )
-import Cardano.Ledger.Shelley.LedgerState (PState (..), payPoolDeposit)
 import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
-import Cardano.Ledger.State (PoolMetadata (..), PoolParams (..), mkStakePoolState)
+import Cardano.Ledger.State
 import Control.DeepSeq
 import Control.Monad (forM_, when)
 import Control.Monad.Trans.Reader (asks)
-import Control.SetAlgebra (dom, eval, setSingleton, singleton, (∈), (∉), (⋪), (⨃))
 import Control.State.Transition (
   STS (..),
   TRC (..),
@@ -68,9 +66,10 @@ import Control.State.Transition (
  )
 import qualified Data.ByteString as BS
 import Data.Kind (Type)
+import qualified Data.Map as Map
 import Data.Word (Word8)
 import GHC.Generics (Generic)
-import Lens.Micro ((^.))
+import Lens.Micro
 import NoThunks.Class (NoThunks (..))
 
 data PoolEnv era
@@ -199,7 +198,7 @@ poolDelegationTransition ::
 poolDelegationTransition = do
   TRC
     ( PoolEnv cEpoch pp
-      , ps@PState {psStakePools, psFutureStakePools, psRetiring}
+      , ps@PState {psStakePools}
       , poolCert
       ) <-
     judgmentContext
@@ -234,13 +233,13 @@ poolDelegationTransition = do
               , mismatchExpected = minPoolCost
               }
 
-      if eval (ppId ∉ dom psStakePools)
+      if not (Map.member ppId psStakePools)
         then do
           -- register new, Pool-Reg
           tellEvent $ RegisterPool ppId
           pure $
             payPoolDeposit ppId pp $
-              ps {psStakePools = eval (psStakePools ⨃ singleton ppId (mkStakePoolState poolParams))}
+              ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
         else do
           tellEvent $ ReregisterPool ppId
           -- hk is already registered, so we want to reregister it. That means adding it
@@ -254,12 +253,10 @@ poolDelegationTransition = do
           -- the if statement.
           pure $
             ps
-              { psFutureStakePools =
-                  eval (psFutureStakePools ⨃ singleton ppId (mkStakePoolState poolParams))
-              , psRetiring = eval (setSingleton ppId ⋪ psRetiring)
-              }
-    RetirePool hk e -> do
-      eval (hk ∈ dom psStakePools) ?! StakePoolNotRegisteredOnKeyPOOL hk
+              & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
+              & psRetiringL %~ Map.delete ppId
+    RetirePool ppId e -> do
+      Map.member ppId psStakePools ?! StakePoolNotRegisteredOnKeyPOOL ppId
       let maxEpoch = pp ^. ppEMaxL
           limitEpoch = addEpochInterval cEpoch maxEpoch
       (cEpoch < e && e <= limitEpoch)
@@ -273,4 +270,4 @@ poolDelegationTransition = do
             , mismatchExpected = limitEpoch
             }
       -- We just schedule it for retirement. When it is retired we refund the deposit (see POOLREAP)
-      pure $ ps {psRetiring = eval (psRetiring ⨃ singleton hk e)}
+      pure $ ps & psRetiringL %~ Map.insert ppId e

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

@@ -37,7 +37,6 @@ import Cardano.Ledger.Slot (EpochNo (..))
 import Cardano.Ledger.State
 import Cardano.Ledger.Val ((<+>), (<->))
 import Control.DeepSeq (NFData)
-import Control.SetAlgebra (dom, eval, setSingleton, (⋪), (▷), (◁))
 import Control.State.Transition (
   Assertion (..),
   AssertionViolation (..),
@@ -51,7 +50,7 @@ import Data.Default (Default, def)
 import Data.Foldable (fold)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
-import qualified Data.Set as Set (member)
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks (..))
@@ -126,21 +125,28 @@ instance
 
 poolReapTransition :: forall era. EraCertState era => TransitionRule (ShelleyPOOLREAP era)
 poolReapTransition = do
-  TRC (_, PoolreapState us a cs, e) <- judgmentContext
-
+  TRC (_, PoolreapState us a cs0, e) <- judgmentContext
   let
-    ps = cs ^. certPStateL
+    ps0 = cs0 ^. certPStateL
+    -- activate future stakePools
+    ps =
+      ps0
+        { psStakePools = Map.union (ps0 ^. psFutureStakePoolsL) (ps0 ^. psStakePoolsL)
+        , psFutureStakePools = Map.empty
+        }
+    cs = cs0 & certPStateL .~ ps
+
     ds = cs ^. certDStateL
     -- The set of pools retiring this epoch
     retired :: Set (KeyHash 'StakePool)
-    retired = eval (dom (psRetiring ps ▷ setSingleton e))
+    retired = Set.fromDistinctAscList [k | (k, v) <- Map.toAscList (psRetiring ps), v == e]
     -- The Map of pools (retiring this epoch) to their deposits
     retiringDeposits, remainingDeposits :: Map.Map (KeyHash 'StakePool) (CompactForm Coin)
     (retiringDeposits, remainingDeposits) =
       Map.partitionWithKey (\k _ -> Set.member k retired) (psDeposits ps)
     -- collect all accounts for stake pools that will retire
     retiredStakePoolAccounts :: Map.Map (KeyHash 'StakePool) RewardAccount
-    retiredStakePoolAccounts = Map.map spsRewardAccount $ eval (retired ◁ psStakePools ps)
+    retiredStakePoolAccounts = Map.map spsRewardAccount $ Map.restrictKeys (psStakePools ps) retired
     retiredStakePoolAccountsWithRefund :: Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin)
     retiredStakePoolAccountsWithRefund = Map.intersectionWith (,) retiredStakePoolAccounts retiringDeposits
     -- collect all of the potential refunds
@@ -183,9 +189,8 @@ poolReapTransition = do
       ( cs
           & certDStateL . accountsL
             %~ removeStakePoolDelegations retired . addToBalanceAccounts refunds
-          & certPStateL . psStakePoolsL %~ (eval . (retired ⋪))
-          & certPStateL . psFutureStakePoolsL %~ (eval . (retired ⋪))
-          & certPStateL . psRetiringL %~ (eval . (retired ⋪))
+          & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
+          & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
           & certPStateL . psDepositsCompactL .~ remainingDeposits
       )