o-c-cardano: add DijkstraMeasure

Author: geo2a

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

@@ -128,7 +128,7 @@ type CardanoHardForkConstraints c =
 --     the calculation of later rewards. In this transition, we consume the
 --     'shelleyToAllegraAVVMsToDelete' as deletions in the ledger tables.
 instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
-  type HardForkTxMeasure (CardanoEras c) = ConwayMeasure
+  type HardForkTxMeasure (CardanoEras c) = DijkstraMeasure
 
   hardForkEraTranslation =
     EraTranslation
@@ -227,7 +227,7 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
       `o` fromAlonzo
       `o` fromConway
       `o` fromConway
-      `o` fromConway
+      `o` fromDijkstra
       `o` nil
    where
     nil :: SOP.NS f '[] -> a
@@ -243,10 +243,11 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
       SOP.Z (WrapTxMeasure x) -> f x
       SOP.S y -> g y
 
-    fromByteSize :: IgnoringOverflow ByteSize32 -> ConwayMeasure
+    fromByteSize :: IgnoringOverflow ByteSize32 -> DijkstraMeasure
     fromByteSize x = fromAlonzo $ AlonzoMeasure x mempty
     fromAlonzo x = fromConway $ ConwayMeasure x mempty
-    fromConway x = x
+    fromConway x = fromDijkstra $ DijkstraMeasure x
+    fromDijkstra x = x
 
 class SelectView (BlockProtocol blk) ~ PraosChainSelectView c => HasPraosSelectView c blk
 instance SelectView (BlockProtocol blk) ~ PraosChainSelectView c => HasPraosSelectView c blk

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

@@ -33,6 +33,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool
     -- * Exported for tests
   , AlonzoMeasure (..)
   , ConwayMeasure (..)
+  , DijkstraMeasure (..)
   , fromExUnits
   ) where
 
@@ -628,6 +629,41 @@ instance
 
 -----
 
+newtype DijkstraMeasure = DijkstraMeasure
+  { conwayMeasure :: ConwayMeasure
+  }
+  deriving stock (Eq, Generic, Show)
+  deriving anyclass NoThunks
+  deriving newtype (Semigroup, Monoid, HasByteSize, TxMeasureMetrics)
+  deriving
+    Measure
+    via (InstantiatedAt Generic DijkstraMeasure)
+
+blockCapacityDijkstraMeasure ::
+  forall proto era mk.
+  ( ShelleyCompatible proto era
+  , L.AlonzoEraPParams era
+  ) =>
+  TickedLedgerState (ShelleyBlock proto era) mk ->
+  DijkstraMeasure
+blockCapacityDijkstraMeasure = DijkstraMeasure . blockCapacityConwayMeasure
+
+txMeasureDijkstra ::
+  forall proto era.
+  ( ShelleyCompatible proto era
+  , L.AlonzoEraTxWits era
+  , L.BabbageEraTxBody era
+  , ExUnitsTooBigUTxO era
+  , MaxTxSizeUTxO era
+  , TxRefScriptsSizeTooBig era
+  ) =>
+  TickedLedgerState (ShelleyBlock proto era) ValuesMK ->
+  GenTx (ShelleyBlock proto era) ->
+  V.Validation (TxErrorSG era) DijkstraMeasure
+txMeasureDijkstra st tx = DijkstraMeasure <$> txMeasureConway st tx -- TODO(geo2a): eta-reduce
+
+-----
+
 data ConwayMeasure = ConwayMeasure
   { alonzoMeasure :: !AlonzoMeasure
   , refScriptsSize :: !(IgnoringOverflow ByteSize32)
@@ -769,6 +805,6 @@ instance
   ShelleyCompatible p DijkstraEra =>
   TxLimits (ShelleyBlock p DijkstraEra)
   where
-  type TxMeasure (ShelleyBlock p DijkstraEra) = ConwayMeasure
-  txMeasure _cfg st tx = runValidation $ txMeasureConway st tx
-  blockCapacityTxMeasure _cfg = blockCapacityConwayMeasure
+  type TxMeasure (ShelleyBlock p DijkstraEra) = DijkstraMeasure
+  txMeasure _cfg st tx = runValidation $ txMeasureDijkstra st tx
+  blockCapacityTxMeasure _cfg = blockCapacityDijkstraMeasure