Merge pull request #5063 from input-output-hk/newhoggy/improve-roundtrip-functions-to-report-annotations-on-callsite

Improve roundtrip functions to report annotations on callsite

Author: newhoggy

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

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

@@ -1,29 +1,44 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Hedgehog.Roundtrip.CBOR
   ( roundtrip_CBOR
   , roundtrip_CDDL_Tx
   ) 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)

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

@@ -87,7 +87,6 @@ import           Data.Either.Combinators (rightToMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import           Data.Typeable (Typeable)
 import qualified Text.Parsec as Parsec
 import qualified Text.Parsec.String as Parsec
 
@@ -445,7 +444,7 @@ instance HasTypeProxy era => HasTypeProxy (AddressInEra era) where
     data AsType (AddressInEra era) = AsAddressInEra (AsType era)
     proxyToAsType _ = AsAddressInEra (proxyToAsType (Proxy :: Proxy era))
 
-instance (IsCardanoEra era, Typeable era) => SerialiseAsRawBytes (AddressInEra era) where
+instance IsCardanoEra era => SerialiseAsRawBytes (AddressInEra era) where
 
     serialiseToRawBytes (AddressInEra ByronAddressInAnyEra addr) =
       serialiseToRawBytes addr

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.
   --

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"