{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 (ProtVer (..), 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)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayDELEG, ConwayEra)
import Cardano.Ledger.Conway.State (
  ConwayEraCertState (..),
  vsDRepsL,
 )
import Cardano.Ledger.Conway.TxCert (
  ConwayDelegCert (ConwayDelegCert, ConwayRegCert, ConwayRegDelegCert, ConwayUnRegCert),
  Delegatee (DelegStake, DelegStakeVote, DelegVote),
 )
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRep (..), DRepState (..))
import Cardano.Ledger.PoolParams (PoolParams)
import qualified Cardano.Ledger.Shelley.HardForks as HF
import Cardano.Ledger.State (
  EraCertState (..),
  dsUnifiedL,
 )
import qualified Cardano.Ledger.UMap as UM
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) PoolParams
cdePools :: Map (KeyHash 'StakePool) PoolParams
  }
  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) PoolParams
_) =
    let ConwayDelegEnv {Map (KeyHash 'StakePool) PoolParams
PParams era
cdePParams :: forall era. ConwayDelegEnv era -> PParams era
cdePools :: forall era.
ConwayDelegEnv era -> Map (KeyHash 'StakePool) PoolParams
cdePParams :: PParams era
cdePools :: Map (KeyHash 'StakePool) PoolParams
..} = 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) PoolParams -> ConwayDelegEnv era)
-> Encode
     ('Closed 'Dense)
     (PParams era
      -> Map (KeyHash 'StakePool) PoolParams -> ConwayDelegEnv era)
forall t. t -> Encode ('Closed 'Dense) t
Rec PParams era
-> Map (KeyHash 'StakePool) PoolParams -> ConwayDelegEnv era
forall era.
PParams era
-> Map (KeyHash 'StakePool) PoolParams -> ConwayDelegEnv era
ConwayDelegEnv
            Encode
  ('Closed 'Dense)
  (PParams era
   -> Map (KeyHash 'StakePool) PoolParams -> ConwayDelegEnv era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode
     ('Closed 'Dense)
     (Map (KeyHash 'StakePool) PoolParams -> 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) PoolParams -> ConwayDelegEnv era)
-> Encode ('Closed 'Dense) (Map (KeyHash 'StakePool) PoolParams)
-> 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) PoolParams
-> Encode ('Closed 'Dense) (Map (KeyHash 'StakePool) PoolParams)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (KeyHash 'StakePool) PoolParams
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)
  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

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
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) PoolParams
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
    dsUnified :: UMap
dsUnified = CertState era
State (ConwayDELEG era)
certState CertState era -> Getting UMap (CertState era) UMap -> UMap
forall s a. s -> Getting a s a -> a
^. (DState era -> Const UMap (DState era))
-> CertState era -> Const UMap (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const UMap (DState era))
 -> CertState era -> Const UMap (CertState era))
-> ((UMap -> Const UMap UMap)
    -> DState era -> Const UMap (DState era))
-> Getting UMap (CertState era) UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const UMap UMap) -> DState era -> Const UMap (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL
    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
    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 ()
?! Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
deposit
    registerStakeCredential :: Credential 'Staking -> UMap
registerStakeCredential Credential 'Staking
stakeCred =
      let rdPair :: RDPair
rdPair = CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0) (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError Coin
ppKeyDeposit)
       in Credential 'Staking
-> RDPair -> UView (Credential 'Staking) RDPair -> UMap
forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
stakeCred RDPair
rdPair (UView (Credential 'Staking) RDPair -> UMap)
-> UView (Credential 'Staking) RDPair -> UMap
forall a b. (a -> b) -> a -> b
$ UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
dsUnified
    checkStakeKeyNotRegistered :: Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred =
      Credential 'Staking -> UView (Credential 'Staking) RDPair -> Bool
forall k v. k -> UView k v -> Bool
UM.notMember Credential 'Staking
stakeCred (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
dsUnified) 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 mUMElem :: Maybe UMElem
mUMElem = Credential 'Staking
-> Map (Credential 'Staking) UMElem -> Maybe UMElem
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
stakeCred (UMap -> Map (Credential 'Staking) UMElem
UM.umElems UMap
dsUnified)
      Maybe UMElem -> Bool
forall a. Maybe a -> Bool
isJust Maybe UMElem
mUMElem 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 UMElem
mUMElem Maybe UMElem -> (UMElem -> 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
>>= UMElem -> Maybe Delegatee
umElemToDelegatee
    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) PoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'StakePool) PoolParams
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
HF.bootstrapPhase (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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> UMap -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking -> UMap
registerStakeCredential Credential 'Staking
stakeCred
    ConwayUnRegCert Credential 'Staking
stakeCred StrictMaybe Coin
sMayRefund -> do
      let (Maybe UMElem
mUMElem, UMap
umap) = Credential 'Staking -> UMap -> (Maybe UMElem, UMap)
UM.extractStakingCredential Credential 'Staking
stakeCred UMap
dsUnified
          mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe UMElem
mUMElem Maybe UMElem -> (UMElem -> 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
>>= UMElem -> Maybe Delegatee
umElemToDelegatee
          checkInvalidRefund :: Maybe Coin
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:
            UM.UMElem (SJust RDPair
rd) Set Ptr
_ StrictMaybe (KeyHash 'StakePool)
_ StrictMaybe DRep
_ <- Maybe UMElem
mUMElem
            -- we return offending refund only when it doesn't match the expected one:
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Coin
suppliedRefund Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
UM.fromCompact (RDPair -> CompactForm Coin
UM.rdDeposit RDPair
rd))
            Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
suppliedRefund
          checkStakeKeyHasZeroRewardBalance :: Maybe Coin
checkStakeKeyHasZeroRewardBalance = do
            UM.UMElem (SJust RDPair
rd) Set Ptr
_ StrictMaybe (KeyHash 'StakePool)
_ StrictMaybe DRep
_ <- Maybe UMElem
mUMElem
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RDPair -> CompactForm Coin
UM.rdReward RDPair
rd 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
UM.fromCompact (RDPair -> CompactForm Coin
UM.rdReward RDPair
rd)
      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
checkInvalidRefund Coin -> PredicateFailure (ConwayDELEG era)
Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG
      Maybe UMElem -> Bool
forall a. Maybe a -> Bool
isJust Maybe UMElem
mUMElem 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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> UMap -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap
umap
    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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> UMap -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking -> UMap
registerStakeCredential Credential 'Staking
stakeCred

-- | 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
    mUMElem :: Maybe UMElem
mUMElem = Credential 'Staking
-> Map (Credential 'Staking) UMElem -> Maybe UMElem
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
stakeCred (UMap -> Map (Credential 'Staking) UMElem
UM.umElems (CertState era
certState CertState era -> Getting UMap (CertState era) UMap -> UMap
forall s a. s -> Getting a s a -> a
^. (DState era -> Const UMap (DState era))
-> CertState era -> Const UMap (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const UMap (DState era))
 -> CertState era -> Const UMap (CertState era))
-> ((UMap -> Const UMap UMap)
    -> DState era -> Const UMap (DState era))
-> Getting UMap (CertState era) UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const UMap UMap) -> DState era -> Const UMap (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL))
    mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe UMElem
mUMElem Maybe UMElem -> (UMElem -> 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
>>= UMElem -> Maybe Delegatee
umElemToDelegatee

-- | 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
sPool 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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> (UMap -> UMap) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap
umap ->
          UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
umap UView (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool) -> UMap
forall k v. UView k v -> Map k v -> UMap
UM.⨃ Credential 'Staking
-> KeyHash 'StakePool
-> Map (Credential 'Staking) (KeyHash 'StakePool)
forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
stakeCred KeyHash 'StakePool
sPool
    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))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> (UMap -> UMap) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap
umap ->
                UMap -> UView (Credential 'Staking) DRep
UM.DRepUView UMap
umap UView (Credential 'Staking) DRep
-> Map (Credential 'Staking) DRep -> UMap
forall k v. UView k v -> Map k v -> UMap
UM.⨃ Credential 'Staking -> DRep -> Map (Credential 'Staking) DRep
forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
stakeCred DRep
dRep
          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'

umElemToDelegatee :: UM.UMElem -> Maybe Delegatee
umElemToDelegatee :: UMElem -> Maybe Delegatee
umElemToDelegatee (UM.UMElem StrictMaybe RDPair
_ Set Ptr
_ StrictMaybe (KeyHash 'StakePool)
mPool StrictMaybe DRep
mDRep) =
  case (StrictMaybe (KeyHash 'StakePool)
mPool, StrictMaybe DRep
mDRep) of
    (StrictMaybe (KeyHash 'StakePool)
SNothing, StrictMaybe DRep
SNothing) -> Maybe Delegatee
forall a. Maybe a
Nothing
    (SJust KeyHash 'StakePool
pool, StrictMaybe DRep
SNothing) -> Delegatee -> Maybe Delegatee
forall a. a -> Maybe a
Just (Delegatee -> Maybe Delegatee) -> Delegatee -> Maybe Delegatee
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Delegatee
DelegStake KeyHash 'StakePool
pool
    (StrictMaybe (KeyHash 'StakePool)
SNothing, SJust DRep
dRep) -> Delegatee -> Maybe Delegatee
forall a. a -> Maybe a
Just (Delegatee -> Maybe Delegatee) -> Delegatee -> Maybe Delegatee
forall a b. (a -> b) -> a -> b
$ DRep -> Delegatee
DelegVote DRep
dRep
    (SJust KeyHash 'StakePool
pool, SJust DRep
dRep) -> Delegatee -> Maybe Delegatee
forall a. a -> Maybe a
Just (Delegatee -> Maybe Delegatee) -> Delegatee -> Maybe Delegatee
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> DRep -> Delegatee
DelegStakeVote KeyHash 'StakePool
pool DRep
dRep

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