Reapply review suggestions

Co-authored-by: Alexey Kuleshevich <[email protected]>

Author: Soupstraw

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -287,9 +287,9 @@ fixupDatums tx = impAnn "fixupDatums" $ do
     getData txOut =
       let sh = txOutScriptHash txOut
        in case txOut ^. datumTxOutF of
-            DatumHash _dh -> case Map.lookup sh (scriptTestContexts @era) of
-              Just x -> pure . Just $ spendDatum x
-              Nothing -> do
+            DatumHash dh -> case Map.lookup sh (scriptTestContexts @era) of
+              Just x | hashData @era (spendDatum x) == dh -> pure . Just $ spendDatum x
+              _ -> do
                 logText $
                   "Script not found in `scriptTestContexts`:\n"
                     <> T.pack (show sh)

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs

@@ -232,7 +232,9 @@ disjointRefInputs ::
   Test (BabbageUtxoPredFailure era)
 disjointRefInputs pp inputs refInputs =
   when
-    (pvMajor (pp ^. ppProtocolVersionL) == natVersion @10)
+    ( pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra
+        && pvMajor (pp ^. ppProtocolVersionL) < natVersion @11
+    )
     (failureOnNonEmpty common BabbageNonDisjointRefInputs)
   where
     common = inputs `Set.intersection` refInputs

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxoSpec.hs

@@ -13,11 +13,10 @@ import Cardano.Ledger.Babbage.Core (
   EraTx (..),
   EraTxBody (..),
   EraTxOut (..),
-  KeyRole (..),
  )
 import Cardano.Ledger.BaseTypes (Inject (..))
 import Cardano.Ledger.Coin (Coin (..))
-import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+import Cardano.Ledger.Credential (StakeReference (..))
 import Cardano.Ledger.Plutus (
   Data (..),
   Datum (..),
@@ -49,11 +48,11 @@ spec = describe "UTXO" $ do
         txOut =
           mkBasicTxOut
             ( mkAddr
-                (ScriptHashObj @'Payment $ hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
+                (hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
                 StakeRefNull
             )
             (inject $ Coin 1_000_000)
-            & datumTxOutL .~ (Datum . dataToBinaryData . Data . PV1.I $ 0)
+            & datumTxOutL .~ Datum (dataToBinaryData . Data $ PV1.I 0)
       tx <-
         submitTx $
           mkBasicTx mkBasicTxBody

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

@@ -118,6 +118,7 @@ import Control.DeepSeq (NFData)
 import Control.Monad (unless, when, zipWithM)
 import Data.Aeson (ToJSON (..), (.=))
 import Data.Foldable as F (Foldable (..))
+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
@@ -166,7 +167,7 @@ data ConwayContextError era
   | VotingProceduresFieldNotSupported !(VotingProcedures era)
   | ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
   | TreasuryDonationFieldNotSupported !Coin
-  | ReferenceInputsNotDisjointFromInputs !(Set.Set TxIn)
+  | ReferenceInputsNotDisjointFromInputs !(NonEmpty TxIn)
   deriving (Generic)
 
 deriving instance
@@ -472,8 +473,9 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
     refInputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList refInputs)
     let
       commonInputs = txInputs `Set.intersection` refInputs
-    unless (pvMajor ltiProtVer < natVersion @11 || Set.null commonInputs) . Left $
-      ReferenceInputsNotDisjointFromInputs commonInputs
+    unless (pvMajor ltiProtVer < natVersion @11) $ case toList commonInputs of
+      (x : xs) -> Left $ ReferenceInputsNotDisjointFromInputs $ x :| xs
+      _ -> Right ()
     outputs <-
       zipWithM
         (Babbage.transTxOutV2 . TxOutFromOutput)

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

@@ -90,7 +90,6 @@ spec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
-  , ContextError era ~ ConwayContextError era
   ) =>
   Spec
 spec = do
@@ -126,7 +125,6 @@ conwaySpec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
-  , ContextError era ~ ConwayContextError era
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
 conwaySpec = do

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
 
@@ -42,7 +41,6 @@ import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val
 import qualified Data.ByteString.Short as SBS (length)
 import Data.Functor ((<&>))
-import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
@@ -58,7 +56,7 @@ spec ::
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
-  , ContextError era ~ ConwayContextError era
+  , Inject (ConwayContextError era) (ContextError era)
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
 spec =
@@ -83,39 +81,31 @@ spec =
     describe "disjoint inputs and reference inputs" $ do
       let
         scriptHash lang = hashPlutusScript $ inputsOverlapsWithRefInputs lang
-        tx :: TxIn -> Tx era
-        tx txIn =
+        mkTestTx :: TxIn -> Tx era
+        mkTestTx txIn =
           mkBasicTx mkBasicTxBody
             & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
             & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
 
-      it "Can run scripts that expect inputs and refInputs to overlap (PV 9)" . whenMajorVersion @9 $ do
+      it "Cannot run scripts that expect inputs and refInputs to overlap (PV 9)" $ whenMajorVersion @9 $ do
         txIn <- produceScript $ scriptHash SPlutusV3
-        submitTx_ @era $ tx txIn
-      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 10)"
-        . whenMajorVersion @10
-        $ do
-          txIn <- produceScript $ scriptHash SPlutusV3
-          submitFailingTx @era
-            (tx txIn)
-            [ injectFailure $
-                BabbageNonDisjointRefInputs
-                  (txIn NE.:| [])
-            ]
-      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)"
-        . whenMajorVersionAtLeast @11
-        $ do
-          txIn <- produceScript $ scriptHash SPlutusV3
-          submitFailingTx @era
-            (tx txIn)
-            [ injectFailure $
-                CollectErrors
-                  [ BadTranslation
-                      ( ReferenceInputsNotDisjointFromInputs
-                          (Set.singleton txIn)
-                      )
-                  ]
-            ]
+        submitFailingTx @era
+          (mkTestTx txIn)
+          [ injectFailure $ BabbageNonDisjointRefInputs [txIn]
+          ]
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 10)" $ whenMajorVersion @10 $ do
+        txIn <- produceScript $ scriptHash SPlutusV3
+        submitFailingTx @era
+          (mkTestTx txIn)
+          [ injectFailure $ BabbageNonDisjointRefInputs [txIn]
+          ]
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)" $ whenMajorVersionAtLeast @11 $ do
+        txIn <- produceScript $ scriptHash SPlutusV3
+        submitFailingTx @era
+          (mkTestTx txIn)
+          [ injectFailure $
+              CollectErrors [BadTranslation . inject $ ReferenceInputsNotDisjointFromInputs @era [txIn]]
+          ]
   where
     checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
     checkMinFee scriptToSpend refScripts = do

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs

@@ -32,7 +32,6 @@ import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
 import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
 import Data.Default (def)
-import Data.Either (isLeft, isRight)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
@@ -121,17 +120,16 @@ datumAndReferenceInputsSpec = do
               , mkTxInPartial producingTx 1
               ]
           & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
-    pv <- getProtVer
-    res <- trySubmitTx consumingTx
-    if pv == ProtVer (natVersion @10) 0
-      then case res of
-        Left (err, _) ->
-          err
-            `shouldBeExpr` ( pure . injectFailure . BabbageNonDisjointRefInputs $
-                              mkTxInPartial producingTx 0 :| []
-                           )
-        x -> x `shouldSatisfyExpr` isLeft
-      else res `shouldSatisfyExpr` isRight
+    let badTxIns = mkTxInPartial producingTx 0 :| []
+
+    whenMajorVersionAtMost @10 $
+      submitFailingTx
+        consumingTx
+        (pure . injectFailure $ BabbageNonDisjointRefInputs badTxIns)
+
+    -- consumingTx uses PlutusV1 script, so it should be a success
+    whenMajorVersionAtLeast @11 $
+      submitTx_ consumingTx
   it "fails when using inline datums for PlutusV1" $ do
     let shSpending = hashPlutusScript (redeemerSameAsDatum SPlutusV1)
     refTxOut <- mkRefTxOut shSpending