Simplify CardanoHardForkTriggers

see the PR and issue description for details

Author: amesgen

ouroboros-consensus-cardano/changelog.d/20241014_170244_alexander.esgen_cardano_hf_trigger.md

@@ -0,0 +1,16 @@
+### Breaking
+
+- Changed `CardanoHardTriggers` to contain `CardanoHardForkTrigger`s which are a
+  simpler version of the previous `TriggerHardForkAt`. In particular, this will
+  affect call sites of `protocolInfoCardano`.
+
+  Migration notes:
+
+    - Change `TriggerHardForkAtEpoch` to `CardanoTriggerHardForkAtEpoch`.
+    - Change `TriggerHardForkAtVersion` to `CardanoTriggerHardForkAtDefaultVersion`.
+
+      This constructor does not take a version argument, but rather defaults to
+      the corresponding first ledger protocol version. We are not aware of any
+      use case that requires a different value, but if there is, it is still
+      possible to manually modify the returned `LedgerConfig`s of
+      `protocolInfoCardano` directly.

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano.hs

@@ -8,6 +8,7 @@ module Ouroboros.Consensus.Cardano (
   , ProtocolCardano
   , ProtocolShelley
     -- * Abstract over the various protocols
+  , CardanoHardForkTrigger (..)
   , CardanoHardForkTriggers (..)
   , module X
   ) where

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -33,6 +34,7 @@
 
 module Ouroboros.Consensus.Cardano.Node (
     CardanoHardForkConstraints
+  , CardanoHardForkTrigger (..)
   , CardanoHardForkTriggers (.., CardanoHardForkTriggers', triggerHardForkShelley, triggerHardForkAllegra, triggerHardForkMary, triggerHardForkAlonzo, triggerHardForkBabbage, triggerHardForkConway)
   , CardanoProtocolParams (..)
   , MaxMajorProtVer (..)
@@ -504,17 +506,42 @@ instance CardanoHardForkConstraints c
   ProtocolInfo
 -------------------------------------------------------------------------------}
 
+-- | When to trigger a hard fork to a Cardano era.
+data CardanoHardForkTrigger blk =
+    -- | Trigger the hard fork when the ledger protocol version is updated to
+    -- the default for that era (@'L.eraProtVerLow' \@('ShelleyBlockLedgerEra'
+    -- blk)@). Also see 'TriggerHardForkAtVersion'.
+    CardanoTriggerHardForkAtDefaultVersion
+  |
+    -- | Trigger the hard fork at the given epoch. For testing only. Also see
+    -- 'TriggerHardForkAtEpoch'.
+    CardanoTriggerHardForkAtEpoch EpochNo
+  deriving stock (Show)
+
+toTriggerHardFork ::
+     forall blk. L.Era (ShelleyBlockLedgerEra blk)
+  => CardanoHardForkTrigger blk
+  -> TriggerHardFork
+toTriggerHardFork = \case
+    CardanoTriggerHardForkAtDefaultVersion ->
+      TriggerHardForkAtVersion $
+        SL.getVersion (L.eraProtVerLow @(ShelleyBlockLedgerEra blk))
+    CardanoTriggerHardForkAtEpoch epochNo ->
+      TriggerHardForkAtEpoch epochNo
+
 newtype CardanoHardForkTriggers = CardanoHardForkTriggers {
-    getCardanoHardForkTriggers :: NP (K TriggerHardFork) (CardanoShelleyEras StandardCrypto)
+    getCardanoHardForkTriggers ::
+         NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto)
   }
 
 pattern CardanoHardForkTriggers' ::
-     TriggerHardFork
-  -> TriggerHardFork
-  -> TriggerHardFork
-  -> TriggerHardFork
-  -> TriggerHardFork
-  -> TriggerHardFork
+     (c ~ StandardCrypto)
+  => CardanoHardForkTrigger (ShelleyBlock (TPraos c) (ShelleyEra  c))
+  -> CardanoHardForkTrigger (ShelleyBlock (TPraos c) (AllegraEra  c))
+  -> CardanoHardForkTrigger (ShelleyBlock (TPraos c) (MaryEra     c))
+  -> CardanoHardForkTrigger (ShelleyBlock (TPraos c) (AlonzoEra   c))
+  -> CardanoHardForkTrigger (ShelleyBlock (Praos  c) (BabbageEra  c))
+  -> CardanoHardForkTrigger (ShelleyBlock (Praos  c) (ConwayEra   c))
   -> CardanoHardForkTriggers
 pattern CardanoHardForkTriggers' {
         triggerHardForkShelley
@@ -525,12 +552,12 @@ pattern CardanoHardForkTriggers' {
       , triggerHardForkConway
       } =
     CardanoHardForkTriggers
-      (  K triggerHardForkShelley
-      :* K triggerHardForkAllegra
-      :* K triggerHardForkMary
-      :* K triggerHardForkAlonzo
-      :* K triggerHardForkBabbage
-      :* K triggerHardForkConway
+      (  triggerHardForkShelley
+      :* triggerHardForkAllegra
+      :* triggerHardForkMary
+      :* triggerHardForkAlonzo
+      :* triggerHardForkBabbage
+      :* triggerHardForkConway
       :* Nil
       )
 {-# COMPLETE CardanoHardForkTriggers' #-}
@@ -674,7 +701,7 @@ protocolInfoCardano paramsCardano
     partialLedgerConfigByron :: PartialLedgerConfig ByronBlock
     partialLedgerConfigByron = ByronPartialLedgerConfig {
           byronLedgerConfig    = ledgerConfigByron
-        , byronTriggerHardFork = triggerHardForkShelley
+        , byronTriggerHardFork = toTriggerHardFork triggerHardForkShelley
         }
 
     kByron :: SecurityParam
@@ -728,7 +755,7 @@ protocolInfoCardano paramsCardano
         mkPartialLedgerConfigShelley
           transitionConfigShelley
           maxMajorProtVer
-          triggerHardForkAllegra
+          (toTriggerHardFork triggerHardForkAllegra)
 
     kShelley :: SecurityParam
     kShelley = SecurityParam $ sgSecurityParam genesisShelley
@@ -751,7 +778,7 @@ protocolInfoCardano paramsCardano
         mkPartialLedgerConfigShelley
           transitionConfigAllegra
           maxMajorProtVer
-          triggerHardForkMary
+          (toTriggerHardFork triggerHardForkMary)
 
     -- Mary
 
@@ -771,7 +798,7 @@ protocolInfoCardano paramsCardano
         mkPartialLedgerConfigShelley
           transitionConfigMary
           maxMajorProtVer
-          triggerHardForkAlonzo
+          (toTriggerHardFork triggerHardForkAlonzo)
 
     -- Alonzo
 
@@ -791,7 +818,7 @@ protocolInfoCardano paramsCardano
         mkPartialLedgerConfigShelley
           transitionConfigAlonzo
           maxMajorProtVer
-          triggerHardForkBabbage
+          (toTriggerHardFork triggerHardForkBabbage)
 
     -- Babbage
 
@@ -821,7 +848,7 @@ protocolInfoCardano paramsCardano
         mkPartialLedgerConfigShelley
           transitionConfigBabbage
           maxMajorProtVer
-          triggerHardForkConway
+          (toTriggerHardFork triggerHardForkConway)
 
     -- Conway
 

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
@@ -14,9 +13,8 @@ module Test.Consensus.Cardano.ProtocolInfo (
   , ShelleySlotLengthInSeconds (..)
     -- ** Hard-fork specification
   , Era (..)
-  , HardForkSpec (..)
   , hardForkInto
-  , stayInByron
+  , hardForkOnDefaultProtocolVersions
     -- * ProtocolInfo elaboration
   , mkSimpleTestProtocolInfo
   , mkTestProtocolInfo
@@ -31,6 +29,7 @@ import qualified Cardano.Ledger.BaseTypes as SL
 import qualified Cardano.Protocol.TPraos.OCert as SL
 import qualified Cardano.Slotting.Time as Time
 import           Data.Proxy (Proxy (..))
+import           Data.SOP.Strict
 import           Data.Word (Word64)
 import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.BlockchainTime (SlotLength)
@@ -39,9 +38,8 @@ import           Ouroboros.Consensus.Byron.Node (ByronLeaderCredentials,
                      byronPbftSignatureThreshold, byronSoftwareVersion)
 import           Ouroboros.Consensus.Cardano.Block (CardanoBlock)
 import           Ouroboros.Consensus.Cardano.Node (CardanoHardForkConstraints,
-                     CardanoHardForkTriggers (..), CardanoProtocolParams (..),
-                     TriggerHardFork (TriggerHardForkAtEpoch, TriggerHardForkNotDuringThisExecution),
-                     protocolInfoCardano)
+                     CardanoHardForkTrigger (..), CardanoHardForkTriggers (..),
+                     CardanoProtocolParams (..), protocolInfoCardano)
 import           Ouroboros.Consensus.Config (emptyCheckpointsMap)
 import           Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
 import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..),
@@ -77,19 +75,6 @@ instance ToSlotLength ByronSlotLengthInSeconds where
 instance ToSlotLength ShelleySlotLengthInSeconds where
   toSlotLength (ShelleySlotLengthInSeconds n) = Time.slotLengthFromSec $ fromIntegral n
 
--- | This data structure is used to specify if and when hardforks should take
--- place, and the version used at each era. See 'stayInByron' and 'hardForkInto'
--- for examples.
-data HardForkSpec =
-    HardForkSpec {
-      shelleyHardForkSpec :: TriggerHardFork
-    , allegraHardForkSpec :: TriggerHardFork
-    , maryHardForkSpec    :: TriggerHardFork
-    , alonzoHardForkSpec  :: TriggerHardFork
-    , babbageHardForkSpec :: TriggerHardFork
-    , conwayHardForkSpec  :: TriggerHardFork
-    }
-
 data Era = Byron
          | Shelley
          | Allegra
@@ -99,52 +84,37 @@ data Era = Byron
          | Conway
   deriving (Show, Eq, Ord, Enum)
 
-selectEra :: Era -> HardForkSpec -> TriggerHardFork
-selectEra Byron   _                                    = error "Byron is the first era, therefore there is no hard fork spec."
-selectEra Shelley HardForkSpec { shelleyHardForkSpec } = shelleyHardForkSpec
-selectEra Allegra HardForkSpec { allegraHardForkSpec } = allegraHardForkSpec
-selectEra Mary    HardForkSpec { maryHardForkSpec    } = maryHardForkSpec
-selectEra Alonzo  HardForkSpec { alonzoHardForkSpec  } = alonzoHardForkSpec
-selectEra Babbage HardForkSpec { babbageHardForkSpec } = babbageHardForkSpec
-selectEra Conway  HardForkSpec { conwayHardForkSpec  } = conwayHardForkSpec
-
-stayInByron :: HardForkSpec
-stayInByron =
-    HardForkSpec {
-      shelleyHardForkSpec = TriggerHardForkNotDuringThisExecution
-    , allegraHardForkSpec = TriggerHardForkNotDuringThisExecution
-    , maryHardForkSpec    = TriggerHardForkNotDuringThisExecution
-    , alonzoHardForkSpec  = TriggerHardForkNotDuringThisExecution
-    , babbageHardForkSpec = TriggerHardForkNotDuringThisExecution
-    , conwayHardForkSpec  = TriggerHardForkNotDuringThisExecution
-    }
-
 protocolVersionZero :: SL.ProtVer
 protocolVersionZero = SL.ProtVer versionZero 0
   where
     versionZero :: SL.Version
     versionZero = SL.natVersion @0
 
-hardForkInto :: Era -> HardForkSpec
-hardForkInto Byron   = stayInByron
+hardForkOnDefaultProtocolVersions :: CardanoHardForkTriggers
+hardForkOnDefaultProtocolVersions =
+      CardanoHardForkTriggers
+    $ hpure CardanoTriggerHardForkAtDefaultVersion
+
+hardForkInto :: Era -> CardanoHardForkTriggers
+hardForkInto Byron   = hardForkOnDefaultProtocolVersions
 hardForkInto Shelley =
-    stayInByron
-      { shelleyHardForkSpec = TriggerHardForkAtEpoch 0 }
+    hardForkOnDefaultProtocolVersions
+      { triggerHardForkShelley = CardanoTriggerHardForkAtEpoch 0 }
 hardForkInto Allegra =
     (hardForkInto Shelley)
-      { allegraHardForkSpec = TriggerHardForkAtEpoch 0 }
+      { triggerHardForkAllegra = CardanoTriggerHardForkAtEpoch 0 }
 hardForkInto Mary    =
     (hardForkInto Allegra)
-      { maryHardForkSpec    = TriggerHardForkAtEpoch 0 }
+      { triggerHardForkMary    = CardanoTriggerHardForkAtEpoch 0 }
 hardForkInto Alonzo  =
     (hardForkInto Mary)
-      { alonzoHardForkSpec  = TriggerHardForkAtEpoch 0 }
+      { triggerHardForkAlonzo  = CardanoTriggerHardForkAtEpoch 0 }
 hardForkInto Babbage =
     (hardForkInto Alonzo)
-      { babbageHardForkSpec = TriggerHardForkAtEpoch 0 }
+      { triggerHardForkBabbage = CardanoTriggerHardForkAtEpoch 0 }
 hardForkInto Conway =
     (hardForkInto Babbage)
-      { conwayHardForkSpec  = TriggerHardForkAtEpoch 0 }
+      { triggerHardForkConway  = CardanoTriggerHardForkAtEpoch 0 }
 
 {-------------------------------------------------------------------------------
  ProtocolInfo elaboration
@@ -167,9 +137,10 @@ hardForkInto Conway =
 -- If you want to tweak the resulting protocol info further see
 -- 'mkTestProtocolInfo'.
 --
--- The resulting 'ProtocolInfo' contains a ledger state. The 'HardForkSpec'
--- parameter will determine to which era this ledger state belongs. See
--- 'HardForkSpec' for more details on how to specify a value of this type.
+-- The resulting 'ProtocolInfo' contains a ledger state. The
+-- 'CardanoHardForkTriggers' parameter will determine to which era this ledger
+-- state belongs. See 'hardForkInto' and 'hardForkOnDefaultProtocolVersions' for
+-- more details on how to specify a value of this type.
 --
 mkSimpleTestProtocolInfo ::
      forall c
@@ -180,15 +151,15 @@ mkSimpleTestProtocolInfo ::
   -> ByronSlotLengthInSeconds
   -> ShelleySlotLengthInSeconds
   -> SL.ProtVer
-  -> HardForkSpec
+  -> CardanoHardForkTriggers
   -> ProtocolInfo (CardanoBlock c)
 mkSimpleTestProtocolInfo
     decentralizationParam
     securityParam
     byronSlotLenghtInSeconds
     shelleySlotLengthInSeconds
     protocolVersion
-    hardForkSpec
+    hardForkTriggers
   = fst
   $ mkTestProtocolInfo @IO
       (CoreNodeId 0, coreNodeShelley)
@@ -199,7 +170,7 @@ mkSimpleTestProtocolInfo
       generatedSecretsByron
       (Just $ PBftSignatureThreshold 1)
       protocolVersion
-      hardForkSpec
+      hardForkTriggers
   where
     byronProtocolVersion =
         CC.Update.ProtocolVersion 0 0 0
@@ -258,8 +229,8 @@ mkTestProtocolInfo ::
   -> SL.ProtVer
   -- ^ See 'protocolInfoCardano' for the details of what is the
   -- relation between this version and any 'TriggerHardForkAtVersion'
-  -- that __might__ appear in the 'HardForkSpec' parameter.
-  -> HardForkSpec
+  -- that __might__ appear in the 'CardanoHardForkTriggers' parameter.
+  -> CardanoHardForkTriggers
   -- ^ Specification of the era to which the initial state should hard-fork to.
   -> (ProtocolInfo (CardanoBlock c), m [BlockForging m (CardanoBlock c)])
 mkTestProtocolInfo
@@ -271,7 +242,7 @@ mkTestProtocolInfo
     generatedSecretsByron
     aByronPbftSignatureThreshold
     protocolVersion
-    hardForkSpec
+    hardForkTriggers
   =
     protocolInfoCardano
         (CardanoProtocolParams
@@ -286,14 +257,7 @@ mkTestProtocolInfo
               shelleyBasedInitialNonce      = initialNonce
             , shelleyBasedLeaderCredentials = [leaderCredentialsShelley]
             }
-          CardanoHardForkTriggers' {
-              triggerHardForkShelley = selectEra Shelley hardForkSpec
-            , triggerHardForkAllegra = selectEra Allegra hardForkSpec
-            , triggerHardForkMary    = selectEra Mary    hardForkSpec
-            , triggerHardForkAlonzo  = selectEra Alonzo  hardForkSpec
-            , triggerHardForkBabbage = selectEra Babbage hardForkSpec
-            , triggerHardForkConway  = selectEra Conway  hardForkSpec
-            }
+          hardForkTriggers
           ( L.mkLatestTransitionConfig
               shelleyGenesis
               -- These example genesis objects might need to become more