Avoid branching on translateUpperBoundForPlutusScripts protocol version

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.14.0.0
 
+* Make `transValidityInterval` based on eras instead of protocol versions.
+  * Remove `hardforkConwayTranslateUpperBoundForPlutusScripts` from `Cardano.Ledger.Alonzo.Era`.
+  * Remove protocol version from arguments to `transValidityInterval`.
 * Add `NFData` instance for `AlonzoGenesis`
 * Add `reqSignerHashesTxBodyG`
 * Add `mkScriptIntegrity`

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

@@ -14,10 +14,8 @@ module Cardano.Ledger.Alonzo.Era (
   AlonzoUTXOW,
   AlonzoBBODY,
   AlonzoLEDGER,
-  hardforkConwayTranslateUpperBoundForPlutusScripts,
 ) where
 
-import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), natVersion)
 import Cardano.Ledger.Internal.Era (AlonzoEra)
 import Cardano.Ledger.Mary (MaryEra, MaryValue)
 import Cardano.Ledger.Shelley.Core
@@ -93,8 +91,3 @@ type instance EraRule "TICK" AlonzoEra = ShelleyTICK AlonzoEra
 type instance EraRule "TICKF" AlonzoEra = ShelleyTICKF AlonzoEra
 
 type instance EraRule "UPEC" AlonzoEra = ShelleyUPEC AlonzoEra
-
--- | Starting with protocol version 9, we translate the upper bound of validity
--- interval correctly for Plutus scripts.
-hardforkConwayTranslateUpperBoundForPlutusScripts :: ProtVer -> Bool
-hardforkConwayTranslateUpperBoundForPlutusScripts pv = pvMajor pv > natVersion @8

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs

@@ -46,7 +46,7 @@ module Cardano.Ledger.Alonzo.Plutus.TxInfo (
 
 import Cardano.Crypto.Hash.Class (hashToBytes)
 import Cardano.Ledger.Alonzo.Core
-import Cardano.Ledger.Alonzo.Era (AlonzoEra, hardforkConwayTranslateUpperBoundForPlutusScripts)
+import Cardano.Ledger.Alonzo.Era (AlonzoEra)
 import Cardano.Ledger.Alonzo.Plutus.Context
 import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), PlutusScript (..), toAsItem)
 import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
@@ -103,7 +103,7 @@ instance EraPlutusTxInfo 'PlutusV1 AlonzoEra where
 
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     timeRange <-
-      transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     txInsMaybes <- forM (Set.toList (txBody ^. inputsTxBodyL)) $ \txIn -> do
       txOut <- transLookupTxOut ltiUTxO txIn
       pure $ PV1.TxInInfo (transTxIn txIn) <$> transTxOut txOut
@@ -218,23 +218,14 @@ transValidityInterval ::
   forall proxy era a.
   Inject (AlonzoContextError era) a =>
   proxy era ->
-  ProtVer ->
   EpochInfo (Either Text) ->
   SystemStart ->
   ValidityInterval ->
   Either a PV1.POSIXTimeRange
-transValidityInterval _ protVer epochInfo systemStart = \case
+transValidityInterval _ epochInfo systemStart = \case
   ValidityInterval SNothing SNothing -> pure PV1.always
   ValidityInterval (SJust i) SNothing -> PV1.from <$> transSlotToPOSIXTime i
-  ValidityInterval SNothing (SJust i) -> do
-    t <- transSlotToPOSIXTime i
-    pure $
-      if hardforkConwayTranslateUpperBoundForPlutusScripts protVer
-        then
-          PV1.Interval
-            (PV1.LowerBound PV1.NegInf True)
-            (PV1.strictUpperBound t)
-        else PV1.to t
+  ValidityInterval SNothing (SJust i) -> PV1.to <$> transSlotToPOSIXTime i
   ValidityInterval (SJust i) (SJust j) -> do
     t1 <- transSlotToPOSIXTime i
     t2 <- transSlotToPOSIXTime j

eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/TxInfoSpec.hs

@@ -11,15 +11,14 @@ import Cardano.Ledger.Alonzo (AlonzoEra, Tx (..))
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.Plutus.Context (
   ContextError,
-  EraPlutusContext,
   LedgerTxInfo (..),
   toPlutusTxInfo,
  )
-import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), transValidityInterval)
+import Cardano.Ledger.Alonzo.Plutus.TxInfo (transValidityInterval)
 import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..))
 import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..), TxBody (..))
-import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..), natVersion)
-import qualified Cardano.Ledger.BaseTypes as BT (Inject (..), ProtVer (..))
+import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..))
+import qualified Cardano.Ledger.BaseTypes as BT (ProtVer (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Credential (StakeReference (..))
 import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
@@ -107,44 +106,18 @@ silentlyIgnore tx =
 
 -- | The test checks that the old implementation of 'transVITime' stays intentionally incorrect,
 -- by returning close upper bound of the validaty interval.
-transVITimeUpperBoundIsClosed ::
-  forall era.
-  ( EraPlutusContext era
-  , BT.Inject (AlonzoContextError era) (ContextError era)
-  ) =>
-  Expectation
+transVITimeUpperBoundIsClosed :: Expectation
 transVITimeUpperBoundIsClosed = do
   let interval = ValidityInterval SNothing (SJust (SlotNo 40))
-      pv = BT.ProtVer (eraProtVerLow @era) 0
-  case transValidityInterval (Proxy @era) pv ei ss interval of
-    Left (e :: ContextError era) ->
+  case transValidityInterval (Proxy @AlonzoEra) ei ss interval of
+    Left (e :: ContextError AlonzoEra) ->
       expectationFailure $ "no translation error was expected, but got: " <> show e
     Right t ->
       t
         `shouldBe` PV1.Interval
           (PV1.LowerBound PV1.NegInf True)
           (PV1.UpperBound (PV1.Finite (PV1.POSIXTime 40000)) True)
 
--- | The test checks that since protocol version 9 'transVITime' works correctly,
--- by returning open upper bound of the validaty interval.
-transVITimeUpperBoundIsOpen ::
-  forall era.
-  ( EraPlutusContext era
-  , BT.Inject (AlonzoContextError era) (ContextError era)
-  ) =>
-  Expectation
-transVITimeUpperBoundIsOpen = do
-  let interval = ValidityInterval SNothing (SJust (SlotNo 40))
-      pv = BT.ProtVer (natVersion @9) 0
-  case transValidityInterval (Proxy @era) pv ei ss interval of
-    Left (e :: ContextError era) ->
-      expectationFailure $ "no translation error was expected, but got: " <> show e
-    Right t ->
-      t
-        `shouldBe` PV1.Interval
-          (PV1.LowerBound PV1.NegInf True)
-          (PV1.UpperBound (PV1.Finite (PV1.POSIXTime 40000)) False)
-
 spec :: Spec
 spec = describe "txInfo translation" $ do
   -- TODO: convert to Imp: https://github.com/IntersectMBO/cardano-ledger/issues/5210
@@ -155,9 +128,7 @@ spec = describe "txInfo translation" $ do
       silentlyIgnore (txEx byronInput shelleyOutput)
   describe "transVITime" $ do
     it "validity interval's upper bound is closed when protocol < 9" $
-      transVITimeUpperBoundIsClosed @AlonzoEra
-    it "validity interval's upper bound is open when protocol >= 9" $
-      transVITimeUpperBoundIsOpen @AlonzoEra
+      transVITimeUpperBoundIsClosed
 
 genesisId :: TxId
 genesisId = TxId (unsafeMakeSafeHash (mkDummyHash (0 :: Int)))

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs

@@ -23,6 +23,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
   toPlutusTxInfo,
  )
 import Cardano.Ledger.Alonzo.TxWits (Redeemers)
+import Cardano.Ledger.BaseTypes (ProtVer (ProtVer))
 import Cardano.Ledger.Core as Core
 import Cardano.Ledger.Plutus.Language (SLanguage (..))
 import Cardano.Ledger.State (UTxO (..))
@@ -74,7 +75,8 @@ genTranslationInstance ::
   TranslatableGen era =>
   Gen (TranslationInstance era)
 genTranslationInstance = do
-  protVer <- arbitrary
+  version <- choose (eraProtVerLow @era, eraProtVerHigh @era)
+  let protVer = ProtVer version 0
   supportedLanguage :: SupportedLanguage era <- arbitrary
   tx <- tgTx supportedLanguage
   utxo <- tgUtxo supportedLanguage tx

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

@@ -322,7 +322,7 @@ instance EraPlutusTxInfo 'PlutusV1 BabbageEra where
     unless (Set.null refInputs) $ Left (ReferenceInputsNotSupported refInputs)
 
     timeRange <-
-      Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      Alonzo.transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     inputs <- mapM (transTxInInfoV1 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
     outputs <-
       zipWithM
@@ -355,7 +355,7 @@ instance EraPlutusTxInfo 'PlutusV2 BabbageEra where
 
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     timeRange <-
-      Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      Alonzo.transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     inputs <- mapM (transTxInInfoV2 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
     refInputs <- mapM (transTxInInfoV2 ltiUTxO) (Set.toList (txBody ^. referenceInputsTxBodyL))
     outputs <-

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.20.0.0
 
+* Make `transValidityInterval` implicit to eras instead of protocol versions.
+  * Implement `transValidityInterval` for Conway.
 * Add `NFData` for `ConwayGenesis`
 * Deprecate `PoolParams` in favor of `StakePoolState`. #5196
   * Update `DRepPulser` and `RatifyEnv` to use `StakePoolState` instead of `PoolParams`.

eras/conway/impl/cardano-ledger-conway.cabal

@@ -187,7 +187,7 @@ library testlib
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-mary:{cardano-ledger-mary, testlib},
     cardano-ledger-shelley:{cardano-ledger-shelley, testlib},
-    cardano-slotting:testlib,
+    cardano-slotting:{cardano-slotting, testlib},
     cardano-strict-containers,
     containers,
     cuddle >=0.4,
@@ -202,6 +202,7 @@ library testlib
     prettyprinter,
     small-steps >=1.1,
     text,
+    time,
 
 executable huddle-cddl
   main-is: Main.hs

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

@@ -31,6 +31,7 @@ module Cardano.Ledger.Conway.TxInfo (
   transTxOutV1,
   transMintValue,
   transTxBodyId,
+  transValidityInterval,
   transVotingProcedures,
   transProposal,
   toPlutusV3Args,
@@ -103,6 +104,7 @@ import Cardano.Ledger.Plutus.Data (Data)
 import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..))
 import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
 import Cardano.Ledger.Plutus.TxInfo (
+  slotToPOSIXTime,
   transBoundedRational,
   transCoinToLovelace,
   transCoinToValue,
@@ -116,6 +118,8 @@ import Cardano.Ledger.Plutus.TxInfo (
  )
 import qualified Cardano.Ledger.Plutus.TxInfo as TxInfo
 import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
+import Cardano.Slotting.EpochInfo (EpochInfo)
+import Cardano.Slotting.Time (SystemStart)
 import Control.Arrow (ArrowChoice (..))
 import Control.DeepSeq (NFData)
 import Control.Monad (unless, when, zipWithM)
@@ -125,6 +129,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
 import qualified Data.Set as Set
+import Data.Text (Text)
 import GHC.Generics hiding (to)
 import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks)
@@ -398,7 +403,7 @@ instance EraPlutusTxInfo 'PlutusV1 ConwayEra where
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     guardConwayFeaturesForPlutusV1V2 ltiTx
     timeRange <-
-      Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     inputs <- mapM (transTxInInfoV1 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
     mapM_ (transTxInInfoV1 ltiUTxO) (Set.toList (txBody ^. referenceInputsTxBodyL))
     outputs <-
@@ -433,7 +438,7 @@ instance EraPlutusTxInfo 'PlutusV2 ConwayEra where
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     guardConwayFeaturesForPlutusV1V2 ltiTx
     timeRange <-
-      Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     inputs <- mapM (Babbage.transTxInInfoV2 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
     refInputs <- mapM (Babbage.transTxInInfoV2 ltiUTxO) (Set.toList (txBody ^. referenceInputsTxBodyL))
     outputs <-
@@ -470,7 +475,7 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
 
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     timeRange <-
-      Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
+      transValidityInterval ltiTx ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
     let
       txInputs = txBody ^. inputsTxBodyL
       refInputs = txBody ^. referenceInputsTxBodyL
@@ -764,3 +769,30 @@ class
 
 instance ConwayEraPlutusTxInfo 'PlutusV3 ConwayEra where
   toPlutusChangedParameters _ x = PV3.ChangedParameters (PV3.dataToBuiltinData (toPlutusData x))
+
+-- | Translate a validity interval to POSIX time
+transValidityInterval ::
+  forall proxy era a.
+  Inject (AlonzoContextError era) a =>
+  proxy era ->
+  EpochInfo (Either Text) ->
+  SystemStart ->
+  ValidityInterval ->
+  Either a PV1.POSIXTimeRange
+transValidityInterval _ epochInfo systemStart = \case
+  ValidityInterval SNothing SNothing -> pure PV1.always
+  ValidityInterval (SJust i) SNothing -> PV1.from <$> transSlotToPOSIXTime i
+  ValidityInterval SNothing (SJust i) -> do
+    t <- transSlotToPOSIXTime i
+    pure $ PV1.Interval (PV1.LowerBound PV1.NegInf True) (PV1.strictUpperBound t)
+  ValidityInterval (SJust i) (SJust j) -> do
+    t1 <- transSlotToPOSIXTime i
+    t2 <- transSlotToPOSIXTime j
+    pure $
+      PV1.Interval
+        (PV1.lowerBound t1)
+        (PV1.strictUpperBound t2)
+  where
+    transSlotToPOSIXTime =
+      left (inject . TimeTranslationPastHorizon @era)
+        . slotToPOSIXTime epochInfo systemStart

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TxInfoSpec.hs

@@ -10,14 +10,25 @@
 
 module Test.Cardano.Ledger.Conway.TxInfoSpec (spec) where
 
-import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo, toPlutusTxCert)
+import Cardano.Ledger.Alonzo.Plutus.Context (
+  EraPlutusContext (ContextError),
+  EraPlutusTxInfo,
+  toPlutusTxCert,
+ )
 import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway (ConwayEra)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.TxCert
+import Cardano.Ledger.Conway.TxInfo (transValidityInterval)
 import Cardano.Ledger.Credential (StakeCredential)
 import Cardano.Ledger.Plutus.Language (Language (..))
+import Cardano.Ledger.Slot
+import Cardano.Slotting.EpochInfo (fixedEpochInfo)
+import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
 import Data.Proxy (Proxy (..))
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import qualified PlutusLedgerApi.V1 as PV1
 import qualified PlutusLedgerApi.V2 as PV2
 import qualified PlutusLedgerApi.V3 as PV3
 import Test.Cardano.Ledger.Common
@@ -54,6 +65,9 @@ spec = do
       expectDeposit coin $ transV10 $ ConwayTxCertDeleg $ ConwayUnRegCert cred (SJust coin)
       expectDeposit coin $ transV10 $ UnRegDepositTxCert cred coin
       expectNoDeposit $ transV10 $ ConwayTxCertDeleg $ ConwayUnRegCert cred SNothing
+
+    it "validity interval's upper bound is open when protocol >= 9" $
+      transVITimeUpperBoundIsOpen
   where
     expectDeposit :: Coin -> PV3.TxCert -> IO ()
     expectDeposit (Coin c) =
@@ -71,3 +85,23 @@ spec = do
         txcert ->
           expectationFailure $
             "Deposit not expected, but found in: " <> show txcert
+
+-- | The test checks that since protocol version 9 'transVITime' works correctly,
+-- by returning open upper bound of the validaty interval.
+transVITimeUpperBoundIsOpen :: Expectation
+transVITimeUpperBoundIsOpen = do
+  let interval = ValidityInterval SNothing (SJust (SlotNo 40))
+  case transValidityInterval (Proxy @ConwayEra) ei ss interval of
+    Left (e :: ContextError ConwayEra) ->
+      expectationFailure $ "no translation error was expected, but got: " <> show e
+    Right t ->
+      t
+        `shouldBe` PV1.Interval
+          (PV1.LowerBound PV1.NegInf True)
+          (PV1.UpperBound (PV1.Finite (PV1.POSIXTime 40000)) False)
+
+ei :: EpochInfo (Either a)
+ei = fixedEpochInfo (EpochSize 100) (mkSlotLength 1)
+
+ss :: SystemStart
+ss = SystemStart $ posixSecondsToUTCTime 0