WIP Ledger: introduce Core.Tx levels

Author: geo2a

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

@@ -123,11 +123,11 @@ class
     SL.LedgerEnv era ->
     SL.LedgerState era ->
     WhetherToIntervene ->
-    Core.Tx era ->
+    Core.Tx TopTx era ->
     Except
       (SL.ApplyTxError era)
       ( SL.LedgerState era
-      , SL.Validated (Core.Tx era)
+      , SL.Validated (Core.Tx TopTx era)
       )
 
   -- | Whether the era has an instance of 'CG.ConwayEraGov'
@@ -148,11 +148,11 @@ defaultApplyShelleyBasedTx ::
   SL.LedgerEnv era ->
   SL.LedgerState era ->
   WhetherToIntervene ->
-  Core.Tx era ->
+  Core.Tx TopTx era ->
   Except
     (SL.ApplyTxError era)
     ( SL.LedgerState era
-    , SL.Validated (Core.Tx era)
+    , SL.Validated (Core.Tx TopTx era)
     )
 defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx =
   liftEither $
@@ -210,11 +210,11 @@ applyAlonzoBasedTx ::
   SL.LedgerEnv era ->
   SL.LedgerState era ->
   WhetherToIntervene ->
-  Core.Tx era ->
+  Core.Tx TopTx era ->
   Except
     (SL.ApplyTxError era)
     ( SL.LedgerState era
-    , SL.Validated (Core.Tx era)
+    , SL.Validated (Core.Tx TopTx era)
     )
 applyAlonzoBasedTx globals ledgerEnv mempoolState wti tx = do
   (mempoolState', vtx) <-

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

@@ -6,7 +6,7 @@
 
 module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where
 
-import qualified Cardano.Ledger.Core as Core (Tx)
+import qualified Cardano.Ledger.Core as Core (TopTx, Tx)
 import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL)
 import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
 import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize)
@@ -85,7 +85,7 @@ forgeShelleyBlock
 
     actualBodySize = SL.bBodySize protocolVersion body
 
-    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
+    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era
     extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx
 
     prevHash :: SL.PrevHash

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

@@ -45,6 +45,7 @@ import qualified Cardano.Crypto.Hash as Hash
 import qualified Cardano.Ledger.Allegra.Rules as AllegraEra
 import Cardano.Ledger.Alonzo.Core
   ( BlockBody
+  , TopTx
   , Tx
   , allInputsTxBodyF
   , bodyTxL
@@ -112,7 +113,7 @@ import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet)
 import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
 
-data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx era)
+data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx TopTx era)
   deriving stock Generic
 
 deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era))
@@ -126,7 +127,7 @@ instance
 data instance Validated (GenTx (ShelleyBlock proto era))
   = ShelleyValidatedTx
       !SL.TxId
-      !(SL.Validated (Tx era))
+      !(SL.Validated (Tx TopTx era))
   deriving stock Generic
 
 deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era)))
@@ -186,13 +187,14 @@ instance
         coerceSet
           (tx ^. bodyTxL . allInputsTxBodyF)
 
-mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
+mkShelleyTx ::
+  forall era proto. ShelleyBasedEra era => Tx TopTx era -> GenTx (ShelleyBlock proto era)
 mkShelleyTx tx = ShelleyTx (txIdTx tx) tx
 
 mkShelleyValidatedTx ::
   forall era proto.
   ShelleyBasedEra era =>
-  SL.Validated (Tx era) ->
+  SL.Validated (Tx TopTx era) ->
   Validated (GenTx (ShelleyBlock proto era))
 mkShelleyValidatedTx vtx = ShelleyValidatedTx txid vtx
  where
@@ -226,7 +228,7 @@ instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
       . SL.blockBody
       . shelleyBlockRaw
    where
-    blockBodyToTxList :: BlockBody era -> [Tx era]
+    blockBodyToTxList :: BlockBody era -> [Tx TopTx era]
     blockBodyToTxList blockBody = toList $ blockBody ^. txSeqBlockBodyL
 
 {-------------------------------------------------------------------------------

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

@@ -391,30 +391,30 @@ translateShelleyTables (LedgerTables utxoTable) =
 
 instance
   ( ShelleyBasedEra era
-  , SL.TranslateEra era SL.Tx
+  , SL.TranslateEra era (SL.Tx SL.TopTx)
   ) =>
   SL.TranslateEra era (GenTx :.: ShelleyBlock proto)
   where
-  type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era SL.Tx
+  type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era (SL.Tx SL.TopTx)
   translateEra ctxt (Comp (ShelleyTx _txId tx)) =
     Comp . mkShelleyTx
       <$> SL.translateEra ctxt tx
 
 instance
   ( ShelleyBasedEra era
-  , SL.TranslateEra era SL.Tx
+  , SL.TranslateEra era (SL.Tx SL.TopTx)
   ) =>
   SL.TranslateEra era (WrapValidatedGenTx :.: ShelleyBlock proto)
   where
   type
     TranslationError era (WrapValidatedGenTx :.: ShelleyBlock proto) =
-      SL.TranslationError era SL.Tx
+      SL.TranslationError era (SL.Tx SL.TopTx)
   translateEra ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx _txId vtx))) =
     Comp
       . WrapValidatedGenTx
       . mkShelleyValidatedTx
       . SL.coerceValidated
-      <$> SL.translateValidated @era @SL.Tx ctxt (SL.coerceValidated vtx)
+      <$> SL.translateValidated @era @(SL.Tx SL.TopTx) ctxt (SL.coerceValidated vtx)
 
 {-------------------------------------------------------------------------------
   Canonical TxIn

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

@@ -188,7 +188,7 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =
   , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2))
   , SL.PreviousEra era2 ~ era1
   , SL.TranslateEra era2 SL.NewEpochState
-  , SL.TranslateEra era2 SL.Tx
+  , SL.TranslateEra era2 (SL.Tx SL.TopTx)
   , SL.TranslationError era2 SL.NewEpochState ~ Void
   , -- At the moment, fix the protocols together
     ProtoCrypto proto1 ~ ProtoCrypto proto2

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs

@@ -176,7 +176,7 @@ migrateUTxO migrationInfo curSlot lcfg lst
             assert (pickedCoin > spentCoin) $
               pickedCoin <-> spentCoin
 
-          body :: SL.TxBody ShelleyEra
+          body :: SL.TxBody SL.TopTx ShelleyEra
           body =
             SL.mkBasicTxBody
               & SL.certsTxBodyL

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs

@@ -65,7 +65,7 @@ instance
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
     SL.Block _ body -> getSum $ foldMap (Sum . countOutputs) (body ^. Core.txSeqBlockBodyL)
    where
-    countOutputs :: Core.Tx era -> Int
+    countOutputs :: Core.Tx Core.TopTx era -> Int
     countOutputs tx = length $ tx ^. Core.bodyTxL . Core.outputsTxBodyL
 
   blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
@@ -100,7 +100,7 @@ instance
          | f <- maybeToList txExUnitsSteps
          ]
    where
-    txs :: StrictSeq (Core.Tx era)
+    txs :: StrictSeq (Core.Tx Core.TopTx era)
     txs = case Shelley.shelleyBlockRaw blk of
       SL.Block _ body -> body ^. Core.txSeqBlockBodyL
 
@@ -109,7 +109,7 @@ instance
   blockApplicationMetrics = []
 
 class PerEraAnalysis era where
-  txExUnitsSteps :: Maybe (Core.Tx era -> Word64)
+  txExUnitsSteps :: Maybe (Core.Tx Core.TopTx era -> Word64)
 
 instance PerEraAnalysis ShelleyEra where txExUnitsSteps = Nothing
 instance PerEraAnalysis AllegraEra where txExUnitsSteps = Nothing

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs

@@ -94,7 +94,7 @@ codecConfig = ShelleyCodecConfig
 mkLedgerTables ::
   forall proto era.
   ShelleyCompatible proto era =>
-  LC.Tx era ->
+  LC.Tx LC.TopTx era ->
   LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
 mkLedgerTables tx =
   LedgerTables $

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs

@@ -79,8 +79,8 @@ type CanMock proto era =
   , Arbitrary (Core.PParams era)
   , Arbitrary (Core.PParamsUpdate era)
   , Arbitrary (Core.Script era)
-  , Arbitrary (Core.TxBody era)
-  , Arbitrary (Core.Tx era)
+  , Arbitrary (Core.TxBody Core.TopTx era)
+  , Arbitrary (Core.Tx Core.TopTx era)
   , Arbitrary (Core.TxOut era)
   , Arbitrary (Core.Value era)
   , Arbitrary (PredicateFailure (SL.ShelleyUTXOW era))

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

@@ -525,7 +525,7 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew =
 
   -- Nothing but the parameter update and the obligatory touching of an
   -- input.
-  body :: SL.TxBody ShelleyEra
+  body :: SL.TxBody SL.TopTx ShelleyEra
   body =
     SL.mkBasicTxBody
       & SL.inputsTxBodyL .~ Set.singleton (fst touchCoins)
@@ -646,7 +646,7 @@ mkMASetDecentralizationParamTxs coreNodes pVer ttl dNew =
 
   -- Nothing but the parameter update and the obligatory touching of an
   -- input.
-  body :: SL.TxBody era
+  body :: SL.TxBody SL.TopTx era
   body =
     SL.mkBasicTxBody
       & SL.inputsTxBodyL .~ inputs