{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Deleg (
  ConwayDELEG,
  ConwayDelegPredFailure (..),
  ConwayDelegEnv (..),
  processDelegation,
) where

import Cardano.Ledger.BaseTypes (
  Mismatch (..),
  ProtVer (..),
  Relation (RelEQ),
  ShelleyBase,
  StrictMaybe (..),
  natVersion,
 )
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
  Decode (From, Invalid, SumD, Summands),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin, compactCoinOrError)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (
  ConwayDELEG,
  ConwayEra,
  hardforkConwayBootstrapPhase,
  hardforkConwayDELEGIncorrectDepositsAndRefunds,
 )
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Conway.TxCert (
  ConwayDelegCert (ConwayDelegCert, ConwayRegCert, ConwayRegDelegCert, ConwayUnRegCert),
  Delegatee (DelegStake, DelegStakeVote, DelegVote),
 )
import Cardano.Ledger.Credential (Credential)
import Control.DeepSeq (NFData)
import Control.Monad (forM_, guard, unless)
import Control.State.Transition (
  BaseM,
  Environment,
  Event,
  PredicateFailure,
  STS (..),
  Signal,
  State,
  TRC (TRC),
  TransitionRule,
  failOnJust,
  judgmentContext,
  transitionRules,
  (?!),
 )
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Set as Set
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (.~), (?~), (^.))
import NoThunks.Class (NoThunks)

data ConwayDelegEnv era = ConwayDelegEnv
  { forall era. ConwayDelegEnv era -> PParams era
cdePParams :: PParams era
  , forall era.
ConwayDelegEnv era -> Map (KeyHash 'StakePool) StakePoolState
cdePools :: Map (KeyHash 'StakePool) StakePoolState
  }
  deriving ((forall x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x)
-> (forall x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era)
-> Generic (ConwayDelegEnv era)
forall x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
forall x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
forall era x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
$cfrom :: forall era x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
from :: forall x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
$cto :: forall era x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
to :: forall x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
Generic)

instance EraPParams era => EncCBOR (ConwayDelegEnv era) where
  encCBOR :: ConwayDelegEnv era -> Encoding
encCBOR x :: ConwayDelegEnv era
x@(ConwayDelegEnv PParams era
_ Map (KeyHash 'StakePool) StakePoolState
_) =
    let ConwayDelegEnv {Map (KeyHash 'StakePool) StakePoolState
PParams era
cdePParams :: forall era. ConwayDelegEnv era -> PParams era
cdePools :: forall era.
ConwayDelegEnv era -> Map (KeyHash 'StakePool) StakePoolState
cdePParams :: PParams era
cdePools :: Map (KeyHash 'StakePool) StakePoolState
..} = ConwayDelegEnv era
x
     in Encode ('Closed 'Dense) (ConwayDelegEnv era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (ConwayDelegEnv era) -> Encoding)
-> Encode ('Closed 'Dense) (ConwayDelegEnv era) -> Encoding
forall a b. (a -> b) -> a -> b
$
          (PParams era
 -> Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era)
-> Encode
     ('Closed 'Dense)
     (PParams era
      -> Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era)
forall t. t -> Encode ('Closed 'Dense) t
Rec PParams era
-> Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era
forall era.
PParams era
-> Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era
ConwayDelegEnv
            Encode
  ('Closed 'Dense)
  (PParams era
   -> Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode
     ('Closed 'Dense)
     (Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PParams era -> Encode ('Closed 'Dense) (PParams era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
cdePParams
            Encode
  ('Closed 'Dense)
  (Map (KeyHash 'StakePool) StakePoolState -> ConwayDelegEnv era)
-> Encode
     ('Closed 'Dense) (Map (KeyHash 'StakePool) StakePoolState)
-> Encode ('Closed 'Dense) (ConwayDelegEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Map (KeyHash 'StakePool) StakePoolState
-> Encode
     ('Closed 'Dense) (Map (KeyHash 'StakePool) StakePoolState)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (KeyHash 'StakePool) StakePoolState
cdePools

instance (Era era, NFData (PParams era)) => NFData (ConwayDelegEnv era)

deriving instance Eq (PParams era) => Eq (ConwayDelegEnv era)

deriving instance Show (PParams era) => Show (ConwayDelegEnv era)

data ConwayDelegPredFailure era
  = IncorrectDepositDELEG Coin
  | StakeKeyRegisteredDELEG (Credential 'Staking)
  | StakeKeyNotRegisteredDELEG (Credential 'Staking)
  | StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
  | DelegateeDRepNotRegisteredDELEG (Credential 'DRepRole)
  | DelegateeStakePoolNotRegisteredDELEG (KeyHash 'StakePool)
  | DepositIncorrectDELEG (Mismatch 'RelEQ Coin)
  | RefundIncorrectDELEG (Mismatch 'RelEQ Coin)
  deriving (Int -> ConwayDelegPredFailure era -> ShowS
[ConwayDelegPredFailure era] -> ShowS
ConwayDelegPredFailure era -> String
(Int -> ConwayDelegPredFailure era -> ShowS)
-> (ConwayDelegPredFailure era -> String)
-> ([ConwayDelegPredFailure era] -> ShowS)
-> Show (ConwayDelegPredFailure era)
forall era. Int -> ConwayDelegPredFailure era -> ShowS
forall era. [ConwayDelegPredFailure era] -> ShowS
forall era. ConwayDelegPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ConwayDelegPredFailure era -> ShowS
showsPrec :: Int -> ConwayDelegPredFailure era -> ShowS
$cshow :: forall era. ConwayDelegPredFailure era -> String
show :: ConwayDelegPredFailure era -> String
$cshowList :: forall era. [ConwayDelegPredFailure era] -> ShowS
showList :: [ConwayDelegPredFailure era] -> ShowS
Show, ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
(ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool)
-> (ConwayDelegPredFailure era
    -> ConwayDelegPredFailure era -> Bool)
-> Eq (ConwayDelegPredFailure era)
forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
== :: ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
$c/= :: forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
/= :: ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
Eq, (forall x.
 ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x)
-> (forall x.
    Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era)
-> Generic (ConwayDelegPredFailure era)
forall x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
forall x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
forall era x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
$cfrom :: forall era x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
from :: forall x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
$cto :: forall era x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
to :: forall x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
Generic)

type instance EraRuleFailure "DELEG" ConwayEra = ConwayDelegPredFailure ConwayEra

type instance EraRuleEvent "DELEG" ConwayEra = VoidEraRule "DELEG" ConwayEra

instance InjectRuleFailure "DELEG" ConwayDelegPredFailure ConwayEra

instance NoThunks (ConwayDelegPredFailure era)

instance NFData (ConwayDelegPredFailure era)

instance Era era => EncCBOR (ConwayDelegPredFailure era) where
  encCBOR :: ConwayDelegPredFailure era -> Encoding
encCBOR =
    Encode 'Open (ConwayDelegPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode 'Open (ConwayDelegPredFailure era) -> Encoding)
-> (ConwayDelegPredFailure era
    -> Encode 'Open (ConwayDelegPredFailure era))
-> ConwayDelegPredFailure era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      IncorrectDepositDELEG Coin
mCoin ->
        (Coin -> ConwayDelegPredFailure era)
-> Word -> Encode 'Open (Coin -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG @era) Word
1 Encode 'Open (Coin -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) Coin
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Coin -> Encode ('Closed 'Dense) Coin
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
mCoin
      StakeKeyRegisteredDELEG Credential 'Staking
stakeCred ->
        (Credential 'Staking -> ConwayDelegPredFailure era)
-> Word
-> Encode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG @era) Word
2 Encode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (Credential 'Staking)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Credential 'Staking
-> Encode ('Closed 'Dense) (Credential 'Staking)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'Staking
stakeCred
      StakeKeyNotRegisteredDELEG Credential 'Staking
stakeCred ->
        (Credential 'Staking -> ConwayDelegPredFailure era)
-> Word
-> Encode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG @era) Word
3 Encode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (Credential 'Staking)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Credential 'Staking
-> Encode ('Closed 'Dense) (Credential 'Staking)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'Staking
stakeCred
      StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
mCoin ->
        (Coin -> ConwayDelegPredFailure era)
-> Word -> Encode 'Open (Coin -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG @era) Word
4 Encode 'Open (Coin -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) Coin
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Coin -> Encode ('Closed 'Dense) Coin
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
mCoin
      DelegateeDRepNotRegisteredDELEG Credential 'DRepRole
delegatee ->
        (Credential 'DRepRole -> ConwayDelegPredFailure era)
-> Word
-> Encode
     'Open (Credential 'DRepRole -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'DRepRole -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG @era) Word
5 Encode 'Open (Credential 'DRepRole -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (Credential 'DRepRole)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Credential 'DRepRole
-> Encode ('Closed 'Dense) (Credential 'DRepRole)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'DRepRole
delegatee
      DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool
delegatee ->
        (KeyHash 'StakePool -> ConwayDelegPredFailure era)
-> Word
-> Encode 'Open (KeyHash 'StakePool -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG @era) Word
6 Encode 'Open (KeyHash 'StakePool -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (KeyHash 'StakePool)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> KeyHash 'StakePool -> Encode ('Closed 'Dense) (KeyHash 'StakePool)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'StakePool
delegatee
      DepositIncorrectDELEG Mismatch 'RelEQ Coin
mm ->
        (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Word
-> Encode
     'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
DepositIncorrectDELEG @era) Word
7 Encode 'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (Mismatch 'RelEQ Coin)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Mismatch 'RelEQ Coin
-> Encode ('Closed 'Dense) (Mismatch 'RelEQ Coin)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Mismatch 'RelEQ Coin
mm
      RefundIncorrectDELEG Mismatch 'RelEQ Coin
mm ->
        (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Word
-> Encode
     'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
RefundIncorrectDELEG @era) Word
8 Encode 'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Encode ('Closed 'Dense) (Mismatch 'RelEQ Coin)
-> Encode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Mismatch 'RelEQ Coin
-> Encode ('Closed 'Dense) (Mismatch 'RelEQ Coin)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Mismatch 'RelEQ Coin
mm

instance Era era => DecCBOR (ConwayDelegPredFailure era) where
  decCBOR :: forall s. Decoder s (ConwayDelegPredFailure era)
decCBOR = Decode ('Closed 'Dense) (ConwayDelegPredFailure era)
-> Decoder s (ConwayDelegPredFailure era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (ConwayDelegPredFailure era)
 -> Decoder s (ConwayDelegPredFailure era))
-> Decode ('Closed 'Dense) (ConwayDelegPredFailure era)
-> Decoder s (ConwayDelegPredFailure era)
forall a b. (a -> b) -> a -> b
$ Text
-> (Word -> Decode 'Open (ConwayDelegPredFailure era))
-> Decode ('Closed 'Dense) (ConwayDelegPredFailure era)
forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ConwayDelegPredFailure" ((Word -> Decode 'Open (ConwayDelegPredFailure era))
 -> Decode ('Closed 'Dense) (ConwayDelegPredFailure era))
-> (Word -> Decode 'Open (ConwayDelegPredFailure era))
-> Decode ('Closed 'Dense) (ConwayDelegPredFailure era)
forall a b. (a -> b) -> a -> b
$ \case
    Word
1 -> (Coin -> ConwayDelegPredFailure era)
-> Decode 'Open (Coin -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Decode 'Open (Coin -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) Coin
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> (Credential 'Staking -> ConwayDelegPredFailure era)
-> Decode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Credential 'Staking -> ConwayDelegPredFailure era
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Decode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (Credential 'Staking)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Credential 'Staking)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
3 -> (Credential 'Staking -> ConwayDelegPredFailure era)
-> Decode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Credential 'Staking -> ConwayDelegPredFailure era
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Decode 'Open (Credential 'Staking -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (Credential 'Staking)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Credential 'Staking)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
4 -> (Coin -> ConwayDelegPredFailure era)
-> Decode 'Open (Coin -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG Decode 'Open (Coin -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) Coin
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
5 -> (Credential 'DRepRole -> ConwayDelegPredFailure era)
-> Decode
     'Open (Credential 'DRepRole -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Credential 'DRepRole -> ConwayDelegPredFailure era
forall era. Credential 'DRepRole -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Decode 'Open (Credential 'DRepRole -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (Credential 'DRepRole)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Credential 'DRepRole)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
6 -> (KeyHash 'StakePool -> ConwayDelegPredFailure era)
-> Decode 'Open (KeyHash 'StakePool -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD KeyHash 'StakePool -> ConwayDelegPredFailure era
forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG Decode 'Open (KeyHash 'StakePool -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (KeyHash 'StakePool)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (KeyHash 'StakePool)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
7 -> (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Decode
     'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
DepositIncorrectDELEG Decode 'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (Mismatch 'RelEQ Coin)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Mismatch 'RelEQ Coin)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
8 -> (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Decode
     'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
forall t. t -> Decode 'Open t
SumD Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
RefundIncorrectDELEG Decode 'Open (Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era)
-> Decode ('Closed Any) (Mismatch 'RelEQ Coin)
-> Decode 'Open (ConwayDelegPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Mismatch 'RelEQ Coin)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> Word -> Decode 'Open (ConwayDelegPredFailure era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance
  ( EraPParams era
  , State (EraRule "DELEG" era) ~ CertState era
  , Signal (EraRule "DELEG" era) ~ ConwayDelegCert
  , Environment (EraRule "DELEG" era) ~ ConwayDelegEnv era
  , EraRule "DELEG" era ~ ConwayDELEG era
  , EraCertState era
  , ConwayEraCertState era
  ) =>
  STS (ConwayDELEG era)
  where
  type State (ConwayDELEG era) = CertState era
  type Signal (ConwayDELEG era) = ConwayDelegCert
  type Environment (ConwayDELEG era) = ConwayDelegEnv era
  type BaseM (ConwayDELEG era) = ShelleyBase
  type PredicateFailure (ConwayDELEG era) = ConwayDelegPredFailure era
  type Event (ConwayDELEG era) = Void

  transitionRules :: [TransitionRule (ConwayDELEG era)]
transitionRules = [forall era.
(EraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayDELEG era)
conwayDelegTransition @era]

conwayDelegTransition ::
  (EraPParams era, ConwayEraCertState era) => TransitionRule (ConwayDELEG era)
conwayDelegTransition :: forall era.
(EraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayDELEG era)
conwayDelegTransition = do
  TRC
    ( ConwayDelegEnv PParams era
pp Map (KeyHash 'StakePool) StakePoolState
pools
      , State (ConwayDELEG era)
certState
      , Signal (ConwayDELEG era)
cert
      ) <-
    Rule
  (ConwayDELEG era)
  'Transition
  (RuleContext 'Transition (ConwayDELEG era))
F (Clause (ConwayDELEG era) 'Transition) (TRC (ConwayDELEG era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let
    accounts :: Accounts era
accounts = CertState era
State (ConwayDELEG era)
certState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    ppKeyDeposit :: Coin
ppKeyDeposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
    ppKeyDepositCompact :: CompactForm Coin
ppKeyDepositCompact = HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Coin
ppKeyDeposit
    pv :: ProtVer
pv = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
    checkDepositAgainstPParams :: Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams Coin
deposit =
      Coin
deposit
        Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
ppKeyDeposit
          Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! if ProtVer -> Bool
hardforkConwayDELEGIncorrectDepositsAndRefunds ProtVer
pv
            then
              Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
DepositIncorrectDELEG
                Mismatch
                  { mismatchSupplied :: Coin
mismatchSupplied = Coin
deposit
                  , mismatchExpected :: Coin
mismatchExpected = Coin
ppKeyDeposit
                  }
            else Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
deposit
    checkStakeKeyNotRegistered :: Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred =
      Bool -> Bool
not (Credential 'Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential 'Staking -> Accounts era -> Bool
isAccountRegistered Credential 'Staking
stakeCred Accounts era
accounts) Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Credential 'Staking -> ConwayDelegPredFailure era
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential 'Staking
stakeCred
    checkStakeKeyIsRegistered :: Credential 'Staking
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
checkStakeKeyIsRegistered Credential 'Staking
stakeCred = do
      let mAccountState :: Maybe (AccountState era)
mAccountState = Credential 'Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential 'Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential 'Staking
stakeCred Accounts era
accounts
      Maybe (AccountState era) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (AccountState era)
mAccountState Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Credential 'Staking -> ConwayDelegPredFailure era
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking
stakeCred
      Maybe Delegatee
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Delegatee
 -> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee))
-> Maybe Delegatee
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
forall a b. (a -> b) -> a -> b
$ Maybe (AccountState era)
mAccountState Maybe (AccountState era)
-> (AccountState era -> Maybe Delegatee) -> Maybe Delegatee
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AccountState era -> Maybe Delegatee
forall era.
ConwayEraAccounts era =>
AccountState era -> Maybe Delegatee
accountStateDelegatee
    checkStakeDelegateeRegistered :: Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered =
      let checkPoolRegistered :: KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool =
            KeyHash 'StakePool
targetPool KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'StakePool) StakePoolState
pools Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool -> ConwayDelegPredFailure era
forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool
targetPool
          checkDRepRegistered :: DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered = \case
            DRep
DRepAlwaysAbstain -> () -> Rule (ConwayDELEG era) 'Transition ()
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            DRep
DRepAlwaysNoConfidence -> () -> Rule (ConwayDELEG era) 'Transition ()
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            DRepCredential Credential 'DRepRole
targetDRep -> do
              let dReps :: Map (Credential 'DRepRole) DRepState
dReps = CertState era
State (ConwayDELEG era)
certState CertState era
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
forall s a. s -> Getting a s a -> a
^. (VState era
 -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> CertState era
-> Const (Map (Credential 'DRepRole) DRepState) (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era
  -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
 -> CertState era
 -> Const (Map (Credential 'DRepRole) DRepState) (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Const
          (Map (Credential 'DRepRole) DRepState)
          (Map (Credential 'DRepRole) DRepState))
    -> VState era
    -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Const
      (Map (Credential 'DRepRole) DRepState)
      (Map (Credential 'DRepRole) DRepState))
-> VState era
-> Const (Map (Credential 'DRepRole) DRepState) (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
              Bool
-> Rule (ConwayDELEG era) 'Transition ()
-> Rule (ConwayDELEG era) 'Transition ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtVer -> Bool
hardforkConwayBootstrapPhase (PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL)) (Rule (ConwayDELEG era) 'Transition ()
 -> Rule (ConwayDELEG era) 'Transition ())
-> Rule (ConwayDELEG era) 'Transition ()
-> Rule (ConwayDELEG era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
                Credential 'DRepRole
targetDRep Credential 'DRepRole
-> Map (Credential 'DRepRole) DRepState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Credential 'DRepRole) DRepState
dReps Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Credential 'DRepRole -> ConwayDelegPredFailure era
forall era. Credential 'DRepRole -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Credential 'DRepRole
targetDRep
       in \case
            DelegStake KeyHash 'StakePool
targetPool -> KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool
            DelegStakeVote KeyHash 'StakePool
targetPool DRep
targetDRep ->
              KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool Rule (ConwayDELEG era) 'Transition ()
-> Rule (ConwayDELEG era) 'Transition ()
-> Rule (ConwayDELEG era) 'Transition ()
forall a b.
F (Clause (ConwayDELEG era) 'Transition) a
-> F (Clause (ConwayDELEG era) 'Transition) b
-> F (Clause (ConwayDELEG era) 'Transition) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep
targetDRep
            DelegVote DRep
targetDRep -> DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep
targetDRep
  case Signal (ConwayDELEG era)
cert of
    ConwayRegCert Credential 'Staking
stakeCred StrictMaybe Coin
sMayDeposit -> do
      StrictMaybe Coin
-> (Coin -> Rule (ConwayDELEG era) 'Transition ())
-> Rule (ConwayDELEG era) 'Transition ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe Coin
sMayDeposit Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams
      Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred
      CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertState era
 -> F (Clause (ConwayDELEG era) 'Transition) (CertState era))
-> CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a b. (a -> b) -> a -> b
$
        CertState era
State (ConwayDELEG era)
certState
          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
%~ Credential 'Staking
-> CompactForm Coin
-> Maybe Delegatee
-> Accounts era
-> Accounts era
forall era.
ConwayEraAccounts era =>
Credential 'Staking
-> CompactForm Coin
-> Maybe Delegatee
-> Accounts era
-> Accounts era
registerConwayAccount Credential 'Staking
stakeCred CompactForm Coin
ppKeyDepositCompact Maybe Delegatee
forall a. Maybe a
Nothing
    ConwayUnRegCert Credential 'Staking
stakeCred StrictMaybe Coin
sMayRefund -> do
      let (Maybe (AccountState era)
mAccountState, Accounts era
newAccounts) = Credential 'Staking
-> Accounts era -> (Maybe (AccountState era), Accounts era)
forall era.
EraAccounts era =>
Credential 'Staking
-> Accounts era -> (Maybe (AccountState era), Accounts era)
unregisterConwayAccount Credential 'Staking
stakeCred Accounts era
accounts
          mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe (AccountState era)
mAccountState Maybe (AccountState era)
-> (AccountState era -> Maybe Delegatee) -> Maybe Delegatee
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AccountState era -> Maybe Delegatee
forall era.
ConwayEraAccounts era =>
AccountState era -> Maybe Delegatee
accountStateDelegatee
          checkInvalidRefund :: Maybe (ConwayDelegPredFailure era)
checkInvalidRefund = do
            SJust Coin
suppliedRefund <- StrictMaybe Coin -> Maybe (StrictMaybe Coin)
forall a. a -> Maybe a
Just StrictMaybe Coin
sMayRefund
            -- we don't want to report invalid refund when stake credential is not registered:
            AccountState era
accountState <- Maybe (AccountState era)
mAccountState
            -- we return offending refund only when it doesn't match the expected one:
            let expectedRefund :: Coin
expectedRefund = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Coin
suppliedRefund Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Coin
expectedRefund)
            ConwayDelegPredFailure era -> Maybe (ConwayDelegPredFailure era)
forall a. a -> Maybe a
Just (ConwayDelegPredFailure era -> Maybe (ConwayDelegPredFailure era))
-> ConwayDelegPredFailure era -> Maybe (ConwayDelegPredFailure era)
forall a b. (a -> b) -> a -> b
$
              if ProtVer -> Bool
hardforkConwayDELEGIncorrectDepositsAndRefunds ProtVer
pv
                then
                  Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
forall era. Mismatch 'RelEQ Coin -> ConwayDelegPredFailure era
RefundIncorrectDELEG
                    Mismatch
                      { mismatchSupplied :: Coin
mismatchSupplied = Coin
suppliedRefund
                      , mismatchExpected :: Coin
mismatchExpected = Coin
expectedRefund
                      }
                else Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
suppliedRefund
          checkStakeKeyHasZeroRewardBalance :: Maybe Coin
checkStakeKeyHasZeroRewardBalance = do
            AccountState era
accountState <- Maybe (AccountState era)
mAccountState
            let balanceCompact :: CompactForm Coin
balanceCompact = AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CompactForm Coin
balanceCompact CompactForm Coin -> CompactForm Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= CompactForm Coin
forall a. Monoid a => a
mempty)
            Coin -> Maybe Coin
forall a. a -> Maybe a
Just (Coin -> Maybe Coin) -> Coin -> Maybe Coin
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
balanceCompact
      Maybe (ConwayDelegPredFailure era)
-> (ConwayDelegPredFailure era
    -> PredicateFailure (ConwayDELEG era))
-> Rule (ConwayDELEG era) 'Transition ()
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe (ConwayDelegPredFailure era)
checkInvalidRefund ConwayDelegPredFailure era -> PredicateFailure (ConwayDELEG era)
ConwayDelegPredFailure era -> ConwayDelegPredFailure era
forall a. a -> a
id
      Maybe (AccountState era) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (AccountState era)
mAccountState Bool
-> PredicateFailure (ConwayDELEG era)
-> Rule (ConwayDELEG era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Credential 'Staking -> ConwayDelegPredFailure era
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking
stakeCred
      Maybe Coin
-> (Coin -> PredicateFailure (ConwayDELEG era))
-> Rule (ConwayDELEG era) 'Transition ()
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe Coin
checkStakeKeyHasZeroRewardBalance Coin -> PredicateFailure (ConwayDELEG era)
Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG
      CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertState era
 -> F (Clause (ConwayDELEG era) 'Transition) (CertState era))
-> CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a b. (a -> b) -> a -> b
$
        Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
forall era.
ConwayEraCertState era =>
Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee (CertState era -> CertState era) -> CertState era -> CertState era
forall a b. (a -> b) -> a -> b
$
          CertState era
State (ConwayDELEG era)
certState 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 -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Accounts era
newAccounts
    ConwayDelegCert Credential 'Staking
stakeCred Delegatee
delegatee -> do
      Maybe Delegatee
mCurDelegatee <- Credential 'Staking
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
checkStakeKeyIsRegistered Credential 'Staking
stakeCred
      Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee
delegatee
      CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertState era
 -> F (Clause (ConwayDELEG era) 'Transition) (CertState era))
-> CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a b. (a -> b) -> a -> b
$
        Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
forall era.
ConwayEraCertState era =>
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal (ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
delegatee CertState era
State (ConwayDELEG era)
certState
    ConwayRegDelegCert Credential 'Staking
stakeCred Delegatee
delegatee Coin
deposit -> do
      Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams Coin
deposit
      Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred
      Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee
delegatee
      CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayDELEG era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertState era
 -> F (Clause (ConwayDELEG era) 'Transition) (CertState era))
-> CertState era
-> F (Clause (ConwayDELEG era) 'Transition) (CertState era)
forall a b. (a -> b) -> a -> b
$
        Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
forall era.
ConwayEraCertState era =>
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal (ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Credential 'Staking
stakeCred Maybe Delegatee
forall a. Maybe a
Nothing Delegatee
delegatee (CertState era -> CertState era) -> CertState era -> CertState era
forall a b. (a -> b) -> a -> b
$
          CertState era
State (ConwayDELEG era)
certState
            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
%~ Credential 'Staking
-> CompactForm Coin
-> Maybe Delegatee
-> Accounts era
-> Accounts era
forall era.
ConwayEraAccounts era =>
Credential 'Staking
-> CompactForm Coin
-> Maybe Delegatee
-> Accounts era
-> Accounts era
registerConwayAccount Credential 'Staking
stakeCred CompactForm Coin
ppKeyDepositCompact (Delegatee -> Maybe Delegatee
forall a. a -> Maybe a
Just Delegatee
delegatee)

-- | Apply new delegation, while properly cleaning up older delegations. This function
-- does not enforce that delegatee is registered, that has to be handled by the caller.
processDelegation ::
  ConwayEraCertState era =>
  -- | Delegator
  Credential 'Staking ->
  -- | New delegatee
  Delegatee ->
  CertState era ->
  CertState era
processDelegation :: forall era.
ConwayEraCertState era =>
Credential 'Staking -> Delegatee -> CertState era -> CertState era
processDelegation Credential 'Staking
stakeCred Delegatee
newDelegatee !CertState era
certState = CertState era
certState'
  where
    !certState' :: CertState era
certState' = Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
forall era.
ConwayEraCertState era =>
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal Bool
False Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
newDelegatee CertState era
certState
    mAccountState :: Maybe (AccountState era)
mAccountState = Credential 'Staking
-> Map (Credential 'Staking) (AccountState era)
-> Maybe (AccountState era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
stakeCred (CertState era
certState 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)
    mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe (AccountState era)
mAccountState Maybe (AccountState era)
-> (AccountState era -> Maybe Delegatee) -> Maybe Delegatee
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AccountState era -> Maybe Delegatee
forall era.
ConwayEraAccounts era =>
AccountState era -> Maybe Delegatee
accountStateDelegatee

-- | Same as `processDelegation`, except it expects the current delegation supplied as an
-- argument, because in ledger rules we already have it readily available.
processDelegationInternal ::
  ConwayEraCertState era =>
  -- | Preserve the buggy behavior where DRep delegations are not updated correctly (See #4772)
  Bool ->
  -- | Delegator
  Credential 'Staking ->
  -- | Current delegatee for the above stake credential that needs to be cleaned up.
  Maybe Delegatee ->
  -- | New delegatee
  Delegatee ->
  CertState era ->
  CertState era
processDelegationInternal :: forall era.
ConwayEraCertState era =>
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal Bool
preserveIncorrectDelegation Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
newDelegatee =
  case Delegatee
newDelegatee of
    DelegStake KeyHash 'StakePool
sPool -> KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
sPool
    DelegVote DRep
dRep -> DRep -> CertState era -> CertState era
delegVote DRep
dRep
    DelegStakeVote KeyHash 'StakePool
sPool DRep
dRep -> DRep -> CertState era -> CertState era
delegVote DRep
dRep (CertState era -> CertState era)
-> (CertState era -> CertState era)
-> CertState era
-> CertState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
sPool
  where
    delegStake :: KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
stakePool CertState era
cState =
      CertState era
cState
        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
%~ (AccountState era -> AccountState era)
-> Credential 'Staking -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
(AccountState era -> AccountState era)
-> Credential 'Staking -> Accounts era -> Accounts era
adjustAccountState ((Maybe (KeyHash 'StakePool)
 -> Identity (Maybe (KeyHash 'StakePool)))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
stakePoolDelegationAccountStateL ((Maybe (KeyHash 'StakePool)
  -> Identity (Maybe (KeyHash 'StakePool)))
 -> AccountState era -> Identity (AccountState era))
-> KeyHash 'StakePool -> AccountState era -> AccountState era
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ KeyHash 'StakePool
stakePool) Credential 'Staking
stakeCred
    delegVote :: DRep -> CertState era -> CertState era
delegVote DRep
dRep CertState era
cState =
      let cState' :: CertState era
cState' =
            Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
forall era.
ConwayEraCertState era =>
Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee CertState era
cState
              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
%~ (AccountState era -> AccountState era)
-> Credential 'Staking -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
(AccountState era -> AccountState era)
-> Credential 'Staking -> Accounts era -> Accounts era
adjustAccountState ((Maybe DRep -> Identity (Maybe DRep))
-> AccountState era -> Identity (AccountState era)
forall era.
ConwayEraAccounts era =>
Lens' (AccountState era) (Maybe DRep)
Lens' (AccountState era) (Maybe DRep)
dRepDelegationAccountStateL ((Maybe DRep -> Identity (Maybe DRep))
 -> AccountState era -> Identity (AccountState era))
-> DRep -> AccountState era -> AccountState era
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ DRep
dRep) Credential 'Staking
stakeCred
          dReps :: Map (Credential 'DRepRole) DRepState
dReps
            | Bool
preserveIncorrectDelegation = CertState era
cState CertState era
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
forall s a. s -> Getting a s a -> a
^. (VState era
 -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> CertState era
-> Const (Map (Credential 'DRepRole) DRepState) (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era
  -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
 -> CertState era
 -> Const (Map (Credential 'DRepRole) DRepState) (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Const
          (Map (Credential 'DRepRole) DRepState)
          (Map (Credential 'DRepRole) DRepState))
    -> VState era
    -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Const
      (Map (Credential 'DRepRole) DRepState)
      (Map (Credential 'DRepRole) DRepState))
-> VState era
-> Const (Map (Credential 'DRepRole) DRepState) (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
            | Bool
otherwise = CertState era
cState' CertState era
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
forall s a. s -> Getting a s a -> a
^. (VState era
 -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> CertState era
-> Const (Map (Credential 'DRepRole) DRepState) (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era
  -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
 -> CertState era
 -> Const (Map (Credential 'DRepRole) DRepState) (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Const
          (Map (Credential 'DRepRole) DRepState)
          (Map (Credential 'DRepRole) DRepState))
    -> VState era
    -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Const
      (Map (Credential 'DRepRole) DRepState)
      (Map (Credential 'DRepRole) DRepState))
-> VState era
-> Const (Map (Credential 'DRepRole) DRepState) (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
       in case DRep
dRep of
            DRepCredential Credential 'DRepRole
targetDRep
              | Just DRepState
dRepState <- Credential 'DRepRole
-> Map (Credential 'DRepRole) DRepState -> Maybe DRepState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
targetDRep Map (Credential 'DRepRole) DRepState
dReps ->
                  let dRepState' :: DRepState
dRepState' = DRepState
dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)}
                   in CertState era
cState' CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (VState era -> Identity (VState era))
-> CertState era -> Identity (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Identity (VState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Identity (Map (Credential 'DRepRole) DRepState))
    -> VState era -> Identity (VState era))
-> (Map (Credential 'DRepRole) DRepState
    -> Identity (Map (Credential 'DRepRole) DRepState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Identity (Map (Credential 'DRepRole) DRepState))
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL ((Map (Credential 'DRepRole) DRepState
  -> Identity (Map (Credential 'DRepRole) DRepState))
 -> CertState era -> Identity (CertState era))
-> Map (Credential 'DRepRole) DRepState
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'DRepRole
-> DRepState
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole
targetDRep DRepState
dRepState' Map (Credential 'DRepRole) DRepState
dReps
            DRep
_ -> CertState era
cState'

processDRepUnDelegation ::
  ConwayEraCertState era =>
  Credential 'Staking ->
  Maybe Delegatee ->
  CertState era ->
  CertState era
processDRepUnDelegation :: forall era.
ConwayEraCertState era =>
Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
_ Maybe Delegatee
Nothing CertState era
cState = CertState era
cState
processDRepUnDelegation Credential 'Staking
stakeCred (Just Delegatee
delegatee) CertState era
cState =
  case Delegatee
delegatee of
    DelegStake KeyHash 'StakePool
_ -> CertState era
cState
    DelegVote DRep
dRep -> CertState era
cState CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (VState era -> Identity (VState era))
-> CertState era -> Identity (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Identity (VState era))
 -> CertState era -> Identity (CertState era))
-> VState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VState era -> DRep -> VState era
unDelegVote (CertState era
cState CertState era
-> Getting (VState era) (CertState era) (VState era) -> VState era
forall s a. s -> Getting a s a -> a
^. Getting (VState era) (CertState era) (VState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL) DRep
dRep
    DelegStakeVote KeyHash 'StakePool
_sPool DRep
dRep -> CertState era
cState CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (VState era -> Identity (VState era))
-> CertState era -> Identity (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Identity (VState era))
 -> CertState era -> Identity (CertState era))
-> VState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VState era -> DRep -> VState era
unDelegVote (CertState era
cState CertState era
-> Getting (VState era) (CertState era) (VState era) -> VState era
forall s a. s -> Getting a s a -> a
^. Getting (VState era) (CertState era) (VState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL) DRep
dRep
  where
    unDelegVote :: VState era -> DRep -> VState era
unDelegVote VState era
vState = \case
      DRepCredential Credential 'DRepRole
dRepCred ->
        let removeDelegation :: DRepState -> DRepState
removeDelegation DRepState
dRepState =
              DRepState
dRepState {drepDelegs = Set.delete stakeCred (drepDelegs dRepState)}
         in VState era
vState VState era -> (VState era -> VState era) -> VState era
forall a b. a -> (a -> b) -> b
& (Map (Credential 'DRepRole) DRepState
 -> Identity (Map (Credential 'DRepRole) DRepState))
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL ((Map (Credential 'DRepRole) DRepState
  -> Identity (Map (Credential 'DRepRole) DRepState))
 -> VState era -> Identity (VState era))
-> (Map (Credential 'DRepRole) DRepState
    -> Map (Credential 'DRepRole) DRepState)
-> VState era
-> VState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (DRepState -> DRepState)
-> Credential 'DRepRole
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust DRepState -> DRepState
removeDelegation Credential 'DRepRole
dRepCred
      DRep
_ -> VState era
vState