33{-# LANGUAGE DerivingStrategies #-}
44{-# LANGUAGE DerivingVia #-}
55{-# LANGUAGE FlexibleContexts #-}
6- {-# LANGUAGE LambdaCase #-}
76{-# LANGUAGE OverloadedStrings #-}
87{-# LANGUAGE RecordWildCards #-}
98{-# LANGUAGE ScopedTypeVariables #-}
109{-# LANGUAGE StandaloneDeriving #-}
1110{-# LANGUAGE TypeApplications #-}
12- {-# LANGUAGE TypeFamilyDependencies #-}
11+ {-# LANGUAGE TypeFamilies #-}
1312{-# LANGUAGE TypeOperators #-}
1413{-# LANGUAGE UndecidableInstances #-}
15- {-# LANGUAGE UndecidableSuperClasses #-}
14+ {-# OPTIONS_GHC -Wno-orphans #-}
1615
1716module Cardano.Ledger.Shelley.Governance (
1817 EraGov (.. ),
@@ -24,14 +23,11 @@ module Cardano.Ledger.Shelley.Governance (
2423 nextEpochPParams ,
2524 nextEpochUpdatedPParams ,
2625 -- Lens
27- proposalsL ,
28- futureProposalsL ,
2926 curPParamsShelleyGovStateL ,
3027 prevPParamsShelleyGovStateL ,
3128 futurePParamsShelleyGovStateL ,
3229) where
3330
34- import Cardano.Ledger.BaseTypes (StrictMaybe (.. ), fromSMaybe , maybeToStrictMaybe )
3531import Cardano.Ledger.Binary (
3632 DecCBOR (decCBOR ),
3733 DecShareCBOR (.. ),
@@ -42,11 +38,11 @@ import Cardano.Ledger.Binary (
4238 decNoShareCBOR ,
4339 )
4440import Cardano.Ledger.Binary.Coders (Decode (.. ), Encode (.. ), decode , encode , (!>) , (<!) )
45- import Cardano.Ledger.CertState (Obligations )
4641import Cardano.Ledger.Core
4742import Cardano.Ledger.Credential (Credential )
4843import Cardano.Ledger.Shelley.Era (ShelleyEra )
4944import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates , emptyPPPUpdates )
45+ import Cardano.Ledger.State
5046import Control.DeepSeq (NFData (.. ))
5147import Data.Aeson (
5248 KeyValue ,
@@ -56,68 +52,13 @@ import Data.Aeson (
5652 (.=) ,
5753 )
5854import Data.Default (Default (.. ))
59- import Data.Kind (Type )
60- import Data.Typeable
6155import GHC.Generics (Generic )
62- import Lens.Micro (Lens' , lens , (^.) )
63- import NoThunks.Class (AllowThunk (.. ), NoThunks (.. ))
64-
65- class
66- ( EraPParams era
67- , Eq GovState era )
68- , Show GovState era )
69- , NoThunks (GovState era )
70- , NFData (GovState era )
71- , EncCBOR (GovState era )
72- , DecCBOR (GovState era )
73- , DecShareCBOR (GovState era )
74- , Share (GovState era )
75- ~ ( Interns (Credential 'Staking)
76- , Interns (KeyHash 'StakePool)
77- , Interns (Credential 'DRepRole)
78- , Interns (Credential 'HotCommitteeRole)
79- )
80- , ToCBOR (GovState era )
81- , FromCBOR (GovState era )
82- , Default (GovState era )
83- , ToJSON (GovState era )
84- ) =>
85- EraGov era
86- where
87- type GovState era = (r :: Type ) | r -> era
88-
89- -- | Construct empty governance state
90- emptyGovState :: GovState era
91- emptyGovState = def
92-
93- -- | Returns `Nothing` for all eras starting with Conway, otherwise returns proposed
94- -- pparams updates
95- getProposedPPUpdates :: GovState era -> Maybe ProposedPPUpdates era )
96- getProposedPPUpdates _ = Nothing
97-
98- -- | Lens for accessing current protocol parameters
99- curPParamsGovStateL :: Lens' (GovState era ) (PParams era )
100-
101- -- | Lens for accessing the previous protocol parameters
102- prevPParamsGovStateL :: Lens' (GovState era ) (PParams era )
103-
104- -- | Lens for accessing the future protocol parameters.
105- --
106- -- This lens will produce `DefinitePParamsUpdate` whenever we are absolutely sure that
107- -- the new PParams will be updated. Which means there will be no chance of a
108- -- `DefinitePParamsUpdate` value until we are past the point of no return, which is 2
109- -- stability windows before the end of the epoch. This lens is mostly intended for
110- -- ledger usage and `nextEpochUpdatedPParams` should be used instead whenever definite
111- -- results are desired.
112- futurePParamsGovStateL :: Lens' (GovState era ) (FuturePParams era )
113-
114- obligationGovState :: GovState era -> Obligations
56+ import Lens.Micro (Lens' , lens )
57+ import NoThunks.Class (NoThunks (.. ))
11558
11659instance EraGov ShelleyEra where
11760 type GovState ShelleyEra = ShelleyGovState ShelleyEra
11861
119- getProposedPPUpdates = Just . sgsCurProposals
120-
12162 curPParamsGovStateL = curPParamsShelleyGovStateL
12263
12364 prevPParamsGovStateL = prevPParamsShelleyGovStateL
@@ -136,87 +77,6 @@ data ShelleyGovState era = ShelleyGovState
13677 }
13778 deriving (Generic )
13879
139- data FuturePParams era
140- = -- | This indicates that there is definitely not going to be an update to PParams
141- -- expected at the next epoch boundary.
142- NoPParamsUpdate
143- | -- | This case specifies the PParams that will be adopted at the next epoch boundary.
144- DefinitePParamsUpdate ! (PParams era )
145- | -- | With this case there is no guarantee that these will be the new PParams, users
146- -- should not rely on this value to be computed efficiently and should use
147- -- `nextEpochPParams` instead. The field is lazy on purpose, since we truly need to
148- -- compute this field only towards the end of the epoch, which is done by
149- -- `solidifyFuturePParams` two stability windows before the end of the epoch.
150- PotentialPParamsUpdate (Maybe PParams era ))
151- deriving (Generic )
152-
153- instance Default (FuturePParams era ) where
154- def = NoPParamsUpdate
155-
156- instance ToJSON (PParams era ) => ToJSON (FuturePParams era )
157-
158- -- | Return new PParams only when it is known that there was an update proposed and it is
159- -- guaranteed to be applied
160- knownFuturePParams :: FuturePParams era -> Maybe PParams era )
161- knownFuturePParams = \ case
162- DefinitePParamsUpdate pp -> Just pp
163- _ -> Nothing
164-
165- -- | This function is guaranteed to produce `PParams` that will be adopted at the next
166- -- epoch boundary, whenever this function is applied to the `GovState` that was produced
167- -- by ledger at any point that is two stability windows before the end of the epoch. If
168- -- you need to know if there were actual changes to those PParams then use
169- -- `nextEpochUpdatedPParams` instead.
170- nextEpochPParams :: EraGov era => GovState era -> PParams era
171- nextEpochPParams govState =
172- fromSMaybe (govState ^. curPParamsGovStateL) $ nextEpochUpdatedPParams govState
173-
174- -- | This function is guaranteed to return updated PParams when it is called during the
175- -- last two stability windows of the epoch and there were proposals to update PParams that
176- -- all relevant parties reached consensus on. In other words whenever there is a definite
177- -- update to PParams coming on the epoch boundary those PParams will be returned,
178- -- otherwise it will return `Nothing`. This function is inexpensive and can be invoked at
179- -- any time without danger of forcing some suspended computation.
180- nextEpochUpdatedPParams :: EraGov era => GovState era -> StrictMaybe (PParams era )
181- nextEpochUpdatedPParams govState =
182- maybeToStrictMaybe $ knownFuturePParams (govState ^. futurePParamsGovStateL)
183-
184- solidifyFuturePParams :: FuturePParams era -> FuturePParams era
185- solidifyFuturePParams = \ case
186- -- Here we convert a potential to a definite update:
187- PotentialPParamsUpdate Nothing -> NoPParamsUpdate
188- PotentialPParamsUpdate (Just pp) -> DefinitePParamsUpdate pp
189- fpp -> fpp
190-
191- deriving stock instance Eq PParams era ) => Eq FuturePParams era )
192- deriving stock instance Show PParams era ) => Show FuturePParams era )
193- deriving via AllowThunk (FuturePParams era ) instance NoThunks (FuturePParams era )
194- instance (Typeable era , EncCBOR (PParams era )) => EncCBOR (FuturePParams era ) where
195- encCBOR =
196- encode . \ case
197- NoPParamsUpdate -> Sum NoPParamsUpdate 0
198- DefinitePParamsUpdate pp -> Sum DefinitePParamsUpdate 1 !> To pp
199- PotentialPParamsUpdate pp -> Sum PotentialPParamsUpdate 2 !> To pp
200-
201- instance (Typeable era , DecCBOR (PParams era )) => DecCBOR (FuturePParams era ) where
202- decCBOR = decode . Summands " FuturePParams" $ \ case
203- 0 -> SumD NoPParamsUpdate
204- 1 -> SumD DefinitePParamsUpdate <! From
205- 2 -> SumD PotentialPParamsUpdate <! From
206- k -> Invalid k
207-
208- instance NFData (PParams era ) => NFData (FuturePParams era ) where
209- rnf = \ case
210- NoPParamsUpdate -> ()
211- PotentialPParamsUpdate pp -> rnf pp
212- DefinitePParamsUpdate pp -> rnf pp
213-
214- proposalsL :: Lens' (ShelleyGovState era ) (ProposedPPUpdates era )
215- proposalsL = lens sgsCurProposals (\ sgov x -> sgov {sgsCurProposals = x})
216-
217- futureProposalsL :: Lens' (ShelleyGovState era ) (ProposedPPUpdates era )
218- futureProposalsL = lens sgsFutureProposals (\ sgov x -> sgov {sgsFutureProposals = x})
219-
22080curPParamsShelleyGovStateL :: Lens' (ShelleyGovState era ) (PParams era )
22181curPParamsShelleyGovStateL = lens sgsCurPParams (\ sps x -> sps {sgsCurPParams = x})
22282
0 commit comments