Merge pull request #5125 from IntersectMBO/aniketd/better-upgrade-txout

Faster upgradeTxOut for alonzo, babbage and conway

Author: aniketd

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

@@ -340,7 +340,7 @@ instance EraTxOut AlonzoEra where
 
   mkBasicTxOut addr vl = AlonzoTxOut addr vl SNothing
 
-  upgradeTxOut (Shelley.TxOutCompact addr value) = TxOutCompact addr value
+  upgradeTxOut (Shelley.TxOutCompact addr value) = TxOutCompact' addr value
 
   addrEitherTxOutL =
     lens

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxOut.hs

@@ -20,9 +20,13 @@ module Cardano.Ledger.Babbage.TxOut (
   BabbageTxOut (
     BabbageTxOut,
     TxOutCompact,
+    TxOutCompact',
     TxOutCompactDH,
+    TxOutCompactDH',
     TxOutCompactDatum,
-    TxOutCompactRefScript
+    TxOutCompactRefScript,
+    TxOut_AddrHash28_AdaOnly,
+    TxOut_AddrHash28_AdaOnly_DataHash32
   ),
   BabbageEraTxOut (..),
   TxOut,
@@ -48,10 +52,10 @@ import Cardano.Ledger.Address (
   decompactAddr,
   fromCborBothAddr,
  )
+import Cardano.Ledger.Alonzo (AlonzoEra)
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.TxBody (
   Addr28Extra,
-  AlonzoTxOut (AlonzoTxOut),
   DataHash32,
   decodeAddress28,
   decodeDataHash32,
@@ -218,11 +222,7 @@ instance EraTxOut BabbageEra where
 
   mkBasicTxOut addr vl = BabbageTxOut addr vl NoDatum SNothing
 
-  upgradeTxOut (AlonzoTxOut addr value mDatumHash) = BabbageTxOut addr value datum SNothing
-    where
-      datum = case mDatumHash of
-        SNothing -> NoDatum
-        SJust datumHash -> DatumHash datumHash
+  upgradeTxOut = upgradeAlonzoTxOut
 
   addrEitherTxOutL = addrEitherBabbageTxOutL
   {-# INLINE addrEitherTxOutL #-}
@@ -232,6 +232,13 @@ instance EraTxOut BabbageEra where
 
   getMinCoinSizedTxOut = babbageMinUTxOValue
 
+upgradeAlonzoTxOut :: Alonzo.AlonzoTxOut AlonzoEra -> BabbageTxOut BabbageEra
+upgradeAlonzoTxOut = \case
+  Alonzo.TxOutCompact' ca cv -> TxOutCompact' ca cv
+  Alonzo.TxOutCompactDH' ca cv dh -> TxOutCompactDH' ca cv dh
+  Alonzo.TxOut_AddrHash28_AdaOnly c a28e cc -> TxOut_AddrHash28_AdaOnly c a28e cc
+  Alonzo.TxOut_AddrHash28_AdaOnly_DataHash32 c a28e cc dh32 -> TxOut_AddrHash28_AdaOnly_DataHash32 c a28e cc dh32
+
 dataHashBabbageTxOutL ::
   EraTxOut era => Lens' (BabbageTxOut era) (StrictMaybe DataHash)
 dataHashBabbageTxOutL =

eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs

@@ -49,6 +49,7 @@ module Cardano.Ledger.Conway.TxBody (
   conwayProposalsDeposits,
   conwayRedeemerPointer,
   conwayRedeemerPointerInverse,
+  upgradeBabbageTxOut,
 ) where
 
 import Cardano.Ledger.Alonzo.TxBody (Indexable (..))
@@ -90,7 +91,7 @@ import Cardano.Ledger.Conway.Scripts (ConwayEraScript, ConwayPlutusPurpose (..))
 import Cardano.Ledger.Conway.TxCert (
   ConwayEraTxCert,
  )
-import Cardano.Ledger.Conway.TxOut ()
+import Cardano.Ledger.Conway.TxOut (upgradeBabbageTxOut)
 import Cardano.Ledger.Mary.Value (MultiAsset (..), policies)
 import Cardano.Ledger.MemoBytes (
   EqRaw,

eras/conway/impl/src/Cardano/Ledger/Conway/TxOut.hs

@@ -2,14 +2,16 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Cardano.Ledger.Conway.TxOut () where
+module Cardano.Ledger.Conway.TxOut (upgradeBabbageTxOut) where
 
 import Cardano.Ledger.Babbage.Core
 import Cardano.Ledger.Babbage.TxOut (
@@ -27,6 +29,7 @@ import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.PParams ()
 import Cardano.Ledger.Conway.Scripts ()
 import Cardano.Ledger.Plutus.Data (Datum (..), translateDatum)
+import Data.Coerce (coerce)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Lens.Micro
 
@@ -35,8 +38,7 @@ instance EraTxOut ConwayEra where
 
   mkBasicTxOut addr vl = BabbageTxOut addr vl NoDatum SNothing
 
-  upgradeTxOut (BabbageTxOut addr value d s) =
-    BabbageTxOut addr value (translateDatum d) (upgradeScript <$> s)
+  upgradeTxOut = upgradeBabbageTxOut
 
   addrEitherTxOutL = addrEitherBabbageTxOutL
   {-# INLINE addrEitherTxOutL #-}
@@ -62,3 +64,18 @@ instance BabbageEraTxOut ConwayEra where
 
   referenceScriptTxOutL = referenceScriptBabbageTxOutL
   {-# INLINE referenceScriptTxOutL #-}
+
+upgradeBabbageTxOut ::
+  ( Value era ~ Value (PreviousEra era)
+  , EraScript (PreviousEra era)
+  , EraScript era
+  ) =>
+  BabbageTxOut (PreviousEra era) ->
+  BabbageTxOut era
+upgradeBabbageTxOut = \case
+  TxOutCompact' ca cv -> TxOutCompact' ca cv
+  TxOutCompactDH' ca cv dh -> TxOutCompactDH' ca cv dh
+  TxOutCompactDatum ca cv bd -> TxOutCompactDatum ca cv (coerce bd)
+  TxOutCompactRefScript ca cv d s -> TxOutCompactRefScript ca cv (translateDatum d) (upgradeScript s)
+  TxOut_AddrHash28_AdaOnly c a28e cc -> TxOut_AddrHash28_AdaOnly c a28e cc
+  TxOut_AddrHash28_AdaOnly_DataHash32 c a28e cc dh32 -> TxOut_AddrHash28_AdaOnly_DataHash32 c a28e cc dh32

eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxOut.hs

@@ -17,10 +17,11 @@ import Cardano.Ledger.Babbage.TxOut (
   referenceScriptBabbageTxOutL,
   valueEitherBabbageTxOutL,
  )
-import Cardano.Ledger.Core (EraScript (..), EraTxOut (..))
+import Cardano.Ledger.Conway.TxBody (upgradeBabbageTxOut)
+import Cardano.Ledger.Core (EraTxOut (..))
 import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
 import Cardano.Ledger.Dijkstra.Scripts ()
-import Cardano.Ledger.Plutus (Datum (..), translateDatum)
+import Cardano.Ledger.Plutus (Datum (..))
 import Data.Maybe.Strict (StrictMaybe (..))
 import Lens.Micro (to)
 
@@ -29,8 +30,7 @@ instance EraTxOut DijkstraEra where
 
   mkBasicTxOut addr vl = BabbageTxOut addr vl NoDatum SNothing
 
-  upgradeTxOut (BabbageTxOut addr value d s) =
-    BabbageTxOut addr value (translateDatum d) (upgradeScript <$> s)
+  upgradeTxOut = upgradeBabbageTxOut
 
   addrEitherTxOutL = addrEitherBabbageTxOutL
   {-# INLINE addrEitherTxOutL #-}