Introduce new AnyShelleyBasedEra type and simplify CDDL tests.

cardano-api/cardano-api.cabal

@@ -240,6 +240,7 @@ test-suite cardano-api-test
                       , time
 
   other-modules:        Test.Cardano.Api.Crypto
+                        Test.Cardano.Api.Eras
                         Test.Cardano.Api.Genesis
                         Test.Cardano.Api.Json
                         Test.Cardano.Api.KeysByron

cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs

@@ -5,7 +5,6 @@
 
 module Test.Hedgehog.Roundtrip.CBOR
   ( roundtrip_CBOR
-  , roundtrip_CDDL_Tx
   ) where
 
 import           Cardano.Api
@@ -30,15 +29,3 @@ roundtrip_CBOR typeProxy gen =
     GHC.withFrozenCallStack $ H.noteShow_ $ typeRep $ Proxy @a
     val <- H.forAll gen
     H.tripping val serialiseToCBOR (deserialiseFromCBOR typeProxy)
-
-
-roundtrip_CDDL_Tx
-  :: (IsCardanoEra era, HasCallStack)
-  => CardanoEra era
-  -> Gen (Tx era)
-  -> Property
-roundtrip_CDDL_Tx era gen =
-  H.property $ do
-    GHC.withFrozenCallStack $ H.noteShow_ era
-    val <- H.forAll gen
-    H.tripping val serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)

cardano-api/src/Cardano/Api.hs

@@ -28,6 +28,7 @@ module Cardano.Api (
     -- ** Shelley-based eras
     ShelleyBasedEra(..),
     IsShelleyBasedEra(..),
+    AnyShelleyBasedEra(..),
     InAnyShelleyBasedEra(..),
     CardanoEraStyle(..),
     cardanoEraStyle,

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -32,6 +33,7 @@ module Cardano.Api.Eras
     -- * Shelley-based eras
   , ShelleyBasedEra(..)
   , IsShelleyBasedEra(..)
+  , AnyShelleyBasedEra(..)
   , InAnyShelleyBasedEra(..)
   , shelleyBasedToCardanoEra
 
@@ -191,7 +193,7 @@ instance TestEquality CardanoEra where
     testEquality MaryEra    MaryEra    = Just Refl
     testEquality AlonzoEra  AlonzoEra  = Just Refl
     testEquality BabbageEra BabbageEra = Just Refl
-    testEquality ConwayEra ConwayEra   = Just Refl
+    testEquality ConwayEra  ConwayEra  = Just Refl
     testEquality _          _          = Nothing
 
 
@@ -339,6 +341,17 @@ deriving instance Eq   (ShelleyBasedEra era)
 deriving instance Ord  (ShelleyBasedEra era)
 deriving instance Show (ShelleyBasedEra era)
 
+instance ToJSON (ShelleyBasedEra era) where
+   toJSON = toJSON . shelleyBasedToCardanoEra
+
+instance TestEquality ShelleyBasedEra where
+    testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl
+    testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl
+    testEquality ShelleyBasedEraMary    ShelleyBasedEraMary    = Just Refl
+    testEquality ShelleyBasedEraAlonzo  ShelleyBasedEraAlonzo  = Just Refl
+    testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl
+    testEquality ShelleyBasedEraConway  ShelleyBasedEraConway  = Just Refl
+    testEquality _                      _                      = Nothing
 
 -- | The class of eras that are based on Shelley. This allows uniform handling
 -- of Shelley-based eras, but also non-uniform by making case distinctions on
@@ -365,6 +378,62 @@ instance IsShelleyBasedEra BabbageEra where
 instance IsShelleyBasedEra ConwayEra where
    shelleyBasedEra = ShelleyBasedEraConway
 
+data AnyShelleyBasedEra where
+  AnyShelleyBasedEra
+    :: IsShelleyBasedEra era  -- Provide class constraint
+    => ShelleyBasedEra era    -- and explicit value.
+    -> AnyShelleyBasedEra
+
+deriving instance Show AnyShelleyBasedEra
+
+instance Eq AnyShelleyBasedEra where
+    AnyShelleyBasedEra era == AnyShelleyBasedEra era' =
+      case testEquality era era' of
+        Nothing   -> False
+        Just Refl -> True -- since no constructors share types
+
+instance Bounded AnyShelleyBasedEra where
+   minBound = AnyShelleyBasedEra ShelleyBasedEraShelley
+   maxBound = AnyShelleyBasedEra ShelleyBasedEraConway
+
+instance Enum AnyShelleyBasedEra where
+   enumFrom e = enumFromTo e maxBound
+
+   fromEnum = \case
+      AnyShelleyBasedEra ShelleyBasedEraShelley  -> 1
+      AnyShelleyBasedEra ShelleyBasedEraAllegra  -> 2
+      AnyShelleyBasedEra ShelleyBasedEraMary     -> 3
+      AnyShelleyBasedEra ShelleyBasedEraAlonzo   -> 4
+      AnyShelleyBasedEra ShelleyBasedEraBabbage  -> 5
+      AnyShelleyBasedEra ShelleyBasedEraConway   -> 6
+
+   toEnum = \case
+      1 -> AnyShelleyBasedEra ShelleyBasedEraShelley
+      2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra
+      3 -> AnyShelleyBasedEra ShelleyBasedEraMary
+      4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo
+      5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage
+      6 -> AnyShelleyBasedEra ShelleyBasedEraConway
+      n ->
+         error $
+            "AnyShelleyBasedEra.toEnum: " <> show n
+            <> " does not correspond to any known enumerated era."
+
+instance ToJSON AnyShelleyBasedEra where
+   toJSON (AnyShelleyBasedEra era) = toJSON era
+
+instance FromJSON AnyShelleyBasedEra where
+   parseJSON = withText "AnyShelleyBasedEra"
+     $ \case
+        "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley
+        "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra
+        "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary
+        "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
+        "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage
+        "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway
+        wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong
+
+
 -- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that
 -- tells us what era it is, but hides the era type. This is useful when the era
 -- is not statically known, for example when deserialising from a file.

cardano-api/test/Test/Cardano/Api/Eras.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Api.Eras
+  ( tests
+  ) where
+
+import           Cardano.Api
+import           Cardano.Api.Orphans ()
+import           Data.Aeson (ToJSON (..), decode, encode)
+import           Hedgehog (Property, forAll, property, (===))
+import qualified Hedgehog as H
+import qualified Hedgehog.Gen as Gen
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.Hedgehog (testPropertyNamed)
+
+--------------------------------------------------------------------------------
+-- Bounded instances
+
+prop_maxBound_CardanoMatchesShelley :: Property
+prop_maxBound_CardanoMatchesShelley = property $ do
+  AnyCardanoEra era <- forAll $ Gen.element [maxBound]
+  AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound]
+
+  fromEnum (AnyCardanoEra era) === fromEnum (AnyCardanoEra (shelleyBasedToCardanoEra sbe))
+
+--------------------------------------------------------------------------------
+-- Aeson instances
+
+prop_roundtrip_JSON_Shelley :: Property
+prop_roundtrip_JSON_Shelley = property $ do
+  anySbe <- forAll $ Gen.element @_ @AnyShelleyBasedEra [minBound..maxBound]
+
+  H.tripping anySbe encode decode
+
+prop_roundtrip_JSON_Cardano :: Property
+prop_roundtrip_JSON_Cardano = property $ do
+  anyEra <- forAll $ Gen.element @_ @AnyCardanoEra [minBound..maxBound]
+
+  H.tripping anyEra encode decode
+
+prop_toJSON_CardanoMatchesShelley :: Property
+prop_toJSON_CardanoMatchesShelley = property $ do
+  AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound]
+
+  toJSON (AnyShelleyBasedEra sbe) === toJSON (AnyCardanoEra (shelleyBasedToCardanoEra sbe))
+
+tests :: TestTree
+tests = testGroup "Test.Cardano.Api.Json"
+  [ testPropertyNamed "maxBound cardano matches shelley"           "maxBound cardano matches shelley"           prop_maxBound_CardanoMatchesShelley
+  , testPropertyNamed "roundtrip JSON shelley"                     "roundtrip JSON shelley"                     prop_roundtrip_JSON_Shelley
+  , testPropertyNamed "roundtrip JSON cardano"                     "roundtrip JSON cardano"                     prop_roundtrip_JSON_Cardano
+  , testPropertyNamed "toJSON cardano matches shelley"             "toJSON cardano matches shelley"             prop_toJSON_CardanoMatchesShelley
+  ]

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

@@ -10,10 +10,12 @@ import           Cardano.Api
 
 import           Data.Proxy (Proxy (..))
 import           Data.String (IsString (..))
-import           Hedgehog (Property, forAll, property, success, tripping)
+import           Hedgehog (Property, forAll, tripping)
+import qualified Hedgehog as H
+import qualified Hedgehog.Gen as Gen
 import           Test.Cardano.Api.Typed.Orphans ()
 import           Test.Gen.Cardano.Api.Typed
-import           Test.Hedgehog.Roundtrip.CBOR (roundtrip_CBOR, roundtrip_CDDL_Tx)
+import           Test.Hedgehog.Roundtrip.CBOR (roundtrip_CBOR)
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.Hedgehog (testPropertyNamed)
 
@@ -22,12 +24,11 @@ import           Test.Tasty.Hedgehog (testPropertyNamed)
 -- TODO: Need to add PaymentExtendedKey roundtrip tests however
 -- we can't derive an Eq instance for Crypto.HD.XPrv
 
-test_roundtrip_txbody_CBOR :: [TestTree]
-test_roundtrip_txbody_CBOR =
-  [ testPropertyNamed (show era) (fromString (show era)) $
-    roundtrip_CDDL_Tx era (makeSignedTransaction [] <$> genTxBody era)
-  | AnyCardanoEra era <- [minBound..(AnyCardanoEra BabbageEra)]
-  ]
+prop_roundtrip_txbody_CBOR :: Property
+prop_roundtrip_txbody_CBOR = H.property $ do
+  AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra]
+  x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era
+  H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)
 
 test_roundtrip_tx_CBOR :: [TestTree]
 test_roundtrip_tx_CBOR =
@@ -155,38 +156,18 @@ prop_roundtrip_UpdateProposal_CBOR :: Property
 prop_roundtrip_UpdateProposal_CBOR =
   roundtrip_CBOR AsUpdateProposal genUpdateProposal
 
+prop_roundtrip_Tx_Cddl :: Property
+prop_roundtrip_Tx_Cddl = H.property $ do
+  AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound]
+  x <- forAll $ genTx era
+  H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)
 
-test_roundtrip_Tx_Cddl :: [TestTree]
-test_roundtrip_Tx_Cddl =
-  [ testPropertyNamed (show era) (fromString (show era)) $ roundtrip_Tx_Cddl anyEra
-  | anyEra@(AnyCardanoEra era) <- [minBound..(AnyCardanoEra AlonzoEra)] --TODO: Babbage era
-  ]
-
-test_roundtrip_TxWitness_Cddl :: [TestTree]
-test_roundtrip_TxWitness_Cddl =
-  [ testPropertyNamed (show era) (fromString (show era)) $ roundtrip_TxWitness_Cddl era
-  | AnyCardanoEra era <- [minBound..(AnyCardanoEra AlonzoEra)] --TODO: Babbage era
-  , AnyCardanoEra era /= AnyCardanoEra ByronEra
-  ]
+prop_roundtrip_TxWitness_Cddl :: Property
+prop_roundtrip_TxWitness_Cddl = H.property $ do
+  AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound]
+  x <- forAll $ genShelleyKeyWitness $ shelleyBasedToCardanoEra sbe
+  tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe)
 
-roundtrip_TxWitness_Cddl :: CardanoEra era -> Property
-roundtrip_TxWitness_Cddl era =
-  property $
-    case cardanoEraStyle era of
-      LegacyByronEra -> success
-      ShelleyBasedEra sbe -> do
-        keyWit <- forAll $ genShelleyKeyWitness era
-        tripping keyWit
-          (serialiseWitnessLedgerCddl sbe)
-          (deserialiseWitnessLedgerCddl sbe)
-
-roundtrip_Tx_Cddl :: AnyCardanoEra -> Property
-roundtrip_Tx_Cddl (AnyCardanoEra era) =
-  property $ do
-   tx <- forAll $ genTx era
-   tripping tx
-     serialiseTxLedgerCddl
-     (deserialiseTxLedgerCddl era)
 
 -- -----------------------------------------------------------------------------
 
@@ -221,8 +202,8 @@ tests = testGroup "Test.Cardano.Api.Typed.CBOR"
   , testPropertyNamed "roundtrip script PlutusScriptV2 CBOR"                 "roundtrip script PlutusScriptV2 CBOR"                 prop_roundtrip_script_PlutusScriptV2_CBOR
   , testPropertyNamed "roundtrip UpdateProposal CBOR"                        "roundtrip UpdateProposal CBOR"                        prop_roundtrip_UpdateProposal_CBOR
   , testPropertyNamed "roundtrip ScriptData CBOR"                            "roundtrip ScriptData CBOR"                            prop_roundtrip_ScriptData_CBOR
-  , testGroup "roundtrip txbody CBOR"     test_roundtrip_txbody_CBOR
+  , testPropertyNamed "roundtrip txbody CBOR"                                "roundtrip txbody CBOR"                                prop_roundtrip_txbody_CBOR
+  , testPropertyNamed "roundtrip Tx Cddl"                                    "roundtrip Tx Cddl"                                    prop_roundtrip_Tx_Cddl
+  , testPropertyNamed "roundtrip TxWitness Cddl"                             "roundtrip TxWitness Cddl"                             prop_roundtrip_TxWitness_Cddl
   , testGroup "roundtrip tx CBOR"         test_roundtrip_tx_CBOR
-  , testGroup "roundtrip Tx Cddl"         test_roundtrip_Tx_Cddl
-  , testGroup "roundtrip TxWitness Cddl"  test_roundtrip_TxWitness_Cddl
   ]

cardano-api/test/cardano-api-test.hs

@@ -4,6 +4,7 @@ import           Cardano.Crypto.Libsodium (sodiumInit)
 import           Test.Tasty (TestTree, defaultMain, testGroup)
 
 import qualified Test.Cardano.Api.Crypto
+import qualified Test.Cardano.Api.Eras
 import qualified Test.Cardano.Api.Json
 import qualified Test.Cardano.Api.KeysByron
 import qualified Test.Cardano.Api.Ledger
@@ -29,6 +30,7 @@ tests :: TestTree
 tests =
   testGroup "Cardano.Api"
     [ Test.Cardano.Api.Crypto.tests
+    , Test.Cardano.Api.Eras.tests
     , Test.Cardano.Api.Json.tests
     , Test.Cardano.Api.KeysByron.tests
     , Test.Cardano.Api.Ledger.tests