New encode(TxIn|TxOut)WithHint methods for SerializeTablesWithHint

Author: jasagredo

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs

@@ -214,6 +214,48 @@ instance
       toPlainEncoding (eraProtVerLow @era) $
         encodeMap encodeMemPack (eliminateCardanoTxOut (const encodeMemPack)) tbs
 
+  encodeTxInWithHint (HardForkLedgerState (HardForkState idx)) txin =
+    let
+      -- These could be made into a CAF to avoid recomputing it, but
+      -- it is only used in serialization so it is not critical.
+      np =
+        (Fn $ const $ K $ Codec.CBOR.Encoding.encodeMapLen 0)
+          :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AllegraEra))
+          :* (Fn $ const $ K $ encOne (Proxy @MaryEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra))
+          :* (Fn $ const $ K $ encOne (Proxy @BabbageEra))
+          :* (Fn $ const $ K $ encOne (Proxy @ConwayEra))
+          :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (eraProtVerLow @era) $ encodeMemPack txin
+
+  encodeTxOutWithHint (HardForkLedgerState (HardForkState idx)) txout =
+    let
+      -- These could be made into a CAF to avoid recomputing it, but
+      -- it is only used in serialization so it is not critical.
+      np =
+        (Fn $ const $ K $ Codec.CBOR.Encoding.encodeMapLen 0)
+          :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AllegraEra))
+          :* (Fn $ const $ K $ encOne (Proxy @MaryEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra))
+          :* (Fn $ const $ K $ encOne (Proxy @BabbageEra))
+          :* (Fn $ const $ K $ encOne (Proxy @ConwayEra))
+          :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (eraProtVerLow @era) $ eliminateCardanoTxOut (const encodeMemPack) txout
+
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock (CardanoEras c)) EmptyMK ->

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -367,6 +367,8 @@ instance
   where
   encodeTablesWithHint _ (LedgerTables (ValuesMK tbs)) =
     toPlainEncoding (Core.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs
+  encodeTxInWithHint _ = toPlainEncoding (Core.eraProtVerLow @era) . encodeMemPack
+  encodeTxOutWithHint _ = toPlainEncoding (Core.eraProtVerLow @era) . encodeMemPack
   decodeTablesWithHint st =
     let certInterns =
           internsFromMap $

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -503,6 +503,8 @@ instance
     encOne :: Encoding
     encOne = toPlainEncoding (SL.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs
 
+  encodeTxInWithHint _ = toPlainEncoding (SL.eraProtVerLow @era) . encodeMemPack
+  encodeTxOutWithHint _ = toPlainEncoding (SL.eraProtVerLow @era) . encodeMemPack
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock '[ShelleyBlock proto era]) EmptyMK ->

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -548,6 +548,34 @@ instance
           )
           tbs
 
+  encodeTxInWithHint (HardForkLedgerState (HardForkState idx)) txin =
+    let
+      np =
+        (Fn $ const $ K $ encOne (Proxy @era1))
+          :* (Fn $ const $ K $ encOne (Proxy @era2))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. SL.Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (SL.eraProtVerLow @era) $ encodeMemPack (getShelleyHFCTxIn txin)
+
+  encodeTxOutWithHint (HardForkLedgerState (HardForkState idx)) txout0 =
+    let
+      np =
+        (Fn $ const $ K $ encOne (Proxy @era1))
+          :* (Fn $ const $ K $ encOne (Proxy @era2))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. SL.Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (SL.eraProtVerLow @era) $ case txout0 of
+        Z txout -> encodeMemPack $ unwrapTxOut txout
+        S (Z txout) -> encodeMemPack $ unwrapTxOut txout
+
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2)) EmptyMK ->

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs

@@ -479,6 +479,8 @@ instance SerialiseHFC '[BlockA, BlockB]
 instance SerializeTablesWithHint (LedgerState (HardForkBlock '[BlockA, BlockB])) where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 instance
   IndexedMemPack

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs

@@ -1122,6 +1122,8 @@ instance
   where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 instance
   ( Bridge m a

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs

@@ -383,4 +383,6 @@ instance
 
 instance SerializeTablesWithHint (LedgerState blk) => SerializeTablesWithHint (ExtLedgerState blk) where
   decodeTablesWithHint st = castLedgerTables <$> decodeTablesWithHint (ledgerState st)
+  encodeTxInWithHint st = encodeTxInWithHint (ledgerState st)
+  encodeTxOutWithHint st = encodeTxOutWithHint (ledgerState st)
   encodeTablesWithHint st tbs = encodeTablesWithHint (ledgerState st) (castLedgerTables tbs)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs

@@ -176,6 +176,7 @@ module Ouroboros.Consensus.Ledger.Tables
   , SerializeTablesWithHint (..)
   , defaultDecodeTablesWithHint
   , defaultEncodeTablesWithHint
+  , defaultEncodeMemPackWithHint
   , valuesMKDecoder
   , valuesMKEncoder
 
@@ -322,6 +323,14 @@ class SerializeTablesWithHint l where
     SerializeTablesHint (LedgerTables l ValuesMK) ->
     LedgerTables l ValuesMK ->
     CBOR.Encoding
+  encodeTxInWithHint ::
+    SerializeTablesHint (LedgerTables l ValuesMK) ->
+    TxIn l ->
+    CBOR.Encoding
+  encodeTxOutWithHint ::
+    SerializeTablesHint (LedgerTables l ValuesMK) ->
+    TxOut l ->
+    CBOR.Encoding
   decodeTablesWithHint ::
     SerializeTablesHint (LedgerTables l ValuesMK) ->
     CBOR.Decoder s (LedgerTables l ValuesMK)
@@ -339,19 +348,22 @@ defaultEncodeTablesWithHint ::
   SerializeTablesHint (LedgerTables l ValuesMK) ->
   LedgerTables l ValuesMK ->
   CBOR.Encoding
-defaultEncodeTablesWithHint _ (LedgerTables (ValuesMK tbs)) =
+defaultEncodeTablesWithHint h (LedgerTables (ValuesMK tbs)) =
   mconcat
     [ CBOR.encodeMapLen (fromIntegral $ Map.size tbs)
     , Map.foldMapWithKey
         ( \k v ->
             mconcat
-              [ CBOR.encodeBytes (packByteString k)
-              , CBOR.encodeBytes (packByteString v)
+              [ defaultEncodeMemPackWithHint h k
+              , defaultEncodeMemPackWithHint h v
               ]
         )
         tbs
     ]
 
+defaultEncodeMemPackWithHint :: MemPack a => p -> a -> CBOR.Encoding
+defaultEncodeMemPackWithHint _ k = CBOR.encodeBytes (packByteString k)
+
 defaultDecodeTablesWithHint ::
   (Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
   SerializeTablesHint (LedgerTables l ValuesMK) ->
@@ -414,8 +426,10 @@ instance IndexedMemPack (TrivialLedgerTables l EmptyMK) Void where
   indexedPackM _ = packM
   indexedUnpackM _ = unpackM
 
-instance SerializeTablesWithHint (TrivialLedgerTables l) where
+instance (MemPack (TxIn l), MemPack (TxOut l)) => SerializeTablesWithHint (TrivialLedgerTables l) where
   decodeTablesWithHint _ = do
     _ <- CBOR.decodeMapLen
     pure (LedgerTables $ ValuesMK Map.empty)
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
   encodeTablesWithHint _ _ = CBOR.encodeMapLen 0

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LedgerStateOnlyTables.hs

@@ -78,6 +78,8 @@ instance
 instance (Ord k, MemPack k, MemPack v) => SerializeTablesWithHint (LedgerState (OTBlock k v)) where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 {-------------------------------------------------------------------------------
   Stowable

ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -538,6 +538,8 @@ instance IndexedMemPack (LedgerState (SimpleBlock c ext) EmptyMK) Mock.TxOut whe
 instance SerializeTablesWithHint (LedgerState (SimpleBlock c ext)) where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 instance HasLedgerTables (LedgerState (SimpleBlock c ext)) where
   projectLedgerTables = simpleLedgerTables