Added RATIFY thresholds (#3674)

* Added RATIFY thresholds
IntersectMBO · Aug 31, 2023 · 302541b · 302541b
1 parent 4694722
commit 302541b
Show file tree

Hide file tree

Showing 15 changed files with 510 additions and 59 deletions.
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -2,6 +2,19 @@
 
 ## 1.8.0.0
 
+* Add:
+  * `PParamGroup`
+  * `ParamGrouper`
+  * `pGroup`
+  * `pUngrouped`
+  * `modifiedGroups`
+  * `dvtPPNetworkGroupL`
+  * `dvtPPGovGroupL`
+  * `dvtPPTechnicalGroupL`
+  * `dvtPPEconomicGroupL`
+  * `threshold`
+  * `ensCommitteeL`
+* Add `pparamsGroups` to `ConwayEraPParams`
 * Add `PrevGovActionIds`
 * Change `EnactState` to add `ensPrevGovActionIds`
 * Add  `ensPrevGovActionIdsL`, `ensPrevPParamUpdateL`, `ensPrevHardForkL` `ensPrevCommitteeL`, `ensPrevConstitutionL`

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -16,6 +17,11 @@ module Cardano.Ledger.Conway.Core (
   module X,
   ConwayEraTxBody (..),
   ConwayEraPParams (..),
+  PParamGroup (..),
+  ParamGrouper,
+  pGroup,
+  pUngrouped,
+  modifiedGroups,
   ppPoolVotingThresholdsL,
   ppDRepVotingThresholdsL,
   ppMinCommitteeSizeL,
@@ -34,11 +40,17 @@ module Cardano.Ledger.Conway.Core (
   ppuDRepActivityL,
   PoolVotingThresholds (..),
   DRepVotingThresholds (..),
+  dvtPPNetworkGroupL,
+  dvtPPGovGroupL,
+  dvtPPTechnicalGroupL,
+  dvtPPEconomicGroupL,
+  dvtUpdateToConstitutionL,
 )
 where
 
+import Cardano.Ledger.Ap (Ap, runAp_)
 import Cardano.Ledger.Babbage.Core as X
-import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe, UnitInterval)
+import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe (..), UnitInterval)
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR, decodeRecordNamed, encodeListLen)
 import Cardano.Ledger.Binary.Decoding (DecCBOR (decCBOR))
 import Cardano.Ledger.Binary.Encoding (EncCBOR (encCBOR))
@@ -51,8 +63,10 @@ import Data.Aeson (ToJSON)
 import Data.Default.Class (Default)
 import Data.Functor.Identity (Identity)
 import Data.Sequence.Strict (StrictSeq (..))
+import Data.Set (Set)
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
-import Lens.Micro (Lens')
+import Lens.Micro (Lens', lens)
 import NoThunks.Class (NoThunks)
 import Numeric.Natural (Natural)
 
@@ -69,7 +83,33 @@ class BabbageEraTxBody era => ConwayEraTxBody era where
 
   treasuryDonationTxBodyL :: Lens' (TxBody era) Coin
 
+data PParamGroup
+  = EconomicGroup
+  | NetworkGroup
+  | TechnicalGroup
+  | GovernanceGroup
+  deriving (Eq, Ord)
+
+newtype ParamGrouper a = ParamGrouper {unParamGrouper :: Set PParamGroup}
+  deriving (Functor)
+
+pGroup :: PParamGroup -> StrictMaybe a -> Ap f (ParamGrouper a)
+pGroup pg (SJust _) = pure . ParamGrouper $ Set.singleton pg
+pGroup _ SNothing = pure $ ParamGrouper mempty
+
+pUngrouped :: Ap f (ParamGrouper a)
+pUngrouped = pure $ ParamGrouper mempty
+
+modifiedGroups ::
+  forall era.
+  ConwayEraPParams era =>
+  PParamsUpdate era ->
+  Set PParamGroup
+modifiedGroups = runAp_ unParamGrouper . (pparamsGroups @era)
+
 class BabbageEraPParams era => ConwayEraPParams era where
+  pparamsGroups ::
+    Functor f => PParamsUpdate era -> Ap f (PParamsHKD ParamGrouper era)
   ppuWellFormed :: PParamsUpdate era -> Bool
 
   hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds)
@@ -172,6 +212,21 @@ data DRepVotingThresholds = DRepVotingThresholds
 
 instance ToExpr DRepVotingThresholds
 
+dvtPPNetworkGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPNetworkGroupL = lens dvtPPNetworkGroup (\x y -> x {dvtPPNetworkGroup = y})
+
+dvtPPEconomicGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPEconomicGroupL = lens dvtPPEconomicGroup (\x y -> x {dvtPPEconomicGroup = y})
+
+dvtPPTechnicalGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPTechnicalGroupL = lens dvtPPTechnicalGroup (\x y -> x {dvtPPTechnicalGroup = y})
+
+dvtPPGovGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPGovGroupL = lens dvtPPGovGroup (\x y -> x {dvtPPGovGroup = y})
+
+dvtUpdateToConstitutionL :: Lens' DRepVotingThresholds UnitInterval
+dvtUpdateToConstitutionL = lens dvtUpdateToConstitution (\x y -> x {dvtUpdateToConstitution = y})
+
 instance EncCBOR DRepVotingThresholds where
   encCBOR DRepVotingThresholds {..} =
     encodeListLen 10

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -41,13 +41,17 @@ module Cardano.Ledger.Conway.Governance (
   indexedGovProps,
   Constitution (..),
   ConwayEraGov (..),
+  thresholdSPO,
+  thresholdDRep,
+  thresholdCC,
   -- Lenses
   cgGovActionsStateL,
   cgEnactStateL,
   cgRatifyStateL,
   ensCommitteeL,
   ensConstitutionL,
   ensCurPParamsL,
+  ensPrevPParamsL,
   ensPrevGovActionIdsL,
   ensPrevPParamUpdateL,
   ensPrevHardForkL,
@@ -66,7 +70,12 @@ module Cardano.Ledger.Conway.Governance (
 ) where
 
 import Cardano.Ledger.Address (RewardAcnt)
-import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), StrictMaybe)
+import Cardano.Ledger.BaseTypes (
+  EpochNo (..),
+  ProtVer (..),
+  StrictMaybe (..),
+  UnitInterval,
+ )
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
@@ -83,6 +92,17 @@ import Cardano.Ledger.Binary.Coders (
  )
 import Cardano.Ledger.CertState (CommitteeState, DRepState)
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway.Core (
+  ConwayEraPParams,
+  PParamGroup (..),
+  dvtPPEconomicGroupL,
+  dvtPPGovGroupL,
+  dvtPPNetworkGroupL,
+  dvtPPTechnicalGroupL,
+  modifiedGroups,
+  ppDRepVotingThresholdsL,
+  ppPoolVotingThresholdsL,
+ )
 import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.Governance.Procedures (
   Anchor (..),
@@ -102,7 +122,10 @@ import Cardano.Ledger.Conway.Governance.Procedures (
   govActionIdToText,
   indexedGovProps,
  )
-import Cardano.Ledger.Conway.PParams ()
+import Cardano.Ledger.Conway.PParams (
+  DRepVotingThresholds (..),
+  PoolVotingThresholds (..),
+ )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (Crypto)
@@ -117,6 +140,7 @@ import Data.Functor.Identity (Identity)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -593,3 +617,88 @@ class EraGov era => ConwayEraGov era where
 
 instance Crypto c => ConwayEraGov (ConwayEra c) where
   constitutionGovStateL = cgEnactStateL . ensConstitutionL
+
+pparamsUpdateThreshold ::
+  forall era.
+  ConwayEraPParams era =>
+  PParams era ->
+  PParamsUpdate era ->
+  UnitInterval
+pparamsUpdateThreshold pp ppu =
+  let thresholdLens = \case
+        NetworkGroup -> dvtPPNetworkGroupL
+        GovernanceGroup -> dvtPPGovGroupL
+        TechnicalGroup -> dvtPPTechnicalGroupL
+        EconomicGroup -> dvtPPEconomicGroupL
+      lookupGroupThreshold grp =
+        pp ^. ppDRepVotingThresholdsL . thresholdLens grp
+   in Set.foldr' max minBound $
+        Set.map lookupGroupThreshold $
+          modifiedGroups @era ppu
+
+thresholdSPO ::
+  ConwayEraPParams era =>
+  RatifyState era ->
+  GovAction era ->
+  StrictMaybe UnitInterval
+thresholdSPO rSt action =
+  let pp = rSt ^. rsEnactStateL . ensCurPParamsL
+      PoolVotingThresholds
+        { pvtCommitteeNoConfidence
+        , pvtCommitteeNormal
+        , pvtHardForkInitiation
+        } = pp ^. ppPoolVotingThresholdsL
+      committee = rSt ^. rsEnactStateL . ensCommitteeL
+   in case action of
+        NoConfidence {} -> SJust pvtCommitteeNoConfidence
+        NewCommittee {} -> SJust $
+          case committee of
+            SJust _ -> pvtCommitteeNormal
+            SNothing -> pvtCommitteeNoConfidence
+        NewConstitution {} -> SJust minBound
+        HardForkInitiation {} -> SJust pvtHardForkInitiation
+        ParameterChange {} -> SJust minBound
+        TreasuryWithdrawals {} -> SJust minBound
+        InfoAction {} -> SNothing
+
+thresholdCC ::
+  StrictMaybe (Committee era) ->
+  GovAction era ->
+  StrictMaybe UnitInterval
+thresholdCC committee action =
+  let ccThreshold = committeeQuorum <$> committee
+   in case action of
+        NoConfidence {} -> SJust minBound
+        NewCommittee {} -> SJust minBound
+        NewConstitution {} -> ccThreshold
+        HardForkInitiation {} -> ccThreshold
+        ParameterChange {} -> ccThreshold
+        TreasuryWithdrawals {} -> ccThreshold
+        InfoAction {} -> SNothing
+
+thresholdDRep ::
+  ConwayEraPParams era =>
+  RatifyState era ->
+  GovAction era ->
+  StrictMaybe UnitInterval
+thresholdDRep rSt action =
+  let pp = rSt ^. rsEnactStateL . ensCurPParamsL
+      DRepVotingThresholds
+        { dvtCommitteeNoConfidence
+        , dvtCommitteeNormal
+        , dvtUpdateToConstitution
+        , dvtHardForkInitiation
+        , dvtTreasuryWithdrawal
+        } = pp ^. ppDRepVotingThresholdsL
+      committee = rSt ^. rsEnactStateL . ensCommitteeL
+   in case action of
+        NoConfidence {} -> SJust dvtCommitteeNoConfidence
+        NewCommittee {} -> SJust $
+          case committee of
+            SJust _ -> dvtCommitteeNormal
+            SNothing -> dvtCommitteeNoConfidence
+        NewConstitution {} -> SJust dvtUpdateToConstitution
+        HardForkInitiation {} -> SJust dvtHardForkInitiation
+        ParameterChange _ ppu -> SJust $ pparamsUpdateThreshold pp ppu
+        TreasuryWithdrawals {} -> SJust dvtTreasuryWithdrawal
+        InfoAction {} -> SNothing
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs
@@ -36,7 +36,6 @@ where
 import Cardano.Ledger.Alonzo.PParams (OrdExUnits (..))
 import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits (..), Prices (Prices), emptyCostModels)
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.Core hiding (Value)
 import Cardano.Ledger.Babbage.PParams
 import Cardano.Ledger.BaseTypes (EpochNo (EpochNo), NonNegativeInterval, ProtVer (ProtVer), UnitInterval)
 import Cardano.Ledger.Binary
@@ -299,6 +298,39 @@ instance Crypto c => BabbageEraPParams (ConwayEra c) where
   hkdCoinsPerUTxOByteL = lens cppCoinsPerUTxOByte (\pp x -> pp {cppCoinsPerUTxOByte = x})
 
 instance Crypto c => ConwayEraPParams (ConwayEra c) where
+  pparamsGroups (PParamsUpdate ConwayPParams {..}) =
+    ConwayPParams
+      <$> pGroup EconomicGroup cppMinFeeA
+      <*> pGroup EconomicGroup cppMinFeeB
+      <*> pGroup NetworkGroup cppMaxBBSize
+      <*> pGroup NetworkGroup cppMaxTxSize
+      <*> pGroup NetworkGroup cppMaxBHSize
+      <*> pGroup EconomicGroup cppKeyDeposit
+      <*> pGroup EconomicGroup cppPoolDeposit
+      <*> pGroup TechnicalGroup cppEMax
+      <*> pGroup TechnicalGroup cppNOpt
+      <*> pGroup TechnicalGroup cppA0
+      <*> pGroup EconomicGroup cppRho
+      <*> pGroup EconomicGroup cppTau
+      <*> pUngrouped
+      <*> pGroup EconomicGroup cppMinPoolCost
+      <*> pGroup EconomicGroup cppCoinsPerUTxOByte
+      <*> pGroup TechnicalGroup cppCostModels
+      <*> pGroup EconomicGroup cppPrices
+      <*> pGroup NetworkGroup cppMaxTxExUnits
+      <*> pGroup NetworkGroup cppMaxBlockExUnits
+      <*> pGroup NetworkGroup cppMaxValSize
+      <*> pGroup TechnicalGroup cppCollateralPercentage
+      <*> pGroup NetworkGroup cppMaxCollateralInputs
+      <*> pGroup GovernanceGroup cppPoolVotingThresholds
+      <*> pGroup GovernanceGroup cppDRepVotingThresholds
+      <*> pGroup GovernanceGroup cppMinCommitteeSize
+      <*> pGroup GovernanceGroup cppCommitteeTermLimit
+      <*> pGroup GovernanceGroup cppGovActionExpiration
+      <*> pGroup GovernanceGroup cppGovActionDeposit
+      <*> pGroup GovernanceGroup cppDRepDeposit
+      <*> pGroup GovernanceGroup cppDRepActivity
+
   ppuWellFormed ppu =
     and
       [ -- Numbers