Convert AdaOnlyFeatureSupportedInEra to OnlyFeature using new Feature…

… API.

Convert MultiAsseteFeatureSupportedInEra to MultiAssetFeature using new Feature API.

cardano-api/internal/Cardano/Api/Fees.hs

@@ -675,7 +675,7 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo
                    => ShelleyEraTxBody ledgerera
                    => LedgerEraConstraints ledgerera
                    => LedgerMultiAssetConstraints ledgerera
-                   => MultiAssetSupportedInEra era
+                   => MultiAssetFeature era
                    -> TxOutValue era
     evalMultiAsset evidence =
       TxOutValue evidence . fromMaryValue $
@@ -691,7 +691,7 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo
                 => ShelleyEraTxBody ledgerera
                 => LedgerEraConstraints ledgerera
                 => LedgerAdaOnlyConstraints ledgerera
-                => OnlyAdaSupportedInEra era
+                => OnlyAdaFeature era
                 -> TxOutValue era
     evalAdaOnly evidence =
      TxOutAdaOnly evidence . fromShelleyLovelace
@@ -710,13 +710,13 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo
           => LedgerAdaOnlyConstraints ledgerera
           => LedgerPParamsConstraints ledgerera
           => LedgerTxBodyConstraints ledgerera
-          => OnlyAdaSupportedInEra era
+          => OnlyAdaFeature era
           -> a)
       -> (   LedgerEraConstraints ledgerera
           => LedgerMultiAssetConstraints ledgerera
           => LedgerPParamsConstraints ledgerera
           => LedgerTxBodyConstraints ledgerera
-          => MultiAssetSupportedInEra era
+          => MultiAssetFeature era
           -> a)
       -> a
     withLedgerConstraints ShelleyBasedEraShelley f _ = f AdaOnlyInShelleyEra

cardano-api/internal/Cardano/Api/TxBody.hs

@@ -113,8 +113,8 @@ module Cardano.Api.TxBody (
 
     -- * Era-dependent transaction body features
     CollateralSupportedInEra(..),
-    MultiAssetSupportedInEra(..),
-    OnlyAdaSupportedInEra(..),
+    MultiAssetFeature(..),
+    OnlyAdaFeature(..),
     TxFeesExplicitInEra(..),
     TxFeesImplicitInEra(..),
     ValidityUpperBoundSupportedInEra(..),
@@ -132,6 +132,7 @@ module Cardano.Api.TxBody (
     -- ** Feature availability functions
     collateralSupportedInEra,
     multiAssetSupportedInEra,
+    onlyAdaOrMultiAssetFeatureInEra,
     txFeesExplicitInEra,
     validityUpperBoundSupportedInEra,
     validityNoUpperBoundSupportedInEra,
@@ -894,56 +895,83 @@ collateralSupportedInEra ConwayEra = Just CollateralInConwayEra
 --
 -- The Mary and subsequent eras support multi-asset transactions.
 --
--- The negation of this is 'OnlyAdaSupportedInEra'.
+-- The negation of this is 'OnlyAdaFeature'.
 --
-data MultiAssetSupportedInEra era where
+data MultiAssetFeature era where
 
      -- | Multi-asset transactions are supported in the 'Mary' era.
-     MultiAssetInMaryEra :: MultiAssetSupportedInEra MaryEra
+     MultiAssetInMaryEra :: MultiAssetFeature MaryEra
 
      -- | Multi-asset transactions are supported in the 'Alonzo' era.
-     MultiAssetInAlonzoEra :: MultiAssetSupportedInEra AlonzoEra
+     MultiAssetInAlonzoEra :: MultiAssetFeature AlonzoEra
 
      -- | Multi-asset transactions are supported in the 'Babbage' era.
-     MultiAssetInBabbageEra :: MultiAssetSupportedInEra BabbageEra
+     MultiAssetInBabbageEra :: MultiAssetFeature BabbageEra
 
      -- | Multi-asset transactions are supported in the 'Conway' era.
-     MultiAssetInConwayEra :: MultiAssetSupportedInEra ConwayEra
+     MultiAssetInConwayEra :: MultiAssetFeature ConwayEra
 
-deriving instance Eq   (MultiAssetSupportedInEra era)
-deriving instance Show (MultiAssetSupportedInEra era)
+deriving instance Eq   (MultiAssetFeature era)
+deriving instance Show (MultiAssetFeature era)
 
-instance ToJSON (MultiAssetSupportedInEra era) where
+instance ToJSON (MultiAssetFeature era) where
   toJSON = Aeson.String . Text.pack . show
 
+instance FeatureInEra MultiAssetFeature where
+  featureInEra no yes = \case
+    ByronEra    -> no
+    ShelleyEra  -> no
+    AllegraEra  -> no
+    MaryEra     -> yes MultiAssetInMaryEra
+    AlonzoEra   -> yes MultiAssetInAlonzoEra
+    BabbageEra  -> yes MultiAssetInBabbageEra
+    ConwayEra   -> yes MultiAssetInConwayEra
+
 -- | A representation of whether the era supports only ada transactions.
 --
 -- Prior to the Mary era only ada transactions are supported. Multi-assets are
 -- supported from the Mary era onwards.
 --
--- This is the negation of 'MultiAssetSupportedInEra'. It exists since we need
+-- This is the negation of 'MultiAssetFeature'. It exists since we need
 -- evidence to be positive.
 --
-data OnlyAdaSupportedInEra era where
+data OnlyAdaFeature era where
 
-     AdaOnlyInByronEra   :: OnlyAdaSupportedInEra ByronEra
-     AdaOnlyInShelleyEra :: OnlyAdaSupportedInEra ShelleyEra
-     AdaOnlyInAllegraEra :: OnlyAdaSupportedInEra AllegraEra
+     AdaOnlyInByronEra   :: OnlyAdaFeature ByronEra
+     AdaOnlyInShelleyEra :: OnlyAdaFeature ShelleyEra
+     AdaOnlyInAllegraEra :: OnlyAdaFeature AllegraEra
 
-deriving instance Eq   (OnlyAdaSupportedInEra era)
-deriving instance Show (OnlyAdaSupportedInEra era)
+deriving instance Eq   (OnlyAdaFeature era)
+deriving instance Show (OnlyAdaFeature era)
 
-multiAssetSupportedInEra :: CardanoEra era
-                         -> Either (OnlyAdaSupportedInEra era)
-                                   (MultiAssetSupportedInEra era)
-multiAssetSupportedInEra ByronEra   = Left AdaOnlyInByronEra
-multiAssetSupportedInEra ShelleyEra = Left AdaOnlyInShelleyEra
-multiAssetSupportedInEra AllegraEra = Left AdaOnlyInAllegraEra
-multiAssetSupportedInEra MaryEra    = Right MultiAssetInMaryEra
-multiAssetSupportedInEra AlonzoEra  = Right MultiAssetInAlonzoEra
-multiAssetSupportedInEra BabbageEra = Right MultiAssetInBabbageEra
-multiAssetSupportedInEra ConwayEra = Right MultiAssetInConwayEra
+instance FeatureInEra OnlyAdaFeature where
+  featureInEra no yes = \case
+    ByronEra    -> yes AdaOnlyInByronEra
+    ShelleyEra  -> yes AdaOnlyInShelleyEra
+    AllegraEra  -> yes AdaOnlyInAllegraEra
+    MaryEra     -> no
+    AlonzoEra   -> no
+    BabbageEra  -> no
+    ConwayEra   -> no
+
+onlyAdaOrMultiAssetFeatureInEra :: ()
+  => (OnlyAdaFeature era -> a)    -- ^ Value to use if the feature is not supported in the era
+  -> (MultiAssetFeature era -> b) -- ^ Function to get thealue to use if the feature is supported in the era
+  -> CardanoEra era               -- ^ Era to check
+  -> Either a b
+onlyAdaOrMultiAssetFeatureInEra onlyAda multiAsset era =
+  featureInEra
+    (featureInEra
+      (error "IMPOSSIBLE: This is checked by prop_total_onlyAdaOrMultiAssetFeatureInEra")
+      (Left . onlyAda)
+      era)
+    (Right . multiAsset)
+    era
 
+multiAssetSupportedInEra :: CardanoEra era
+                         -> Either (OnlyAdaFeature era)
+                                   (MultiAssetFeature era)
+multiAssetSupportedInEra = onlyAdaOrMultiAssetFeatureInEra id id
 
 -- | A representation of whether the era requires explicitly specified fees in
 -- transactions.
@@ -1319,17 +1347,17 @@ deriving instance Show (TxInsReference build era)
 
 data TxOutValue era where
 
-     TxOutAdaOnly :: OnlyAdaSupportedInEra era -> Lovelace -> TxOutValue era
+     TxOutAdaOnly :: OnlyAdaFeature era -> Lovelace -> TxOutValue era
 
-     TxOutValue   :: MultiAssetSupportedInEra era -> Value -> TxOutValue era
+     TxOutValue   :: MultiAssetFeature era -> Value -> TxOutValue era
 
 instance EraCast TxOutValue where
   eraCast toEra v = case v of
     TxOutAdaOnly _previousEra lovelace ->
       case multiAssetSupportedInEra toEra of
         Left adaOnly -> Right $ TxOutAdaOnly adaOnly lovelace
         Right multiAssetSupp -> Right $ TxOutValue multiAssetSupp $ lovelaceToValue lovelace
-    TxOutValue  (_ :: MultiAssetSupportedInEra fromEra) value  ->
+    TxOutValue  (_ :: MultiAssetFeature fromEra) value  ->
       case multiAssetSupportedInEra toEra of
         Left _adaOnly -> Left $ EraCastError v (cardanoEra @fromEra) toEra
         Right multiAssetSupp -> Right $ TxOutValue multiAssetSupp value
@@ -1667,7 +1695,7 @@ data TxMintValue build era where
 
      TxMintNone  :: TxMintValue build era
 
-     TxMintValue :: MultiAssetSupportedInEra era
+     TxMintValue :: MultiAssetFeature era
                  -> Value
                  -> BuildTxWith build
                       (Map PolicyId (ScriptWitness WitCtxMint era))
@@ -2800,7 +2828,7 @@ fromAlonzoTxOut :: forall era ledgerera.
                 => L.AlonzoEraTxOut ledgerera
                 => Ledger.EraCrypto ledgerera ~ StandardCrypto
                 => Ledger.Value ledgerera ~ MaryValue StandardCrypto
-                => MultiAssetSupportedInEra era
+                => MultiAssetFeature era
                 -> ScriptDataSupportedInEra era
                 -> Map (L.DataHash StandardCrypto)
                        (L.Data ledgerera)
@@ -2829,7 +2857,7 @@ fromBabbageTxOut
   => ShelleyLedgerEra era ~ ledgerera
   => Ledger.EraCrypto ledgerera ~ StandardCrypto
   => Ledger.Value ledgerera ~ MaryValue StandardCrypto
-  => MultiAssetSupportedInEra era
+  => MultiAssetFeature era
   -> ScriptDataSupportedInEra era
   -> ReferenceTxInsScriptsInlineDatumsSupportedInEra era
   -> Map (L.DataHash StandardCrypto)

cardano-api/src/Cardano/Api.hs

@@ -261,8 +261,8 @@ module Cardano.Api (
 
     -- ** Era-dependent transaction body features
     CollateralSupportedInEra(..),
-    MultiAssetSupportedInEra(..),
-    OnlyAdaSupportedInEra(..),
+    MultiAssetFeature(..),
+    OnlyAdaFeature(..),
     TxFeesExplicitInEra(..),
     TxFeesImplicitInEra(..),
     ValidityUpperBoundSupportedInEra(..),
@@ -280,6 +280,7 @@ module Cardano.Api (
 
     -- ** Feature availability functions
     collateralSupportedInEra,
+    onlyAdaOrMultiAssetFeatureInEra,
     multiAssetSupportedInEra,
     txFeesExplicitInEra,
     validityUpperBoundSupportedInEra,

cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Api.Typed.TxBody
   ( tests
@@ -14,8 +15,9 @@ import           Test.Gen.Cardano.Api.Typed (genTxBodyContent)
 
 import           Test.Cardano.Api.Typed.Orphans ()
 
-import           Hedgehog (MonadTest, Property, annotateShow, failure, (===))
+import           Hedgehog (MonadTest, Property, annotateShow, failure, forAll, (===))
 import qualified Hedgehog as H
+import qualified Hedgehog.Gen as Gen
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.Hedgehog (testPropertyNamed)
 
@@ -74,7 +76,23 @@ prop_roundtrip_txbodycontent_txouts =
     (ReferenceScript _ (ScriptInAnyLang actual _)) -> isJust $ testEquality expected actual
     _ -> False
 
+prop_disjoint_OnlyAdaFeature_MultiAssetFeature :: Property
+prop_disjoint_OnlyAdaFeature_MultiAssetFeature =
+  H.property $ do
+    AnyCardanoEra era <- forAll $ Gen.element [minBound..maxBound]
+    let hasOnlyAdaFeature = featureInEra @OnlyAdaFeature False (const True) era
+    let hasMultiAssetFeature = featureInEra @MultiAssetFeature False (const True) era
+    hasOnlyAdaFeature === not hasMultiAssetFeature
+
+prop_total_onlyAdaOrMultiAssetFeatureInEra :: Property
+prop_total_onlyAdaOrMultiAssetFeatureInEra =
+  H.property $ do
+    AnyCardanoEra era <- forAll $ Gen.element [minBound..maxBound]
+    either id id (onlyAdaOrMultiAssetFeatureInEra (const ()) (const ()) era) === ()
+
 tests :: TestTree
 tests = testGroup "Test.Cardano.Api.Typed.TxBody"
   [ testPropertyNamed "roundtrip txbodycontent txouts" "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts
+  , testPropertyNamed "disjoint OnlyAdaFeature MultiAssetFeature" "disjoint OnlyAdaFeature MultiAssetFeature" prop_disjoint_OnlyAdaFeature_MultiAssetFeature
+  , testPropertyNamed "total onlyAdaOrMultiAssetFeatureInEra" "total onlyAdaOrMultiAssetFeatureInEra" prop_total_onlyAdaOrMultiAssetFeatureInEra
   ]