Merge pull request #3698 from input-output-hk/jj/reorder-procedures

Reordering of governance actions

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

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

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) =

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

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)

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

eras/conway/test-suite/test/Tests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Main where

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)
+    ]