feat(testing): collect coverage-data when script fails before submission

bogdan-manole · bogdan-manole · commit d992b354a7c0 · 2026-01-19T17:34:08.000+02:00
diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs
@@ -14,6 +14,7 @@ import Cardano.Ledger.Conway.PParams qualified as Ledger
 import Cardano.Ledger.Conway.Rules qualified as Rules
 import Cardano.Ledger.Shelley.API (ApplyTxError (..))
 import Cardano.Ledger.Shelley.TxCert qualified as TxCert
+import Control.Exception (catch, throwIO)
 import Control.Lens (view, (&), (.~), (^.), _3, _4)
 import Control.Monad (replicateM, void, when)
 import Control.Monad.Except (MonadError, runExceptT)
@@ -71,8 +72,13 @@ import Convex.MockChain.Defaults qualified as Defaults
 import Convex.MockChain.Gen qualified as Gen
 import Convex.MockChain.Staking (registerPool)
 import Convex.MockChain.Utils (
+  Options (coverageRef),
+  defaultOptions,
   mockchainFails,
+  mockchainFailsWithOptions,
   mockchainSucceeds,
+  mockchainSucceedsWithOptions,
+  modifyTransactionLimits,
   runMockchainProp,
   runTestableErr,
  )
@@ -82,8 +88,10 @@ import Convex.NodeParams (
  )
 import Convex.Query (balancePaymentCredentials)
 import Convex.TestingInterface (
+  RunOptions (mcOptions),
   TestingInterface (..),
-  propRunActions,
+  defaultRunOptions,
+  propRunActionsWithOptions,
  )
 import Convex.Utils (failOnError, inBabbage)
 import Convex.Utils.String (unsafeAssetName, unsafeTxId)
@@ -99,15 +107,18 @@ import Convex.Wallet.Operator (
   verificationKey,
  )
 import Data.Foldable (traverse_)
+import Data.IORef (IORef, newIORef, readIORef)
 import Data.List qualified as List
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import PlutusLedgerApi.V2 qualified as PV2
-import PlutusTx.Coverage (CoverageReport (CoverageReport))
+import PlutusTx.Coverage (CoverageData, CoverageReport (CoverageReport))
 import Prettyprinter qualified as Pretty
+import Scripts (pingPongCovIdx)
 import Scripts qualified
 import Scripts.PingPong qualified as PingPong
+import System.Exit (ExitCode)
 import Test.QuickCheck.Gen qualified as Gen
 import Test.Tasty (
   TestTree,
@@ -121,7 +132,6 @@ import Test.Tasty.QuickCheck (
   testProperty,
  )
 import Test.Tasty.QuickCheck qualified as QC
-import Text.Show.Pretty (ppShow)
 
 -- | Model state for the PingPong contract testing interface
 data PingPongModel = PingPongModel
@@ -282,10 +292,18 @@ instance TestingInterface PingPongModel where
   monitoring _state _action prop = prop
 
 main :: IO ()
-main = defaultMain tests
+main = do
+  ref <- newIORef mempty
+  defaultMain (tests ref)
+    `catch` ( \(e :: ExitCode) -> do
+                covData <- readIORef ref
+                let report = CoverageReport pingPongCovIdx covData
+                print $ Pretty.pretty report
+                throwIO e
+            )
 
-tests :: TestTree
-tests =
+tests :: IORef CoverageData -> TestTree
+tests ref =
   testGroup
     "unit tests"
     [ testGroup
@@ -323,63 +341,74 @@ tests =
             "ping-pong"
             [ testCase
                 "Ping and Pong should succeed"
-                ( mockchainSucceeds $
+                ( mockchainSucceedsWithOptions opts $
                     failOnError
                       (pingPongMultipleRounds Scripts.Pinged [Scripts.Pong])
                 )
             , testCase
                 "Pong and Ping should succeed"
-                ( mockchainSucceeds $
+                ( mockchainSucceedsWithOptions opts $
                     failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Ping])
                 )
-            , testCase
+            , --
+              -- , testCase
+              --     "Ping and Ping should fail"
+              --     ( mockchainSucceedsWithOptions opts $
+              --         failOnError (pingPongMultipleRounds Scripts.Pinged [Scripts.Ping])
+              --     )
+              testCase
                 "Ping and Ping should fail"
-                ( mockchainFails
+                ( mockchainFailsWithOptions
+                    opts
                     (failOnError (pingPongMultipleRounds Scripts.Pinged [Scripts.Ping]))
                     -- Test tree fails
                     (\_ -> pure ())
                 )
             , testCase
                 "Pong and Pong should fail"
-                ( mockchainFails
+                ( mockchainFailsWithOptions
+                    opts
                     (failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Pong]))
                     -- Test tree fails
                     (\_ -> pure ())
                 )
             , testCase
                 "Stop after Ping should succeed"
-                ( mockchainSucceeds $
+                ( mockchainSucceedsWithOptions opts $
                     failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Ping, Scripts.Stop])
                 )
             , testCase
                 "Stop after Pong should succeed"
-                ( mockchainSucceeds $
+                ( mockchainSucceedsWithOptions opts $
                     failOnError (pingPongMultipleRounds Scripts.Pinged [Scripts.Pong, Scripts.Stop])
                 )
             , testCase
                 "Stop after Stop should fail"
-                ( mockchainFails
+                ( mockchainFailsWithOptions
+                    opts
                     (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Stop]))
                     -- Test tree fails
                     (\_ -> pure ())
                 )
             , testCase
                 "Ping after Stop should fail"
-                ( mockchainFails
+                ( mockchainFailsWithOptions
+                    opts
                     (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Ping]))
                     -- Test tree fails
                     (\_ -> pure ())
                 )
             , testCase
                 "Pong after Stop should fail"
-                ( mockchainFails
+                ( mockchainFailsWithOptions
+                    opts
                     (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Pong]))
                     -- Test tree fails
                     (\_ -> pure ())
                 )
             , testProperty
                 "Property-based test with TestingInterface"
-                (propRunActions @PingPongModel)
+                (propRunActionsWithOptions @PingPongModel runOpts)
             ]
         ]
     , testGroup
@@ -401,6 +430,9 @@ tests =
         , testCase "script withdrawl with custom redeemer" (mockchainSucceeds $ failOnError addScriptWithdrawalWithCustomRedeemerTest)
         ]
     ]
+ where
+  opts = modifyTransactionLimits (defaultOptions{coverageRef = Just ref}) 17000
+  runOpts = defaultRunOptions{mcOptions = opts}
 
 spendPublicKeyOutput :: Assertion
 spendPublicKeyOutput = mockchainSucceeds $ failOnError (Wallet.w2 `paymentTo` Wallet.w1)
diff --git a/src/mockchain/lib/Convex/MockChain.hs b/src/mockchain/lib/Convex/MockChain.hs
@@ -424,7 +424,6 @@ constructValidated globals (UtxoEnv _ pp _) st tx =
             scriptResults = map (evaluatePlutusWithContext Verbose) sLst
             -- Extract logs and check if validation passed
             allLogs = concatMap fst scriptResults
-            _ = coverageDataFromLogMsg
             validationPassed = all (isRight . snd) scriptResults
 
             -- Format logs for display
diff --git a/src/mockchain/lib/Convex/MockChain/Defaults.hs b/src/mockchain/lib/Convex/MockChain/Defaults.hs
@@ -115,7 +115,7 @@ protocolParameters =
           L.emptyPParamsIdentity @ConwayEra
             & L.hkdMaxBHSizeL .~ 1_100
             & L.hkdMaxBBSizeL .~ 90_112
-            & L.hkdMaxTxSizeL .~ 17_384
+            & L.hkdMaxTxSizeL .~ 16_384
             & L.hkdMinFeeAL .~ 44
             & L.hkdMinFeeBL .~ 155_381
             & L.hkdKeyDepositL .~ 2_000_000
diff --git a/src/mockchain/lib/Convex/MockChain/Utils.hs b/src/mockchain/lib/Convex/MockChain/Utils.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Utility functions for using the mockchain types in @hunit@ or @QuickCheck@ tests
 module Convex.MockChain.Utils (
@@ -22,12 +23,13 @@ module Convex.MockChain.Utils (
   -- * Options for running mockchain testCase
   Options (..),
   defaultOptions,
+  modifyTransactionLimits,
 ) where
 
 import Cardano.Api (ConwayEra)
 import Cardano.Api qualified as C
 import Control.Exception (SomeException, try)
-import Control.Lens ((^.))
+import Control.Lens ((&), (.~), (^.))
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Class (liftIO)
 import Convex.Class (coverageData)
@@ -39,19 +41,25 @@ import Convex.MockChain (
   runMockchain,
   runMockchain0IOWith,
  )
+
+import Cardano.Ledger.Core qualified as L
 import Convex.MockChain.Defaults qualified as Defaults
-import Convex.NodeParams (NodeParams)
+import Convex.NodeParams (NodeParams (..))
 import Convex.Wallet.MockWallet qualified as Wallet
 import Data.Functor.Identity (Identity)
 import Data.IORef (IORef, modifyIORef)
-import PlutusTx.Coverage (CoverageData)
+import Data.Maybe (fromMaybe)
+import Data.Word (Word32)
+import PlutusTx.Coverage (CoverageData, coverageDataFromLogMsg)
 import Test.HUnit (Assertion)
 import Test.QuickCheck (
   Property,
   Testable (..),
   counterexample,
  )
 import Test.QuickCheck.Monadic (PropertyM (..), monadic, monadicIO)
+import Text.Read (readMaybe)
+import Text.Show.Pretty (ppShow)
 
 data Options era = Options
   { params :: NodeParams era
@@ -65,6 +73,14 @@ defaultOptions =
     , coverageRef = Nothing
     }
 
+-- | Modify the maximum transaction size in the protocol parameters of the given options
+modifyTransactionLimits :: Options ConwayEra -> Word32 -> Options ConwayEra
+modifyTransactionLimits opts@Options{params = Defaults.pParams -> pp} newVal =
+  -- TODO: use lenses to make this cleaner
+  opts
+    { params = (params opts){npProtocolParameters = C.LedgerProtocolParameters $ pp & L.ppMaxTxSizeL .~ newVal}
+    }
+
 -- | Run the 'Mockchain' action and fail if there is an error
 mockchainSucceeds :: MockchainIO C.ConwayEra a -> Assertion
 mockchainSucceeds = mockchainSucceedsWith Defaults.nodeParams
@@ -78,13 +94,11 @@ mockchainSucceedsWithOptions :: (C.IsShelleyBasedEra era) => Options era -> Mock
 mockchainSucceedsWithOptions Options{params, coverageRef} action =
   try @SomeException (runMockchain0IOWith Wallet.initialUTxOs params action) >>= \case
     Right (_, st) -> do
-      case coverageRef of
-        Nothing -> pure ()
-        Just ref -> do
-          let covData = st ^. coverageData
-          modifyIORef ref (<> covData)
+      appendCovData coverageRef $ st ^. coverageData
       pure ()
-    Left err -> fail (show err)
+    Left err -> do
+      appendCovData coverageRef $ tryExtractCovverageData err
+      fail (show err)
 
 {- | Run the 'Mockchain' action, fail if it succeeds, and handle the error
   appropriately.
@@ -106,13 +120,13 @@ mockchainFailsWithOptions :: (C.IsShelleyBasedEra era) => Options era -> Mockcha
 mockchainFailsWithOptions Options{params, coverageRef} action handleError =
   try @SomeException (runMockchain0IOWith Wallet.initialUTxOs params action) >>= \case
     Right (_, st) -> do
-      case coverageRef of
-        Nothing -> pure ()
-        Just ref -> do
-          let covData = st ^. coverageData
-          modifyIORef ref (<> covData)
+      let covData = st ^. coverageData
+      appendCovData coverageRef covData
       fail "mockchainFailsWithOptions: Did not fail"
-    Left err -> handleError err
+    Left err -> do
+      let covData = tryExtractCovverageData err
+      appendCovData coverageRef covData
+      handleError err
 
 {- | Run the 'Mockchain' action as a QuickCheck property, considering all 'MockchainError'
 as test failures.
@@ -145,21 +159,16 @@ runMockchainPropWithOptions
   -- ^ The mockchain action to run
   -> Property
 runMockchainPropWithOptions Options{params, coverageRef} utxos =
-  monadic runFinalPredicate
- where
-  runFinalPredicate
-    :: MockchainT era Identity Property
-    -> Property
-  runFinalPredicate m =
-    let (prop', state) = runMockchain m params iState
-     in case coverageRef of
-          Nothing -> prop'
-          Just ref -> monadicIO $ do
-            liftIO $ do
-              let covData = state ^. coverageData
-              modifyIORef ref (<> covData)
-            pure prop'
-  iState = initialStateFor params utxos
+  let iState = initialStateFor params utxos
+   in monadic $ \m ->
+        let (prop', state) = runMockchain m params iState
+         in case coverageRef of
+              Nothing -> prop'
+              Just ref -> monadicIO $ do
+                liftIO $ do
+                  let covData = state ^. coverageData
+                  modifyIORef ref (<> covData)
+                pure prop'
 
 {- | Run the 'Mockchain' action as a QuickCheck property, using the default node params
     and initial distribution, and considering all 'MockchainError's as test failures.
@@ -180,3 +189,20 @@ instance (Show e, Testable a) => Testable (TestableErr e a) where
 -}
 runTestableErr :: forall e m a. (Functor m) => ExceptT e m a -> m (TestableErr e a)
 runTestableErr = fmap TestableErr . runExceptT
+
+appendCovData :: Maybe (IORef CoverageData) -> CoverageData -> IO ()
+appendCovData Nothing _ = pure ()
+appendCovData (Just ref) cd = modifyIORef ref (<> cd)
+
+-- TODO: ugly hack, we have to somehow extract the coverage data from the Exception
+-- the problem is that BalanceError is exposed on the upper level, so we cannot pattern match on it directly
+tryExtractCovverageData :: SomeException -> CoverageData
+tryExtractCovverageData e = mconcat $ map coverageDataFromLogMsg xs
+ where
+  xs = fromErrToStringList e
+  dropO = dropWhile (/= '[')
+  dropC = dropWhile (/= ']')
+  tail' [] = []
+  tail' (_ : xs') = xs'
+  parse = reverse . dropC . tail' . dropC . reverse . dropO . tail' . dropO
+  fromErrToStringList err = fromMaybe [] (readMaybe @[String] $ parse $ show err)
diff --git a/src/testing-interface/lib/Convex/TestingInterface.hs b/src/testing-interface/lib/Convex/TestingInterface.hs
