{-# LANGUAGE CPP #-}
{-# 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 #-}
#if __GLASGOW_HASKELL__ >= 910
-- See https://gitlab.haskell.org/ghc/ghc/-/issues/27342
{-# OPTIONS_GHC -fno-spec-eval #-}
#endif

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

import Cardano.Ledger.BaseTypes (
  EpochInterval,
  EpochNo (EpochNo),
  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 (
  CERT,
  CERTS,
  ConwayEra,
 )
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 qualified Cardano.Ledger.Shelley.Rules as Shelley
import Control.DeepSeq (NFData)
import Control.State.Transition.Extended (
  Embed (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  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

data CertsEnv era = CertsEnv
  { 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 {}) =
    let CertsEnv {Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
StrictMaybe (Committee era)
PParams era
EpochNo
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)
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
$
          (PParams era
 -> EpochNo
 -> StrictMaybe (Committee era)
 -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
 -> CertsEnv era)
-> Encode
     (Closed Dense)
     (PParams era
      -> EpochNo
      -> StrictMaybe (Committee era)
      -> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
      -> CertsEnv era)
forall t. t -> Encode (Closed Dense) t
Rec PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertsEnv era
forall era.
PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose) (GovActionState era)
-> CertsEnv era
CertsEnv
            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 TopTx era)) => Eq (CertsEnv era)

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

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

newtype ConwayCertsPredFailure era
  = -- | 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" Shelley.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
  Ord (PredicateFailure (EraRule "CERT" era)) =>
  Ord (ConwayCertsPredFailure era)

deriving stock instance
  Show (PredicateFailure (EraRule "CERT" era)) =>
  Show (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
      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
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 (ZonkAny 0)) (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 (ZonkAny 0)) (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) (CERTS era)
  , EraCertState era
  , ConwayEraCertState era
  , EraRuleFailure "CERT" era ~ PredicateFailure (EraRule "CERT" era)
  ) =>
  STS (CERTS era)
  where
  type State (CERTS era) = CertState era
  type Signal (CERTS era) = Seq (TxCert era)
  type Environment (CERTS era) = CertsEnv era
  type BaseM (CERTS era) = ShelleyBase
  type PredicateFailure (CERTS era) = ConwayCertsPredFailure era
  type Event (CERTS era) = ConwayCertsEvent era

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

conwayCertsTransition ::
  forall era.
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraCertState era
  , State (EraRule "CERT" era) ~ CertState era
  , Embed (EraRule "CERT" era) (CERTS era)
  , Environment (EraRule "CERT" era) ~ CertEnv era
  , Signal (EraRule "CERT" era) ~ TxCert era
  , EraRuleFailure "CERT" era ~ PredicateFailure (EraRule "CERT" era)
  ) =>
  TransitionRule (CERTS era)
conwayCertsTransition :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era,
 State (EraRule "CERT" era) ~ CertState era,
 Embed (EraRule "CERT" era) (CERTS era),
 Environment (EraRule "CERT" era) ~ CertEnv era,
 Signal (EraRule "CERT" era) ~ TxCert era,
 EraRuleFailure "CERT" era
 ~ PredicateFailure (EraRule "CERT" era)) =>
TransitionRule (CERTS era)
conwayCertsTransition = do
  TRC
    ( env@(CertsEnv pp currentEpoch committee committeeProposals)
      , certState
      , certificates
      ) <-
    Rule (CERTS era) 'Transition (RuleContext 'Transition (CERTS era))
F (Clause (CERTS era) 'Transition) (TRC (CERTS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case certificates of
    Seq (TxCert era)
Signal (CERTS era)
Empty -> CertState era -> F (Clause (CERTS era) 'Transition) (CertState era)
forall a. a -> F (Clause (CERTS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CertState era
State (CERTS era)
certState
    Seq (TxCert era)
gamma :|> TxCert era
txCert -> do
      certState' <-
        forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(CERTS era) (RuleContext 'Transition (CERTS era)
 -> F (Clause (CERTS era) 'Transition) (State (CERTS era)))
-> RuleContext 'Transition (CERTS era)
-> F (Clause (CERTS era) 'Transition) (State (CERTS era))
forall a b. (a -> b) -> a -> b
$ (Environment (CERTS era), State (CERTS era), Signal (CERTS era))
-> TRC (CERTS era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (CERTS era)
env, State (CERTS era)
certState, Seq (TxCert era)
Signal (CERTS era)
gamma)
      trans @(EraRule "CERT" era) $
        TRC (CertEnv pp currentEpoch committee committeeProposals, certState', 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 l era -> EpochNo -> CertState era -> CertState era
updateDormantDRepExpiries :: forall era (l :: TxLevel).
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx l era -> EpochNo -> CertState era -> CertState era
updateDormantDRepExpiries Tx l 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 l era
tx Tx l era
-> Getting
     (OSet (ProposalProcedure era))
     (Tx l era)
     (OSet (ProposalProcedure era))
-> OSet (ProposalProcedure era)
forall s a. s -> Getting a s a -> a
^. (TxBody l era
 -> Const (OSet (ProposalProcedure era)) (TxBody l era))
-> Tx l era -> Const (OSet (ProposalProcedure era)) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era
  -> Const (OSet (ProposalProcedure era)) (TxBody l era))
 -> Tx l era -> Const (OSet (ProposalProcedure era)) (Tx l era))
-> ((OSet (ProposalProcedure era)
     -> Const
          (OSet (ProposalProcedure era)) (OSet (ProposalProcedure era)))
    -> TxBody l era
    -> Const (OSet (ProposalProcedure era)) (TxBody l era))
-> Getting
     (OSet (ProposalProcedure era))
     (Tx l 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 l era
-> Const (OSet (ProposalProcedure era)) (TxBody l era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l 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 l era -> EpochNo -> EpochInterval -> CertState era -> CertState era
updateVotingDRepExpiries :: forall era (l :: TxLevel).
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx l era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
updateVotingDRepExpiries Tx l 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 l era
tx Tx l era
-> Getting (VotingProcedures era) (Tx l era) (VotingProcedures era)
-> VotingProcedures era
forall s a. s -> Getting a s a -> a
^. (TxBody l era -> Const (VotingProcedures era) (TxBody l era))
-> Tx l era -> Const (VotingProcedures era) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Const (VotingProcedures era) (TxBody l era))
 -> Tx l era -> Const (VotingProcedures era) (Tx l era))
-> ((VotingProcedures era
     -> Const (VotingProcedures era) (VotingProcedures era))
    -> TxBody l era -> Const (VotingProcedures era) (TxBody l era))
-> Getting (VotingProcedures era) (Tx l era) (VotingProcedures era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era
 -> Const (VotingProcedures era) (VotingProcedures era))
-> TxBody l era -> Const (VotingProcedures era) (TxBody l era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l 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 (CERT era)
  , BaseM (EraRule "CERT" era) ~ ShelleyBase
  , Event (EraRule "CERT" era) ~ ConwayCertEvent era
  , PredicateFailure (EraRule "CERT" era) ~ ConwayCertPredFailure era
  ) =>
  Embed (CERT era) (CERTS era)
  where
  wrapFailed :: PredicateFailure (CERT era) -> PredicateFailure (CERTS era)
wrapFailed = PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
PredicateFailure (CERT era) -> PredicateFailure (CERTS era)
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure
  wrapEvent :: Event (CERT era) -> Event (CERTS era)
wrapEvent = Event (EraRule "CERT" era) -> ConwayCertsEvent era
Event (CERT era) -> Event (CERTS 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