Remove BabbageEra from experimental Era type

Author: palas

cardano-api/src/Cardano/Api/Experimental.hs

@@ -31,7 +31,6 @@ module Cardano.Api.Experimental
   , LedgerEra
   , DeprecatedEra (..)
   , eraToSbe
-  , babbageEraOnwardsToEra
   , eraToBabbageEraOnwards
   , sbeToEra
 

cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs

@@ -26,7 +26,6 @@ module Cardano.Api.Internal.Experimental.Eras
   , EraCommonConstraints
   , obtainCommonConstraints
   , eraToSbe
-  , babbageEraOnwardsToEra
   , eraToBabbageEraOnwards
   , sbeToEra
   )
@@ -42,7 +41,6 @@ import Cardano.Api.Internal.ReexposeLedger qualified as L
 import Cardano.Api.Internal.Via.ShowOf
 
 import Cardano.Ledger.Api qualified as L
-import Cardano.Ledger.Babbage qualified as Ledger
 import Cardano.Ledger.BaseTypes (Inject (..))
 import Cardano.Ledger.Conway qualified as Ledger
 import Cardano.Ledger.Core qualified as Ledger
@@ -64,7 +62,6 @@ import Prettyprinter
 -- from the upcoming era. Therefore, protocol versions are limited to the current mainnet era
 -- and the next (upcoming) era.
 type family LedgerEra era = (r :: Type) | r -> era where
-  LedgerEra BabbageEra = Ledger.BabbageEra
   LedgerEra ConwayEra = Ledger.ConwayEra
 
 -- | An existential wrapper for types of kind @k -> Type@. It can hold any
@@ -93,8 +90,6 @@ data Some (f :: k -> Type) where
 -- codebase to the new mainnet era.
 data Era era where
   -- | The currently active era on the Cardano mainnet.
-  BabbageEra :: Era BabbageEra
-  -- | The upcoming era in development.
   ConwayEra :: Era ConwayEra
 
 deriving instance Show (Era era)
@@ -105,10 +100,7 @@ instance Pretty (Era era) where
   pretty = eraToStringLike
 
 instance TestEquality Era where
-  testEquality BabbageEra BabbageEra = Just Refl
-  testEquality BabbageEra _ = Nothing
   testEquality ConwayEra ConwayEra = Just Refl
-  testEquality ConwayEra _ = Nothing
 
 instance ToJSON (Era era) where
   toJSON = eraToStringLike
@@ -120,15 +112,13 @@ instance Eq (Some Era) where
   Some era1 == Some era2 = isJust $ testEquality era1 era2
 
 instance Bounded (Some Era) where
-  minBound = Some BabbageEra
+  minBound = Some ConwayEra
   maxBound = Some ConwayEra
 
 instance Enum (Some Era) where
-  toEnum 0 = Some BabbageEra
-  toEnum 1 = Some ConwayEra
+  toEnum 0 = Some ConwayEra
   toEnum i = error $ "Enum.toEnum: invalid argument " <> show i <> " - does not correspond to any era"
-  fromEnum (Some BabbageEra) = 0
-  fromEnum (Some ConwayEra) = 1
+  fromEnum (Some ConwayEra) = 0
 
 instance Ord (Some Era) where
   compare e1 e2 = compare (fromEnum e1) (fromEnum e2)
@@ -152,25 +142,21 @@ instance FromJSON (Some Era) where
 instance Eon Era where
   inEonForEra v f = \case
     Api.ConwayEra -> f ConwayEra
-    Api.BabbageEra -> f BabbageEra
     _ -> v
 
 -- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
 instance Api.ToCardanoEra Era where
   toCardanoEra = \case
-    BabbageEra -> Api.BabbageEra
     ConwayEra -> Api.ConwayEra
 
 eraToStringLike :: IsString a => Era era -> a
 {-# INLINE eraToStringLike #-}
 eraToStringLike = \case
-  BabbageEra -> "Babbage"
   ConwayEra -> "Conway"
 
 eraFromStringLike :: (IsString a, Eq a) => a -> Either a (Some Era)
 {-# INLINE eraFromStringLike #-}
 eraFromStringLike = \case
-  "Babbage" -> pure $ Some BabbageEra
   "Conway" -> pure $ Some ConwayEra
   wrong -> Left wrong
 
@@ -211,29 +197,20 @@ eraToSbe = convert
 
 instance Convert Era Api.CardanoEra where
   convert = \case
-    BabbageEra -> Api.BabbageEra
     ConwayEra -> Api.ConwayEra
 
 instance Convert Era ShelleyBasedEra where
   convert = \case
-    BabbageEra -> ShelleyBasedEraBabbage
     ConwayEra -> ShelleyBasedEraConway
 
 instance Convert Era AlonzoEraOnwards where
   convert = \case
-    BabbageEra -> AlonzoEraOnwardsBabbage
     ConwayEra -> AlonzoEraOnwardsConway
 
 instance Convert Era BabbageEraOnwards where
   convert = \case
-    BabbageEra -> BabbageEraOnwardsBabbage
     ConwayEra -> BabbageEraOnwardsConway
 
-instance Convert BabbageEraOnwards Era where
-  convert = \case
-    BabbageEraOnwardsBabbage -> BabbageEra
-    BabbageEraOnwardsConway -> ConwayEra
-
 newtype DeprecatedEra era
   = DeprecatedEra (ShelleyBasedEra era)
   deriving Show
@@ -245,16 +222,12 @@ sbeToEra
   => ShelleyBasedEra era
   -> m (Era era)
 sbeToEra ShelleyBasedEraConway = return ConwayEra
-sbeToEra ShelleyBasedEraBabbage = return BabbageEra
+sbeToEra e@ShelleyBasedEraBabbage = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraAlonzo = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraMary = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraAllegra = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraShelley = throwError $ DeprecatedEra e
 
-{-# DEPRECATED babbageEraOnwardsToEra "Use 'convert' instead." #-}
-babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era era
-babbageEraOnwardsToEra = convert
-
 {-# DEPRECATED eraToBabbageEraOnwards "Use 'convert' instead." #-}
 eraToBabbageEraOnwards :: Era era -> BabbageEraOnwards era
 eraToBabbageEraOnwards = convert
@@ -265,17 +238,13 @@ eraToBabbageEraOnwards = convert
 class IsEra era where
   useEra :: Era era
 
-instance IsEra BabbageEra where
-  useEra = BabbageEra
-
 instance IsEra ConwayEra where
   useEra = ConwayEra
 
 obtainCommonConstraints
   :: Era era
   -> (EraCommonConstraints era => a)
   -> a
-obtainCommonConstraints BabbageEra x = x
 obtainCommonConstraints ConwayEra x = x
 
 type EraCommonConstraints era =

cardano-api/src/Cardano/Api/Internal/Experimental/Tx.hs

@@ -138,7 +138,6 @@ import Cardano.Api.Internal.Tx.Sign
 import Cardano.Crypto.Hash qualified as Hash
 import Cardano.Ledger.Alonzo.TxBody qualified as L
 import Cardano.Ledger.Api qualified as L
-import Cardano.Ledger.Babbage qualified as Ledger
 import Cardano.Ledger.Conway qualified as Ledger
 import Cardano.Ledger.Conway.TxBody qualified as L
 import Cardano.Ledger.Core qualified as Ledger
@@ -156,7 +155,6 @@ newtype UnsignedTx era
 
 instance IsEra era => Show (UnsignedTx era) where
   showsPrec p (UnsignedTx tx) = case useEra @era of
-    BabbageEra -> showsPrec p (tx :: Ledger.Tx Ledger.BabbageEra)
     ConwayEra -> showsPrec p (tx :: Ledger.Tx Ledger.ConwayEra)
 
 newtype UnsignedTxError
@@ -207,51 +205,67 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do
       setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses
       ledgerTxBody =
         L.mkBasicTxBody
-          & L.inputsTxBodyL .~ txins
-          & L.collateralInputsTxBodyL .~ collTxIns
-          & L.referenceInputsTxBodyL .~ refTxIns
-          & L.outputsTxBodyL .~ outs
-          & L.totalCollateralTxBodyL .~ totalCollateral
-          & L.collateralReturnTxBodyL .~ returnCollateral
-          & L.feeTxBodyL .~ fee
-          & L.vldtTxBodyL . L.invalidBeforeL .~ convValidityLowerBound (txValidityLowerBound bc)
-          & L.vldtTxBodyL . L.invalidHereAfterL .~ convValidityUpperBound sbe (txValidityUpperBound bc)
-          & L.reqSignerHashesTxBodyL .~ setReqSignerHashes
-          & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
-          & L.withdrawalsTxBodyL .~ withdrawals
-          & L.certsTxBodyL .~ certs
-          & L.mintTxBodyL .~ setMint
-          & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData
+          & L.inputsTxBodyL
+          .~ txins
+          & L.collateralInputsTxBodyL
+          .~ collTxIns
+          & L.referenceInputsTxBodyL
+          .~ refTxIns
+          & L.outputsTxBodyL
+          .~ outs
+          & L.totalCollateralTxBodyL
+          .~ totalCollateral
+          & L.collateralReturnTxBodyL
+          .~ returnCollateral
+          & L.feeTxBodyL
+          .~ fee
+          & L.vldtTxBodyL
+          . L.invalidBeforeL
+          .~ convValidityLowerBound (txValidityLowerBound bc)
+          & L.vldtTxBodyL
+          . L.invalidHereAfterL
+          .~ convValidityUpperBound sbe (txValidityUpperBound bc)
+          & L.reqSignerHashesTxBodyL
+          .~ setReqSignerHashes
+          & L.scriptIntegrityHashTxBodyL
+          .~ scriptIntegrityHash
+          & L.withdrawalsTxBodyL
+          .~ withdrawals
+          & L.certsTxBodyL
+          .~ certs
+          & L.mintTxBodyL
+          .~ setMint
+          & L.auxDataHashTxBodyL
+          .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData
 
       scriptWitnesses =
         L.mkBasicTxWits
           & L.scriptTxWitsL
-            .~ fromList
-              [ (L.hashScript sw, sw)
-              | sw <- scripts
-              ]
-          & L.datsTxWitsL .~ datums
-          & L.rdmrsTxWitsL .~ redeemers
+          .~ fromList
+            [ (L.hashScript sw, sw)
+            | sw <- scripts
+            ]
+          & L.datsTxWitsL
+          .~ datums
+          & L.rdmrsTxWitsL
+          .~ redeemers
 
   eraSpecificTxBody <- eraSpecificLedgerTxBody era ledgerTxBody bc
 
   return . UnsignedTx $
     L.mkBasicTx eraSpecificTxBody
-      & L.witsTxL .~ scriptWitnesses
-      & L.auxDataTxL .~ maybeToStrictMaybe (toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc))
-      & L.isValidTxL .~ txScriptValidityToIsValid apiScriptValidity
+      & L.witsTxL
+      .~ scriptWitnesses
+      & L.auxDataTxL
+      .~ maybeToStrictMaybe (toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc))
+      & L.isValidTxL
+      .~ txScriptValidityToIsValid apiScriptValidity
 
 eraSpecificLedgerTxBody
   :: Era era
   -> Ledger.TxBody (LedgerEra era)
   -> TxBodyContent BuildTx era
   -> Either TxBodyError (Ledger.TxBody (LedgerEra era))
-eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do
-  let sbe = convert BabbageEra
-
-  setUpdateProposal <- convTxUpdateProposal sbe (txUpdateProposal bc)
-
-  return $ ledgerbody & L.updateTxBodyL .~ setUpdateProposal
 eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
   let propProcedures = txProposalProcedures bc
       voteProcedures = txVotingProcedures bc
@@ -260,12 +274,13 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
    in return $
         ledgerbody
           & L.proposalProceduresTxBodyL
-            .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures)
+          .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures)
           & L.votingProceduresTxBodyL
-            .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
-          & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation
+          .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
+          & L.treasuryDonationTxBodyL
+          .~ maybe (L.Coin 0) unFeatured treasuryDonation
           & L.currentTreasuryValueTxBodyL
-            .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue)
+          .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue)
 
 hashTxBody
   :: L.HashAnnotated (Ledger.TxBody era) L.EraIndependentTxBody
@@ -300,9 +315,9 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) =
           obtainCommonConstraints era $
             L.mkBasicTxWits
               & L.addrTxWitsL
-                .~ Set.fromList shelleyKeyWits
+              .~ Set.fromList shelleyKeyWits
               & L.bootAddrTxWitsL
-                .~ Set.fromList bootstrapWits
+              .~ Set.fromList bootstrapWits
         signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses)
      in signedTx