{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Certs (
  ConwayCERTS,
  ConwayCertsPredFailure (..),
  ConwayCertsEvent (..),
  CertsEnv (..),
  updateDormantDRepExpiry,
  updateDormantDRepExpiries,
  updateVotingDRepExpiries,
) where

import Cardano.Ledger.BaseTypes (
  EpochInterval,
  EpochNo (EpochNo),
  Globals (..),
  ShelleyBase,
  StrictMaybe,
  binOpEpochNo,
 )
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (
  ConwayCERT,
  ConwayCERTS,
  ConwayEra,
  hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule,
 )
import Cardano.Ledger.Conway.Governance (
  Committee,
  GovActionPurpose (..),
  GovActionState,
  GovPurposeId,
  Voter (DRepVoter),
  VotingProcedures (unVotingProcedures),
 )
import Cardano.Ledger.Conway.Rules.Cert (CertEnv (CertEnv), ConwayCertEvent, ConwayCertPredFailure)
import Cardano.Ledger.Conway.Rules.Deleg (ConwayDelegPredFailure)
import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure, computeDRepExpiry)
import Cardano.Ledger.Conway.State
import Cardano.Ledger.DRep (drepExpiryL)
import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended (
  Embed (..),
  STS (..),
  TRC (..),
  TransitionRule,
  failOnJust,
  judgmentContext,
  liftSTS,
  trans,
 )
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import Data.Sequence (Seq (..))
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

data CertsEnv era = CertsEnv
  { forall era. CertsEnv era -> Tx era
certsTx :: Tx era
  , forall era. CertsEnv era -> PParams era
certsPParams :: PParams era
  , forall era. CertsEnv era -> EpochNo
certsCurrentEpoch :: EpochNo
  -- ^ Lazy on purpose, because not all certificates need to know the current EpochNo
  , forall era. CertsEnv era -> StrictMaybe (Committee era)
certsCurrentCommittee :: StrictMaybe (Committee era)
  , forall era.
CertsEnv era
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
certsCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
  }
  deriving ((forall x. CertsEnv era -> Rep (CertsEnv era) x)
-> (forall x. Rep (CertsEnv era) x -> CertsEnv era)
-> Generic (CertsEnv era)
forall x. Rep (CertsEnv era) x -> CertsEnv era
forall x. CertsEnv era -> Rep (CertsEnv era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CertsEnv era) x -> CertsEnv era
forall era x. CertsEnv era -> Rep (CertsEnv era) x
$cfrom :: forall era x. CertsEnv era -> Rep (CertsEnv era) x
from :: forall x. CertsEnv era -> Rep (CertsEnv era) x
$cto :: forall era x. Rep (CertsEnv era) x -> CertsEnv era
to :: forall x. Rep (CertsEnv era) x -> CertsEnv era
Generic)

instance EraTx era => EncCBOR (CertsEnv era) where
  encCBOR :: CertsEnv era -> Encoding
encCBOR x :: CertsEnv era
x@(CertsEnv Tx era
_ PParams era
_ EpochNo
_ StrictMaybe (Committee era)
_ Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
_) =
    let CertsEnv {Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
StrictMaybe (Committee era)
Tx era
PParams era
EpochNo
certsTx :: forall era. CertsEnv era -> Tx era
certsPParams :: forall era. CertsEnv era -> PParams era
certsCurrentEpoch :: forall era. CertsEnv era -> EpochNo
certsCurrentCommittee :: forall era. CertsEnv era -> StrictMaybe (Committee era)
certsCommitteeProposals :: forall era.
CertsEnv era
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
certsTx :: Tx era
certsPParams :: PParams era
certsCurrentEpoch :: EpochNo
certsCurrentCommittee :: StrictMaybe (Committee era)
certsCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
..} = CertsEnv era
x
     in Encode ('Closed 'Dense) (CertsEnv era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (CertsEnv era) -> Encoding)
-> Encode ('Closed 'Dense) (CertsEnv era) -> Encoding
forall a b. (a -> b) -> a -> b
$
          (Tx era
 -> PParams era
 -> EpochNo
 -> StrictMaybe (Committee era)
 -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
 -> CertsEnv era)
-> Encode
     ('Closed 'Dense)
     (Tx era
      -> PParams era
      -> EpochNo
      -> StrictMaybe (Committee era)
      -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv era)
forall t. t -> Encode ('Closed 'Dense) t
Rec Tx era
-> PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertsEnv era
forall era.
Tx era
-> PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertsEnv era
CertsEnv
            Encode
  ('Closed 'Dense)
  (Tx era
   -> PParams era
   -> EpochNo
   -> StrictMaybe (Committee era)
   -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
   -> CertsEnv era)
-> Encode ('Closed 'Dense) (Tx era)
-> Encode
     ('Closed 'Dense)
     (PParams era
      -> EpochNo
      -> StrictMaybe (Committee era)
      -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Tx era -> Encode ('Closed 'Dense) (Tx era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Tx era
certsTx
            Encode
  ('Closed 'Dense)
  (PParams era
   -> EpochNo
   -> StrictMaybe (Committee era)
   -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
   -> CertsEnv era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode
     ('Closed 'Dense)
     (EpochNo
      -> StrictMaybe (Committee era)
      -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv 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
certsPParams
            Encode
  ('Closed 'Dense)
  (EpochNo
   -> StrictMaybe (Committee era)
   -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
   -> CertsEnv era)
-> Encode ('Closed 'Dense) EpochNo
-> Encode
     ('Closed 'Dense)
     (StrictMaybe (Committee era)
      -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> EpochNo -> Encode ('Closed 'Dense) EpochNo
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
certsCurrentEpoch
            Encode
  ('Closed 'Dense)
  (StrictMaybe (Committee era)
   -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
   -> CertsEnv era)
-> Encode ('Closed 'Dense) (StrictMaybe (Committee era))
-> Encode
     ('Closed 'Dense)
     (Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> StrictMaybe (Committee era)
-> Encode ('Closed 'Dense) (StrictMaybe (Committee era))
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe (Committee era)
certsCurrentCommittee
            Encode
  ('Closed 'Dense)
  (Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
   -> CertsEnv era)
-> Encode
     ('Closed 'Dense)
     (Map (GovPurposeId 'CommitteePurpose) (GovActionState era))
-> Encode ('Closed 'Dense) (CertsEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> Encode
     ('Closed 'Dense)
     (Map (GovPurposeId 'CommitteePurpose) (GovActionState era))
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
certsCommitteeProposals

deriving instance (EraPParams era, Eq (Tx era)) => Eq (CertsEnv era)

deriving instance (EraPParams era, Show (Tx era)) => Show (CertsEnv era)

instance (EraPParams era, NFData (Tx era)) => NFData (CertsEnv era)

data ConwayCertsPredFailure era
  = -- | Withdrawals that are missing or do not withdraw the entire amount (pv < 11)
    WithdrawalsNotInRewardsCERTS Withdrawals
  | -- | CERT rule subtransition Failures
    CertFailure (PredicateFailure (EraRule "CERT" era))
  deriving ((forall x.
 ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x)
-> (forall x.
    Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era)
-> Generic (ConwayCertsPredFailure era)
forall x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
forall x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
forall era x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
$cfrom :: forall era x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
from :: forall x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
$cto :: forall era x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
to :: forall x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
Generic)

type instance EraRuleFailure "CERTS" ConwayEra = ConwayCertsPredFailure ConwayEra

type instance EraRuleEvent "CERTS" ConwayEra = ConwayCertsEvent ConwayEra

instance InjectRuleFailure "CERTS" ConwayCertsPredFailure ConwayEra

instance InjectRuleFailure "CERTS" ConwayCertPredFailure ConwayEra where
  injectFailure :: ConwayCertPredFailure ConwayEra -> EraRuleFailure "CERTS" ConwayEra
injectFailure = PredicateFailure (EraRule "CERT" ConwayEra)
-> ConwayCertsPredFailure ConwayEra
ConwayCertPredFailure ConwayEra -> EraRuleFailure "CERTS" ConwayEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure

instance InjectRuleFailure "CERTS" ConwayDelegPredFailure ConwayEra where
  injectFailure :: ConwayDelegPredFailure ConwayEra
-> EraRuleFailure "CERTS" ConwayEra
injectFailure = PredicateFailure (EraRule "CERT" ConwayEra)
-> ConwayCertsPredFailure ConwayEra
ConwayCertPredFailure ConwayEra -> ConwayCertsPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure (ConwayCertPredFailure ConwayEra
 -> ConwayCertsPredFailure ConwayEra)
-> (ConwayDelegPredFailure ConwayEra
    -> ConwayCertPredFailure ConwayEra)
-> ConwayDelegPredFailure ConwayEra
-> ConwayCertsPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayDelegPredFailure ConwayEra -> EraRuleFailure "CERT" ConwayEra
ConwayDelegPredFailure ConwayEra -> ConwayCertPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ShelleyPoolPredFailure ConwayEra where
  injectFailure :: ShelleyPoolPredFailure ConwayEra
-> EraRuleFailure "CERTS" ConwayEra
injectFailure = PredicateFailure (EraRule "CERT" ConwayEra)
-> ConwayCertsPredFailure ConwayEra
ConwayCertPredFailure ConwayEra -> ConwayCertsPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure (ConwayCertPredFailure ConwayEra
 -> ConwayCertsPredFailure ConwayEra)
-> (ShelleyPoolPredFailure ConwayEra
    -> ConwayCertPredFailure ConwayEra)
-> ShelleyPoolPredFailure ConwayEra
-> ConwayCertsPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyPoolPredFailure ConwayEra -> EraRuleFailure "CERT" ConwayEra
ShelleyPoolPredFailure ConwayEra -> ConwayCertPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ConwayGovCertPredFailure ConwayEra where
  injectFailure :: ConwayGovCertPredFailure ConwayEra
-> EraRuleFailure "CERTS" ConwayEra
injectFailure = PredicateFailure (EraRule "CERT" ConwayEra)
-> ConwayCertsPredFailure ConwayEra
ConwayCertPredFailure ConwayEra -> ConwayCertsPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure (ConwayCertPredFailure ConwayEra
 -> ConwayCertsPredFailure ConwayEra)
-> (ConwayGovCertPredFailure ConwayEra
    -> ConwayCertPredFailure ConwayEra)
-> ConwayGovCertPredFailure ConwayEra
-> ConwayCertsPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayGovCertPredFailure ConwayEra
-> EraRuleFailure "CERT" ConwayEra
ConwayGovCertPredFailure ConwayEra
-> ConwayCertPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

deriving stock instance
  Eq (PredicateFailure (EraRule "CERT" era)) =>
  Eq (ConwayCertsPredFailure era)

deriving stock instance
  Show (PredicateFailure (EraRule "CERT" era)) =>
  Show (ConwayCertsPredFailure era)

instance
  NoThunks (PredicateFailure (EraRule "CERT" era)) =>
  NoThunks (ConwayCertsPredFailure era)

instance
  NFData (PredicateFailure (EraRule "CERT" era)) =>
  NFData (ConwayCertsPredFailure era)

newtype ConwayCertsEvent era = CertEvent (Event (EraRule "CERT" era))
  deriving ((forall x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x)
-> (forall x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era)
-> Generic (ConwayCertsEvent era)
forall x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
forall x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
forall era x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
$cfrom :: forall era x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
from :: forall x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
$cto :: forall era x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
to :: forall x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
Generic)

deriving instance Eq (Event (EraRule "CERT" era)) => Eq (ConwayCertsEvent era)

instance NFData (Event (EraRule "CERT" era)) => NFData (ConwayCertsEvent era)

instance
  ( Era era
  , EncCBOR (PredicateFailure (EraRule "CERT" era))
  ) =>
  EncCBOR (ConwayCertsPredFailure era)
  where
  encCBOR :: ConwayCertsPredFailure era -> Encoding
encCBOR =
    Encode 'Open (ConwayCertsPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode 'Open (ConwayCertsPredFailure era) -> Encoding)
-> (ConwayCertsPredFailure era
    -> Encode 'Open (ConwayCertsPredFailure era))
-> ConwayCertsPredFailure era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      WithdrawalsNotInRewardsCERTS Withdrawals
rs -> (Withdrawals -> ConwayCertsPredFailure era)
-> Word -> Encode 'Open (Withdrawals -> ConwayCertsPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era) Word
0 Encode 'Open (Withdrawals -> ConwayCertsPredFailure era)
-> Encode ('Closed 'Dense) Withdrawals
-> Encode 'Open (ConwayCertsPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Withdrawals -> Encode ('Closed 'Dense) Withdrawals
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Withdrawals
rs
      CertFailure PredicateFailure (EraRule "CERT" era)
x -> (PredicateFailure (EraRule "CERT" era)
 -> ConwayCertsPredFailure era)
-> Word
-> Encode
     'Open
     (PredicateFailure (EraRule "CERT" era)
      -> ConwayCertsPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure @era) Word
1 Encode
  'Open
  (PredicateFailure (EraRule "CERT" era)
   -> ConwayCertsPredFailure era)
-> Encode ('Closed 'Dense) (PredicateFailure (EraRule "CERT" era))
-> Encode 'Open (ConwayCertsPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PredicateFailure (EraRule "CERT" era)
-> Encode ('Closed 'Dense) (PredicateFailure (EraRule "CERT" era))
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PredicateFailure (EraRule "CERT" era)
x

instance
  ( Era era
  , DecCBOR (PredicateFailure (EraRule "CERT" era))
  ) =>
  DecCBOR (ConwayCertsPredFailure era)
  where
  decCBOR :: forall s. Decoder s (ConwayCertsPredFailure era)
decCBOR = Decode ('Closed 'Dense) (ConwayCertsPredFailure era)
-> Decoder s (ConwayCertsPredFailure era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (ConwayCertsPredFailure era)
 -> Decoder s (ConwayCertsPredFailure era))
-> Decode ('Closed 'Dense) (ConwayCertsPredFailure era)
-> Decoder s (ConwayCertsPredFailure era)
forall a b. (a -> b) -> a -> b
$ Text
-> (Word -> Decode 'Open (ConwayCertsPredFailure era))
-> Decode ('Closed 'Dense) (ConwayCertsPredFailure era)
forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ConwayGovPredFailure" ((Word -> Decode 'Open (ConwayCertsPredFailure era))
 -> Decode ('Closed 'Dense) (ConwayCertsPredFailure era))
-> (Word -> Decode 'Open (ConwayCertsPredFailure era))
-> Decode ('Closed 'Dense) (ConwayCertsPredFailure era)
forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> (Withdrawals -> ConwayCertsPredFailure era)
-> Decode 'Open (Withdrawals -> ConwayCertsPredFailure era)
forall t. t -> Decode 'Open t
SumD Withdrawals -> ConwayCertsPredFailure era
forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS Decode 'Open (Withdrawals -> ConwayCertsPredFailure era)
-> Decode ('Closed Any) Withdrawals
-> Decode 'Open (ConwayCertsPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Withdrawals
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
1 -> (PredicateFailure (EraRule "CERT" era)
 -> ConwayCertsPredFailure era)
-> Decode
     'Open
     (PredicateFailure (EraRule "CERT" era)
      -> ConwayCertsPredFailure era)
forall t. t -> Decode 'Open t
SumD PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure Decode
  'Open
  (PredicateFailure (EraRule "CERT" era)
   -> ConwayCertsPredFailure era)
-> Decode ('Closed Any) (PredicateFailure (EraRule "CERT" era))
-> Decode 'Open (ConwayCertsPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (PredicateFailure (EraRule "CERT" era))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
k -> Word -> Decode 'Open (ConwayCertsPredFailure era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
k

instance
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraPParams era
  , State (EraRule "CERT" era) ~ CertState era
  , Signal (EraRule "CERT" era) ~ TxCert era
  , Environment (EraRule "CERT" era) ~ CertEnv era
  , Embed (EraRule "CERT" era) (ConwayCERTS era)
  , EraCertState era
  , ConwayEraCertState era
  , EraRuleFailure "CERT" era ~ PredicateFailure (EraRule "CERT" era)
  ) =>
  STS (ConwayCERTS era)
  where
  type State (ConwayCERTS era) = CertState era
  type Signal (ConwayCERTS era) = Seq (TxCert era)
  type Environment (ConwayCERTS era) = CertsEnv era
  type BaseM (ConwayCERTS era) = ShelleyBase
  type PredicateFailure (ConwayCERTS era) = ConwayCertsPredFailure era
  type Event (ConwayCERTS era) = ConwayCertsEvent era

  transitionRules :: [TransitionRule (ConwayCERTS era)]
transitionRules = [forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era,
 State (EraRule "CERT" era) ~ CertState era,
 Embed (EraRule "CERT" era) (ConwayCERTS era),
 Environment (EraRule "CERT" era) ~ CertEnv era,
 Signal (EraRule "CERT" era) ~ TxCert era,
 EraRuleFailure "CERT" era
 ~ PredicateFailure (EraRule "CERT" era)) =>
TransitionRule (ConwayCERTS era)
conwayCertsTransition @era]

conwayCertsTransition ::
  forall era.
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraCertState era
  , State (EraRule "CERT" era) ~ CertState era
  , Embed (EraRule "CERT" era) (ConwayCERTS era)
  , Environment (EraRule "CERT" era) ~ CertEnv era
  , Signal (EraRule "CERT" era) ~ TxCert era
  , EraRuleFailure "CERT" era ~ PredicateFailure (EraRule "CERT" era)
  ) =>
  TransitionRule (ConwayCERTS era)
conwayCertsTransition :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era,
 State (EraRule "CERT" era) ~ CertState era,
 Embed (EraRule "CERT" era) (ConwayCERTS era),
 Environment (EraRule "CERT" era) ~ CertEnv era,
 Signal (EraRule "CERT" era) ~ TxCert era,
 EraRuleFailure "CERT" era
 ~ PredicateFailure (EraRule "CERT" era)) =>
TransitionRule (ConwayCERTS era)
conwayCertsTransition = do
  TRC
    ( env :: Environment (ConwayCERTS era)
env@(CertsEnv Tx era
tx PParams era
pp EpochNo
currentEpoch StrictMaybe (Committee era)
committee Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
committeeProposals)
      , State (ConwayCERTS era)
certState
      , Signal (ConwayCERTS era)
certificates
      ) <-
    Rule
  (ConwayCERTS era)
  'Transition
  (RuleContext 'Transition (ConwayCERTS era))
F (Clause (ConwayCERTS era) 'Transition) (TRC (ConwayCERTS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case Signal (ConwayCERTS era)
certificates of
    Seq (TxCert era)
Signal (ConwayCERTS era)
Empty ->
      if ProtVer -> Bool
hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule (ProtVer -> Bool) -> ProtVer -> Bool
forall a b. (a -> b) -> a -> b
$ 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
        then CertState era
-> F (Clause (ConwayCERTS era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayCERTS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CertState era
State (ConwayCERTS era)
certState
        else do
          Network
network <- BaseM (ConwayCERTS era) Network
-> Rule (ConwayCERTS era) 'Transition Network
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (ConwayCERTS era) Network
 -> Rule (ConwayCERTS era) 'Transition Network)
-> BaseM (ConwayCERTS era) Network
-> Rule (ConwayCERTS era) 'Transition Network
forall a b. (a -> b) -> a -> b
$ (Globals -> Network) -> ReaderT Globals Identity Network
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Network
networkId
          let accounts :: Accounts era
accounts = CertState era
State (ConwayCERTS 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
              withdrawals :: Withdrawals
withdrawals = Tx era
tx Tx era -> Getting Withdrawals (Tx era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Withdrawals (TxBody era))
-> Tx era -> Const Withdrawals (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Withdrawals (TxBody era))
 -> Tx era -> Const Withdrawals (Tx era))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody era -> Const Withdrawals (TxBody era))
-> Getting Withdrawals (Tx era) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody era -> Const Withdrawals (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
          Maybe (Withdrawals, Withdrawals)
-> ((Withdrawals, Withdrawals)
    -> PredicateFailure (ConwayCERTS era))
-> Rule (ConwayCERTS era) 'Transition ()
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust
            (Withdrawals
-> Network -> Accounts era -> Maybe (Withdrawals, Withdrawals)
forall era.
EraAccounts era =>
Withdrawals
-> Network -> Accounts era -> Maybe (Withdrawals, Withdrawals)
withdrawalsThatDoNotDrainAccounts Withdrawals
withdrawals Network
network Accounts era
accounts)
            ( \(Withdrawals
invalid, Withdrawals
incomplete) ->
                Withdrawals -> ConwayCertsPredFailure era
forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS (Withdrawals -> ConwayCertsPredFailure era)
-> Withdrawals -> ConwayCertsPredFailure era
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> Withdrawals
Withdrawals (Map RewardAccount Coin -> Withdrawals)
-> Map RewardAccount Coin -> Withdrawals
forall a b. (a -> b) -> a -> b
$ Withdrawals -> Map RewardAccount Coin
unWithdrawals Withdrawals
invalid Map RewardAccount Coin
-> Map RewardAccount Coin -> Map RewardAccount Coin
forall a. Semigroup a => a -> a -> a
<> Withdrawals -> Map RewardAccount Coin
unWithdrawals Withdrawals
incomplete
            )
          CertState era
-> F (Clause (ConwayCERTS era) 'Transition) (CertState era)
forall a. a -> F (Clause (ConwayCERTS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertState era
 -> F (Clause (ConwayCERTS era) 'Transition) (CertState era))
-> CertState era
-> F (Clause (ConwayCERTS era) 'Transition) (CertState era)
forall a b. (a -> b) -> a -> b
$
            CertState era
State (ConwayCERTS era)
certState
              CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& Tx era -> EpochNo -> CertState era -> CertState era
forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx era -> EpochNo -> CertState era -> CertState era
updateDormantDRepExpiries Tx era
tx EpochNo
currentEpoch
              CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& Tx era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
updateVotingDRepExpiries Tx era
tx EpochNo
currentEpoch (PParams era
pp PParams era
-> Getting EpochInterval (PParams era) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams era) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppDRepActivityL)
              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
%~ Withdrawals -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Withdrawals -> Accounts era -> Accounts era
drainAccounts Withdrawals
withdrawals
    Seq (TxCert era)
gamma :|> TxCert era
txCert -> do
      CertState era
certState' <-
        forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(ConwayCERTS era) (RuleContext 'Transition (ConwayCERTS era)
 -> TransitionRule (ConwayCERTS era))
-> RuleContext 'Transition (ConwayCERTS era)
-> TransitionRule (ConwayCERTS era)
forall a b. (a -> b) -> a -> b
$ (Environment (ConwayCERTS era), State (ConwayCERTS era),
 Signal (ConwayCERTS era))
-> TRC (ConwayCERTS era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (ConwayCERTS era)
env, State (ConwayCERTS era)
certState, Seq (TxCert era)
Signal (ConwayCERTS era)
gamma)
      forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "CERT" era) (RuleContext 'Transition (EraRule "CERT" era)
 -> Rule (ConwayCERTS era) 'Transition (State (EraRule "CERT" era)))
-> RuleContext 'Transition (EraRule "CERT" era)
-> Rule (ConwayCERTS era) 'Transition (State (EraRule "CERT" era))
forall a b. (a -> b) -> a -> b
$
        (Environment (EraRule "CERT" era), State (EraRule "CERT" era),
 Signal (EraRule "CERT" era))
-> TRC (EraRule "CERT" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertEnv era
forall era.
PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertEnv era
CertEnv PParams era
pp EpochNo
currentEpoch StrictMaybe (Committee era)
committee Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
committeeProposals, CertState era
State (EraRule "CERT" era)
certState', TxCert era
Signal (EraRule "CERT" era)
txCert)

-- | If there is a new governance proposal to vote on in this transaction,
-- AND the number of dormant-epochs recorded is greater than zero, we bump
-- the expiry for all DReps by the number of dormant epochs, and reset the
-- counter to zero.
--
-- It does not matter that this is called _before_ the GOV rule in LEDGER, even
-- though we cannot validate any governance proposal here, since the entire
-- transaction will fail if the proposal is not accepted in GOV, and so will
-- this expiry bump done here.
updateDormantDRepExpiries ::
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraCertState era
  ) =>
  Tx era -> EpochNo -> CertState era -> CertState era
updateDormantDRepExpiries :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx era -> EpochNo -> CertState era -> CertState era
updateDormantDRepExpiries Tx era
tx EpochNo
currentEpoch =
  let hasProposals :: Bool
hasProposals = Bool -> Bool
not (Bool -> Bool)
-> (OSet (ProposalProcedure era) -> Bool)
-> OSet (ProposalProcedure era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OSet (ProposalProcedure era) -> Bool
forall a. OSet a -> Bool
OSet.null (OSet (ProposalProcedure era) -> Bool)
-> OSet (ProposalProcedure era) -> Bool
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era
-> Getting
     (OSet (ProposalProcedure era))
     (Tx era)
     (OSet (ProposalProcedure era))
-> OSet (ProposalProcedure era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (OSet (ProposalProcedure era)) (TxBody era))
-> Tx era -> Const (OSet (ProposalProcedure era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (OSet (ProposalProcedure era)) (TxBody era))
 -> Tx era -> Const (OSet (ProposalProcedure era)) (Tx era))
-> ((OSet (ProposalProcedure era)
     -> Const
          (OSet (ProposalProcedure era)) (OSet (ProposalProcedure era)))
    -> TxBody era -> Const (OSet (ProposalProcedure era)) (TxBody era))
-> Getting
     (OSet (ProposalProcedure era))
     (Tx era)
     (OSet (ProposalProcedure era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Const
      (OSet (ProposalProcedure era)) (OSet (ProposalProcedure era)))
-> TxBody era -> Const (OSet (ProposalProcedure era)) (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
   in if Bool
hasProposals
        then (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 -> VState era) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ EpochNo -> VState era -> VState era
forall era. EpochNo -> VState era -> VState era
updateDormantDRepExpiry EpochNo
currentEpoch
        else CertState era -> CertState era
forall a. a -> a
id

-- | Update DRep expiry for all DReps that are voting in this transaction. This
-- will execute in mutual-exclusion to the updates to the dormant DRep expiry,
-- because if there are no proposals to vote on, there will be no votes either.
updateVotingDRepExpiries ::
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraCertState era
  ) =>
  Tx era -> EpochNo -> EpochInterval -> CertState era -> CertState era
updateVotingDRepExpiries :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
updateVotingDRepExpiries Tx era
tx EpochNo
currentEpoch EpochInterval
drepActivity CertState era
certState =
  let numDormantEpochs :: EpochNo
numDormantEpochs = CertState era
certState CertState era -> Getting EpochNo (CertState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. (VState era -> Const EpochNo (VState era))
-> CertState era -> Const EpochNo (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const EpochNo (VState era))
 -> CertState era -> Const EpochNo (CertState era))
-> ((EpochNo -> Const EpochNo EpochNo)
    -> VState era -> Const EpochNo (VState era))
-> Getting EpochNo (CertState era) EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpochNo -> Const EpochNo EpochNo)
-> VState era -> Const EpochNo (VState era)
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL
      updateVSDReps :: Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
updateVSDReps Map (Credential 'DRepRole) DRepState
vsDReps =
        (Map (Credential 'DRepRole) DRepState
 -> Voter
 -> Map GovActionId (VotingProcedure era)
 -> Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
-> Map Voter (Map GovActionId (VotingProcedure era))
-> Map (Credential 'DRepRole) DRepState
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey'
          ( \Map (Credential 'DRepRole) DRepState
dreps Voter
voter Map GovActionId (VotingProcedure era)
_ -> case Voter
voter of
              DRepVoter Credential 'DRepRole
cred ->
                (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
                  ((EpochNo -> Identity EpochNo) -> DRepState -> Identity DRepState
Lens' DRepState EpochNo
drepExpiryL ((EpochNo -> Identity EpochNo) -> DRepState -> Identity DRepState)
-> EpochNo -> DRepState -> DRepState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry EpochInterval
drepActivity EpochNo
currentEpoch EpochNo
numDormantEpochs)
                  Credential 'DRepRole
cred
                  Map (Credential 'DRepRole) DRepState
dreps
              Voter
_ -> Map (Credential 'DRepRole) DRepState
dreps
          )
          Map (Credential 'DRepRole) DRepState
vsDReps
          (VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures (VotingProcedures era
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era
-> Getting (VotingProcedures era) (Tx era) (VotingProcedures era)
-> VotingProcedures era
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (VotingProcedures era) (TxBody era))
-> Tx era -> Const (VotingProcedures era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (VotingProcedures era) (TxBody era))
 -> Tx era -> Const (VotingProcedures era) (Tx era))
-> ((VotingProcedures era
     -> Const (VotingProcedures era) (VotingProcedures era))
    -> TxBody era -> Const (VotingProcedures era) (TxBody era))
-> Getting (VotingProcedures era) (Tx era) (VotingProcedures era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era
 -> Const (VotingProcedures era) (VotingProcedures era))
-> TxBody era -> Const (VotingProcedures era) (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL)
   in CertState era
certState 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
    -> Map (Credential 'DRepRole) DRepState)
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
updateVSDReps

instance
  ( Era era
  , STS (ConwayCERT era)
  , BaseM (EraRule "CERT" era) ~ ShelleyBase
  , Event (EraRule "CERT" era) ~ ConwayCertEvent era
  , PredicateFailure (EraRule "CERT" era) ~ ConwayCertPredFailure era
  ) =>
  Embed (ConwayCERT era) (ConwayCERTS era)
  where
  wrapFailed :: PredicateFailure (ConwayCERT era)
-> PredicateFailure (ConwayCERTS era)
wrapFailed = PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
PredicateFailure (ConwayCERT era)
-> PredicateFailure (ConwayCERTS era)
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure
  wrapEvent :: Event (ConwayCERT era) -> Event (ConwayCERTS era)
wrapEvent = Event (EraRule "CERT" era) -> ConwayCertsEvent era
Event (ConwayCERT era) -> Event (ConwayCERTS era)
forall era. Event (EraRule "CERT" era) -> ConwayCertsEvent era
CertEvent

-- | Update dormant expiry for all DReps that are active.
-- And also reset the `numDormantEpochs` counter.
updateDormantDRepExpiry ::
  -- | Current Epoch
  EpochNo ->
  VState era ->
  VState era
updateDormantDRepExpiry :: forall era. EpochNo -> VState era -> VState era
updateDormantDRepExpiry EpochNo
currentEpoch VState era
vState =
  if EpochNo
numDormantEpochs EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0
    then VState era
vState
    else
      VState era
vState
        VState era -> (VState era -> VState era) -> VState era
forall a b. a -> (a -> b) -> b
& (EpochNo -> Identity EpochNo)
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL ((EpochNo -> Identity EpochNo)
 -> VState era -> Identity (VState era))
-> EpochNo -> VState era -> VState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64 -> EpochNo
EpochNo Word64
0
        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)
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map DRepState -> DRepState
updateExpiry
  where
    numDormantEpochs :: EpochNo
numDormantEpochs = VState era
vState VState era -> Getting EpochNo (VState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (VState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL
    updateExpiry :: DRepState -> DRepState
updateExpiry =
      (EpochNo -> Identity EpochNo) -> DRepState -> Identity DRepState
Lens' DRepState EpochNo
drepExpiryL
        ((EpochNo -> Identity EpochNo) -> DRepState -> Identity DRepState)
-> (EpochNo -> EpochNo) -> DRepState -> DRepState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \EpochNo
currentExpiry ->
          let actualExpiry :: EpochNo
actualExpiry = (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) EpochNo
numDormantEpochs EpochNo
currentExpiry
           in if EpochNo
actualExpiry EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
< EpochNo
currentEpoch
                then EpochNo
currentExpiry
                else EpochNo
actualExpiry