From c68a162871462a32d998a1c30455c89b633d275d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 3 Sep 2026 11:26:46 -0400 Subject: [PATCH 1/5] Remove caseShelleyEraOnlyOrAllegraEraOnwards Two of the three call sites discarded the `ShelleyEraOnly` witness entirely, so they are expressed directly with `inEonForShelleyBasedEra` and an `AllegraEraOnwards` default. `invalidHereAfterTxBodyL` needs the `ShelleyEraOnly` witness in the Shelley branch to reach `ttlAsInvalidHereAfterTxBodyL`, which `inEonForShelleyBasedEra` cannot supply, so it now matches on the `ShelleyBasedEra` constructors directly. --- .../src/Cardano/Api/Era/Internal/Case.hs | 20 ------------------ .../src/Cardano/Api/Tx/Internal/Body.hs | 8 +++---- .../src/Cardano/Api/Tx/Internal/Body/Lens.hs | 21 ++++++++++++++----- 3 files changed, 20 insertions(+), 29 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs index d8dd947ed0..59783cd240 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs @@ -7,16 +7,13 @@ module Cardano.Api.Era.Internal.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra -- Case on ShelleyBasedEra - , caseShelleyEraOnlyOrAllegraEraOnwards , caseShelleyToBabbageOrConwayEraOnwards ) where import Cardano.Api.Era.Internal.Core -import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra -import Cardano.Api.Era.Internal.Eon.ShelleyEraOnly import Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra -- | @caseByronOrShelleyBasedEra f g era@ returns @f@ in Byron and applies @g@ to Shelley-based eras. @@ -38,23 +35,6 @@ caseByronOrShelleyBasedEra l r = \case ConwayEra -> r ShelleyBasedEraConway DijkstraEra -> r ShelleyBasedEraDijkstra --- | @caseShelleyEraOnlyOrAllegraEraOnwards f g era@ applies @f@ to shelley; --- and applies @g@ to allegra and later eras. -caseShelleyEraOnlyOrAllegraEraOnwards - :: () - => (ShelleyEraOnlyConstraints era => ShelleyEraOnly era -> a) - -> (AllegraEraOnwardsConstraints era => AllegraEraOnwards era -> a) - -> ShelleyBasedEra era - -> a -caseShelleyEraOnlyOrAllegraEraOnwards l r = \case - ShelleyBasedEraShelley -> l ShelleyEraOnlyShelley - ShelleyBasedEraAllegra -> r AllegraEraOnwardsAllegra - ShelleyBasedEraMary -> r AllegraEraOnwardsMary - ShelleyBasedEraAlonzo -> r AllegraEraOnwardsAlonzo - ShelleyBasedEraBabbage -> r AllegraEraOnwardsBabbage - ShelleyBasedEraConway -> r AllegraEraOnwardsConway - ShelleyBasedEraDijkstra -> r AllegraEraOnwardsDijkstra - -- | @caseShelleyToBabbageOrConwayEraOnwards f g era@ applies @f@ to eras before conway; -- and applies @g@ to conway and later eras. caseShelleyToBabbageOrConwayEraOnwards diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 829c376f85..618348d15c 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs @@ -1656,8 +1656,8 @@ fromLedgerTxValidityLowerBound -> A.LedgerTxBody era -> TxValidityLowerBound era fromLedgerTxValidityLowerBound sbe body = - caseShelleyEraOnlyOrAllegraEraOnwards - (const TxValidityNoLowerBound) + inEonForShelleyBasedEra + TxValidityNoLowerBound ( \w -> let mInvalidBefore = body ^. A.invalidBeforeTxBodyL w in case mInvalidBefore of @@ -1719,8 +1719,8 @@ fromLedgerTxAuxiliaryData sbe (Just auxData) = metadata = if null ms then TxMetadataNone else TxMetadataInEra sbe $ TxMetadata ms auxdata = - caseShelleyEraOnlyOrAllegraEraOnwards - (const TxAuxScriptsNone) + inEonForShelleyBasedEra + TxAuxScriptsNone ( \w -> case ss of [] -> TxAuxScriptsNone diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs index 9092c64403..f5e993d0cd 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {- HLINT ignore "Eta reduce" -} @@ -45,7 +47,6 @@ module Cardano.Api.Tx.Internal.Body.Lens ) where -import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards @@ -109,10 +110,20 @@ invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ txBodyL . L.vldtTxBody -- 'invalidHereAfterTxBodyL' lens over both with a 'Maybe SlotNo' type representation. Withing the -- Shelley era, setting Nothing will set the ttl to 'maxBound' in the underlying ledger type. invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (LedgerTxBody era) (Maybe SlotNo) -invalidHereAfterTxBodyL = - caseShelleyEraOnlyOrAllegraEraOnwards - ttlAsInvalidHereAfterTxBodyL - (const $ txBodyL . L.vldtTxBodyL . L.invalidHereAfterL . strictMaybeL) +invalidHereAfterTxBodyL = \case + ShelleyBasedEraShelley -> ttlAsInvalidHereAfterTxBodyL ShelleyEraOnlyShelley + ShelleyBasedEraAllegra -> vldtAsInvalidHereAfterTxBodyL + ShelleyBasedEraMary -> vldtAsInvalidHereAfterTxBodyL + ShelleyBasedEraAlonzo -> vldtAsInvalidHereAfterTxBodyL + ShelleyBasedEraBabbage -> vldtAsInvalidHereAfterTxBodyL + ShelleyBasedEraConway -> vldtAsInvalidHereAfterTxBodyL + ShelleyBasedEraDijkstra -> vldtAsInvalidHereAfterTxBodyL + where + vldtAsInvalidHereAfterTxBodyL + :: L.AllegraEraTxBody (ShelleyLedgerEra era') + => Lens' (LedgerTxBody era') (Maybe SlotNo) + vldtAsInvalidHereAfterTxBodyL = + txBodyL . L.vldtTxBodyL . L.invalidHereAfterL . strictMaybeL -- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'. ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (LedgerTxBody era) (Maybe SlotNo) From 238a8a927727693b695f5af561392646bd97b3c5 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 3 Sep 2026 11:38:07 -0400 Subject: [PATCH 2/5] Remove caseByronOrShelleyBasedEra It had no call sites left, and its own comment marked it for deletion once `build-raw --byron-era` was deprecated in cardano-cli. Callers needing the same split can use `inEonForEra` with `ShelleyBasedEra`, which is what the `Cardano.Api.Network.IPC` haddock example now shows. --- cardano-api/src/Cardano/Api/Era.hs | 3 --- .../src/Cardano/Api/Era/Internal/Case.hs | 25 +------------------ cardano-api/src/Cardano/Api/Network/IPC.hs | 2 +- 3 files changed, 2 insertions(+), 28 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Era.hs b/cardano-api/src/Cardano/Api/Era.hs index 8dd13e9c8b..48c5cc5b24 100644 --- a/cardano-api/src/Cardano/Api/Era.hs +++ b/cardano-api/src/Cardano/Api/Era.hs @@ -61,9 +61,6 @@ module Cardano.Api.Era -- * Era case handling - -- ** Case on CardanoEra - , caseByronOrShelleyBasedEra - -- ** Case on ShelleyBasedEra , caseShelleyToBabbageOrConwayEraOnwards ) diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs index 59783cd240..8a686c9a79 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs @@ -4,37 +4,14 @@ {-# LANGUAGE RankNTypes #-} module Cardano.Api.Era.Internal.Case - ( -- Case on CardanoEra - caseByronOrShelleyBasedEra - -- Case on ShelleyBasedEra - , caseShelleyToBabbageOrConwayEraOnwards + ( caseShelleyToBabbageOrConwayEraOnwards ) where -import Cardano.Api.Era.Internal.Core import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra --- | @caseByronOrShelleyBasedEra f g era@ returns @f@ in Byron and applies @g@ to Shelley-based eras. -caseByronOrShelleyBasedEra - :: () - => a - -> (ShelleyBasedEraConstraints era => ShelleyBasedEra era -> a) - -> CardanoEra era - -> a -caseByronOrShelleyBasedEra l r = \case - ByronEra -> l -- We no longer provide the witness because Byron is isolated. - -- This function will be deleted shortly after build-raw --byron-era is - -- deprecated in cardano-cli - ShelleyEra -> r ShelleyBasedEraShelley - AllegraEra -> r ShelleyBasedEraAllegra - MaryEra -> r ShelleyBasedEraMary - AlonzoEra -> r ShelleyBasedEraAlonzo - BabbageEra -> r ShelleyBasedEraBabbage - ConwayEra -> r ShelleyBasedEraConway - DijkstraEra -> r ShelleyBasedEraDijkstra - -- | @caseShelleyToBabbageOrConwayEraOnwards f g era@ applies @f@ to eras before conway; -- and applies @g@ to conway and later eras. caseShelleyToBabbageOrConwayEraOnwards diff --git a/cardano-api/src/Cardano/Api/Network/IPC.hs b/cardano-api/src/Cardano/Api/Network/IPC.hs index c27d42d09b..275f414eeb 100644 --- a/cardano-api/src/Cardano/Api/Network/IPC.hs +++ b/cardano-api/src/Cardano/Api/Network/IPC.hs @@ -107,7 +107,7 @@ module Cardano.Api.Network.IPC -- @ -- Api.AnyShelleyBasedEra sbe :: Api.AnyShelleyBasedEra <- case eEra of -- Right (Api.AnyCardanoEra era) -> - -- Api.caseByronOrShelleyBasedEra + -- Api.inEonForEra -- (error "Error, we are in Byron era") -- (return . Api.AnyShelleyBasedEra) -- era From 674c99b777c49765f8dc4a97982cf065717b9a64 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 3 Sep 2026 11:48:45 -0400 Subject: [PATCH 3/5] Prefer inEonForShelleyBasedEra over caseShelleyToBabbageOrConwayEraOnwards Sixteen of the nineteen call sites ignored one of the two witnesses, so they are expressed with `inEonForShelleyBasedEra` and a default for the eras outside the eon. Unlike the case combinator, `inEonForShelleyBasedEra` hands the callback a witness but no constraints, so `maybeFromLedgerTxUpdateProposal` now calls `shelleyToBabbageEraConstraints` itself. In `toConsensusQueryShelleyBased` the eleven Conway-onwards queries go through a local `conwayOnwards` witness which matches on `ShelleyBasedEra` exhaustively instead of using an eon, so adding or retiring an era is a compile error at that match rather than a silent fall through to the unsupported branch. The witness is `ConwayEraOnwards` and the constraints come from `conwayEraOnwardsConstraints`, so these queries no longer depend on the experimental `Era`, whose constructors only cover the currently supported eras. `nextEpochEligibleLeadershipSlots` needs a visible type application because neither branch mentions the witness. --- cardano-api/src/Cardano/Api/LedgerState.hs | 4 +- .../Cardano/Api/Query/Internal/Convenience.hs | 4 +- .../Api/Query/Internal/Type/QueryInMode.hs | 162 +++++------------- .../src/Cardano/Api/Tx/Internal/Body.hs | 22 ++- 4 files changed, 59 insertions(+), 133 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 6e3c3b6c1b..8007f148b1 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -110,9 +110,9 @@ import Cardano.Api.Byron.Internal.Proposal as Byron import Cardano.Api.Certificate.Internal import Cardano.Api.Consensus.Internal.Mode import Cardano.Api.Consensus.Internal.Mode qualified as Api -import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Core (forEraInEon, forEraMaybeEon, toCardanoEra) import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards +import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards (ConwayEraOnwards) import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Error as Api import Cardano.Api.Genesis.Internal @@ -2119,7 +2119,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr stabilityWindowSlots :: SlotNo stabilityWindowSlots = fromIntegral @Word64 $ floor $ fromRational @Double stabilityWindowR stableStakeDistribSlot = currentEpochLastSlot - stabilityWindowSlots - stabilityWindowConst = caseShelleyToBabbageOrConwayEraOnwards (const 3) (const 4) sbe + stabilityWindowConst = inEonForShelleyBasedEra @ConwayEraOnwards 3 (const 4) sbe case cTip of ChainTipAtGenesis -> Left LeaderErrGenesisSlot diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs b/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs index 59c19a63ad..d6a74be61e 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs @@ -169,8 +169,8 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do ) featuredTxTreasuryValueM <- - caseShelleyToBabbageOrConwayEraOnwards - (const $ pure Nothing) + inEonForShelleyBasedEra + (pure Nothing) ( \cOnwards -> do ChainAccountState{casTreasury} <- lift (queryAccountState cOnwards) diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs index 671a787d3b..c7c714b765 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs @@ -71,12 +71,12 @@ import Cardano.Api.Address import Cardano.Api.Block import Cardano.Api.Certificate.Internal import Cardano.Api.Consensus.Internal.Mode -import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Core -import Cardano.Api.Era.Internal.Eon.Convert (Convert (convert)) -import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards () +import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards + ( ConwayEraOnwards (..) + , conwayEraOnwardsConstraints + ) import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra -import Cardano.Api.Experimental.Era (obtainCommonConstraints) import Cardano.Api.Genesis.Internal.Parameters import Cardano.Api.HasTypeProxy (HasTypeProxy (..)) import Cardano.Api.Key.Internal @@ -586,15 +586,8 @@ toConsensusQueryShelleyBased sbe = \case QueryEpoch -> Some (consensusQueryInEraInMode era Consensus.GetEpochNo) QueryConstitution -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryConstitution is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ Some (consensusQueryInEraInMode era Consensus.GetConstitution) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryConstitution") $ + Some (consensusQueryInEraInMode era Consensus.GetConstitution) QueryGenesisParameters -> Some (consensusQueryInEraInMode era Consensus.GetGenesisConfig) QueryProtocolParameters -> @@ -662,128 +655,63 @@ toConsensusQueryShelleyBased sbe = \case QueryGovState -> Some (consensusQueryInEraInMode era Consensus.GetGovState) QueryRatifyState -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error "toConsensusQueryShelleyBased: QueryRatifyState is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ Some (consensusQueryInEraInMode era Consensus.GetRatifyState) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryRatifyState") $ + Some (consensusQueryInEraInMode era Consensus.GetRatifyState) QueryFuturePParams -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryFuturePParams is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some (consensusQueryInEraInMode era Consensus.GetFuturePParams) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryFuturePParams") $ + Some (consensusQueryInEraInMode era Consensus.GetFuturePParams) QueryDRepState creds -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error "toConsensusQueryShelleyBased: QueryDRepState is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryDRepState") $ + Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds)) QueryDRepStakeDistr dreps -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryDRepStakeDistr is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some (consensusQueryInEraInMode era (Consensus.GetDRepStakeDistr dreps)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryDRepStakeDistr") $ + Some (consensusQueryInEraInMode era (Consensus.GetDRepStakeDistr dreps)) QuerySPOStakeDistr spos -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QuerySPOStakeDistr is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some (consensusQueryInEraInMode era (Consensus.GetSPOStakeDistr spos)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QuerySPOStakeDistr") $ + Some (consensusQueryInEraInMode era (Consensus.GetSPOStakeDistr spos)) QueryCommitteeMembersState coldCreds hotCreds statuses -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryCommitteeMembersState is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some - (consensusQueryInEraInMode era (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryCommitteeMembersState") $ + Some + (consensusQueryInEraInMode era (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) QueryStakeVoteDelegatees creds -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryStakeVoteDelegatees is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some - ( consensusQueryInEraInMode - era - (Consensus.GetFilteredVoteDelegatees creds') - ) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryStakeVoteDelegatees") $ + Some (consensusQueryInEraInMode era (Consensus.GetFilteredVoteDelegatees creds')) where creds' :: Set (Shelley.Credential Shelley.Staking) creds' = Set.map toShelleyStakeCredential creds QueryProposals govActs -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error "toConsensusQueryShelleyBased: QueryProposals is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some - (consensusQueryInEraInMode era (Consensus.GetProposals govActs)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryProposals") $ + Some (consensusQueryInEraInMode era (Consensus.GetProposals govActs)) QueryLedgerPeerSnapshot peerKind -> Some (consensusQueryInEraInMode era (Consensus.GetLedgerPeerSnapshot peerKind)) QueryStakePoolDefaultVote govActs -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: QueryStakePoolDefaultVote is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some - (consensusQueryInEraInMode era (Consensus.QueryStakePoolDefaultVote govActs)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "QueryStakePoolDefaultVote") $ + Some (consensusQueryInEraInMode era (Consensus.QueryStakePoolDefaultVote govActs)) GetDRepDelegations dreps -> - caseShelleyToBabbageOrConwayEraOnwards - ( const $ - error - "toConsensusQueryShelleyBased: GetDRepDelegations is only available from the Conway era onwards" - ) - ( \w -> - obtainCommonConstraints (convert w) $ - Some - (consensusQueryInEraInMode era (Consensus.GetDRepDelegations dreps)) - ) - sbe + conwayEraOnwardsConstraints (conwayOnwards "GetDRepDelegations") $ + Some (consensusQueryInEraInMode era (Consensus.GetDRepDelegations dreps)) where era = toCardanoEra sbe + -- Witness that @era@ is Conway or later. Matched on 'ShelleyBasedEra', + -- totally: adding or retiring an era is then a compile error here rather + -- than a silent fall through to 'unsupported'. + conwayOnwards :: String -> ConwayEraOnwards era + conwayOnwards q = case sbe of + ShelleyBasedEraShelley -> unsupported + ShelleyBasedEraAllegra -> unsupported + ShelleyBasedEraMary -> unsupported + ShelleyBasedEraAlonzo -> unsupported + ShelleyBasedEraBabbage -> unsupported + ShelleyBasedEraConway -> ConwayEraOnwardsConway + ShelleyBasedEraDijkstra -> ConwayEraOnwardsDijkstra + where + unsupported :: forall a. a + unsupported = + error $ + "toConsensusQueryShelleyBased: " <> q <> " is only available from the Conway era onwards" + consensusQueryInEraInMode :: forall era erablock modeblock result result' fp xs . ConsensusBlockForEra era ~ erablock diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 618348d15c..0d82849b54 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs @@ -238,7 +238,6 @@ where import Cardano.Api.Address import Cardano.Api.Byron.Internal.Key -import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Core import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards @@ -1780,13 +1779,14 @@ maybeFromLedgerTxUpdateProposal -> Ledger.TxBody Ledger.TopTx (ShelleyLedgerEra era) -> TxUpdateProposal era maybeFromLedgerTxUpdateProposal sbe body = - caseShelleyToBabbageOrConwayEraOnwards + inEonForShelleyBasedEra + TxUpdateProposalNone ( \w -> - case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> TxUpdateProposal w (fromLedgerUpdate sbe p) + shelleyToBabbageEraConstraints w $ + case body ^. L.updateTxBodyL of + SNothing -> TxUpdateProposalNone + SJust p -> TxUpdateProposal w (fromLedgerUpdate sbe p) ) - (const TxUpdateProposalNone) sbe fromLedgerTxMintValue @@ -2384,10 +2384,8 @@ collectTxBodyScriptWitnessRequirements extractWitnessableMints aEon txMintValue txVotingWits <- - caseShelleyToBabbageOrConwayEraOnwards - ( \w -> - shelleyToBabbageEraConstraints w $ Right $ TxScriptWitnessRequirements mempty mempty mempty mempty - ) + inEonForShelleyBasedEra + (Right $ TxScriptWitnessRequirements mempty mempty mempty mempty) ( \eon -> first TxBodyPlutusScriptDecodeError $ legacyWitnessToScriptRequirements aEon $ @@ -2395,8 +2393,8 @@ collectTxBodyScriptWitnessRequirements ) sbe txProposalWits <- - caseShelleyToBabbageOrConwayEraOnwards - (const $ Right $ TxScriptWitnessRequirements mempty mempty mempty mempty) + inEonForShelleyBasedEra + (Right $ TxScriptWitnessRequirements mempty mempty mempty mempty) ( \eon -> first TxBodyPlutusScriptDecodeError $ legacyWitnessToScriptRequirements aEon $ From ac98ffedebdab83b5320ddc178b3e8598c66580d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 3 Sep 2026 11:57:09 -0400 Subject: [PATCH 4/5] Remove caseShelleyToBabbageOrConwayEraOnwards The three remaining call sites are certificate generators whose pre-Conway branch needs `ShelleyEraTxCert` and whose Conway branch needs `ConwayEraTxCert`. `inEonForShelleyBasedEra` supplies a witness but no constraints, and its default argument has no witness at all, so these match on the `ShelleyBasedEra` constructors and obtain the constraints from the witness in each branch. That empties `Cardano.Api.Era.Internal.Case`, so the module goes too. --- cardano-api/cardano-api.cabal | 1 - cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 111 ++++++++++-------- cardano-api/src/Cardano/Api/Era.hs | 6 - .../src/Cardano/Api/Era/Internal/Case.hs | 30 ----- 4 files changed, 65 insertions(+), 83 deletions(-) delete mode 100644 cardano-api/src/Cardano/Api/Era/Internal/Case.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e7ed538ab6..48b34e6263 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -217,7 +217,6 @@ library Cardano.Api.Consensus.Internal.Mode Cardano.Api.Consensus.Internal.Protocol Cardano.Api.Consensus.Internal.Reexport - Cardano.Api.Era.Internal.Case Cardano.Api.Era.Internal.Core Cardano.Api.Era.Internal.Eon.AllegraEraOnwards Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 63130f4b53..e2671ef83c 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -2,6 +2,7 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -849,58 +850,76 @@ genCertificate sbe = genStakeAddressRegistrationCertificate :: ShelleyBasedEra era -> Gen (Exp.Certificate (ShelleyLedgerEra era)) -genStakeAddressRegistrationCertificate = - caseShelleyToBabbageOrConwayEraOnwards - ( \w -> - shelleyToBabbageEraConstraints w $ - Exp.Certificate . L.mkRegTxCert . toShelleyStakeCredential <$> genStakeCredential - ) - ( \w -> - conwayEraOnwardsConstraints w $ - Exp.Certificate - <$> ( L.mkRegDepositTxCert . toShelleyStakeCredential - <$> genStakeCredential - <*> genLovelace - ) - ) +genStakeAddressRegistrationCertificate = \case + ShelleyBasedEraShelley -> preConway + ShelleyBasedEraAllegra -> preConway + ShelleyBasedEraMary -> preConway + ShelleyBasedEraAlonzo -> preConway + ShelleyBasedEraBabbage -> preConway + ShelleyBasedEraConway -> postConway + ShelleyBasedEraDijkstra -> postConway + where + preConway :: L.ShelleyEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + preConway = + Exp.Certificate . L.mkRegTxCert . toShelleyStakeCredential <$> genStakeCredential + + postConway :: L.ConwayEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + postConway = + Exp.Certificate + <$> ( L.mkRegDepositTxCert . toShelleyStakeCredential + <$> genStakeCredential + <*> genLovelace + ) genStakeAddressUnregistrationCertificate :: ShelleyBasedEra era -> Gen (Exp.Certificate (ShelleyLedgerEra era)) -genStakeAddressUnregistrationCertificate = - caseShelleyToBabbageOrConwayEraOnwards - ( \w -> - shelleyToBabbageEraConstraints w $ - Exp.Certificate . L.mkUnRegTxCert . toShelleyStakeCredential <$> genStakeCredential - ) - ( \w -> - conwayEraOnwardsConstraints w $ - Exp.Certificate - <$> ( L.mkUnRegDepositTxCert . toShelleyStakeCredential - <$> genStakeCredential - <*> genLovelace - ) - ) +genStakeAddressUnregistrationCertificate = \case + ShelleyBasedEraShelley -> preConway + ShelleyBasedEraAllegra -> preConway + ShelleyBasedEraMary -> preConway + ShelleyBasedEraAlonzo -> preConway + ShelleyBasedEraBabbage -> preConway + ShelleyBasedEraConway -> postConway + ShelleyBasedEraDijkstra -> postConway + where + preConway :: L.ShelleyEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + preConway = + Exp.Certificate . L.mkUnRegTxCert . toShelleyStakeCredential <$> genStakeCredential + + postConway :: L.ConwayEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + postConway = + Exp.Certificate + <$> ( L.mkUnRegDepositTxCert . toShelleyStakeCredential + <$> genStakeCredential + <*> genLovelace + ) genStakeAddressDelegationCertificate :: ShelleyBasedEra era -> Gen (Exp.Certificate (ShelleyLedgerEra era)) -genStakeAddressDelegationCertificate = - caseShelleyToBabbageOrConwayEraOnwards - ( \w -> - shelleyToBabbageEraConstraints w $ - Exp.Certificate - <$> ( L.mkDelegStakeTxCert . toShelleyStakeCredential - <$> genStakeCredential - <*> (unStakePoolKeyHash <$> genVerificationKeyHash AsStakePoolKey) - ) - ) - ( \w -> - conwayEraOnwardsConstraints w $ - Exp.Certificate - <$> ( L.mkDelegTxCert . toShelleyStakeCredential - <$> genStakeCredential - <*> Q.arbitrary - ) - ) +genStakeAddressDelegationCertificate = \case + ShelleyBasedEraShelley -> preConway + ShelleyBasedEraAllegra -> preConway + ShelleyBasedEraMary -> preConway + ShelleyBasedEraAlonzo -> preConway + ShelleyBasedEraBabbage -> preConway + ShelleyBasedEraConway -> postConway + ShelleyBasedEraDijkstra -> postConway + where + preConway :: L.ShelleyEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + preConway = + Exp.Certificate + <$> ( L.mkDelegStakeTxCert . toShelleyStakeCredential + <$> genStakeCredential + <*> (unStakePoolKeyHash <$> genVerificationKeyHash AsStakePoolKey) + ) + + postConway :: L.ConwayEraTxCert ledgerera => Gen (Exp.Certificate ledgerera) + postConway = + Exp.Certificate + <$> ( L.mkDelegTxCert . toShelleyStakeCredential + <$> genStakeCredential + <*> Q.arbitrary + ) genStakePoolRegistrationCertificate :: ShelleyBasedEra era -> Gen (Exp.Certificate (ShelleyLedgerEra era)) diff --git a/cardano-api/src/Cardano/Api/Era.hs b/cardano-api/src/Cardano/Api/Era.hs index 48c5cc5b24..b37a52e917 100644 --- a/cardano-api/src/Cardano/Api/Era.hs +++ b/cardano-api/src/Cardano/Api/Era.hs @@ -58,15 +58,9 @@ module Cardano.Api.Era , AsConwayEra , AsDijkstraEra ) - - -- * Era case handling - - -- ** Case on ShelleyBasedEra - , caseShelleyToBabbageOrConwayEraOnwards ) where -import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Core import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs deleted file mode 100644 index 8a686c9a79..0000000000 --- a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} - -module Cardano.Api.Era.Internal.Case - ( caseShelleyToBabbageOrConwayEraOnwards - ) -where - -import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards -import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra -import Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra - --- | @caseShelleyToBabbageOrConwayEraOnwards f g era@ applies @f@ to eras before conway; --- and applies @g@ to conway and later eras. -caseShelleyToBabbageOrConwayEraOnwards - :: () - => (ShelleyToBabbageEraConstraints era => ShelleyToBabbageEra era -> a) - -> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a) - -> ShelleyBasedEra era - -> a -caseShelleyToBabbageOrConwayEraOnwards l r = \case - ShelleyBasedEraShelley -> l ShelleyToBabbageEraShelley - ShelleyBasedEraAllegra -> l ShelleyToBabbageEraAllegra - ShelleyBasedEraMary -> l ShelleyToBabbageEraMary - ShelleyBasedEraAlonzo -> l ShelleyToBabbageEraAlonzo - ShelleyBasedEraBabbage -> l ShelleyToBabbageEraBabbage - ShelleyBasedEraConway -> r ConwayEraOnwardsConway - ShelleyBasedEraDijkstra -> r ConwayEraOnwardsDijkstra From df6b4acc52ee0ec4008ffc913211e0e84325762b Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 3 Sep 2026 11:57:10 -0400 Subject: [PATCH 5/5] Add changelog fragment --- ...remove-case-shelley-era-only-or-allegra-era-onwards.yml | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 .changes/remove-case-shelley-era-only-or-allegra-era-onwards.yml diff --git a/.changes/remove-case-shelley-era-only-or-allegra-era-onwards.yml b/.changes/remove-case-shelley-era-only-or-allegra-era-onwards.yml new file mode 100644 index 0000000000..bac242c345 --- /dev/null +++ b/.changes/remove-case-shelley-era-only-or-allegra-era-onwards.yml @@ -0,0 +1,7 @@ +project: cardano-api +pr: 1326 +kind: + - breaking + - refactoring +description: | + Removed the era case combinators `caseByronOrShelleyBasedEra` and `caseShelleyToBabbageOrConwayEraOnwards`, along with the internal `caseShelleyEraOnlyOrAllegraEraOnwards`, and the now-empty `Cardano.Api.Era.Internal.Case` module. Use `inEonForEra` / `inEonForShelleyBasedEra` with the appropriate eon, or match on the era constructors where both branches need era constraints.