From 0faa29ad82e2795c9d01df61f54436fa2d39cc03 Mon Sep 17 00:00:00 2001
From: Johannes Lund <anviking@me.com>
Date: Sat, 1 Jun 2024 01:04:44 +0200
Subject: [PATCH] Label Plutus Context errors exhaustively in balanceTx
 property

This prevents flakiness when the catch-all `_` triggers failures.
---
 .../Internal/Cardano/Write/Tx/BalanceSpec.hs  | 56 +++++++++++++------
 1 file changed, 38 insertions(+), 18 deletions(-)

diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs
index 903052a21f8..2b986225aae 100644
--- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs
+++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs
@@ -1312,24 +1312,8 @@ prop_balanceTxValid
                 (ErrBalanceTxAssignRedeemers
                 (ErrAssignRedeemersTranslationError x)) ->
                     case recentEra @era of
-                        RecentEraBabbage -> case x of
-                            ByronTxOutInContext _ ->
-                                label "failed with ByronTxOutInContext"
-                                    $ property True
-                            ReferenceScriptsNotSupported _ ->
-                                label "ReferenceScriptsNotSupported"
-                                    $ property True
-                            _ -> property False
-                        RecentEraConway -> case x of
-                            BabbageContextError y -> case y of
-                                ByronTxOutInContext _ ->
-                                    label "failed with ByronTxOutInContext"
-                                        $ property True
-                                ReferenceScriptsNotSupported _ ->
-                                    label "ReferenceScriptsNotSupported"
-                                        $ property True
-                                _ -> property False
-                            _ -> property False
+                        RecentEraBabbage -> prop_babbageContextError x
+                        RecentEraConway -> prop_conwayContextError x
             Left ErrBalanceTxUnableToCreateChange {} ->
                 label "unable to create change" $ property True
             Left ErrBalanceTxInputResolutionConflicts{} ->
@@ -1341,6 +1325,42 @@ prop_balanceTxValid
         balanceTxArgs
     Wallet _ walletUTxO _ = wallet
 
+    prop_babbageContextError :: BabbageContextError era -> Property
+    prop_babbageContextError = \case
+        AlonzoContextError (TranslationLogicMissingInput _) ->
+            succeedWithLabel "TranslationLogicMissingInput"
+        AlonzoContextError (TimeTranslationPastHorizon _) ->
+            succeedWithLabel "TimeTranslationPastHorizon"
+        ByronTxOutInContext _ ->
+            succeedWithLabel "ByronTxOutInContext"
+        RedeemerPointerPointsToNothing _ ->
+            succeedWithLabel "RedeemerPointerPointsToNothing"
+        InlineDatumsNotSupported _ ->
+            succeedWithLabel "InlineDatumsNotSupported"
+        ReferenceScriptsNotSupported _ ->
+            succeedWithLabel "ReferenceScriptsNotSupported"
+        ReferenceInputsNotSupported _ ->
+            succeedWithLabel "ReferenceInputsNotSupported"
+
+    prop_conwayContextError :: ConwayContextError era -> Property
+    prop_conwayContextError = \case
+      BabbageContextError e -> prop_babbageContextError e
+      CertificateNotSupported _ ->
+        succeedWithLabel "CertificateNotSupported"
+      PlutusPurposeNotSupported _ ->
+        succeedWithLabel "PlutusPurposeNotSupported"
+      -- Will be needed in later ledger versions:
+      -- CurrentTreasuryFieldNotSupported _ ->
+      --   succeedWithLabel "CurrentTreasuryFieldNotSupported"
+      -- VotingProceduresFieldNotSupported _ ->
+      --   succeedWithLabel "VotingProceduresFieldNotSupported"
+      -- ProposalProceduresFieldNotSupported _ ->
+      --   succeedWithLabel "ProposalProceduresFieldNotSupported"
+      -- TreasuryDonationFieldNotSupported _ ->
+      --   succeedWithLabel "TreasuryDonationFieldNotSupported"
+
+    succeedWithLabel l = label l $ property True
+
     prop_expectFeeExcessSmallerThan
         :: Coin
         -> Tx era