Merge pull request #4846 from IntersectMBO/td/nonannotator-deccbor-instances

Non-Annotator DecCBOR instances

Author: teodanciu

eras/allegra/impl/CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## 1.7.0.0
 
+* Add `DecCBOR` instances for:
+  * `Timelock`
+  * `AllegraTxAuxData`
+  * `AllegraTxBody`
 * Converted `CertState` to a type family
 * Made the fields of predicate failures and environments lazy
 * Add `Era era` constraint to `NoThunks` instance for `TimeLock`

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -76,6 +76,7 @@ import Cardano.Ledger.MemoBytes (
   MemoBytes (Memo),
   Memoized (..),
   byteCountMemoBytes,
+  decodeMemoized,
   getMemoRawType,
   mkMemoBytes,
   mkMemoizedEra,
@@ -189,9 +190,8 @@ instance Era era => EncCBOR (TimelockRaw era) where
       TimeStart m -> Sum TimeStart 4 !> To m
       TimeExpire m -> Sum TimeExpire 5 !> To m
 
--- This instance allows us to derive instance DecCBOR (Annotator (Timelock crypto)).
--- Since Timelock is a newtype around (Memo (Timelock crypto)).
-
+-- This instance allows us to derive instance DecCBOR (Annotator (Timelock era)).
+-- Since Timelock is a newtype around (Memo (Timelock era)).
 instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
   decCBOR = decode (Summands "TimelockRaw" decRaw)
     where
@@ -204,6 +204,16 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
       decRaw 5 = Ann (SumD TimeExpire <! From)
       decRaw n = Invalid n
 
+instance Era era => DecCBOR (TimelockRaw era) where
+  decCBOR = decode $ Summands "TimelockRaw" $ \case
+    0 -> SumD Signature <! From
+    1 -> SumD AllOf <! From
+    2 -> SumD AnyOf <! From
+    3 -> SumD MOfN <! From <! From
+    4 -> SumD TimeStart <! From
+    5 -> SumD TimeExpire <! From
+    n -> Invalid n
+
 -- =================================================================
 -- Native Scripts are Memoized TimelockRaw.
 -- The patterns give the appearence that the mutual recursion is not present.
@@ -222,6 +232,9 @@ instance Era era => MemPack (Timelock era) where
 instance Era era => NoThunks (Timelock era)
 instance Era era => EncCBOR (Timelock era)
 
+instance Era era => DecCBOR (Timelock era) where
+  decCBOR = TimelockConstr <$> decodeMemoized decCBOR
+
 instance Memoized (Timelock era) where
   type RawType (Timelock era) = TimelockRaw era
 

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs

@@ -122,7 +122,7 @@ instance NFData (AllegraTxAuxDataRaw era)
 
 newtype AllegraTxAuxData era = AuxiliaryDataWithBytes (MemoBytes (AllegraTxAuxDataRaw era))
   deriving (Generic)
-  deriving newtype (Eq, ToCBOR, SafeToHash)
+  deriving newtype (Eq, ToCBOR, SafeToHash, DecCBOR)
 
 instance Memoized (AllegraTxAuxData era) where
   type RawType (AllegraTxAuxData era) = AllegraTxAuxDataRaw era
@@ -172,7 +172,7 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where
       TypeListLen -> decodeFromList
       TypeListLen64 -> decodeFromList
       TypeListLenIndef -> decodeFromList
-      _ -> error "Failed to decode AuxiliaryData"
+      _ -> fail "Failed to decode AuxiliaryDataRaw"
     where
       decodeFromMap =
         decode
@@ -187,6 +187,30 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where
               <*! D (sequence <$> decCBOR)
           )
 
+instance Era era => DecCBOR (AllegraTxAuxDataRaw era) where
+  decCBOR =
+    peekTokenType >>= \case
+      TypeMapLen -> decodeFromMap
+      TypeMapLen64 -> decodeFromMap
+      TypeMapLenIndef -> decodeFromMap
+      TypeListLen -> decodeFromList
+      TypeListLen64 -> decodeFromList
+      TypeListLenIndef -> decodeFromList
+      _ -> fail "Failed to decode AuxiliaryDataRaw"
+    where
+      decodeFromMap =
+        decode
+          ( Emit AllegraTxAuxDataRaw
+              <! From
+              <! Emit StrictSeq.empty
+          )
+      decodeFromList =
+        decode
+          ( RecD AllegraTxAuxDataRaw
+              <! From
+              <! From
+          )
+
 deriving via
   (Mem (AllegraTxAuxDataRaw era))
   instance

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs

@@ -210,7 +210,7 @@ emptyAllegraTxBodyRaw =
 -- Wrap it all up in a newtype, hiding the insides with a pattern construtor.
 
 newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw () e))
-  deriving newtype (SafeToHash, ToCBOR)
+  deriving newtype (SafeToHash, ToCBOR, DecCBOR)
 
 instance Memoized (AllegraTxBody era) where
   type RawType (AllegraTxBody era) = AllegraTxBodyRaw () era

eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/Binary/CddlSpec.hs

@@ -9,6 +9,7 @@ import Test.Cardano.Ledger.Allegra.Binary.Cddl (readAllegraCddlFiles)
 import Test.Cardano.Ledger.Allegra.CDDL (allegraCDDL)
 import Test.Cardano.Ledger.Binary.Cddl (
   beforeAllCddlFile,
+  cddlDecoderEquivalenceSpec,
   cddlRoundTripAnnCborSpec,
   cddlRoundTripCborSpec,
  )
@@ -22,11 +23,21 @@ spec =
     describe "Ruby-based" $ beforeAllCddlFile 3 readAllegraCddlFiles $ do
       cddlRoundTripCborSpec @(Value AllegraEra) v "coin"
       cddlRoundTripAnnCborSpec @(TxBody AllegraEra) v "transaction_body"
+      cddlRoundTripCborSpec @(TxBody AllegraEra) v "transaction_body"
       cddlRoundTripAnnCborSpec @(Script AllegraEra) v "native_script"
+      cddlRoundTripCborSpec @(Script AllegraEra) v "native_script"
       cddlRoundTripAnnCborSpec @(TxAuxData AllegraEra) v "auxiliary_data"
+      cddlRoundTripCborSpec @(TxAuxData AllegraEra) v "auxiliary_data"
+      describe "DecCBOR instances equivalence via CDDL" $ do
+        cddlDecoderEquivalenceSpec @(TxBody AllegraEra) v "transaction_body"
+        cddlDecoderEquivalenceSpec @(Script AllegraEra) v "native_script"
+        cddlDecoderEquivalenceSpec @(TxAuxData AllegraEra) v "auxiliary_data"
 
     describe "Huddle" $ specWithHuddle allegraCDDL 100 $ do
       huddleRoundTripCborSpec @(Value AllegraEra) v "coin"
       huddleRoundTripAnnCborSpec @(TxBody AllegraEra) v "transaction_body"
+      huddleRoundTripCborSpec @(TxBody AllegraEra) v "transaction_body"
       huddleRoundTripAnnCborSpec @(TxAuxData AllegraEra) v "auxiliary_data"
+      huddleRoundTripCborSpec @(TxAuxData AllegraEra) v "auxiliary_data"
       huddleRoundTripAnnCborSpec @(Script AllegraEra) v "native_script"
+      huddleRoundTripCborSpec @(Script AllegraEra) v "native_script"

eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/BinarySpec.hs

@@ -11,6 +11,7 @@ import Test.Cardano.Ledger.Allegra.Arbitrary ()
 import Test.Cardano.Ledger.Allegra.TreeDiff ()
 import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Core.Binary (specUpgrade)
+import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec)
 import Test.Cardano.Ledger.Core.Binary.RoundTrip (RuleListEra (..))
 import Test.Cardano.Ledger.Shelley.Binary.RoundTrip (roundTripShelleyCommonSpec)
 
@@ -19,6 +20,8 @@ spec = do
   specUpgrade @AllegraEra def
   describe "RoundTrip" $ do
     roundTripShelleyCommonSpec @AllegraEra
+  describe "DecCBOR instances equivalence" $ do
+    Binary.decoderEquivalenceCoreEraTypesSpec @AllegraEra
 
 instance RuleListEra AllegraEra where
   type

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,17 @@
 
 ## 1.13.0.0
 
+* Add `DecCBOR` instances for:
+  * `MaryTxBody`
+  * `TxDats`
+  * `AlonzoTxAuxData`
+  * `AlonzoScript`
+  * `Redeemers`
+  * `AlonzoTxWits`
+  * `AlonozTxBody`
+  * `AlonzoTx`
+  * `AlonzoTxSeq`
+* Remove redundant `EncCBOR (Data era)` constraint from `DecCBOR` instance for `Annotator (AlonzoTxWits era)`
 * Converted `CertState` to a type family
 * Remove `reapplyAlonzoTx` as no longer needed.
 * Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext`
@@ -16,8 +27,11 @@
 
 ### `testlib`
 
+* Add `DecCBOR` instances for `TranslationInstance`
 * Converted `CertState` to a type family
 * Expose `alonzoFixupFees`
+* Move `Arbitrary` instances for `Data`, `BinaryData` and `Datum` to `cardano-ledger-core`
+* Move `Arbitrary` instance for `PV1.Data` to `cardano-ledger-core`
 
 ## 1.12.0.0
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -610,6 +610,18 @@ instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where
       {-# INLINE decodeScript #-}
   {-# INLINE decCBOR #-}
 
+instance AlonzoEraScript era => DecCBOR (AlonzoScript era) where
+  decCBOR = decode (Summands "AlonzoScript" decodeScript)
+    where
+      decodeScript = \case
+        0 -> SumD TimelockScript <! From
+        1 -> decodePlutus SPlutusV1
+        2 -> decodePlutus SPlutusV2
+        3 -> decodePlutus SPlutusV3
+        n -> Invalid n
+      decodePlutus slang =
+        SumD PlutusScript <! D (decodePlutusScript slang)
+
 -- | Verify that every `Script` represents a valid script. Force native scripts to Normal
 -- Form, to ensure that there are no bottoms and deserialize `Plutus` scripts into a
 -- `Cardano.Ledger.Plutus.Language.PlutusRunnable`.

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs

@@ -105,6 +105,7 @@ import Cardano.Ledger.Binary (
   Encoding,
   ToCBOR (..),
   decodeNullMaybe,
+  decodeNullStrictMaybe,
   encodeListLen,
   encodeNullMaybe,
   serialize,
@@ -449,6 +450,23 @@ instance
           )
   {-# INLINE decCBOR #-}
 
+instance
+  ( Typeable era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
+  DecCBOR (AlonzoTx era)
+  where
+  decCBOR =
+    decode $
+      RecD AlonzoTx
+        <! From
+        <! From
+        <! From
+        <! D (decodeNullStrictMaybe decCBOR)
+  {-# INLINE decCBOR #-}
+
 alonzoEqTxRaw :: AlonzoEraTx era => Tx era -> Tx era -> Bool
 alonzoEqTxRaw tx1 tx2 =
   shelleyEqTxRaw tx1 tx2 && (tx1 ^. isValidTxL == tx2 ^. isValidTxL)

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs

@@ -59,6 +59,7 @@ import Cardano.Ledger.BaseTypes (ProtVer)
 import Cardano.Ledger.Binary (
   Annotator (..),
   DecCBOR (..),
+  Decoder,
   EncCBOR (..),
   ToCBOR,
   TokenType (..),
@@ -183,16 +184,10 @@ getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadTimelock = timelocks, atadPlutus
 
 instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
   decCBOR =
-    peekTokenType >>= \case
-      TypeMapLen -> decodeShelley
-      TypeMapLen64 -> decodeShelley
-      TypeMapLenIndef -> decodeShelley
-      TypeListLen -> decodeShelleyMA
-      TypeListLen64 -> decodeShelleyMA
-      TypeListLenIndef -> decodeShelleyMA
-      TypeTag -> decodeAlonzo
-      TypeTag64 -> decodeAlonzo
-      _ -> fail "Failed to decode AlonzoTxAuxData"
+    decodeTxAuxDataByTokenType @(Annotator (AlonzoTxAuxDataRaw era))
+      decodeShelley
+      decodeAllegra
+      decodeAlonzo
     where
       decodeShelley =
         decode
@@ -201,7 +196,7 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
               <*! Ann (Emit StrictSeq.empty)
               <*! Ann (Emit Map.empty)
           )
-      decodeShelleyMA =
+      decodeAllegra =
         decode
           ( Ann (RecD AlonzoTxAuxDataRaw)
               <*! Ann From
@@ -214,13 +209,6 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
           TagD 259 $
             SparseKeyed "AlonzoTxAuxData" (pure emptyAuxData) auxDataField []
 
-      addPlutusScripts lang scripts ad =
-        case NE.nonEmpty scripts of
-          Nothing -> ad
-          Just neScripts ->
-            -- Avoid leaks by deepseq, since non empty list is lazy.
-            neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad}
-
       auxDataField :: Word -> Field (Annotator (AlonzoTxAuxDataRaw era))
       auxDataField 0 = fieldA (\x ad -> ad {atadrMetadata = x}) From
       auxDataField 1 =
@@ -232,6 +220,53 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
       auxDataField 4 = fieldA (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR))
       auxDataField n = field (\_ t -> t) (Invalid n)
 
+instance Era era => DecCBOR (AlonzoTxAuxDataRaw era) where
+  decCBOR =
+    decodeTxAuxDataByTokenType @(AlonzoTxAuxDataRaw era)
+      decodeShelley
+      decodeAllegra
+      decodeAlonzo
+    where
+      decodeShelley =
+        decode
+          (Emit AlonzoTxAuxDataRaw <! From <! Emit StrictSeq.empty <! Emit Map.empty)
+      decodeAllegra =
+        decode
+          (RecD AlonzoTxAuxDataRaw <! From <! From <! Emit Map.empty)
+      decodeAlonzo =
+        decode $
+          TagD 259 $
+            SparseKeyed "AlonzoTxAuxData" emptyAuxData auxDataField []
+
+      auxDataField :: Word -> Field (AlonzoTxAuxDataRaw era)
+      auxDataField 0 = field (\x ad -> ad {atadrMetadata = x}) From
+      auxDataField 1 = field (\x ad -> ad {atadrTimelock = atadrTimelock ad <> x}) From
+      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)
+
+decodeTxAuxDataByTokenType :: forall t s. Decoder s t -> Decoder s t -> Decoder s t -> Decoder s t
+decodeTxAuxDataByTokenType decodeShelley decodeAllegra decodeAlonzo =
+  peekTokenType >>= \case
+    TypeMapLen -> decodeShelley
+    TypeMapLen64 -> decodeShelley
+    TypeMapLenIndef -> decodeShelley
+    TypeListLen -> decodeAllegra
+    TypeListLen64 -> decodeAllegra
+    TypeListLenIndef -> decodeAllegra
+    TypeTag -> decodeAlonzo
+    TypeTag64 -> decodeAlonzo
+    _ -> fail "Failed to decode AlonzoTxAuxData"
+
+addPlutusScripts :: Language -> [PlutusBinary] -> AlonzoTxAuxDataRaw era -> AlonzoTxAuxDataRaw era
+addPlutusScripts lang scripts ad =
+  case NE.nonEmpty scripts of
+    Nothing -> ad
+    Just neScripts ->
+      -- Avoid leaks by deepseq, since non empty list is lazy.
+      neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad}
+
 emptyAuxData :: AlonzoTxAuxDataRaw era
 emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty
 
@@ -240,7 +275,7 @@ emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty
 
 newtype AlonzoTxAuxData era = AlonzoTxAuxDataConstr (MemoBytes (AlonzoTxAuxDataRaw era))
   deriving (Generic)
-  deriving newtype (ToCBOR, SafeToHash)
+  deriving newtype (ToCBOR, SafeToHash, DecCBOR)
 
 instance Memoized (AlonzoTxAuxData era) where
   type RawType (AlonzoTxAuxData era) = AlonzoTxAuxDataRaw era