Merge pull request #5242 from IntersectMBO/lehins/slight-improvements-to-genesis

lehins · web-flow · commit 3f1225854024 · 2025-08-19T05:41:30.000-06:00
Adds `NFData` instances for `Genesis` types
diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 1.14.0.0
 
+* Add `NFData` instance for `AlonzoGenesis`
 * Add `reqSignerHashesTxBodyG`
 * Add `mkScriptIntegrity`
 * Changed the type of `hashScriptIntegrity`
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs
@@ -50,6 +50,7 @@ import Cardano.Ledger.Binary.Coders (
  )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Genesis (EraGenesis (..))
+import Control.DeepSeq (NFData)
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as Aeson
 import Data.Functor.Identity (Identity)
@@ -62,7 +63,7 @@ newtype AlonzoGenesis = AlonzoGenesisWrapper
   { unAlonzoGenesisWrapper :: UpgradeAlonzoPParams Identity
   }
   deriving stock (Eq, Generic)
-  deriving newtype (Show, NoThunks)
+  deriving newtype (Show, NoThunks, NFData)
   deriving (ToJSON) via KeyValuePairs AlonzoGenesis
 
 pattern AlonzoGenesis ::
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -9,7 +8,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -18,7 +16,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 1.20.0.0
 
+* Add `NFData` for `ConwayGenesis`
 * Deprecate `PoolParams` in favor of `StakePoolState`. #5196
   * Update `DRepPulser` and `RatifyEnv` to use `StakePoolState` instead of `PoolParams`.
 * Better predicate failures for incorrect deposits and refunds.
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs
@@ -32,6 +32,7 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.DRep (DRepState)
 import Cardano.Ledger.Genesis (EraGenesis (..))
+import Control.DeepSeq (NFData)
 import Data.Aeson (
   FromJSON (..),
   KeyValue (..),
@@ -66,6 +67,8 @@ instance EraGenesis ConwayEra where
 
 instance NoThunks ConwayGenesis
 
+instance NFData ConwayGenesis
+
 -- | Genesis are always encoded with the version of era they are defined in.
 instance FromCBOR ConwayGenesis where
   fromCBOR =
diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Genesis.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Genesis.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -9,7 +10,7 @@ module Cardano.Ledger.Dijkstra.Genesis (
   DijkstraGenesis (..),
 ) where
 
-import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
+import Cardano.Ledger.BaseTypes (ToKeyValuePairs (..))
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
@@ -21,35 +22,20 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
 import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams)
 import Cardano.Ledger.Genesis (EraGenesis (..))
-import Data.Aeson (FromJSON (..), ToJSON, Value (..), withObject)
+import Control.DeepSeq (NFData)
+import Data.Aeson (FromJSON (..), ToJSON)
 import Data.Functor.Identity (Identity)
 import GHC.Generics
 import NoThunks.Class (NoThunks)
 
--- TODO: Currently it is just a placeholder for all the new protocol parameters that will be added
--- in the Dijkstra era
-data DijkstraGenesis = DijkstraGenesis
-  { dgUpgradePParams :: !(UpgradeDijkstraPParams Identity DijkstraEra)
+newtype DijkstraGenesis = DijkstraGenesis
+  { dgUpgradePParams :: UpgradeDijkstraPParams Identity DijkstraEra
   }
-  deriving (Eq, Show, Generic)
-  deriving (ToJSON) via KeyValuePairs DijkstraGenesis
-
-instance FromJSON DijkstraGenesis where
-  parseJSON = withObject "DijkstraGenesis" $ \obj -> do
-    dgUpgradePParams <- parseJSON (Object obj)
-    pure DijkstraGenesis {..}
-
-instance NoThunks DijkstraGenesis
+  deriving (Eq, Show, Generic, NoThunks, ToJSON, FromJSON, ToKeyValuePairs, NFData)
 
 instance EraGenesis DijkstraEra where
   type Genesis DijkstraEra = DijkstraGenesis
 
--- TODO: Implement this and use for ToJSON instance
-instance ToKeyValuePairs DijkstraGenesis where
-  toKeyValuePairs dg@(DijkstraGenesis _) =
-    let DijkstraGenesis {..} = dg
-     in toKeyValuePairs dgUpgradePParams
-
 instance FromCBOR DijkstraGenesis where
   fromCBOR =
     eraDecoder @DijkstraEra $
diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -32,6 +33,7 @@ import Cardano.Ledger.Alonzo.PParams
 import Cardano.Ledger.Babbage.PParams
 import Cardano.Ledger.BaseTypes (
   EpochInterval (..),
+  KeyValuePairs (..),
   NonNegativeInterval,
   NonZero,
   PositiveInterval,
@@ -59,7 +61,7 @@ import Cardano.Ledger.Plutus (
 import Cardano.Ledger.Shelley.PParams
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData)
-import Data.Aeson (FromJSON, Key, ToJSON (..), withObject, (.:), (.=))
+import Data.Aeson (FromJSON, ToJSON (..), withObject, (.:), (.=))
 import qualified Data.Aeson as Aeson
 import Data.Data (Proxy (..))
 import Data.Default (Default (..))
@@ -240,12 +242,27 @@ deriving instance Eq (UpgradeDijkstraPParams Identity era)
 deriving instance Show (UpgradeDijkstraPParams Identity era)
 
 instance FromJSON (UpgradeDijkstraPParams Identity era) where
-  parseJSON = withObject "UpgradeDijkstraPParams" $ \o ->
-    UpgradeDijkstraPParams
-      <$> o .: "maxRefScriptSizePerBlock"
-      <*> o .: "maxRefScriptSizePerTx"
-      <*> o .: "refScriptCostStride"
-      <*> o .: "refScriptCostMultiplier"
+  parseJSON = withObject "UpgradeDijkstraPParams" $ \o -> do
+    udppMaxRefScriptSizePerBlock <- o .: "maxRefScriptSizePerBlock"
+    udppMaxRefScriptSizePerTx <- o .: "maxRefScriptSizePerTx"
+    udppRefScriptCostStride <- o .: "refScriptCostStride"
+    udppRefScriptCostMultiplier <- o .: "refScriptCostMultiplier"
+    pure UpgradeDijkstraPParams {..}
+
+instance ToKeyValuePairs (UpgradeDijkstraPParams Identity era) where
+  toKeyValuePairs udpp =
+    [ "maxRefScriptSizePerBlock" .= udppMaxRefScriptSizePerBlock udpp
+    , "maxRefScriptSizePerTx" .= udppMaxRefScriptSizePerTx udpp
+    , "refScriptCostStride" .= udppRefScriptCostStride udpp
+    , "refScriptCostMultiplier" .= udppRefScriptCostMultiplier udpp
+    ]
+
+deriving via
+  KeyValuePairs (UpgradeDijkstraPParams Identity era)
+  instance
+    ToJSON (UpgradeDijkstraPParams Identity era)
+
+instance NFData (UpgradeDijkstraPParams Identity era)
 
 instance NoThunks (UpgradeDijkstraPParams Identity era)
 
@@ -267,17 +284,6 @@ instance Era era => EncCBOR (UpgradeDijkstraPParams Identity era) where
         !> To udppRefScriptCostStride
         !> To udppRefScriptCostMultiplier
 
-upgradeDijkstraPParamsHKDPairs :: UpgradeDijkstraPParams Identity era -> [(Key, Aeson.Value)]
-upgradeDijkstraPParamsHKDPairs UpgradeDijkstraPParams {..} =
-  [ ("maxRefScriptSizePerBlock", toJSON udppMaxRefScriptSizePerBlock)
-  , ("maxRefScriptSizePerTx", toJSON udppMaxRefScriptSizePerTx)
-  , ("refScriptCostStride", toJSON udppRefScriptCostStride)
-  , ("refScriptCostMultiplier", toJSON udppRefScriptCostMultiplier)
-  ]
-
-instance ToKeyValuePairs (UpgradeDijkstraPParams Identity era) where
-  toKeyValuePairs upp = uncurry (.=) <$> upgradeDijkstraPParamsHKDPairs upp
-
 emptyDijkstraUpgradePParamsUpdate :: UpgradeDijkstraPParams StrictMaybe era
 emptyDijkstraUpgradePParamsUpdate = UpgradeDijkstraPParams SNothing SNothing SNothing SNothing
 
diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 1.17.0.0
 
+* Add `NFData` for `NominalDiffTimeMicro`, `ShelleyGenesisStaking` and `ShelleyGenesis`
 * Deprecate `PoolParams` in favor of `StakePoolState`. #5196
   * Deprecate the API `getPoolParameters` in favor of `getStakePools`.
   * Deprecate the lens `epochStatePoolParamsL` in favor of `epochStateStakePoolsL`.
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs
@@ -87,6 +87,7 @@ import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
 import qualified Cardano.Ledger.Val as Val
 import Cardano.Slotting.EpochInfo (EpochInfo)
 import Cardano.Slotting.Time (SystemStart (SystemStart))
+import Control.DeepSeq (NFData)
 import Control.Monad.Identity (Identity)
 import Data.Aeson (FromJSON (..), ToJSON (..), object, (.!=), (.:), (.:?), (.=))
 import qualified Data.Aeson as Aeson
@@ -137,6 +138,8 @@ data ShelleyGenesisStaking = ShelleyGenesisStaking
   deriving stock (Eq, Show, Generic)
   deriving (ToJSON) via KeyValuePairs ShelleyGenesisStaking
 
+instance NFData ShelleyGenesisStaking
+
 instance NoThunks ShelleyGenesisStaking
 
 instance Semigroup ShelleyGenesisStaking where
@@ -166,7 +169,7 @@ emptyGenesisStaking = mempty
 newtype NominalDiffTimeMicro = NominalDiffTimeMicro Micro
   deriving (Show, Eq, Generic)
   deriving anyclass (NoThunks)
-  deriving newtype (Ord, Num, Fractional, Real, ToJSON, FromJSON, EncCBOR, DecCBOR)
+  deriving newtype (Ord, Num, Fractional, Real, ToJSON, FromJSON, EncCBOR, DecCBOR, NFData)
 
 -- | There is no loss of resolution in this conversion
 microToPico :: Micro -> Pico
@@ -230,6 +233,8 @@ data ShelleyGenesis = ShelleyGenesis
   deriving stock (Generic, Show, Eq)
   deriving (ToJSON) via KeyValuePairs ShelleyGenesis
 
+instance NFData ShelleyGenesis
+
 sgInitialFundsL :: Lens' ShelleyGenesis (LM.ListMap Addr Coin)
 sgInitialFundsL = lens sgInitialFunds (\sg x -> sg {sgInitialFunds = x})
 
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs
@@ -54,7 +54,7 @@ import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential
-import Cardano.Ledger.Genesis (EraGenesis, NoGenesis (..))
+import Cardano.Ledger.Genesis
 import Cardano.Ledger.Keys
 import Cardano.Ledger.Shelley.Era
 import Cardano.Ledger.Shelley.Genesis
@@ -169,15 +169,17 @@ class
 
   toTransitionConfigKeyValuePairs ::
     KeyValue e a =>
-    TransitionConfig era -> [a]
+    TransitionConfig era ->
+    [a]
   default toTransitionConfigKeyValuePairs ::
     ( EraTransition (PreviousEra era)
     , ToKeyValuePairs (TranslationContext era)
     , ToKeyValuePairs (TransitionConfig (PreviousEra era))
     , Typeable (TranslationContext era)
     , KeyValue e a
     ) =>
-    TransitionConfig era -> [a]
+    TransitionConfig era ->
+    [a]
   toTransitionConfigKeyValuePairs config =
     toKeyValuePairs (config ^. tcPreviousEraConfigL) ++ translationContextPairs
     where
@@ -194,15 +196,12 @@ class
     , FromJSON (TranslationContext era)
     , FromJSON (TransitionConfig (PreviousEra era))
     ) =>
-    Aeson.Value -> Parser (TransitionConfig era)
+    Aeson.Value ->
+    Parser (TransitionConfig era)
   parseTransitionConfigJSON = withObject (eraName @era <> "TransitionConfig") $ \o -> do
     prevTransitionConfig :: TransitionConfig (PreviousEra era) <- parseJSON (Aeson.Object o)
-    case eqT :: Maybe (TranslationContext era :~: NoGenesis era) of
-      Nothing -> do
-        translationContext :: TranslationContext era <- o .: eraNameKey @era
-        pure $ mkTransitionConfig translationContext prevTransitionConfig
-      Just Refl ->
-        pure $ mkTransitionConfig NoGenesis prevTransitionConfig
+    genesis <- mkGenesisWith @era (o .: eraNameKey @era)
+    pure $ mkTransitionConfig genesis prevTransitionConfig
 
 eraNameKey :: forall era. Era era => Key
 eraNameKey = fromString (map toLower (eraName @era))
diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md
@@ -10,6 +10,9 @@
   * Replace `PoolParams` with `StatekPoolState` in `PState` and rename the fields and lenses.
     * `psStakePoolParams(L)` to `psStakePools(L)`, and
     * `psFutureStakePoolParams(L)` to `psFutureStakePools(L)`.
+* Add `mkGenesisWith`
+* Add `NFData` instance for `NoGenesis`
+* Require `Eq`, `Show`, `Typeable`, `ToCBOR`, `FromCBOR`, `ToJSON`, `FromJSON`, `NFData` for every `Genesis` type.
 * Add `HashHeader` (moved from `cardano-protocol-tpraos`)
 * Add `drepDepositCompactL`
 * Change the type of `drepDeposit` to `CompactForm Coin`
diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs
@@ -1,13 +1,17 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module Cardano.Ledger.Genesis (
   EraGenesis (..),
   NoGenesis (..),
+  mkGenesisWith,
 ) where
 
 import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
@@ -26,6 +30,7 @@ import Data.Aeson (
  )
 import qualified Data.Aeson.KeyMap as KV
 import Data.Kind (Type)
+import Data.Typeable
 
 class Era era => EraGenesis era where
   type Genesis era :: Type
@@ -55,3 +60,17 @@ instance FromJSON (NoGenesis era) where
       unless (KV.null o) $ fail "NoGenesis cannot have any fields"
       pure NoGenesis
     _ -> fail "Unexpected value type for NoGenesis"
+
+-- | Helper function that will produce `NoGenesis` for types that match it, otherwise action will be
+-- called that will produce the desired genesis type.
+mkGenesisWith ::
+  forall era g m.
+  (Typeable era, Typeable g, Monad m) =>
+  -- | Action that will produce the genesis type, but it will be invoked only when it is statically
+  -- known for @g@ to not be `NoGenesis`
+  m g ->
+  m g
+mkGenesisWith f =
+  case eqT :: Maybe (g :~: NoGenesis era) of
+    Nothing -> f
+    Just Refl -> pure (NoGenesis :: NoGenesis era)
diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs
@@ -14,6 +14,7 @@ import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential
+import Cardano.Ledger.Genesis
 import Cardano.Ledger.Plutus (CostModels)
 import Cardano.Ledger.State
 import Cardano.Ledger.UMap
@@ -44,6 +45,7 @@ class
   , EraStake era
   , EraUTxO era
   , EraAccounts era
+  , EraGenesis era
   , -- Arbitrary Core
     Arbitrary (Tx era)
   , Arbitrary (TxOut era)
