diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 65cd169de19..fcb6c80b795 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -203,6 +203,7 @@ library gen , cardano-ledger-shelley ^>= 0.1 , containers , hedgehog + , hedgehog-extras , text test-suite cardano-api-test diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs index ecfb0641bfb..fc2912887ab 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs +++ b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs @@ -1,4 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Hedgehog.Roundtrip.CBOR ( roundtrip_CBOR @@ -6,24 +9,36 @@ module Test.Hedgehog.Roundtrip.CBOR ) where import Cardano.Api -import Hedgehog (Gen, Property) +import Data.Proxy (Proxy (..)) +import Data.Typeable (typeRep) +import GHC.Stack (HasCallStack) +import qualified GHC.Stack as GHC +import Hedgehog (Gen, Property) import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.Base as H {- HLINT ignore "Use camelCase" -} roundtrip_CBOR - :: (SerialiseAsCBOR a, Eq a, Show a) - => AsType a -> Gen a -> Property + :: forall a. (SerialiseAsCBOR a, Eq a, Show a, HasCallStack) + => AsType a + -> Gen a + -> Property roundtrip_CBOR typeProxy gen = H.property $ do + GHC.withFrozenCallStack $ H.noteShow_ $ typeRep $ Proxy @a val <- H.forAll gen H.tripping val serialiseToCBOR (deserialiseFromCBOR typeProxy) roundtrip_CDDL_Tx - :: IsCardanoEra era => CardanoEra era -> Gen (Tx era) -> Property + :: (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) diff --git a/cardano-api/src/Cardano/Api/HasTypeProxy.hs b/cardano-api/src/Cardano/Api/HasTypeProxy.hs index 8be9339f7fd..256c2cb74b4 100644 --- a/cardano-api/src/Cardano/Api/HasTypeProxy.hs +++ b/cardano-api/src/Cardano/Api/HasTypeProxy.hs @@ -8,11 +8,12 @@ module Cardano.Api.HasTypeProxy , FromSomeType(..) ) where +import Data.Kind (Constraint, Type) import Data.Proxy (Proxy (..)) -import Data.Kind (Type, Constraint) +import Data.Typeable (Typeable) -class HasTypeProxy t where +class Typeable t => HasTypeProxy t where -- | A family of singleton types used in this API to indicate which type to -- use where it would otherwise be ambiguous or merely unclear. -- diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index e06b8c646cc..beba14a73e6 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -967,15 +967,14 @@ instance HasTypeProxy lang => HasTypeProxy (PlutusScript lang) where data AsType (PlutusScript lang) = AsPlutusScript (AsType lang) proxyToAsType _ = AsPlutusScript (proxyToAsType (Proxy :: Proxy lang)) -instance (HasTypeProxy lang, Typeable lang) => SerialiseAsRawBytes (PlutusScript lang) where +instance HasTypeProxy lang => SerialiseAsRawBytes (PlutusScript lang) where serialiseToRawBytes (PlutusScriptSerialised sbs) = SBS.fromShort sbs deserialiseFromRawBytes (AsPlutusScript _) bs = -- TODO alonzo: validate the script syntax and fail decoding if invalid Right (PlutusScriptSerialised (SBS.toShort bs)) -instance (IsPlutusScriptLanguage lang, Typeable lang) => - HasTextEnvelope (PlutusScript lang) where +instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) where textEnvelopeType _ = case plutusScriptVersion :: PlutusScriptVersion lang of PlutusScriptV1 -> "PlutusScriptV1"