{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.Rules.PoolReap (
  POOLREAP,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Era (DijkstraEra, POOLREAP)
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
import Cardano.Ledger.Shelley.Rules (
  ShelleyPoolreapEvent (..),
  ShelleyPoolreapState (..),
  poolReapAssertions,
  renderPoolReapViolation,
 )
import Cardano.Ledger.State
import Cardano.Ledger.Val ((<+>), (<->))
import Control.State.Transition (
  Assertion (..),
  AssertionViolation (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  tellEvent,
 )
import Data.Default (Default)
import Data.Foldable (fold)
import Data.Foldable as F (foldl')
import qualified Data.Map.Merge.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Void (Void)
import Data.Word (Word64)
import Lens.Micro

-- The `POOLREAP` rule of the Dijkstra era mirrors the Shelley one, except for how it keeps
-- `psVRFKeyHashes` in sync with the registered stake pools. Dropping the VRF key hashes
-- that a re-registration supersedes, the way Shelley does, loses the references that
-- other pools still hold to the same hash. Instead, every pool that switches to a
-- different VRF key hash releases a single reference to its active one, just like every
-- retired pool releases a single reference to the VRF key hash it uses.
-- The `POOLREAP` rule type itself is declared in "Cardano.Ledger.Dijkstra.Era".
type instance EraRuleEvent "POOLREAP" DijkstraEra = ShelleyPoolreapEvent DijkstraEra

instance
  ( Default (ShelleyPoolreapState era)
  , EraPParams era
  , EraGov era
  , EraCertState era
  ) =>
  STS (POOLREAP era)
  where
  type State (POOLREAP era) = ShelleyPoolreapState era
  type Signal (POOLREAP era) = EpochNo
  type Environment (POOLREAP era) = ()
  type BaseM (POOLREAP era) = ShelleyBase
  type PredicateFailure (POOLREAP era) = Void
  type Event (POOLREAP era) = ShelleyPoolreapEvent era
  transitionRules :: [TransitionRule (POOLREAP era)]
transitionRules = [TransitionRule (POOLREAP era)
forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition]

  renderAssertionViolation :: AssertionViolation (POOLREAP era) -> String
renderAssertionViolation AssertionViolation (POOLREAP era)
av =
    AssertionViolation (POOLREAP era) -> String
forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
AssertionViolation t -> String
renderPoolReapViolation AssertionViolation (POOLREAP era)
av String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ShelleyPoolreapState era -> String)
-> Maybe (ShelleyPoolreapState era) -> String
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ShelleyPoolreapState era -> String
forall era. EraCertState era => ShelleyPoolreapState era -> String
renderVRFKeyHashCounts (AssertionViolation (POOLREAP era) -> Maybe (State (POOLREAP era))
forall sts. AssertionViolation sts -> Maybe (State sts)
avState AssertionViolation (POOLREAP era)
av)
  assertions :: [Assertion (POOLREAP era)]
assertions =
    [Assertion (POOLREAP era)]
forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
[Assertion t]
poolReapAssertions
      [Assertion (POOLREAP era)]
-> [Assertion (POOLREAP era)] -> [Assertion (POOLREAP era)]
forall a. Semigroup a => a -> a -> a
<> [ String
-> (TRC (POOLREAP era) -> State (POOLREAP era) -> Bool)
-> Assertion (POOLREAP era)
forall sts.
String -> (TRC sts -> State sts -> Bool) -> Assertion sts
PostCondition
             String
"VRF key hash counts must match those recomputed from the stake pools (PoolReap)"
             (\TRC (POOLREAP era)
_trc -> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64) -> Bool)
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
  Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
 -> Bool)
-> (ShelleyPoolreapState era
    -> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
        Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> ShelleyPoolreapState era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyPoolreapState era
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
forall era.
EraCertState era =>
ShelleyPoolreapState era
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
vrfKeyHashCounts)
         ]

-- | The VRF key hash counts that @POOLREAP@ leaves behind, together with the ones recomputed
-- from the stake pools that remain registered. Its post-condition requires them to be equal.
vrfKeyHashCounts ::
  EraCertState era =>
  ShelleyPoolreapState era ->
  ( Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
  , Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
  )
vrfKeyHashCounts :: forall era.
EraCertState era =>
ShelleyPoolreapState era
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
vrfKeyHashCounts ShelleyPoolreapState era
st = (PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes PState era
ps, PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes (PState era -> PState era
forall era. PState era -> PState era
populateVRFKeyHashes PState era
ps))
  where
    ps :: PState era
ps = ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState ShelleyPoolreapState era
st CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL

renderVRFKeyHashCounts :: EraCertState era => ShelleyPoolreapState era -> String
renderVRFKeyHashCounts :: forall era. EraCertState era => ShelleyPoolreapState era -> String
renderVRFKeyHashCounts ShelleyPoolreapState era
st =
  String
"\nVRF key hash counts (psVRFKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map (VRFVerKeyHash StakePoolVRF) Word64 -> String
forall a. Show a => a -> String
show (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
counts)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nVRF key hash counts recomputed from the stake pools (populateVRFKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map (VRFVerKeyHash StakePoolVRF) Word64 -> String
forall a. Show a => a -> String
show (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
recomputed)
  where
    (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
counts, Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
recomputed) = ShelleyPoolreapState era
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
forall era.
EraCertState era =>
ShelleyPoolreapState era
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64),
    Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
vrfKeyHashCounts ShelleyPoolreapState era
st

poolReapTransition :: forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition :: forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition = do
  TRC (_, PoolreapState us a cs0, e) <- Rule
  (POOLREAP era) 'Transition (RuleContext 'Transition (POOLREAP era))
F (Clause (POOLREAP era) 'Transition) (TRC (POOLREAP era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let
    ps0 = CertState era
cs0 CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    -- The active VRF key hash of every pool whose future parameters switch to a different
    -- one. A hash that several of these pools share is listed once for each of them.
    supersededVRFKeyHashes =
      Map (KeyHash StakePool) (VRFVerKeyHash StakePoolVRF)
-> [VRFVerKeyHash StakePoolVRF]
forall k a. Map k a -> [a]
Map.elems (Map (KeyHash StakePool) (VRFVerKeyHash StakePoolVRF)
 -> [VRFVerKeyHash StakePoolVRF])
-> Map (KeyHash StakePool) (VRFVerKeyHash StakePoolVRF)
-> [VRFVerKeyHash StakePoolVRF]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing
  (KeyHash StakePool) StakePoolState (VRFVerKeyHash StakePoolVRF)
-> SimpleWhenMissing
     (KeyHash StakePool)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) (StakePoolParams era)
-> Map (KeyHash StakePool) (VRFVerKeyHash StakePoolVRF)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
          SimpleWhenMissing
  (KeyHash StakePool) StakePoolState (VRFVerKeyHash StakePoolVRF)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
          SimpleWhenMissing
  (KeyHash StakePool)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
          ( (KeyHash StakePool
 -> StakePoolState
 -> StakePoolParams era
 -> Maybe (VRFVerKeyHash StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
Map.zipWithMaybeMatched ((KeyHash StakePool
  -> StakePoolState
  -> StakePoolParams era
  -> Maybe (VRFVerKeyHash StakePoolVRF))
 -> SimpleWhenMatched
      (KeyHash StakePool)
      StakePoolState
      (StakePoolParams era)
      (VRFVerKeyHash StakePoolVRF))
-> (KeyHash StakePool
    -> StakePoolState
    -> StakePoolParams era
    -> Maybe (VRFVerKeyHash StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
forall a b. (a -> b) -> a -> b
$ \KeyHash StakePool
_ StakePoolState
sps StakePoolParams era
sppF ->
              if StakePoolState
sps StakePoolState
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash StakePoolVRF)
spsVrfL VRFVerKeyHash StakePoolVRF -> VRFVerKeyHash StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
/= StakePoolParams era
sppF StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL then VRFVerKeyHash StakePoolVRF -> Maybe (VRFVerKeyHash StakePoolVRF)
forall a. a -> Maybe a
Just (StakePoolState
sps StakePoolState
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash StakePoolVRF)
spsVrfL) else Maybe (VRFVerKeyHash StakePoolVRF)
forall a. Maybe a
Nothing
          )
          (PState era
ps0 PState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (PState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash StakePool) StakePoolState)
  (PState era)
  (Map (KeyHash StakePool) StakePoolState)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL)
          (PState era
ps0 PState era
-> Getting
     (Map (KeyHash StakePool) (StakePoolParams era))
     (PState era)
     (Map (KeyHash StakePool) (StakePoolParams era))
-> Map (KeyHash StakePool) (StakePoolParams era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash StakePool) (StakePoolParams era))
  (PState era)
  (Map (KeyHash StakePool) (StakePoolParams era))
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) (StakePoolParams era)
 -> f (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> f (PState era)
psFutureStakePoolParamsL)

    -- activate future stakePools
    ps =
      PState era
ps0
        { psStakePools =
            Map.merge
              Map.dropMissing
              Map.preserveMissing
              ( Map.zipWithMatched $ \KeyHash StakePool
_ StakePoolParams era
futureParams StakePoolState
currentState ->
                  EpochNo
-> StrictMaybe BlsKeyState
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
forall era.
EpochNo
-> StrictMaybe BlsKeyState
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
mkStakePoolState
                    EpochNo
Signal (POOLREAP era)
e
                    -- the pool keeps the epoch its voting key was registered in unless the re-registration actually rotates it
                    (StakePoolState
currentState StakePoolState
-> Getting
     (StrictMaybe BlsKeyState) StakePoolState (StrictMaybe BlsKeyState)
-> StrictMaybe BlsKeyState
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe BlsKeyState) StakePoolState (StrictMaybe BlsKeyState)
Lens' StakePoolState (StrictMaybe BlsKeyState)
spsBlsKeyL)
                    (StakePoolState
currentState StakePoolState
-> Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
Lens' StakePoolState (CompactForm Coin)
spsDepositL)
                    (StakePoolState
currentState StakePoolState
-> Getting
     (Set (Credential Staking))
     StakePoolState
     (Set (Credential Staking))
-> Set (Credential Staking)
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (Credential Staking))
  StakePoolState
  (Set (Credential Staking))
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL)
                    StakePoolParams era
futureParams
              )
              (ps0 ^. psFutureStakePoolParamsL)
              (ps0 ^. psStakePoolsL)
        , psFutureStakePoolParams = Map.empty
        }
    cs = CertState era
cs0 CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps

    ds = CertState era
cs CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    -- The set of pools retiring this epoch
    retired :: Set (KeyHash StakePool)
    retired = [KeyHash StakePool] -> Set (KeyHash StakePool)
forall a. [a] -> Set a
Set.fromDistinctAscList [KeyHash StakePool
k | (KeyHash StakePool
k, EpochNo
v) <- Map (KeyHash StakePool) EpochNo -> [(KeyHash StakePool, EpochNo)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (PState era -> Map (KeyHash StakePool) EpochNo
forall era. PState era -> Map (KeyHash StakePool) EpochNo
psRetiring PState era
ps), EpochNo
v EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== EpochNo
Signal (POOLREAP era)
e]
    -- The Map of pools retiring this epoch
    retiringPools :: Map.Map (KeyHash StakePool) StakePoolState
    retiringPools = Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
ps) Set (KeyHash StakePool)
retired
    -- The VRF key hash of every pool retiring this epoch, once for each of them
    retiredVRFKeyHashes = StakePoolState -> VRFVerKeyHash StakePoolVRF
spsVrf (StakePoolState -> VRFVerKeyHash StakePoolVRF)
-> [StakePoolState] -> [VRFVerKeyHash StakePoolVRF]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash StakePool) StakePoolState -> [StakePoolState]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash StakePool) StakePoolState
retiringPools

    -- Every pool releases a single reference to each VRF key hash it stops using, which
    -- keeps the invariant documented in "Cardano.Ledger.Dijkstra.Rules.Pool".
    vrfKeyHashes =
      (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> VRFVerKeyHash StakePoolVRF
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> [VRFVerKeyHash StakePoolVRF]
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
        ((VRFVerKeyHash StakePoolVRF
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall a b c. (a -> b -> c) -> b -> a -> c
flip VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeVRFKeyHashOccurrence)
        (PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes PState era
ps0)
        ([VRFVerKeyHash StakePoolVRF]
supersededVRFKeyHashes [VRFVerKeyHash StakePoolVRF]
-> [VRFVerKeyHash StakePoolVRF] -> [VRFVerKeyHash StakePoolVRF]
forall a. Semigroup a => a -> a -> a
<> [VRFVerKeyHash StakePoolVRF]
retiredVRFKeyHashes)

    -- collect all of the potential refunds
    accountRefunds :: Map.Map (Credential Staking) (CompactForm Coin)
    accountRefunds =
      (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> [(Credential Staking, CompactForm Coin)]
-> Map (Credential Staking) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>)
        [(AccountId -> Credential Staking
unAccountId (AccountId -> Credential Staking)
-> AccountId -> Credential Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> AccountId
spsAccountId StakePoolState
sps, StakePoolState -> CompactForm Coin
spsDeposit StakePoolState
sps) | StakePoolState
sps <- Map (KeyHash StakePool) StakePoolState -> [StakePoolState]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash StakePool) StakePoolState
retiringPools]
    accounts = DState era
ds DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    -- Deposits that can be refunded and those that are unclaimed (to be deposited into the treasury).
    refunds, unclaimedDeposits :: Map.Map (Credential Staking) (CompactForm Coin)
    (refunds, unclaimedDeposits) =
      Map.partitionWithKey
        (\Credential Staking
stakeCred CompactForm Coin
_ -> Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
stakeCred Accounts era
accounts) -- (k ∈ dom (rewards ds))
        accountRefunds

    refunded = Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) (CompactForm Coin)
refunds
    unclaimed = Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) (CompactForm Coin)
unclaimedDeposits

  tellEvent $
    let rewardAccountsWithPool =
          (KeyHash StakePool
 -> StakePoolState
 -> Map
      (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
 -> Map
      (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin)))
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
-> Map (KeyHash StakePool) StakePoolState
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey'
            ( \KeyHash StakePool
poolId StakePoolState
sps ->
                let cred :: Credential Staking
cred = AccountId -> Credential Staking
unAccountId (AccountId -> Credential Staking)
-> AccountId -> Credential Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> AccountId
spsAccountId StakePoolState
sps
                 in (Map (KeyHash StakePool) (CompactForm Coin)
 -> Map (KeyHash StakePool) (CompactForm Coin)
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> Credential Staking
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>)) Credential Staking
cred (KeyHash StakePool
-> CompactForm Coin -> Map (KeyHash StakePool) (CompactForm Coin)
forall k a. k -> a -> Map k a
Map.singleton KeyHash StakePool
poolId (StakePoolState -> CompactForm Coin
spsDeposit StakePoolState
sps))
            )
            Map
  (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a. Map k a
Map.empty
            Map (KeyHash StakePool) StakePoolState
retiringPools
        (refundPools', unclaimedPools') =
          Map.partitionWithKey
            (\Credential Staking
cred Map (KeyHash StakePool) (CompactForm Coin)
_ -> Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred Accounts era
accounts)
            rewardAccountsWithPool
     in RetiredPools
          { refundPools = refundPools'
          , unclaimedPools = unclaimedPools'
          , epochNo = e
          }
  pure $
    PoolreapState
      us {utxosDeposited = utxosDeposited us <-> fromCompact (unclaimed <> refunded)}
      a {casTreasury = casTreasury a <+> fromCompact unclaimed}
      ( cs
          & certDStateL . accountsL
            %~ removeStakePoolDelegations (delegsToClear cs retired)
              . addToBalanceAccounts refunds
          & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
          & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
          & certPStateL . psVRFKeyHashesL .~ vrfKeyHashes
      )
  where
    delegsToClear :: CertState era
-> Set (KeyHash StakePool) -> Set (Credential Staking)
delegsToClear CertState era
cState Set (KeyHash StakePool)
pools =
      (StakePoolState -> Set (Credential Staking))
-> Map (KeyHash StakePool) StakePoolState
-> Set (Credential Staking)
forall m a. Monoid m => (a -> m) -> Map (KeyHash StakePool) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap StakePoolState -> Set (Credential Staking)
spsDelegators (Map (KeyHash StakePool) StakePoolState
 -> Set (Credential Staking))
-> Map (KeyHash StakePool) StakePoolState
-> Set (Credential Staking)
forall a b. (a -> b) -> a -> b
$
        Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (CertState era
cState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL) Set (KeyHash StakePool)
pools