{-# 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,
  ShelleyPoolreapPredFailure,
) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes (ShelleyBase)
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.Slot (EpochNo (..))
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 qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

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)
-> forall {f :: * -> *}.
   Functor f =>
   (UTxOState era -> f (UTxOState era))
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState 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)
 -> forall {f :: * -> *}.
    Functor f =>
    (UTxOState era -> f (UTxOState era))
    -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era))
-> (ShelleyPoolreapState era
    -> UTxOState era -> ShelleyPoolreapState era)
-> forall {f :: * -> *}.
   Functor f =>
   (UTxOState era -> f (UTxOState era))
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState 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)
-> forall {f :: * -> *}.
   Functor f =>
   (ChainAccountState -> f ChainAccountState)
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
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)
 -> forall {f :: * -> *}.
    Functor f =>
    (ChainAccountState -> f ChainAccountState)
    -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era))
-> (ShelleyPoolreapState era
    -> ChainAccountState -> ShelleyPoolreapState era)
-> forall {f :: * -> *}.
   Functor f =>
   (ChainAccountState -> f ChainAccountState)
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
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)
-> forall {f :: * -> *}.
   Functor f =>
   (CertState era -> f (CertState era))
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState 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)
 -> forall {f :: * -> *}.
    Functor f =>
    (CertState era -> f (CertState era))
    -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era))
-> (ShelleyPoolreapState era
    -> CertState era -> ShelleyPoolreapState era)
-> forall {f :: * -> *}.
   Functor f =>
   (CertState era -> f (CertState era))
   -> ShelleyPoolreapState era -> f (ShelleyPoolreapState era)
forall a b. (a -> b) -> a -> b
$ \ShelleyPoolreapState era
sprs CertState era
x -> ShelleyPoolreapState era
sprs {prCertState = x}

data ShelleyPoolreapPredFailure era -- No predicate failures
  deriving (Int -> ShelleyPoolreapPredFailure era -> ShowS
[ShelleyPoolreapPredFailure era] -> ShowS
ShelleyPoolreapPredFailure era -> String
(Int -> ShelleyPoolreapPredFailure era -> ShowS)
-> (ShelleyPoolreapPredFailure era -> String)
-> ([ShelleyPoolreapPredFailure era] -> ShowS)
-> Show (ShelleyPoolreapPredFailure era)
forall era. Int -> ShelleyPoolreapPredFailure era -> ShowS
forall era. [ShelleyPoolreapPredFailure era] -> ShowS
forall era. ShelleyPoolreapPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ShelleyPoolreapPredFailure era -> ShowS
showsPrec :: Int -> ShelleyPoolreapPredFailure era -> ShowS
$cshow :: forall era. ShelleyPoolreapPredFailure era -> String
show :: ShelleyPoolreapPredFailure era -> String
$cshowList :: forall era. [ShelleyPoolreapPredFailure era] -> ShowS
showList :: [ShelleyPoolreapPredFailure era] -> ShowS
Show, ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
(ShelleyPoolreapPredFailure era
 -> ShelleyPoolreapPredFailure era -> Bool)
-> (ShelleyPoolreapPredFailure era
    -> ShelleyPoolreapPredFailure era -> Bool)
-> Eq (ShelleyPoolreapPredFailure era)
forall era.
ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
== :: ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
$c/= :: forall era.
ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
/= :: ShelleyPoolreapPredFailure era
-> ShelleyPoolreapPredFailure era -> Bool
Eq, (forall x.
 ShelleyPoolreapPredFailure era
 -> Rep (ShelleyPoolreapPredFailure era) x)
-> (forall x.
    Rep (ShelleyPoolreapPredFailure era) x
    -> ShelleyPoolreapPredFailure era)
-> Generic (ShelleyPoolreapPredFailure era)
forall x.
Rep (ShelleyPoolreapPredFailure era) x
-> ShelleyPoolreapPredFailure era
forall x.
ShelleyPoolreapPredFailure era
-> Rep (ShelleyPoolreapPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyPoolreapPredFailure era) x
-> ShelleyPoolreapPredFailure era
forall era x.
ShelleyPoolreapPredFailure era
-> Rep (ShelleyPoolreapPredFailure era) x
$cfrom :: forall era x.
ShelleyPoolreapPredFailure era
-> Rep (ShelleyPoolreapPredFailure era) x
from :: forall x.
ShelleyPoolreapPredFailure era
-> Rep (ShelleyPoolreapPredFailure era) x
$cto :: forall era x.
Rep (ShelleyPoolreapPredFailure era) x
-> ShelleyPoolreapPredFailure era
to :: forall x.
Rep (ShelleyPoolreapPredFailure era) x
-> ShelleyPoolreapPredFailure era
Generic)

instance NFData (ShelleyPoolreapPredFailure era)

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 NoThunks (ShelleyPoolreapPredFailure 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) = ShelleyPoolreapPredFailure era
  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 (Environment (ShelleyPOOLREAP era)
_, PoolreapState UTxOState era
us ChainAccountState
a CertState era
cs0, Signal (ShelleyPOOLREAP era)
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 :: PState era
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 :: Set (VRFVerKeyHash 'StakePoolVRF)
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) StakePoolState (VRFVerKeyHash 'StakePoolVRF)
-> SimpleWhenMatched
     (KeyHash 'StakePool)
     StakePoolState
     StakePoolState
     (VRFVerKeyHash 'StakePoolVRF)
-> Map (KeyHash 'StakePool) StakePoolState
-> Map (KeyHash 'StakePool) StakePoolState
-> 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) StakePoolState (VRFVerKeyHash 'StakePoolVRF)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
            ( (KeyHash 'StakePool
 -> StakePoolState
 -> StakePoolState
 -> Maybe (VRFVerKeyHash 'StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash 'StakePool)
     StakePoolState
     StakePoolState
     (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
  -> StakePoolState
  -> Maybe (VRFVerKeyHash 'StakePoolVRF))
 -> SimpleWhenMatched
      (KeyHash 'StakePool)
      StakePoolState
      StakePoolState
      (VRFVerKeyHash 'StakePoolVRF))
-> (KeyHash 'StakePool
    -> StakePoolState
    -> StakePoolState
    -> Maybe (VRFVerKeyHash 'StakePoolVRF))
-> SimpleWhenMatched
     (KeyHash 'StakePool)
     StakePoolState
     StakePoolState
     (VRFVerKeyHash 'StakePoolVRF)
forall a b. (a -> b) -> a -> b
$ \KeyHash 'StakePool
_ StakePoolState
sps StakePoolState
spsF ->
                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
/= StakePoolState
spsF 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 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) 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)
psFutureStakePoolsL)

    -- activate future stakePools
    ps :: PState era
ps =
      PState era
ps0
        { psStakePools = Map.union (ps0 ^. psFutureStakePoolsL) (ps0 ^. psStakePoolsL)
        , psFutureStakePools = Map.empty
        }
    cs :: CertState era
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 :: DState era
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 :: 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
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
    retiredVRFs :: Set (VRFVerKeyHash 'StakePoolVRF)
retiredVRFs = (StakePoolState -> Set (VRFVerKeyHash 'StakePoolVRF))
-> Map (KeyHash 'StakePool) StakePoolState
-> Set (VRFVerKeyHash 'StakePoolVRF)
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 (VRFVerKeyHash 'StakePoolVRF -> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Set a
Set.singleton (VRFVerKeyHash 'StakePoolVRF -> Set (VRFVerKeyHash 'StakePoolVRF))
-> (StakePoolState -> VRFVerKeyHash 'StakePoolVRF)
-> StakePoolState
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolState -> VRFVerKeyHash 'StakePoolVRF
spsVrf) Map (KeyHash 'StakePool) StakePoolState
retiringPools
    -- collect all of the potential refunds
    accountRefunds :: Map.Map (Credential 'Staking) (CompactForm Coin)
    accountRefunds :: 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
(<>)
        [(RewardAccount -> Credential 'Staking
raCredential (RewardAccount -> Credential 'Staking)
-> RewardAccount -> Credential 'Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> RewardAccount
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 :: Accounts era
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)
    (Map (Credential 'Staking) (CompactForm Coin)
refunds, Map (Credential 'Staking) (CompactForm Coin)
unclaimedDeposits) =
      (Credential 'Staking -> CompactForm Coin -> Bool)
-> Map (Credential 'Staking) (CompactForm Coin)
-> (Map (Credential 'Staking) (CompactForm Coin),
    Map (Credential 'Staking) (CompactForm Coin))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
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))
        Map (Credential 'Staking) (CompactForm Coin)
accountRefunds

    refunded :: CompactForm Coin
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 :: CompactForm Coin
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

  Event (ShelleyPOOLREAP era)
-> Rule (ShelleyPOOLREAP era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ShelleyPOOLREAP era)
 -> Rule (ShelleyPOOLREAP era) 'Transition ())
-> Event (ShelleyPOOLREAP era)
-> Rule (ShelleyPOOLREAP era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
    let rewardAccountsWithPool :: Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
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 = RewardAccount -> Credential 'Staking
raCredential (RewardAccount -> Credential 'Staking)
-> RewardAccount -> Credential 'Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> RewardAccount
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
        (Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
refundPools', Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
unclaimedPools') =
          (Credential 'Staking
 -> Map (KeyHash 'StakePool) (CompactForm Coin) -> Bool)
-> Map
     (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. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
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)
            Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
rewardAccountsWithPool
     in RetiredPools
          { refundPools :: Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
refundPools = Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
refundPools'
          , unclaimedPools :: Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
unclaimedPools = Map
  (Credential 'Staking) (Map (KeyHash 'StakePool) (CompactForm Coin))
unclaimedPools'
          , epochNo :: EpochNo
epochNo = EpochNo
Signal (ShelleyPOOLREAP era)
e
          }
  ShelleyPoolreapState era
-> F (Clause (ShelleyPOOLREAP era) 'Transition)
     (ShelleyPoolreapState era)
forall a. a -> F (Clause (ShelleyPOOLREAP era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyPoolreapState era
 -> F (Clause (ShelleyPOOLREAP era) 'Transition)
      (ShelleyPoolreapState era))
-> ShelleyPoolreapState era
-> F (Clause (ShelleyPOOLREAP era) 'Transition)
     (ShelleyPoolreapState era)
forall a b. (a -> b) -> a -> b
$
    UTxOState era
-> ChainAccountState -> CertState era -> ShelleyPoolreapState era
forall era.
UTxOState era
-> ChainAccountState -> CertState era -> ShelleyPoolreapState era
PoolreapState
      UTxOState era
us {utxosDeposited = utxosDeposited us <-> fromCompact (unclaimed <> refunded)}
      ChainAccountState
a {casTreasury = casTreasury a <+> fromCompact unclaimed}
      ( CertState era
cs
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Accounts era -> Identity (Accounts era))
    -> DState era -> Identity (DState era))
-> (Accounts era -> Identity (Accounts era))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
            ((Accounts era -> Identity (Accounts era))
 -> CertState era -> Identity (CertState era))
-> (Accounts era -> Accounts era) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Set (KeyHash 'StakePool) -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Set (KeyHash 'StakePool) -> Accounts era -> Accounts era
removeStakePoolDelegations Set (KeyHash 'StakePool)
retired (Accounts era -> Accounts era)
-> (Accounts era -> Accounts era) -> Accounts era -> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts Map (Credential 'Staking) (CompactForm Coin)
refunds
          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))
-> ((Map (KeyHash 'StakePool) StakePoolState
     -> Identity (Map (KeyHash 'StakePool) StakePoolState))
    -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) StakePoolState
    -> Identity (Map (KeyHash 'StakePool) StakePoolState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool) StakePoolState
 -> Identity (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) StakePoolState
 -> f (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL ((Map (KeyHash 'StakePool) StakePoolState
  -> Identity (Map (KeyHash 'StakePool) StakePoolState))
 -> CertState era -> Identity (CertState era))
-> (Map (KeyHash 'StakePool) StakePoolState
    -> Map (KeyHash 'StakePool) StakePoolState)
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (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.withoutKeys` Set (KeyHash 'StakePool)
retired)
          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))
-> ((Map (KeyHash 'StakePool) EpochNo
     -> Identity (Map (KeyHash 'StakePool) EpochNo))
    -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) EpochNo
    -> Identity (Map (KeyHash 'StakePool) EpochNo))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool) EpochNo
 -> Identity (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) EpochNo
 -> f (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> f (PState era)
psRetiringL ((Map (KeyHash 'StakePool) EpochNo
  -> Identity (Map (KeyHash 'StakePool) EpochNo))
 -> CertState era -> Identity (CertState era))
-> (Map (KeyHash 'StakePool) EpochNo
    -> Map (KeyHash 'StakePool) EpochNo)
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map (KeyHash 'StakePool) EpochNo
-> Set (KeyHash 'StakePool) -> Map (KeyHash 'StakePool) EpochNo
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set (KeyHash 'StakePool)
retired)
          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))
-> ((Set (VRFVerKeyHash 'StakePoolVRF)
     -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
    -> PState era -> Identity (PState era))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (VRFVerKeyHash 'StakePoolVRF)
 -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Set (VRFVerKeyHash 'StakePoolVRF)
 -> f (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> f (PState era)
psVRFKeyHashesL
            ((Set (VRFVerKeyHash 'StakePoolVRF)
  -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
 -> CertState era -> Identity (CertState era))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Set (VRFVerKeyHash 'StakePoolVRF))
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (VRFVerKeyHash 'StakePoolVRF)
retiredVRFs) (Set (VRFVerKeyHash 'StakePoolVRF)
 -> Set (VRFVerKeyHash 'StakePoolVRF))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Set (VRFVerKeyHash 'StakePoolVRF))
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (VRFVerKeyHash 'StakePoolVRF)
danglingVrfKeyHashes))
      )

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