diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index d5b095da809..afd0eafb67a 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.9.0.0 +* Add `reorderActions`, `actionPriority` * Remove `ensProtVer` field from `EnactState`: #3705 * Move `ConwayEraTxBody` to `Cardano.Ledger.Conway.TxBody` * Move `ConwayEraPParams` to `Cardano.Ledger.Conway.PParams` @@ -25,6 +26,17 @@ * Add `FromJSON` instance for `Committee` * Add `constitution` and `committee` fields to `ConwayGenesis` +### testlib + +* Add `genNewCommittee` +* Add `genNoConfidence` +* Add `genTreasuryWithdrawals` +* Add `genHardForkInitiation` +* Add `genParameterChange` +* Add `genNewConstitution` +* Add `genGovActionStateFromAction` +* Add `govActionGenerators` + ## 1.8.0.0 * Add all Conway `TxCert` to consumed/produced calculations in the `UTXO` rule. #3700 diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 143973e3aa5..97046ddf3d8 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -119,6 +119,7 @@ test-suite tests Test.Cardano.Ledger.Conway.BinarySpec Test.Cardano.Ledger.Conway.RatifySpec Test.Cardano.Ledger.Conway.GenesisSpec + Test.Cardano.Ledger.Conway.GovActionReorderSpec Paths_cardano_ledger_conway default-language: Haskell2010 @@ -135,4 +136,6 @@ test-suite tests cardano-ledger-core, containers, data-default-class, - testlib + testlib, + cardano-strict-containers, + cardano-ledger-binary:testlib diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index 26843eff0d3..1ee3b37b017 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -20,6 +20,8 @@ module Cardano.Ledger.Conway.Rules.Ratify ( RatifySignal (..), dRepAccepted, dRepAcceptedRatio, + reorderActions, + actionPriority, ) where import Cardano.Ledger.BaseTypes (BoundedRational (..), ShelleyBase, StrictMaybe (..)) @@ -51,12 +53,15 @@ import Control.State.Transition.Extended ( judgmentContext, trans, ) +import Data.Foldable (Foldable (..)) +import Data.List (sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Monoid (Sum (..)) import Data.Ratio ((%)) import Data.Sequence.Strict (StrictSeq (..)) +import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set import Data.Void (Void, absurd) import Data.Word (Word64) @@ -202,6 +207,18 @@ delayingAction TreasuryWithdrawals {} = False delayingAction ParameterChange {} = False delayingAction InfoAction {} = False +actionPriority :: GovAction era -> Int +actionPriority NoConfidence {} = 0 +actionPriority NewCommittee {} = 1 +actionPriority NewConstitution {} = 2 +actionPriority HardForkInitiation {} = 3 +actionPriority ParameterChange {} = 4 +actionPriority TreasuryWithdrawals {} = 5 +actionPriority InfoAction {} = 6 + +reorderActions :: StrictSeq (GovActionState era) -> StrictSeq (GovActionState era) +reorderActions = Seq.fromList . sortOn (actionPriority . gasAction) . toList + ratifyTransition :: forall era. ( Embed (EraRule "ENACT" era) (ConwayRATIFY era) @@ -218,7 +235,8 @@ ratifyTransition = do , RatifySignal rsig ) <- judgmentContext - case rsig of + let reorderedActions = reorderActions rsig + case reorderedActions of ast :<| sigs -> do let gas@GovActionState {gasId, gasAction, gasExpiresAfter} = ast withdrawalCanWithdraw (TreasuryWithdrawals m) = diff --git a/eras/conway/impl/test/Main.hs b/eras/conway/impl/test/Main.hs index c1ecba7da90..0fa54a4db80 100644 --- a/eras/conway/impl/test/Main.hs +++ b/eras/conway/impl/test/Main.hs @@ -3,6 +3,7 @@ module Main where import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.BinarySpec as BinarySpec import qualified Test.Cardano.Ledger.Conway.GenesisSpec as GenesisSpec +import qualified Test.Cardano.Ledger.Conway.GovActionReorderSpec as GovActionReorderSpec import qualified Test.Cardano.Ledger.Conway.RatifySpec as RatifySpec main :: IO () @@ -12,3 +13,4 @@ main = BinarySpec.spec RatifySpec.spec GenesisSpec.spec + GovActionReorderSpec.spec diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs new file mode 100644 index 00000000000..5404c203ca4 --- /dev/null +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.GovActionReorderSpec (spec) where + +import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Conway.Governance (GovActionState (..)) +import Cardano.Ledger.Conway.Rules (actionPriority, reorderActions) +import Data.Foldable (Foldable (..)) +import Data.List (sort, sortOn) +import qualified Data.Sequence.Strict as Seq +import Test.Cardano.Ledger.Binary.Arbitrary () +import Test.Cardano.Ledger.Common (Spec, describe, prop, shuffle) +import Test.Cardano.Ledger.Conway.Arbitrary ( + genGovActionStateFromAction, + govActionGenerators, + ) + +spec :: Spec +spec = + describe "Conway governance actions reordering" $ do + prop "preserves length when reordered" $ + \actions -> Seq.length actions == Seq.length (reorderActions @Conway actions) + prop "sorts by priority" $ + \actions -> + sort (toList (actionPriority . gasAction @Conway <$> actions)) + == toList (actionPriority . gasAction <$> reorderActions actions) + prop "same priority actions are not rearranged" $ + \a as -> + let filterPrio b = actionPriority (gasAction a) == actionPriority (gasAction b) + in filter filterPrio (toList $ reorderActions @Conway (a Seq.:<| as)) + == filter filterPrio (toList $ reorderActions (a Seq.:<| as)) + prop "orders actions correctly" $ do + actionsList <- + traverse + (>>= genGovActionStateFromAction) + (govActionGenerators @Conway) + let sortedActions = sortOn (actionPriority . gasAction) actionsList + shuffledActions <- shuffle actionsList + pure $ + Seq.fromList sortedActions + == reorderActions (Seq.fromList shuffledActions) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 51f22c553e9..4b2e0499bda 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -7,7 +7,17 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Cardano.Ledger.Conway.Arbitrary (uniqueIdGovActions) where +module Test.Cardano.Ledger.Conway.Arbitrary ( + genNewCommittee, + genNoConfidence, + genTreasuryWithdrawals, + genHardForkInitiation, + genParameterChange, + genNewConstitution, + genGovActionStateFromAction, + govActionGenerators, + uniqueIdGovActions, +) where import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) @@ -192,30 +202,57 @@ instance <*> arbitrary <*> arbitrary +genGovActionStateFromAction :: Era era => GovAction era -> Gen (GovActionState era) +genGovActionStateFromAction act = + GovActionState + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure act + <*> arbitrary + <*> arbitrary + instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovActionState era) where - arbitrary = - GovActionState - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = genGovActionStateFromAction =<< arbitrary + +genParameterChange :: (Era era, Arbitrary (PParamsUpdate era)) => Gen (GovAction era) +genParameterChange = ParameterChange <$> arbitrary <*> arbitrary + +genHardForkInitiation :: Era era => Gen (GovAction era) +genHardForkInitiation = HardForkInitiation <$> arbitrary <*> arbitrary + +genTreasuryWithdrawals :: Era era => Gen (GovAction era) +genTreasuryWithdrawals = TreasuryWithdrawals <$> arbitrary + +genNoConfidence :: Era era => Gen (GovAction era) +genNoConfidence = NoConfidence <$> arbitrary + +genNewCommittee :: Era era => Gen (GovAction era) +genNewCommittee = NewCommittee <$> arbitrary <*> arbitrary <*> arbitrary + +genNewConstitution :: Era era => Gen (GovAction era) +genNewConstitution = NewConstitution <$> arbitrary <*> arbitrary + +govActionGenerators :: + ( Era era + , Arbitrary (PParamsUpdate era) + ) => + [Gen (GovAction era)] +govActionGenerators = + [ genParameterChange + , genHardForkInitiation + , genTreasuryWithdrawals + , genNoConfidence + , genNewCommittee + , genNewConstitution + , pure InfoAction + ] instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovAction era) where - arbitrary = - oneof - [ ParameterChange <$> arbitrary <*> arbitrary - , HardForkInitiation <$> arbitrary <*> arbitrary - , TreasuryWithdrawals <$> arbitrary - , NoConfidence <$> arbitrary - , NewCommittee <$> arbitrary <*> arbitrary <*> arbitrary - , NewConstitution <$> arbitrary <*> arbitrary - , pure InfoAction - ] + arbitrary = oneof govActionGenerators instance Era era => Arbitrary (Committee era) where arbitrary = Committee <$> arbitrary <*> arbitrary diff --git a/eras/conway/test-suite/test/Tests.hs b/eras/conway/test-suite/test/Tests.hs index 3bf1b4b6b16..71de7180815 100644 --- a/eras/conway/test-suite/test/Tests.hs +++ b/eras/conway/test-suite/test/Tests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Main where diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs index f6cf052b100..10968993308 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs @@ -475,4 +475,5 @@ conwayFeatures :: TestTree conwayFeatures = testGroup "Gov examples" - [testCase "gov" $ testGov (Conway Mock)] + [ testCase "gov" $ testGov (Conway Mock) + ]