Merge pull request #4911 from IntersectMBO/lehins/improve-decoding-error-message

lehins · web-flow · commit 25723a514cc2 · 2025-03-04T21:52:56.000-07:00
Make `invalidKey` report the type that it is decoding
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -97,6 +98,7 @@ import Cardano.Ledger.Binary.Coders (
   decode,
   encode,
   field,
+  invalidField,
   (!>),
  )
 import Cardano.Ledger.Coin (Coin (..))
@@ -663,31 +665,32 @@ instance Era era => EncCBOR (AlonzoPParams StrictMaybe era) where
   encCBOR ppup = encode (encodePParamsUpdate ppup)
 
 updateField :: Word -> Field (AlonzoPParams StrictMaybe era)
-updateField 0 = field (\x up -> up {appMinFeeA = SJust x}) From
-updateField 1 = field (\x up -> up {appMinFeeB = SJust x}) From
-updateField 2 = field (\x up -> up {appMaxBBSize = SJust x}) From
-updateField 3 = field (\x up -> up {appMaxTxSize = SJust x}) From
-updateField 4 = field (\x up -> up {appMaxBHSize = SJust x}) From
-updateField 5 = field (\x up -> up {appKeyDeposit = SJust x}) From
-updateField 6 = field (\x up -> up {appPoolDeposit = SJust x}) From
-updateField 7 = field (\x up -> up {appEMax = SJust x}) From
-updateField 8 = field (\x up -> up {appNOpt = SJust x}) From
-updateField 9 = field (\x up -> up {appA0 = SJust x}) From
-updateField 10 = field (\x up -> up {appRho = SJust x}) From
-updateField 11 = field (\x up -> up {appTau = SJust x}) From
-updateField 12 = field (\x up -> up {appD = SJust x}) From
-updateField 13 = field (\x up -> up {appExtraEntropy = SJust x}) From
-updateField 14 = field (\x up -> up {appProtocolVersion = SJust x}) From
-updateField 16 = field (\x up -> up {appMinPoolCost = SJust x}) From
-updateField 17 = field (\x up -> up {appCoinsPerUTxOWord = SJust x}) From
-updateField 18 = field (\x up -> up {appCostModels = SJust x}) From
-updateField 19 = field (\x up -> up {appPrices = SJust x}) From
-updateField 20 = field (\x up -> up {appMaxTxExUnits = SJust x}) From
-updateField 21 = field (\x up -> up {appMaxBlockExUnits = SJust x}) From
-updateField 22 = field (\x up -> up {appMaxValSize = SJust x}) From
-updateField 23 = field (\x up -> up {appCollateralPercentage = SJust x}) From
-updateField 24 = field (\x up -> up {appMaxCollateralInputs = SJust x}) From
-updateField k = field (\_x up -> up) (Invalid k)
+updateField = \case
+  0 -> field (\x up -> up {appMinFeeA = SJust x}) From
+  1 -> field (\x up -> up {appMinFeeB = SJust x}) From
+  2 -> field (\x up -> up {appMaxBBSize = SJust x}) From
+  3 -> field (\x up -> up {appMaxTxSize = SJust x}) From
+  4 -> field (\x up -> up {appMaxBHSize = SJust x}) From
+  5 -> field (\x up -> up {appKeyDeposit = SJust x}) From
+  6 -> field (\x up -> up {appPoolDeposit = SJust x}) From
+  7 -> field (\x up -> up {appEMax = SJust x}) From
+  8 -> field (\x up -> up {appNOpt = SJust x}) From
+  9 -> field (\x up -> up {appA0 = SJust x}) From
+  10 -> field (\x up -> up {appRho = SJust x}) From
+  11 -> field (\x up -> up {appTau = SJust x}) From
+  12 -> field (\x up -> up {appD = SJust x}) From
+  13 -> field (\x up -> up {appExtraEntropy = SJust x}) From
+  14 -> field (\x up -> up {appProtocolVersion = SJust x}) From
+  16 -> field (\x up -> up {appMinPoolCost = SJust x}) From
+  17 -> field (\x up -> up {appCoinsPerUTxOWord = SJust x}) From
+  18 -> field (\x up -> up {appCostModels = SJust x}) From
+  19 -> field (\x up -> up {appPrices = SJust x}) From
+  20 -> field (\x up -> up {appMaxTxExUnits = SJust x}) From
+  21 -> field (\x up -> up {appMaxBlockExUnits = SJust x}) From
+  22 -> field (\x up -> up {appMaxValSize = SJust x}) From
+  23 -> field (\x up -> up {appCollateralPercentage = SJust x}) From
+  24 -> field (\x up -> up {appMaxCollateralInputs = SJust x}) From
+  k -> invalidField k
 
 instance Era era => DecCBOR (AlonzoPParams StrictMaybe era) where
   decCBOR =
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs
@@ -665,7 +665,8 @@ encFail NoCollateralInputs =
   Sum NoCollateralInputs 20
 
 decFail ::
-  ( DecCBOR (TxOut era)
+  ( Era era
+  , DecCBOR (TxOut era)
   , DecCBOR (Value era)
   , DecCBOR (PredicateFailure (EraRule "UTXOS" era))
   ) =>
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs
@@ -432,6 +432,9 @@ instance
 
 instance
   ( Typeable era
+  , Typeable (TxBody era)
+  , Typeable (TxWits era)
+  , Typeable (TxAuxData era)
   , DecCBOR (Annotator (TxBody era))
   , DecCBOR (Annotator (TxWits era))
   , DecCBOR (Annotator (TxAuxData era))
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs
@@ -218,7 +218,7 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
       auxDataField 2 = fieldA (addPlutusScripts PlutusV1) (D (guardPlutus PlutusV1 >> decCBOR))
       auxDataField 3 = fieldA (addPlutusScripts PlutusV2) (D (guardPlutus PlutusV2 >> decCBOR))
       auxDataField 4 = fieldA (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR))
-      auxDataField n = field (\_ t -> t) (Invalid n)
+      auxDataField n = invalidField n
 
 instance Era era => DecCBOR (AlonzoTxAuxDataRaw era) where
   decCBOR =
@@ -244,7 +244,7 @@ instance Era era => DecCBOR (AlonzoTxAuxDataRaw era) where
       auxDataField 2 = field (addPlutusScripts PlutusV1) (D (guardPlutus PlutusV1 >> decCBOR))
       auxDataField 3 = field (addPlutusScripts PlutusV2) (D (guardPlutus PlutusV2 >> decCBOR))
       auxDataField 4 = field (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR))
-      auxDataField n = field (\_ t -> t) (Invalid n)
+      auxDataField n = invalidField n
 
 decodeTxAuxDataByTokenType :: forall t s. Decoder s t -> Decoder s t -> Decoder s t -> Decoder s t
 decodeTxAuxDataByTokenType decodeShelley decodeAllegra decodeAlonzo =
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs
@@ -622,7 +622,7 @@ instance
       bodyFields 11 = ofield (\x tx -> tx {atbrScriptIntegrityHash = x}) From
       bodyFields 14 = field (\x tx -> tx {atbrReqSignerHashes = x}) From
       bodyFields 15 = ofield (\x tx -> tx {atbrTxNetworkId = x}) From
-      bodyFields n = field (\_ t -> t) (Invalid n)
+      bodyFields n = invalidField n
       requiredFields =
         [ (0, "inputs")
         , (1, "outputs")
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs
@@ -707,7 +707,7 @@ instance
       txWitnessField 5 = fieldAA (\x wits -> wits {atwrRdmrsTxWits = x}) From
       txWitnessField 6 = fieldA addScripts (decodePlutus SPlutusV2)
       txWitnessField 7 = fieldA addScripts (decodePlutus SPlutusV3)
-      txWitnessField n = field (\_ t -> t) (Invalid n)
+      txWitnessField n = invalidField n
       {-# INLINE txWitnessField #-}
 
       nativeScriptsDecoder :: Decoder s (Annotator (Map ScriptHash (Script era)))
@@ -766,7 +766,7 @@ instance
       txWitnessField 5 = field (\x wits -> wits {atwrRdmrsTxWits = x}) From
       txWitnessField 6 = field addScripts (decodePlutus SPlutusV2)
       txWitnessField 7 = field addScripts (decodePlutus SPlutusV3)
-      txWitnessField n = field (\_ t -> t) (Invalid n)
+      txWitnessField n = invalidField n
 
       nativeScriptsDecoder :: Decoder s (Map ScriptHash (Script era))
       nativeScriptsDecoder =
diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs
@@ -148,6 +148,7 @@ instance
 
 instance
   ( Typeable era
+  , Typeable (Tx era)
   , DecCBOR (PParams era)
   , DecCBOR (UTxO era)
   , DecCBOR (Annotator (Core.Tx era))
@@ -183,6 +184,7 @@ instance
 deserializeTranslationInstances ::
   forall era.
   ( Era era
+  , Typeable (Tx era)
   , DecCBOR (PParams era)
   , DecCBOR (UTxO era)
   , DecCBOR (Annotator (Core.Tx era))
diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs
@@ -88,6 +88,7 @@ import Cardano.Ledger.Binary.Coders (
   decode,
   encode,
   field,
+  invalidField,
   (!>),
  )
 import Cardano.Ledger.Coin (Coin (..))
@@ -495,7 +496,7 @@ updateField 21 = field (\x up -> up {bppMaxBlockExUnits = SJust x}) From
 updateField 22 = field (\x up -> up {bppMaxValSize = SJust x}) From
 updateField 23 = field (\x up -> up {bppCollateralPercentage = SJust x}) From
 updateField 24 = field (\x up -> up {bppMaxCollateralInputs = SJust x}) From
-updateField k = field (\_x up -> up) (Invalid k)
+updateField k = invalidField k
 
 instance Era era => DecCBOR (BabbagePParams StrictMaybe era) where
   decCBOR =
diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs
@@ -839,7 +839,7 @@ instance
       bodyFields 11 = ofield (\x tx -> tx {btbrScriptIntegrityHash = x}) From
       bodyFields 14 = field (\x tx -> tx {btbrReqSignerHashes = x}) From
       bodyFields 15 = ofield (\x tx -> tx {btbrTxNetworkId = x}) From
-      bodyFields n = field (\_ t -> t) (Invalid n)
+      bodyFields n = invalidField n
       {-# INLINE bodyFields #-}
       requiredFields :: [(Word, String)]
       requiredFields =
diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxOut.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxOut.hs
@@ -646,7 +646,7 @@ decodeTxOut decAddr = do
       ofield
         (\x txo -> txo {decodingTxOutScript = x})
         (D $ decodeCIC "Script")
-    bodyFields n = field (\_ t -> t) (Invalid n)
+    bodyFields n = invalidField n
     {-# INLINE bodyFields #-}
     requiredFields =
       [ (0, "addr")
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs
@@ -1086,7 +1086,7 @@ updateField = \case
   31 -> field (\x up -> up {cppDRepDeposit = THKD (SJust x)}) From
   32 -> field (\x up -> up {cppDRepActivity = THKD (SJust x)}) From
   33 -> field (\x up -> up {cppMinFeeRefScriptCostPerByte = THKD (SJust x)}) From
-  k -> field (\_x up -> up) (Invalid k)
+  k -> invalidField k
 
 instance Era era => DecCBOR (ConwayPParams StrictMaybe era) where
   decCBOR = decode (SparseKeyed "PParamsUpdate" emptyConwayPParamsUpdate updateField [])
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs
@@ -272,7 +272,7 @@ instance
     2 -> SumD ConwayCertsFailure <! From
     3 -> SumD ConwayGovFailure <! From
     4 -> SumD ConwayWdrlNotDelegatedToDRep <! From
-    5 -> SumD ConwayTreasuryValueMismatch <! (unswapMismatch <$> FromGroup)
+    5 -> SumD ConwayTreasuryValueMismatch <! mapCoder unswapMismatch FromGroup
     6 -> SumD ConwayTxRefScriptsSizeTooBig <! FromGroup
     7 -> SumD ConwayMempoolFailure <! From
     n -> Invalid n
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs
@@ -54,6 +54,7 @@ import Cardano.Ledger.Binary.Coders (
   Encode (..),
   decode,
   encode,
+  mapCoder,
   (!>),
   (<!),
  )
@@ -319,7 +320,7 @@ instance
     2 -> SumD OutsideValidityIntervalUTxO <! From <! From
     3 -> SumD MaxTxSizeUTxO <! FromGroup
     4 -> SumD InputSetEmptyUTxO
-    5 -> SumD FeeTooSmallUTxO <! (unswapMismatch <$> FromGroup)
+    5 -> SumD FeeTooSmallUTxO <! mapCoder unswapMismatch FromGroup
     6 -> SumD ValueNotConservedUTxO <! FromGroup
     7 -> SumD WrongNetwork <! From <! From
     8 -> SumD WrongNetworkWithdrawal <! From <! From
@@ -328,11 +329,11 @@ instance
     11 -> SumD OutputTooBigUTxO <! From
     12 -> SumD InsufficientCollateral <! From <! From
     13 -> SumD ScriptsNotPaidUTxO <! D (UTxO <$> decCBOR)
-    14 -> SumD ExUnitsTooBigUTxO <! (unswapMismatch <$> FromGroup)
+    14 -> SumD ExUnitsTooBigUTxO <! mapCoder unswapMismatch FromGroup
     15 -> SumD CollateralContainsNonADA <! From
-    16 -> SumD WrongNetworkInTxBody <! (unswapMismatch <$> FromGroup)
+    16 -> SumD WrongNetworkInTxBody <! mapCoder unswapMismatch FromGroup
     17 -> SumD OutsideForecast <! From
-    18 -> SumD TooManyCollateralInputs <! (unswapMismatch <$> FromGroup)
+    18 -> SumD TooManyCollateralInputs <! mapCoder unswapMismatch FromGroup
     19 -> SumD NoCollateralInputs
     20 -> SumD IncorrectTotalCollateralField <! From <! From
     21 -> SumD BabbageOutputTooSmallUTxO <! From
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs
@@ -87,6 +87,7 @@ import Cardano.Ledger.Binary.Coders (
   encodeKeyedStrictMaybe,
   field,
   fieldGuarded,
+  invalidField,
   ofield,
   (!>),
  )
@@ -251,7 +252,7 @@ instance
         ofield
           (\x tx -> tx {ctbrTreasuryDonation = fromSMaybe zero x})
           (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero"))
-      bodyFields n = field (\_ t -> t) (Invalid n)
+      bodyFields n = invalidField n
       requiredFields :: [(Word, String)]
       requiredFields =
         [ (0, "inputs")
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs
@@ -309,6 +309,9 @@ instance Era era => EncCBOR (ShelleyTx era)
 
 instance
   ( Era era
+  , Typeable (TxBody era)
+  , Typeable (TxWits era)
+  , Typeable (TxAuxData era)
   , DecCBOR (Annotator (TxBody era))
   , DecCBOR (Annotator (TxWits era))
   , DecCBOR (Annotator (TxAuxData era))
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs
@@ -77,6 +77,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.MapExtras as Map (fromElems)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Void
 import GHC.Generics (Generic)
 import GHC.Records ()
 import Lens.Micro (Lens', (^.))
@@ -243,7 +244,7 @@ instance (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWitsRaw era)
           (\x wits -> wits {scriptWits' = x})
           (D $ Map.fromElems (hashScript @era) <$> decodeList decCBOR)
       witField 2 = field (\x wits -> wits {bootWits' = x}) From
-      witField n = field (\_ wits -> wits) (Invalid n)
+      witField n = invalidField n
 
 decodeWits ::
   forall era s.
@@ -275,7 +276,7 @@ decodeWits =
       fieldAA
         (\x wits -> wits {bootWits' = x})
         (D $ mapTraverseableDecoderA (decodeList decCBOR) Set.fromList)
-    witField n = fieldAA (\_ wits -> wits) (Invalid n)
+    witField n = fieldAA (\(_ :: Void) wits -> wits) (Invalid n)
 
 mapTraverseableDecoderA ::
   Traversable f =>
diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md
@@ -2,6 +2,12 @@
 
 ## 1.6.0.0
 
+* Add `Typeable` constraint to `invalidKey`
+* Add `Typeable` constraint to various Coders functions and types: `field`, `fieldGuarded`,
+  `ofield`, `fieldA`, `fieldAA`, `ApplyD`, `Map`, `Ann`, `ApplyAnn`, `ApplyErr`, `<!`, `<*!`, `<?`,
+  `decode`, `decodE`, `decodeCount`, `decodeClosed`, `listDecodeA`, `setDecodeA`, `mapDecodeA`
+* Add `mapCoder` as a replacement for `fmap`
+* Remove `Functor` and `Applicative` instance for `Decode`
 * Add to `Plain`:
   * `assertTag`
   * `decodeTagMaybe`
diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs
diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Plain.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Plain.hs
