Experimental api: remove redundant type families and functions

IntersectMBO · Sep 3, 2024 · a58f105 · a58f105
1 parent 00bb673
commit a58f105
Show file tree

Hide file tree

Showing 5 changed files with 209 additions and 237 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs
@@ -17,8 +17,6 @@ where
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
 import           Cardano.Api.Eon.ShelleyBasedEra
-import           Cardano.Api.Eon.ShelleyToAlonzoEra
-import           Cardano.Api.Eras
 import           Cardano.Api.Experimental.Eras
 import           Cardano.Api.Experimental.Tx
 import           Cardano.Api.Fees
@@ -96,10 +94,7 @@ constructBalancedTx
     let alternateKeyWits = map (makeKeyWitness availableEra unsignedTx) shelleyWitSigningKeys
         signedTx = signTx availableEra [] alternateKeyWits unsignedTx
 
-    caseShelleyToAlonzoOrBabbageEraOnwards
-      (Left . TxBodyErrorDeprecatedEra . DeprecatedEra . shelleyToAlonzoEraToShelleyBasedEra)
-      (\w -> return $ ShelleyTx sbe $ obtainShimConstraints w signedTx)
-      sbe
+    return $ ShelleyTx sbe $ obtainCommonConstraints availableEra signedTx
 
 data TxInsExistError
   = TxInsDoNotExist [TxIn]

diff --git a/cardano-api/internal/Cardano/Api/Experimental/Eras.hs b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,25 +19,21 @@ module Cardano.Api.Experimental.Eras
   , Era (..)
   , LedgerEra
   , IsEra
-  , ApiEraToLedgerEra
-  , ExperimentalEraToApiEra
-  , ApiEraToExperimentalEra
   , DeprecatedEra (..)
   , EraCommonConstraints
-  , EraShimConstraints
   , obtainCommonConstraints
-  , obtainShimConstraints
   , useEra
   , eraToSbe
   , babbageEraOnwardsToEra
+  , eraToBabbageEraOnwards
   , sbeToEra
   )
 where
 
 import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra)
-import           Cardano.Api.Eras.Core (BabbageEra, ConwayEra)
-import qualified Cardano.Api.Eras.Core as Api
+import qualified Cardano.Api.Eras as Api
+import           Cardano.Api.Eras.Core (BabbageEra, ConwayEra, Eon (..))
 import qualified Cardano.Api.ReexposeLedger as L
 import           Cardano.Api.Via.ShowOf
 
@@ -58,22 +55,11 @@ import           Prettyprinter
 
 -- Allows us to gradually change the api without breaking things.
 -- This will eventually be removed.
-type family ExperimentalEraToApiEra era = (r :: Type) | r -> era where
-  ExperimentalEraToApiEra BabbageEra = Api.BabbageEra
-  ExperimentalEraToApiEra ConwayEra = Api.ConwayEra
-
-type family ApiEraToExperimentalEra era = (r :: Type) | r -> era where
-  ApiEraToExperimentalEra Api.BabbageEra = BabbageEra
-  ApiEraToExperimentalEra Api.ConwayEra = ConwayEra
 
 type family LedgerEra era = (r :: Type) | r -> era where
   LedgerEra BabbageEra = Ledger.Babbage
   LedgerEra ConwayEra = Ledger.Conway
 
-type family ApiEraToLedgerEra era = (r :: Type) | r -> era where
-  ApiEraToLedgerEra Api.BabbageEra = Ledger.Babbage
-  ApiEraToLedgerEra Api.ConwayEra = Ledger.Conway
-
 -- | Represents the eras in Cardano's blockchain.
 -- This type represents eras currently on mainnet and new eras which are
 -- in development.
@@ -117,7 +103,7 @@ deriving instance Show (Era era)
 -- @
 eraToSbe
   :: Era era
-  -> ShelleyBasedEra (ExperimentalEraToApiEra era)
+  -> ShelleyBasedEra era
 eraToSbe BabbageEra = ShelleyBasedEraBabbage
 eraToSbe ConwayEra = ShelleyBasedEraConway
 
@@ -128,18 +114,24 @@ newtype DeprecatedEra era
 deriving via (ShowOf (DeprecatedEra era)) instance Pretty (DeprecatedEra era)
 
 sbeToEra
-  :: MonadError (DeprecatedEra era) m => ShelleyBasedEra era -> m (Era (ApiEraToExperimentalEra era))
+  :: MonadError (DeprecatedEra era) m
+  => ShelleyBasedEra era
+  -> m (Era era)
 sbeToEra ShelleyBasedEraConway = return ConwayEra
 sbeToEra ShelleyBasedEraBabbage = return BabbageEra
 sbeToEra e@ShelleyBasedEraAlonzo = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraMary = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraAllegra = throwError $ DeprecatedEra e
 sbeToEra e@ShelleyBasedEraShelley = throwError $ DeprecatedEra e
 
-babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era (ApiEraToExperimentalEra era)
+babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era era
 babbageEraOnwardsToEra BabbageEraOnwardsBabbage = BabbageEra
 babbageEraOnwardsToEra BabbageEraOnwardsConway = ConwayEra
 
+eraToBabbageEraOnwards :: Era era -> BabbageEraOnwards era
+eraToBabbageEraOnwards BabbageEra = BabbageEraOnwardsBabbage
+eraToBabbageEraOnwards ConwayEra = BabbageEraOnwardsConway
+
 -------------------------------------------------------------------------
 
 -- | Type class interface for the 'Era' type.
@@ -152,20 +144,12 @@ instance IsEra BabbageEra where
 instance IsEra ConwayEra where
   useEra = ConwayEra
 
-obtainShimConstraints
-  :: BabbageEraOnwards era
-  -> (EraShimConstraints era => a)
-  -> a
-obtainShimConstraints BabbageEraOnwardsBabbage x = x
-obtainShimConstraints BabbageEraOnwardsConway x = x
-
--- We need these constraints in order to propagate the new
--- experimental api without changing the existing api
-type EraShimConstraints era =
-  ( LedgerEra (ApiEraToExperimentalEra era) ~ ShelleyLedgerEra era
-  , ExperimentalEraToApiEra (ApiEraToExperimentalEra era) ~ era
-  , L.EraTx (ApiEraToLedgerEra era)
-  )
+-- | A temporary compatibility instance, for easier conversion between experimental and old API.
+instance Eon Era where
+  inEonForEra v f = \case
+    Api.ConwayEra -> f ConwayEra
+    Api.BabbageEra -> f BabbageEra
+    _ -> v
 
 obtainCommonConstraints
   :: Era era
@@ -180,6 +164,7 @@ type EraCommonConstraints era =
   , L.EraTx (LedgerEra era)
   , L.EraUTxO (LedgerEra era)
   , Ledger.EraCrypto (LedgerEra era) ~ L.StandardCrypto
-  , ShelleyLedgerEra (ExperimentalEraToApiEra era) ~ LedgerEra era
+  , ShelleyLedgerEra era ~ LedgerEra era
   , L.HashAnnotated (Ledger.TxBody (LedgerEra era)) EraIndependentTxBody L.StandardCrypto
+  , IsEra era
   )
diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs
@@ -21,9 +21,10 @@ module Cardano.Api.Experimental.Tx
 where
 
 import           Cardano.Api.Eon.ShelleyBasedEra
-import           Cardano.Api.Eras.Case
+import           Cardano.Api.Eras.Core (ToCardanoEra (toCardanoEra), forEraInEon)
 import           Cardano.Api.Experimental.Eras
 import           Cardano.Api.Feature
+import           Cardano.Api.Pretty (docToString, pretty)
 import           Cardano.Api.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe)
 import qualified Cardano.Api.ReexposeLedger as L
 import           Cardano.Api.Tx.Body
@@ -41,6 +42,7 @@ import qualified Cardano.Ledger.SafeHash as L
 
 import qualified Data.Set as Set
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro
 
 -- | A transaction that can contain everything
@@ -58,7 +60,7 @@ newtype UnsignedTxError
 
 makeUnsignedTx
   :: Era era
-  -> TxBodyContent BuildTx (ExperimentalEraToApiEra era)
+  -> TxBodyContent BuildTx era
   -> Either TxBodyError (UnsignedTx era)
 makeUnsignedTx era bc = obtainCommonConstraints era $ do
   let sbe = eraToSbe era
@@ -133,7 +135,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do
 eraSpecificLedgerTxBody
   :: Era era
   -> Ledger.TxBody (LedgerEra era)
-  -> TxBodyContent BuildTx (ExperimentalEraToApiEra era)
+  -> TxBodyContent BuildTx era
   -> Either TxBodyError (Ledger.TxBody (LedgerEra era))
 eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do
   let sbe = eraToSbe BabbageEra
@@ -154,7 +156,7 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
             .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
           & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation
           & L.currentTreasuryValueTxBodyL
-            .~ L.maybeToStrictMaybe (maybe (Just $ L.Coin 0) unFeatured currentTresuryValue)
+            .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue)
 
 hashTxBody
   :: L.HashAnnotated (Ledger.TxBody era) EraIndependentTxBody L.StandardCrypto
@@ -198,12 +200,12 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) =
 -- Compatibility related. Will be removed once the old api has been deprecated and deleted.
 
 convertTxBodyToUnsignedTx
-  :: ShelleyBasedEra era -> TxBody era -> UnsignedTx (ApiEraToExperimentalEra era)
+  :: HasCallStack => ShelleyBasedEra era -> TxBody era -> UnsignedTx era
 convertTxBodyToUnsignedTx sbe txbody =
-  caseShelleyToAlonzoOrBabbageEraOnwards
-    (const $ error "convertTxBodyToUnsignedTx: Error")
-    ( \w ->
+  forEraInEon
+    (toCardanoEra sbe)
+    (error $ "convertTxBodyToUnsignedTx: Error - unsupported era " <> docToString (pretty sbe))
+    ( \w -> do
         let ShelleyTx _ unsignedLedgerTx = makeSignedTransaction [] txbody
-         in UnsignedTx $ obtainShimConstraints w unsignedLedgerTx
+        UnsignedTx $ obtainCommonConstraints w unsignedLedgerTx
     )
-    sbe