Add constitution and committee to ConwayGenesis

IntersectMBO · Aug 25, 2023 · 6e731f6 · 6e731f6
1 parent 1b4f865
commit 6e731f6
Show file tree

Hide file tree

Showing 5 changed files with 61 additions and 22 deletions.
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -12,31 +13,70 @@ where
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
+  decodeNullStrictMaybe,
+  encodeNullStrictMaybe,
  )
+import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams)
-import Cardano.Ledger.Crypto (Crypto)
-import Data.Aeson (FromJSON (..), ToJSON)
-import Data.Aeson.Types (ToJSON (..))
+import Cardano.Ledger.Core
+import Data.Aeson (
+  FromJSON (..),
+  KeyValue (..),
+  ToJSON (..),
+  object,
+  pairs,
+  withObject,
+  (.:),
+  (.:?),
+ )
+import Data.Default.Class (Default (def))
 import Data.Functor.Identity (Identity)
+import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 
-newtype ConwayGenesis c = ConwayGenesis
-  { cgUpgradePParams :: UpgradeConwayPParams Identity
+data ConwayGenesis c = ConwayGenesis
+  { cgUpgradePParams :: !(UpgradeConwayPParams Identity)
+  , cgConstitution :: !(Constitution c)
+  , cgCommittee :: !(StrictMaybe (Committee c))
   }
   deriving (Eq, Generic, Show)
 
-instance NoThunks (ConwayGenesis c)
+instance Era c => NoThunks (ConwayGenesis c)
 
 -- | Genesis are always encoded with the version of era they are defined in.
-instance Crypto c => DecCBOR (ConwayGenesis c) where
-  decCBOR = ConwayGenesis <$> decCBOR
+instance Era c => DecCBOR (ConwayGenesis c) where
+  decCBOR =
+    ConwayGenesis
+      <$> decCBOR
+      <*> decCBOR
+      <*> decodeNullStrictMaybe decCBOR
+
+instance Era c => EncCBOR (ConwayGenesis c) where
+  encCBOR (ConwayGenesis pparams c comm) =
+    encCBOR pparams
+      <> encCBOR c
+      <> encodeNullStrictMaybe encCBOR comm
+
+instance Era c => ToJSON (ConwayGenesis c) where
+  toJSON = object . toConwayGenesisPairs
+  toEncoding = pairs . mconcat . toConwayGenesisPairs
 
-instance Crypto c => EncCBOR (ConwayGenesis c) where
-  encCBOR (ConwayGenesis x) = encCBOR x
+instance Era c => FromJSON (ConwayGenesis c) where
+  parseJSON =
+    withObject "ConwayGenesis" $ \obj ->
+      ConwayGenesis
+        <$> obj .: "upgradeProtocolParams"
+        <*> obj .: "constitution"
+        <*> (maybeToStrictMaybe <$> obj .:? "committee")
 
-instance Crypto c => ToJSON (ConwayGenesis c) where
-  toJSON ConwayGenesis {..} = toJSON cgUpgradePParams
+toConwayGenesisPairs :: (Era c, KeyValue a) => ConwayGenesis c -> [a]
+toConwayGenesisPairs cg@(ConwayGenesis _ _ _) =
+  let ConwayGenesis {..} = cg
+   in [ "upgradeProtocolParams" .= cgUpgradePParams
+      , "constitution" .= cgConstitution
+      , "committee" .= cgConstitution
+      ]
 
-instance Crypto c => FromJSON (ConwayGenesis c) where
-  parseJSON x = ConwayGenesis <$> parseJSON x
+instance Era c => Default (ConwayGenesis c) where
+  def = ConwayGenesis def def def
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs
@@ -63,7 +63,7 @@ import Lens.Micro
 -- being total. Do not change it!
 --------------------------------------------------------------------------------
 
-type instance TranslationContext (ConwayEra c) = ConwayGenesis c
+type instance TranslationContext (ConwayEra c) = ConwayGenesis (ConwayEra c)
 
 instance Crypto c => TranslateEra (ConwayEra c) NewEpochState where
   translateEra ctxt nes =

diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs
@@ -32,8 +32,8 @@ import Test.Cardano.Ledger.Alonzo.Arbitrary (genAlonzoScript)
 import Test.Cardano.Ledger.Babbage.Arbitrary ()
 import Test.Cardano.Ledger.Common
 
-instance Crypto c => Arbitrary (ConwayGenesis c) where
-  arbitrary = ConwayGenesis <$> arbitrary
+instance Era c => Arbitrary (ConwayGenesis c) where
+  arbitrary = ConwayGenesis <$> arbitrary <*> arbitrary <*> arbitrary
 
 instance Arbitrary (UpgradeConwayPParams Identity) where
   arbitrary =

diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs
@@ -200,6 +200,5 @@ exampleConwayNewEpochState =
     emptyPParams
     (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1))
 
-exampleConwayGenesis :: ConwayGenesis c
-exampleConwayGenesis =
-  ConwayGenesis def
+exampleConwayGenesis :: ConwayGenesis Conway
+exampleConwayGenesis = def
diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs
@@ -27,11 +27,11 @@ allprops =
   testGroup
     (show (typeRep (Proxy @e)) <> " CBOR")
     [ testProperty "ConwayGenesis" $
-        roundTripCborRangeExpectation @(ConwayGenesis (EraCrypto e))
+        roundTripCborRangeExpectation @(ConwayGenesis e)
           (natVersion @2)
           maxBound
     , testProperty "ConwayGenesis (Plain)" $
-        roundTripCborRangeExpectation @(ConwayGenesis (EraCrypto e))
+        roundTripCborRangeExpectation @(ConwayGenesis e)
           (eraProtVerLow @Conway)
           (eraProtVerHigh @Conway)
     , testProperty "v9 CostModels" $