{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.Rules.PoolReap (
  ShelleyPOOLREAP,
  ShelleyPoolreapEvent (..),
  ShelleyPoolreapState (..),
  prCertStateL,
  prChainAccountStateL,
  prUTxOStateL,
  PredicateFailure,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyPOOLREAP)
import Cardano.Ledger.Shelley.LedgerState (
  UTxOState (..),
  allObligations,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.LedgerState.Types (potEqualsObligation)
import Cardano.Ledger.State
import Cardano.Ledger.Val ((<+>), (<->))
import Control.DeepSeq (NFData)
import Control.State.Transition (
  Assertion (..),
  AssertionViolation (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  tellEvent,
 )
import Data.Default (Default, def)
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 GHC.Generics (Generic)
import Lens.Micro

data ShelleyPoolreapState era = PoolreapState
  { forall era. ShelleyPoolreapState era -> UTxOState era
prUTxOSt :: UTxOState era
  , forall era. ShelleyPoolreapState era -> ChainAccountState
prChainAccountState :: ChainAccountState
  , forall era. ShelleyPoolreapState era -> CertState era
prCertState :: CertState era
  }

deriving stock instance
  (Show (UTxOState era), Show (CertState era)) => Show (ShelleyPoolreapState era)

prUTxOStateL :: Lens' (ShelleyPoolreapState era) (UTxOState era)
prUTxOStateL :: forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
prUTxOStateL = (ShelleyPoolreapState era -> UTxOState era)
-> (ShelleyPoolreapState era
    -> UTxOState era -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     (UTxOState era)
     (UTxOState era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyPoolreapState era -> UTxOState era
forall era. ShelleyPoolreapState era -> UTxOState era
prUTxOSt ((ShelleyPoolreapState era
  -> UTxOState era -> ShelleyPoolreapState era)
 -> Lens
      (ShelleyPoolreapState era)
      (ShelleyPoolreapState era)
      (UTxOState era)
      (UTxOState era))
-> (ShelleyPoolreapState era
    -> UTxOState era -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     (UTxOState era)
     (UTxOState era)
forall a b. (a -> b) -> a -> b
$ \ShelleyPoolreapState era
sprs UTxOState era
x -> ShelleyPoolreapState era
sprs {prUTxOSt = x}

prChainAccountStateL :: Lens' (ShelleyPoolreapState era) ChainAccountState
prChainAccountStateL :: forall era (f :: * -> *).
Functor f =>
(ChainAccountState -> f ChainAccountState)
-> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
prChainAccountStateL = (ShelleyPoolreapState era -> ChainAccountState)
-> (ShelleyPoolreapState era
    -> ChainAccountState -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     ChainAccountState
     ChainAccountState
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyPoolreapState era -> ChainAccountState
forall era. ShelleyPoolreapState era -> ChainAccountState
prChainAccountState ((ShelleyPoolreapState era
  -> ChainAccountState -> ShelleyPoolreapState era)
 -> Lens
      (ShelleyPoolreapState era)
      (ShelleyPoolreapState era)
      ChainAccountState
      ChainAccountState)
-> (ShelleyPoolreapState era
    -> ChainAccountState -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     ChainAccountState
     ChainAccountState
forall a b. (a -> b) -> a -> b
$ \ShelleyPoolreapState era
sprs ChainAccountState
x -> ShelleyPoolreapState era
sprs {prChainAccountState = x}

prCertStateL :: Lens' (ShelleyPoolreapState era) (CertState era)
prCertStateL :: forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
prCertStateL = (ShelleyPoolreapState era -> CertState era)
-> (ShelleyPoolreapState era
    -> CertState era -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     (CertState era)
     (CertState era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState ((ShelleyPoolreapState era
  -> CertState era -> ShelleyPoolreapState era)
 -> Lens
      (ShelleyPoolreapState era)
      (ShelleyPoolreapState era)
      (CertState era)
      (CertState era))
-> (ShelleyPoolreapState era
    -> CertState era -> ShelleyPoolreapState era)
-> Lens
     (ShelleyPoolreapState era)
     (ShelleyPoolreapState era)
     (CertState era)
     (CertState era)
forall a b. (a -> b) -> a -> b
$ \ShelleyPoolreapState era
sprs CertState era
x -> ShelleyPoolreapState era
sprs {prCertState = x}

data ShelleyPoolreapEvent era = RetiredPools
  { forall era.
ShelleyPoolreapEvent era
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
refundPools ::
      Map.Map (Credential Staking) (Map.Map (KeyHash StakePool) (CompactForm Coin))
  , forall era.
ShelleyPoolreapEvent era
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
unclaimedPools ::
      Map.Map (Credential Staking) (Map.Map (KeyHash StakePool) (CompactForm Coin))
  , forall era. ShelleyPoolreapEvent era -> EpochNo
epochNo :: EpochNo
  }
  deriving ((forall x.
 ShelleyPoolreapEvent era -> Rep (ShelleyPoolreapEvent era) x)
-> (forall x.
    Rep (ShelleyPoolreapEvent era) x -> ShelleyPoolreapEvent era)
-> Generic (ShelleyPoolreapEvent era)
forall x.
Rep (ShelleyPoolreapEvent era) x -> ShelleyPoolreapEvent era
forall x.
ShelleyPoolreapEvent era -> Rep (ShelleyPoolreapEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyPoolreapEvent era) x -> ShelleyPoolreapEvent era
forall era x.
ShelleyPoolreapEvent era -> Rep (ShelleyPoolreapEvent era) x
$cfrom :: forall era x.
ShelleyPoolreapEvent era -> Rep (ShelleyPoolreapEvent era) x
from :: forall x.
ShelleyPoolreapEvent era -> Rep (ShelleyPoolreapEvent era) x
$cto :: forall era x.
Rep (ShelleyPoolreapEvent era) x -> ShelleyPoolreapEvent era
to :: forall x.
Rep (ShelleyPoolreapEvent era) x -> ShelleyPoolreapEvent era
Generic)

deriving instance Eq (ShelleyPoolreapEvent era)

instance NFData (ShelleyPoolreapEvent era)

instance (Default (UTxOState era), Default (CertState era)) => Default (ShelleyPoolreapState era) where
  def :: ShelleyPoolreapState era
def = UTxOState era
-> ChainAccountState -> CertState era -> ShelleyPoolreapState era
forall era.
UTxOState era
-> ChainAccountState -> CertState era -> ShelleyPoolreapState era
PoolreapState UTxOState era
forall a. Default a => a
def ChainAccountState
forall a. Default a => a
def CertState era
forall a. Default a => a
def

type instance EraRuleEvent "POOLREAP" ShelleyEra = ShelleyPoolreapEvent ShelleyEra

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

  renderAssertionViolation :: AssertionViolation (ShelleyPOOLREAP era) -> String
renderAssertionViolation = AssertionViolation (ShelleyPOOLREAP era) -> String
forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
AssertionViolation t -> String
renderPoolReapViolation
  assertions :: [Assertion (ShelleyPOOLREAP era)]
assertions =
    [ String
-> (TRC (ShelleyPOOLREAP era)
    -> State (ShelleyPOOLREAP era) -> Bool)
-> Assertion (ShelleyPOOLREAP era)
forall sts.
String -> (TRC sts -> State sts -> Bool) -> Assertion sts
PostCondition
        String
"Deposit pot must equal obligation (PoolReap)"
        ( \TRC (ShelleyPOOLREAP era)
_trc State (ShelleyPOOLREAP era)
st ->
            CertState era -> UTxOState era -> Bool
forall era.
(EraGov era, EraCertState era) =>
CertState era -> UTxOState era -> Bool
potEqualsObligation
              (ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState State (ShelleyPOOLREAP era)
ShelleyPoolreapState era
st)
              (ShelleyPoolreapState era -> UTxOState era
forall era. ShelleyPoolreapState era -> UTxOState era
prUTxOSt State (ShelleyPOOLREAP era)
ShelleyPoolreapState era
st)
        )
    , String
-> (TRC (ShelleyPOOLREAP era)
    -> State (ShelleyPOOLREAP era) -> Bool)
-> Assertion (ShelleyPOOLREAP era)
forall sts.
String -> (TRC sts -> State sts -> Bool) -> Assertion sts
PostCondition
        String
"PoolReap may not create or remove reward accounts"
        ( \(TRC (Environment (ShelleyPOOLREAP era)
_, State (ShelleyPOOLREAP era)
st, Signal (ShelleyPOOLREAP era)
_)) State (ShelleyPOOLREAP era)
st' ->
            let accountsCount :: ShelleyPoolreapState era -> Int
accountsCount ShelleyPoolreapState era
prState =
                  Map (Credential Staking) (AccountState era) -> Int
forall k a. Map k a -> Int
Map.size (ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState ShelleyPoolreapState era
prState CertState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> CertState era
-> Const
     (Map (Credential Staking) (AccountState era)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (DState era))
 -> CertState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> DState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (DState era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)
             in ShelleyPoolreapState era -> Int
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
ShelleyPoolreapState era -> Int
accountsCount State (ShelleyPOOLREAP era)
ShelleyPoolreapState era
st Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ShelleyPoolreapState era -> Int
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
ShelleyPoolreapState era -> Int
accountsCount State (ShelleyPOOLREAP era)
ShelleyPoolreapState era
st'
        )
    ]

poolReapTransition :: forall era. EraCertState era => TransitionRule (ShelleyPOOLREAP era)
poolReapTransition :: forall era.
EraCertState era =>
TransitionRule (ShelleyPOOLREAP era)
poolReapTransition = do
  TRC (_, PoolreapState us a cs0, e) <- Rule
  (ShelleyPOOLREAP era)
  'Transition
  (RuleContext 'Transition (ShelleyPOOLREAP era))
F (Clause (ShelleyPOOLREAP era) 'Transition)
  (TRC (ShelleyPOOLREAP 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
    -- find the set of VRF key hashes that are no longer relevant, since they have been overwritten
    -- via pool re-registration
    danglingVRFKeyHashes =
      [VRFVerKeyHash StakePoolVRF] -> Set (VRFVerKeyHash StakePoolVRF)
forall a. Ord a => [a] -> Set a
Set.fromList ([VRFVerKeyHash StakePoolVRF] -> Set (VRFVerKeyHash StakePoolVRF))
-> [VRFVerKeyHash StakePoolVRF] -> Set (VRFVerKeyHash StakePoolVRF)
forall a b. (a -> b) -> a -> b
$
        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 (VRFVerKeyHash StakePoolVRF)
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     StakePoolParams
     (VRFVerKeyHash StakePoolVRF)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
-> 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 (VRFVerKeyHash StakePoolVRF)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
            ( (KeyHash StakePool
 -> StakePoolState
 -> StakePoolParams
 -> Maybe (VRFVerKeyHash StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     StakePoolParams
     (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
  -> Maybe (VRFVerKeyHash StakePoolVRF))
 -> SimpleWhenMatched
      (KeyHash StakePool)
      StakePoolState
      StakePoolParams
      (VRFVerKeyHash StakePoolVRF))
-> (KeyHash StakePool
    -> StakePoolState
    -> StakePoolParams
    -> Maybe (VRFVerKeyHash StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash StakePool)
     StakePoolState
     StakePoolParams
     (VRFVerKeyHash StakePoolVRF)
forall a b. (a -> b) -> a -> b
$ \KeyHash StakePool
_ StakePoolState
sps StakePoolParams
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
sppF StakePoolParams
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     StakePoolParams
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  StakePoolParams
  (VRFVerKeyHash StakePoolVRF)
Lens' StakePoolParams (VRFVerKeyHash StakePoolVRF)
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)
     (PState era)
     (Map (KeyHash StakePool) StakePoolParams)
-> Map (KeyHash StakePool) StakePoolParams
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash StakePool) StakePoolParams)
  (PState era)
  (Map (KeyHash StakePool) StakePoolParams)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolParams
 -> f (Map (KeyHash StakePool) StakePoolParams))
-> 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
futureParams StakePoolState
currentState ->
                  CompactForm Coin
-> Set (Credential Staking) -> StakePoolParams -> StakePoolState
mkStakePoolState
                    (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
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 (ShelleyPOOLREAP 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
    -- collect all accounts for stake pools that will retire
    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

    -- 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
(<>)
        [(StakePoolState -> Credential Staking
spsRewardAccount 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 = StakePoolState -> Credential Staking
spsRewardAccount 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
            %~ ( removeVRFKeyHashOccurrences retiredVRFKeyHashes
                   . (`Map.withoutKeys` danglingVRFKeyHashes)
               )
      )
  where
    removeVRFKeyHashOccurrences ::
      [VRFVerKeyHash StakePoolVRF] ->
      Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64) ->
      Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    removeVRFKeyHashOccurrences :: [VRFVerKeyHash StakePoolVRF]
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeVRFKeyHashOccurrences [VRFVerKeyHash StakePoolVRF]
vrfs Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
vrfsMap = (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) Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
vrfsMap [VRFVerKeyHash StakePoolVRF]
vrfs
    removeVRFKeyHashOccurrence :: VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeVRFKeyHashOccurrence =
      -- Removes the key from the map if the value drops to 0
      (NonZero Word64 -> Maybe (NonZero Word64))
-> VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update ((Word64 -> Word64) -> NonZero Word64 -> Maybe (NonZero Word64)
forall b a.
(Eq b, HasZero b) =>
(a -> b) -> NonZero a -> Maybe (NonZero b)
mapNonZero (\Word64
n -> Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1))
    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

renderPoolReapViolation ::
  ( EraGov era
  , State t ~ ShelleyPoolreapState era
  , EraCertState era
  ) =>
  AssertionViolation t ->
  String
renderPoolReapViolation :: forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
AssertionViolation t -> String
renderPoolReapViolation
  AssertionViolation {String
avSTS :: String
avSTS :: forall sts. AssertionViolation sts -> String
avSTS, String
avMsg :: String
avMsg :: forall sts. AssertionViolation sts -> String
avMsg, avCtx :: forall sts. AssertionViolation sts -> TRC sts
avCtx = TRC (Environment t
_, State t
poolreapst, Signal t
_)} =
    let obligations :: Obligations
obligations =
          CertState era -> GovState era -> Obligations
forall era.
(EraGov era, EraCertState era) =>
CertState era -> GovState era -> Obligations
allObligations (ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState State t
ShelleyPoolreapState era
poolreapst) (ShelleyPoolreapState era -> UTxOState era
forall era. ShelleyPoolreapState era -> UTxOState era
prUTxOSt State t
ShelleyPoolreapState era
poolreapst UTxOState era
-> Getting (GovState era) (UTxOState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. Getting (GovState era) (UTxOState era) (GovState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL)
     in String
"\n\nAssertionViolation ("
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
avSTS
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")\n   "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
avMsg
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\npot (utxosDeposited) = "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (UTxOState era -> Coin
forall era. UTxOState era -> Coin
utxosDeposited (ShelleyPoolreapState era -> UTxOState era
forall era. ShelleyPoolreapState era -> UTxOState era
prUTxOSt State t
ShelleyPoolreapState era
poolreapst))
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Obligations -> String
forall a. Show a => a -> String
show Obligations
obligations