Simplify CardanoHardForkTriggers (#1282)

Closes #1281

Instead of letting the user provide several `TriggerHardFork`s, only let
them provide `CardanoHardForkTrigger`s, a restricted version that should
make `protocolInfoCardano` more straightforward and less error-prone.

```haskell
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
```

It is (intentionally) no longer possible to directly (though still
manually, also see the changelog entry) to use a non-default version
trigger. However, this feature was used in the Cardano ThreadNet test
(as Byron had an intra-era HF), which we resolve by modifying the
initial Byron protocol version (see the corresponding Haddocks).

In the node, this will result in the removal of the (unused)
`TestXxxHardForkAtVersion` config fields.

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 (..)
@@ -518,17 +520,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
@@ -539,12 +566,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' #-}
@@ -684,7 +711,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigByron :: PartialLedgerConfig ByronBlock
  partialLedgerConfigByron = ByronPartialLedgerConfig {
  byronLedgerConfig = ledgerConfigByron
- , byronTriggerHardFork = triggerHardForkShelley
+ , byronTriggerHardFork = toTriggerHardFork triggerHardForkShelley
  }
 
  kByron :: SecurityParam
@@ -737,7 +764,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigShelley =
  mkPartialLedgerConfigShelley
  transitionConfigShelley
- triggerHardForkAllegra
+ (toTriggerHardFork triggerHardForkAllegra)
 
  kShelley :: SecurityParam
  kShelley = SecurityParam $ sgSecurityParam genesisShelley
@@ -759,7 +786,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigAllegra =
  mkPartialLedgerConfigShelley
  transitionConfigAllegra
- triggerHardForkMary
+ (toTriggerHardFork triggerHardForkMary)
 
  -- Mary
 
@@ -778,7 +805,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigMary =
  mkPartialLedgerConfigShelley
  transitionConfigMary
- triggerHardForkAlonzo
+ (toTriggerHardFork triggerHardForkAlonzo)
 
  -- Alonzo
 
@@ -797,7 +824,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigAlonzo =
  mkPartialLedgerConfigShelley
  transitionConfigAlonzo
- triggerHardForkBabbage
+ (toTriggerHardFork triggerHardForkBabbage)
 
  -- Babbage
 
@@ -826,7 +853,7 @@ protocolInfoCardano paramsCardano
  partialLedgerConfigBabbage =
  mkPartialLedgerConfigShelley
  transitionConfigBabbage
- 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,28 +151,28 @@ mkSimpleTestProtocolInfo ::
  -> ByronSlotLengthInSeconds
  -> ShelleySlotLengthInSeconds
  -> SL.ProtVer
- -> HardForkSpec
+ -> CardanoHardForkTriggers
  -> ProtocolInfo (CardanoBlock c)
 mkSimpleTestProtocolInfo
  decentralizationParam
  securityParam
  byronSlotLenghtInSeconds
  shelleySlotLengthInSeconds
  protocolVersion
- hardForkSpec
+ hardForkTriggers
  = fst
  $ mkTestProtocolInfo @IO
  (CoreNodeId 0, coreNodeShelley)
  shelleyGenesis
- byronProtocolVersion
+ aByronProtocolVersion
  SL.NeutralNonce
  genesisByron
  generatedSecretsByron
  (Just $ PBftSignatureThreshold 1)
  protocolVersion
- hardForkSpec
+ hardForkTriggers
  where
- byronProtocolVersion =
+ aByronProtocolVersion =
  CC.Update.ProtocolVersion 0 0 0
 
  coreNodeShelley = runGen initSeed $ Shelley.genCoreNode initialKESPeriod
@@ -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