Skip to content

Commit e7d85bb

Browse files
newhoggynewhoggy
authored
Merge pull request #5072 from input-output-hk/newhoggy/simplify-cddl-tests
Simplify cddl tests
2 parents 8a14700 + 09a6d21 commit e7d85bb

File tree

7 files changed

+149
-55
lines changed

7 files changed

+149
-55
lines changed

Diff for: ‎cardano-api/cardano-api.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -240,6 +240,7 @@ test-suite cardano-api-test
240240
, time
241241

242242
other-modules: Test.Cardano.Api.Crypto
243+
Test.Cardano.Api.Eras
243244
Test.Cardano.Api.Genesis
244245
Test.Cardano.Api.Json
245246
Test.Cardano.Api.KeysByron

Diff for: ‎cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs

-13
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,6 @@
55

66
module Test.Hedgehog.Roundtrip.CBOR
77
( roundtrip_CBOR
8-
, roundtrip_CDDL_Tx
98
) where
109

1110
import Cardano.Api
@@ -30,15 +29,3 @@ roundtrip_CBOR typeProxy gen =
3029
GHC.withFrozenCallStack $ H.noteShow_ $ typeRep $ Proxy @a
3130
val <- H.forAll gen
3231
H.tripping val serialiseToCBOR (deserialiseFromCBOR typeProxy)
33-
34-
35-
roundtrip_CDDL_Tx
36-
:: (IsCardanoEra era, HasCallStack)
37-
=> CardanoEra era
38-
-> Gen (Tx era)
39-
-> Property
40-
roundtrip_CDDL_Tx era gen =
41-
H.property $ do
42-
GHC.withFrozenCallStack $ H.noteShow_ era
43-
val <- H.forAll gen
44-
H.tripping val serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)

Diff for: ‎cardano-api/src/Cardano/Api.hs

+1
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ module Cardano.Api (
2828
-- ** Shelley-based eras
2929
ShelleyBasedEra(..),
3030
IsShelleyBasedEra(..),
31+
AnyShelleyBasedEra(..),
3132
InAnyShelleyBasedEra(..),
3233
CardanoEraStyle(..),
3334
cardanoEraStyle,

Diff for: ‎cardano-api/src/Cardano/Api/Eras.hs

+70-1
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE GADTs #-}
23
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE PatternSynonyms #-}
@@ -32,6 +33,7 @@ module Cardano.Api.Eras
3233
-- * Shelley-based eras
3334
, ShelleyBasedEra(..)
3435
, IsShelleyBasedEra(..)
36+
, AnyShelleyBasedEra(..)
3537
, InAnyShelleyBasedEra(..)
3638
, shelleyBasedToCardanoEra
3739

@@ -191,7 +193,7 @@ instance TestEquality CardanoEra where
191193
testEquality MaryEra MaryEra = Just Refl
192194
testEquality AlonzoEra AlonzoEra = Just Refl
193195
testEquality BabbageEra BabbageEra = Just Refl
194-
testEquality ConwayEra ConwayEra = Just Refl
196+
testEquality ConwayEra ConwayEra = Just Refl
195197
testEquality _ _ = Nothing
196198

197199

@@ -339,6 +341,17 @@ deriving instance Eq (ShelleyBasedEra era)
339341
deriving instance Ord (ShelleyBasedEra era)
340342
deriving instance Show (ShelleyBasedEra era)
341343

344+
instance ToJSON (ShelleyBasedEra era) where
345+
toJSON = toJSON . shelleyBasedToCardanoEra
346+
347+
instance TestEquality ShelleyBasedEra where
348+
testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl
349+
testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl
350+
testEquality ShelleyBasedEraMary ShelleyBasedEraMary = Just Refl
351+
testEquality ShelleyBasedEraAlonzo ShelleyBasedEraAlonzo = Just Refl
352+
testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl
353+
testEquality ShelleyBasedEraConway ShelleyBasedEraConway = Just Refl
354+
testEquality _ _ = Nothing
342355

343356
-- | The class of eras that are based on Shelley. This allows uniform handling
344357
-- of Shelley-based eras, but also non-uniform by making case distinctions on
@@ -365,6 +378,62 @@ instance IsShelleyBasedEra BabbageEra where
365378
instance IsShelleyBasedEra ConwayEra where
366379
shelleyBasedEra = ShelleyBasedEraConway
367380

381+
data AnyShelleyBasedEra where
382+
AnyShelleyBasedEra
383+
:: IsShelleyBasedEra era -- Provide class constraint
384+
=> ShelleyBasedEra era -- and explicit value.
385+
-> AnyShelleyBasedEra
386+
387+
deriving instance Show AnyShelleyBasedEra
388+
389+
instance Eq AnyShelleyBasedEra where
390+
AnyShelleyBasedEra era == AnyShelleyBasedEra era' =
391+
case testEquality era era' of
392+
Nothing -> False
393+
Just Refl -> True -- since no constructors share types
394+
395+
instance Bounded AnyShelleyBasedEra where
396+
minBound = AnyShelleyBasedEra ShelleyBasedEraShelley
397+
maxBound = AnyShelleyBasedEra ShelleyBasedEraConway
398+
399+
instance Enum AnyShelleyBasedEra where
400+
enumFrom e = enumFromTo e maxBound
401+
402+
fromEnum = \case
403+
AnyShelleyBasedEra ShelleyBasedEraShelley -> 1
404+
AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2
405+
AnyShelleyBasedEra ShelleyBasedEraMary -> 3
406+
AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4
407+
AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5
408+
AnyShelleyBasedEra ShelleyBasedEraConway -> 6
409+
410+
toEnum = \case
411+
1 -> AnyShelleyBasedEra ShelleyBasedEraShelley
412+
2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra
413+
3 -> AnyShelleyBasedEra ShelleyBasedEraMary
414+
4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo
415+
5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage
416+
6 -> AnyShelleyBasedEra ShelleyBasedEraConway
417+
n ->
418+
error $
419+
"AnyShelleyBasedEra.toEnum: " <> show n
420+
<> " does not correspond to any known enumerated era."
421+
422+
instance ToJSON AnyShelleyBasedEra where
423+
toJSON (AnyShelleyBasedEra era) = toJSON era
424+
425+
instance FromJSON AnyShelleyBasedEra where
426+
parseJSON = withText "AnyShelleyBasedEra"
427+
$ \case
428+
"Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley
429+
"Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra
430+
"Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary
431+
"Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
432+
"Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage
433+
"Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway
434+
wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong
435+
436+
368437
-- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that
369438
-- tells us what era it is, but hides the era type. This is useful when the era
370439
-- is not statically known, for example when deserialising from a file.

Diff for: ‎cardano-api/test/Test/Cardano/Api/Eras.hs

+53
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
3+
module Test.Cardano.Api.Eras
4+
( tests
5+
) where
6+
7+
import Cardano.Api
8+
import Cardano.Api.Orphans ()
9+
import Data.Aeson (ToJSON (..), decode, encode)
10+
import Hedgehog (Property, forAll, property, (===))
11+
import qualified Hedgehog as H
12+
import qualified Hedgehog.Gen as Gen
13+
import Test.Tasty (TestTree, testGroup)
14+
import Test.Tasty.Hedgehog (testPropertyNamed)
15+
16+
--------------------------------------------------------------------------------
17+
-- Bounded instances
18+
19+
prop_maxBound_CardanoMatchesShelley :: Property
20+
prop_maxBound_CardanoMatchesShelley = property $ do
21+
AnyCardanoEra era <- forAll $ Gen.element [maxBound]
22+
AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound]
23+
24+
fromEnum (AnyCardanoEra era) === fromEnum (AnyCardanoEra (shelleyBasedToCardanoEra sbe))
25+
26+
--------------------------------------------------------------------------------
27+
-- Aeson instances
28+
29+
prop_roundtrip_JSON_Shelley :: Property
30+
prop_roundtrip_JSON_Shelley = property $ do
31+
anySbe <- forAll $ Gen.element @_ @AnyShelleyBasedEra [minBound..maxBound]
32+
33+
H.tripping anySbe encode decode
34+
35+
prop_roundtrip_JSON_Cardano :: Property
36+
prop_roundtrip_JSON_Cardano = property $ do
37+
anyEra <- forAll $ Gen.element @_ @AnyCardanoEra [minBound..maxBound]
38+
39+
H.tripping anyEra encode decode
40+
41+
prop_toJSON_CardanoMatchesShelley :: Property
42+
prop_toJSON_CardanoMatchesShelley = property $ do
43+
AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound]
44+
45+
toJSON (AnyShelleyBasedEra sbe) === toJSON (AnyCardanoEra (shelleyBasedToCardanoEra sbe))
46+
47+
tests :: TestTree
48+
tests = testGroup "Test.Cardano.Api.Json"
49+
[ testPropertyNamed "maxBound cardano matches shelley" "maxBound cardano matches shelley" prop_maxBound_CardanoMatchesShelley
50+
, testPropertyNamed "roundtrip JSON shelley" "roundtrip JSON shelley" prop_roundtrip_JSON_Shelley
51+
, testPropertyNamed "roundtrip JSON cardano" "roundtrip JSON cardano" prop_roundtrip_JSON_Cardano
52+
, testPropertyNamed "toJSON cardano matches shelley" "toJSON cardano matches shelley" prop_toJSON_CardanoMatchesShelley
53+
]

Diff for: ‎cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs

+22-41
Original file line numberDiff line numberDiff line change
@@ -10,10 +10,12 @@ import Cardano.Api
1010

1111
import Data.Proxy (Proxy (..))
1212
import Data.String (IsString (..))
13-
import Hedgehog (Property, forAll, property, success, tripping)
13+
import Hedgehog (Property, forAll, tripping)
14+
import qualified Hedgehog as H
15+
import qualified Hedgehog.Gen as Gen
1416
import Test.Cardano.Api.Typed.Orphans ()
1517
import Test.Gen.Cardano.Api.Typed
16-
import Test.Hedgehog.Roundtrip.CBOR (roundtrip_CBOR, roundtrip_CDDL_Tx)
18+
import Test.Hedgehog.Roundtrip.CBOR (roundtrip_CBOR)
1719
import Test.Tasty (TestTree, testGroup)
1820
import Test.Tasty.Hedgehog (testPropertyNamed)
1921

@@ -22,12 +24,11 @@ import Test.Tasty.Hedgehog (testPropertyNamed)
2224
-- TODO: Need to add PaymentExtendedKey roundtrip tests however
2325
-- we can't derive an Eq instance for Crypto.HD.XPrv
2426

25-
test_roundtrip_txbody_CBOR :: [TestTree]
26-
test_roundtrip_txbody_CBOR =
27-
[ testPropertyNamed (show era) (fromString (show era)) $
28-
roundtrip_CDDL_Tx era (makeSignedTransaction [] <$> genTxBody era)
29-
| AnyCardanoEra era <- [minBound..(AnyCardanoEra BabbageEra)]
30-
]
27+
prop_roundtrip_txbody_CBOR :: Property
28+
prop_roundtrip_txbody_CBOR = H.property $ do
29+
AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra]
30+
x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era
31+
H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)
3132

3233
test_roundtrip_tx_CBOR :: [TestTree]
3334
test_roundtrip_tx_CBOR =
@@ -155,38 +156,18 @@ prop_roundtrip_UpdateProposal_CBOR :: Property
155156
prop_roundtrip_UpdateProposal_CBOR =
156157
roundtrip_CBOR AsUpdateProposal genUpdateProposal
157158

159+
prop_roundtrip_Tx_Cddl :: Property
160+
prop_roundtrip_Tx_Cddl = H.property $ do
161+
AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound]
162+
x <- forAll $ genTx era
163+
H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era)
158164

159-
test_roundtrip_Tx_Cddl :: [TestTree]
160-
test_roundtrip_Tx_Cddl =
161-
[ testPropertyNamed (show era) (fromString (show era)) $ roundtrip_Tx_Cddl anyEra
162-
| anyEra@(AnyCardanoEra era) <- [minBound..(AnyCardanoEra AlonzoEra)] --TODO: Babbage era
163-
]
164-
165-
test_roundtrip_TxWitness_Cddl :: [TestTree]
166-
test_roundtrip_TxWitness_Cddl =
167-
[ testPropertyNamed (show era) (fromString (show era)) $ roundtrip_TxWitness_Cddl era
168-
| AnyCardanoEra era <- [minBound..(AnyCardanoEra AlonzoEra)] --TODO: Babbage era
169-
, AnyCardanoEra era /= AnyCardanoEra ByronEra
170-
]
165+
prop_roundtrip_TxWitness_Cddl :: Property
166+
prop_roundtrip_TxWitness_Cddl = H.property $ do
167+
AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound]
168+
x <- forAll $ genShelleyKeyWitness $ shelleyBasedToCardanoEra sbe
169+
tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe)
171170

172-
roundtrip_TxWitness_Cddl :: CardanoEra era -> Property
173-
roundtrip_TxWitness_Cddl era =
174-
property $
175-
case cardanoEraStyle era of
176-
LegacyByronEra -> success
177-
ShelleyBasedEra sbe -> do
178-
keyWit <- forAll $ genShelleyKeyWitness era
179-
tripping keyWit
180-
(serialiseWitnessLedgerCddl sbe)
181-
(deserialiseWitnessLedgerCddl sbe)
182-
183-
roundtrip_Tx_Cddl :: AnyCardanoEra -> Property
184-
roundtrip_Tx_Cddl (AnyCardanoEra era) =
185-
property $ do
186-
tx <- forAll $ genTx era
187-
tripping tx
188-
serialiseTxLedgerCddl
189-
(deserialiseTxLedgerCddl era)
190171

191172
-- -----------------------------------------------------------------------------
192173

@@ -221,8 +202,8 @@ tests = testGroup "Test.Cardano.Api.Typed.CBOR"
221202
, testPropertyNamed "roundtrip script PlutusScriptV2 CBOR" "roundtrip script PlutusScriptV2 CBOR" prop_roundtrip_script_PlutusScriptV2_CBOR
222203
, testPropertyNamed "roundtrip UpdateProposal CBOR" "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR
223204
, testPropertyNamed "roundtrip ScriptData CBOR" "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
224-
, testGroup "roundtrip txbody CBOR" test_roundtrip_txbody_CBOR
205+
, testPropertyNamed "roundtrip txbody CBOR" "roundtrip txbody CBOR" prop_roundtrip_txbody_CBOR
206+
, testPropertyNamed "roundtrip Tx Cddl" "roundtrip Tx Cddl" prop_roundtrip_Tx_Cddl
207+
, testPropertyNamed "roundtrip TxWitness Cddl" "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
225208
, testGroup "roundtrip tx CBOR" test_roundtrip_tx_CBOR
226-
, testGroup "roundtrip Tx Cddl" test_roundtrip_Tx_Cddl
227-
, testGroup "roundtrip TxWitness Cddl" test_roundtrip_TxWitness_Cddl
228209
]

Diff for: ‎cardano-api/test/cardano-api-test.hs

+2
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ import Cardano.Crypto.Libsodium (sodiumInit)
44
import Test.Tasty (TestTree, defaultMain, testGroup)
55

66
import qualified Test.Cardano.Api.Crypto
7+
import qualified Test.Cardano.Api.Eras
78
import qualified Test.Cardano.Api.Json
89
import qualified Test.Cardano.Api.KeysByron
910
import qualified Test.Cardano.Api.Ledger
@@ -29,6 +30,7 @@ tests :: TestTree
2930
tests =
3031
testGroup "Cardano.Api"
3132
[ Test.Cardano.Api.Crypto.tests
33+
, Test.Cardano.Api.Eras.tests
3234
, Test.Cardano.Api.Json.tests
3335
, Test.Cardano.Api.KeysByron.tests
3436
, Test.Cardano.Api.Ledger.tests

0 commit comments

Comments
 (0)