Non-Annotator DecCBOR instances

.github/workflows/haskell.yml

@@ -36,7 +36,7 @@ jobs:
   build:
     strategy:
       matrix:
-        ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.4", "9.10.1"]
+        ghc: ["9.2.8", "9.6.6", "9.8.4", "9.10.1"]
         os: [ubuntu-latest]
       fail-fast: false
 
@@ -213,7 +213,7 @@ jobs:
         - set-algebra
         - small-steps
         - vector-map
-        ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.4", "9.10.1"]
+        ghc: ["9.2.8", "9.6.6", "9.8.4", "9.10.1"]
         os: [ubuntu-latest]
       fail-fast: false
 

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,17 @@ 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 "Timelock" decRaw)
+    where
+      decRaw 0 = SumD Signature <! From
+      decRaw 1 = SumD AllOf <! D decCBOR
+      decRaw 2 = SumD AnyOf <! D decCBOR
+      decRaw 3 = SumD MOfN <! From <! D decCBOR
+      decRaw 4 = SumD TimeStart <! From
+      decRaw 5 = SumD TimeExpire <! From
+      decRaw n = Invalid n
+
 -- =================================================================
 -- Native Scripts are Memoized TimelockRaw.
 -- The patterns give the appearence that the mutual recursion is not present.
@@ -222,6 +233,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
@@ -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
+      _ -> error "Failed to decode AuxiliaryData"
+    where
+      decodeFromMap =
+        decode
+          ( Emit AllegraTxAuxDataRaw
+              <! From
+              <! Emit StrictSeq.empty
+          )
+      decodeFromList =
+        decode
+          ( RecD AllegraTxAuxDataRaw
+              <! From
+              <! D decCBOR
+          )
+
 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/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.13.0.0
 
+* Remove redundant `EncCBOR (Data era)` constraint from `DecCBOR` instance for `Annotator (AlonzoTxWits era)`
 * Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext`
 * Add `lookupTxInfoResultImpossible` helper
 * Add `TxInfoResult era` parameter to `toPlutusWithContext` and `mkPlutusWithContext`

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

@@ -449,6 +449,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 (maybeToStrictMaybe <$> decodeNullMaybe 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
+      decodeShelleyMA
+      decodeAlonzo
     where
       decodeShelley =
         decode
@@ -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,56 @@ 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
+      decodeShelleyMA
+      decodeAlonzo
+    where
+      decodeShelley =
+        decode
+          (Emit AlonzoTxAuxDataRaw <! From <! Emit StrictSeq.empty <! Emit Map.empty)
+      decodeShelleyMA =
+        decode
+          (RecD AlonzoTxAuxDataRaw <! From <! D (decodeStrictSeq decCBOR) <! 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})
+          (D (decodeStrictSeq decCBOR))
+      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 decodeShelleyMA decodeAlonzo =
+  peekTokenType >>= \case
+    TypeMapLen -> decodeShelley
+    TypeMapLen64 -> decodeShelley
+    TypeMapLenIndef -> decodeShelley
+    TypeListLen -> decodeShelleyMA
+    TypeListLen64 -> decodeShelleyMA
+    TypeListLenIndef -> decodeShelleyMA
+    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 +278,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

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs

@@ -401,6 +401,10 @@ deriving via
     (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) =>
     DecCBOR (Annotator (AlonzoTxBody era))
 
+deriving newtype instance
+  (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) =>
+  DecCBOR (AlonzoTxBody era)
+
 pattern AlonzoTxBody ::
   forall era.
   (EraTxOut era, EraTxCert era) =>

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs

@@ -32,9 +32,11 @@ import qualified Cardano.Crypto.Hash as Hash
 import Cardano.Ledger.Alonzo.Era
 import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx)
 import Cardano.Ledger.Binary (
+  Annotated (..),
   Annotator,
   DecCBOR (..),
   EncCBORGroup (..),
+  decodeAnnotated,
   encCBOR,
   encodeFoldableEncoder,
   encodeFoldableMapEncoder,
@@ -44,14 +46,14 @@ import Cardano.Ledger.Binary (
   withSlice,
  )
 import Cardano.Ledger.Core
-import Cardano.Ledger.Shelley.BlockChain (constructMetadata)
+import Cardano.Ledger.Shelley.BlockChain (constructMetadata, indexLookupSeq)
 import Control.Monad (unless)
 import Data.ByteString (ByteString)
 import Data.ByteString.Builder (shortByteString, toLazyByteString)
 import qualified Data.ByteString.Lazy as BSL
 import Data.Coerce (coerce)
 import qualified Data.Map.Strict as Map
-import Data.Maybe.Strict (strictMaybeToMaybe)
+import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe)
 import Data.Proxy (Proxy (..))
 import qualified Data.Sequence as Seq
 import Data.Sequence.Strict (StrictSeq)
@@ -230,6 +232,65 @@ instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where
         <*> auxDataAnn
         <*> isValAnn
 
+instance
+  ( AlonzoEraTx era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
+  DecCBOR (AlonzoTxSeq era)
+  where
+  decCBOR = do
+    Annotated bodies bodiesBs <- decodeAnnotated decCBOR
+    Annotated wits witsBs <- decodeAnnotated decCBOR
+    Annotated auxDataMap auxDataBs <- decodeAnnotated decCBOR
+    let b = length bodies
+        inRange x = (0 <= x) && (x <= (b - 1))
+        w = length wits
+    unless
+      (all inRange (Map.keysSet auxDataMap))
+      ( fail
+          ( "Some Auxiliarydata index is not in the range: 0 .. "
+              ++ show (b - 1)
+          )
+      )
+    let auxData = maybeToStrictMaybe <$> indexLookupSeq b auxDataMap
+    Annotated isValidIdxs isValidBs <- decodeAnnotated decCBOR
+    let vs = alignedValidFlags b isValidIdxs
+    unless
+      (b == w)
+      ( fail $
+          "different number of transaction bodies ("
+            <> show b
+            <> ") and witness sets ("
+            <> show w
+            <> ")"
+      )
+    unless
+      (all inRange isValidIdxs)
+      ( fail
+          ( "Some IsValid index is not in the range: 0 .. "
+              ++ show (b - 1)
+              ++ ", "
+              ++ show isValidIdxs
+          )
+      )
+    let mkTx body wt isValid ad =
+          mkBasicTx body
+            & witsTxL .~ wt
+            & auxDataTxL .~ ad
+            & isValidTxL .~ isValid
+    let txs =
+          StrictSeq.forceToStrict $
+            Seq.zipWith4 mkTx bodies wits vs auxData
+    pure $
+      AlonzoTxSeqRaw
+        txs
+        bodiesBs
+        witsBs
+        auxDataBs
+        isValidBs
+
 --------------------------------------------------------------------------------
 -- Internal utility functions
 --------------------------------------------------------------------------------