mockcat 1.0.1.0 → 1.1.0.0

raw patch · 29 files changed

+1092/−389 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README-ja.md +5/−0
• README.md +6/−0
• mockcat.cabal +6/−2
• src/Test/MockCat/Internal/GHC/StableName.hs +27/−0
• src/Test/MockCat/Internal/Message.hs +29/−21
• src/Test/MockCat/Internal/MockRegistry.hs +4/−0
• src/Test/MockCat/Internal/Registry/Core.hs +64/−13
• src/Test/MockCat/MockT.hs +1/−0
• src/Test/MockCat/Verify.hs +148/−61
• src/Test/MockCat/WithMock.hs +40/−16
• test/Property/AdditionalProps.hs +6/−0
• test/Property/Generators.hs +2/−0
• test/Property/OrderProps.hs +5/−0
• test/Property/ReinforcementProps.hs +5/−0
• test/Property/ScriptProps.hs +2/−0
• test/ReadmeVerifySpec.hs +1/−1
• test/Spec.hs +6/−2
• test/Test/MockCat/ErrorDiffSpec.hs +0/−252
• test/Test/MockCat/HPCFallbackSpec.hs +59/−0
• test/Test/MockCat/HPCNestSpec.hs +118/−0
• test/Test/MockCat/Internal/MockRegistrySpec.hs +4/−4
• test/Test/MockCat/PartialMockSpec.hs +5/−4
• test/Test/MockCat/ShouldBeCalledErrorDiffSpec.hs +253/−0
• test/Test/MockCat/ShouldBeCalledMockMSpec.hs +1/−0
• test/Test/MockCat/ShouldBeCalledSpec.hs +1/−0
• test/Test/MockCat/TypeClassSpec.hs +4/−10
• test/Test/MockCat/WithMockErrorDiffSpec.hs +278/−0
• test/Test/MockCat/WithMockSpec.hs +4/−3

@@ -6,6 +6,14 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.1.0.0] - 2025-12-29+### Added+- **HPC Coverage Support**: Verification logic now robustly handles unstable `StableNames` caused by HPC instrumentation (`stack test --coverage`).+- **Optimization Hardening**: Protected verification logic against GHC optimizations (CSE/LICM) to ensure stable tests in optimized builds.++### Changed+- **Automatic History Reset**: `runMockT` and `withMock` now strictly scope mock history. History is automatically reset to prevent interference between sequential tests or Property-Based Testing iterations.+ ## [1.0.0.0] - 2025-12-24 ### Changed - **DSL Reboot**: Replaced `|>` with `~>` as the primary parameter chain operator (representing the "mock arrow").

@@ -367,6 +367,11 @@ </details>  <details>+<summary><strong>Q. コードカバレッジ (HPC) を有効にしてテストを実行できますか？</strong></summary>+A. はい (v1.1.0.0 以降)。Mockcat は HPC によって生じる 不安定さを内部で吸収するため、`stack test --coverage` を問題なく実行できます。+</details>++<details> <summary><strong>Q. `makeMock` が生成するコードは何ですか？</strong></summary> A. 指定された型クラスの `MockT m` インスタンスと、各メソッドに対応する `_メソッド名` というスタブ生成関数定義です。 </details>

@@ -369,6 +369,11 @@ </details>  <details>+<summary><strong>Q. Can I run tests with code coverage (HPC)?</strong></summary>+A. Yes (since v1.1.0.0). Mockcat natively handles the instability of `StableName` introduced by HPC instrumentation, so you can run `stack test --coverage` without issues.+</details>++<details> <summary><strong>Q. What code does `makeMock` generate?</strong></summary> A. It generates a `MockT m` instance for the specified typeclass, and stub generation function definitions named `_methodName` corresponding to each method. </details>@@ -411,5 +416,6 @@ | 9.6.3 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows | | 9.8.2 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows | | 9.10.1 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows |+| 9.12.2 | 3.12.1.0 | Ubuntu, macOS, Windows |  _Happy Mocking!_ 🐱

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mockcat-version:        1.0.1.0+version:        1.1.0.0 synopsis:       Declarative mocking with a single arrow `~>`. description:    Mockcat is a minimal, architecture-agnostic mocking library for Haskell.                 It enables declarative verification and intent-driven matching, allowing you to define function behavior and expectations without specific architectural dependencies.@@ -41,6 +41,7 @@       Test.MockCat.AssociationList       Test.MockCat.Cons       Test.MockCat.Internal.Builder+      Test.MockCat.Internal.GHC.StableName       Test.MockCat.Internal.Message       Test.MockCat.Internal.MockRegistry       Test.MockCat.Internal.Registry.Core@@ -93,8 +94,9 @@       Test.MockCat.AssociationListSpec       Test.MockCat.ConcurrencySpec       Test.MockCat.ConsSpec-      Test.MockCat.ErrorDiffSpec       Test.MockCat.ExampleSpec+      Test.MockCat.HPCFallbackSpec+      Test.MockCat.HPCNestSpec       Test.MockCat.Impl       Test.MockCat.Internal.MockRegistrySpec       Test.MockCat.MockSpec@@ -104,6 +106,7 @@       Test.MockCat.PartialMockSpec       Test.MockCat.PartialMockTHSpec       Test.MockCat.SharedSpecDefs+      Test.MockCat.ShouldBeCalledErrorDiffSpec       Test.MockCat.ShouldBeCalledMockMSpec       Test.MockCat.ShouldBeCalledSpec       Test.MockCat.StubSpec@@ -116,6 +119,7 @@       Test.MockCat.TypeClassSpec       Test.MockCat.TypeClassTHSpec       Test.MockCat.UnsafeCheck+      Test.MockCat.WithMockErrorDiffSpec       Test.MockCat.WithMockSpec       Paths_mockcat   hs-source-dirs:

@@ -0,0 +1,27 @@+{-# LANGUAGE MagicHash #-}++-- | This module isolates StableName operations and disables HPC to workaround+--   instability issues with GHC 9.8.4 and coverage enabled.+{-# OPTIONS_GHC -fno-hpc #-}++module Test.MockCat.Internal.GHC.StableName+  ( makeStableName+  , hashStableName+  , StableName+  , eqStableName+  ) where++import System.Mem.StableName (StableName)+import qualified System.Mem.StableName as S++{-# NOINLINE makeStableName #-}+makeStableName :: a -> IO (StableName a)+makeStableName = S.makeStableName++{-# NOINLINE hashStableName #-}+hashStableName :: StableName a -> Int+hashStableName = S.hashStableName++{-# NOINLINE eqStableName #-}+eqStableName :: StableName a -> StableName b -> Bool+eqStableName = S.eqStableName

@@ -84,28 +84,36 @@ verifyFailedMessage :: Show a => Maybe MockName -> InvocationList a -> a -> VerifyFailed verifyFailedMessage name invocationList expected =   let expectedStr = formatStr (show expected)-      actualStr = formatInvocationList invocationList-      diffLine = "            " <> diffPointer expectedStr actualStr       mainMessage = "function" <> mockNameLabel name <> " was not called with the expected arguments."-   in VerifyFailed $ case structuralDiff expectedStr actualStr of+   in VerifyFailed $ case invocationList of         [] ->-           intercalate "\n"-             [ mainMessage,-               "  expected: " <> expectedStr,-               "   but got: " <> actualStr,-               diffLine-             ]-        ds ->-           let diffMessages = formatDifferences ds-            in intercalate "\n"-                 [ mainMessage,-                   diffMessages,-                   "",-                   "Full context:",-                   "  expected: " <> expectedStr,-                   "   but got: " <> actualStr,-                   diffLine-                 ]+          intercalate "\n"+            [ mainMessage,+              "  expected: " <> expectedStr,+              "  but the function was never called"+            ]+        _ ->+          let actualStr = formatInvocationList invocationList+              diffLine = "            " <> diffPointer expectedStr actualStr+           in case structuralDiff expectedStr actualStr of+                [] ->+                  intercalate "\n"+                    [ mainMessage,+                      "  expected: " <> expectedStr,+                      "   but got: " <> actualStr,+                      diffLine+                    ]+                ds ->+                  let diffMessages = formatDifferences ds+                   in intercalate "\n"+                        [ mainMessage,+                          diffMessages,+                          "",+                          "Full context:",+                          "  expected: " <> expectedStr,+                          "   but got: " <> actualStr,+                          diffLine+                        ]  data Difference = Difference   { diffPath :: String,@@ -195,7 +203,7 @@  formatInvocationList :: Show a => InvocationList a -> String formatInvocationList invocationList = case invocationList of-  [] -> "Function was never called"+  [] -> "(never called)"   [x] -> formatStr (show x)   _ -> "[" <> intercalate ", " (map (formatStr . show) invocationList) <> "]" 

@@ -15,6 +15,8 @@   , withAllUnitGuards   , markUnitUsed   , isGuardActive+  , getLastRecorder+  , resetMockHistory   ) where  import Test.MockCat.Internal.Registry.Core@@ -27,6 +29,8 @@   , withAllUnitGuards   , markUnitUsed   , isGuardActive+  , getLastRecorder+  , resetMockHistory   ) import GHC.IO (evaluate) import Control.Concurrent.STM (TVar, atomically, writeTVar)

@@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} + module Test.MockCat.Internal.Registry.Core   ( attachVerifierToFn   , lookupVerifierForFn@@ -18,6 +19,8 @@   , withAllUnitGuards   , markUnitUsed   , isGuardActive+  , getLastRecorder+  , resetMockHistory   ) where  import Control.Concurrent.STM@@ -31,13 +34,15 @@   ) import Control.Exception (bracket_) import Control.Monad (forM_)-import Data.Dynamic (Dynamic, toDyn)+import Control.Concurrent (ThreadId, myThreadId)+import Data.Dynamic (Dynamic, toDyn, fromDynamic) import Data.Typeable (Typeable) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map import System.IO.Unsafe (unsafePerformIO) import Test.MockCat.Internal.Types (MockName, InvocationRecorder(..))-import System.Mem.StableName (StableName, eqStableName, hashStableName, makeStableName)+import Test.MockCat.Internal.GHC.StableName (StableName, eqStableName, hashStableName, makeStableName)  data SomeStableName = forall a. SomeStableName (StableName a) @@ -73,7 +78,40 @@ registry :: TVar Registry registry = (unsafePerformIO $ newTVarIO IntMap.empty) :: TVar Registry +-- | Thread-local storage for mock history in the current thread.+--   Used for:+--   1. 'expects' to retrieve the recorder without StableName lookup.+--   2. 'lookupVerifierForFn' fallback when StableName lookup fails (HPC workaround).+threadMockHistory :: TVar (Map.Map ThreadId [(Maybe MockName, Dynamic)])+threadMockHistory = unsafePerformIO $ newTVarIO Map.empty+{-# NOINLINE threadMockHistory #-} +-- | Add a recorder to the current thread's history.+addToHistory :: Maybe MockName -> Dynamic -> IO ()+addToHistory name dyn = do+  tid <- myThreadId+  atomically $ modifyTVar' threadMockHistory $ \m ->+    Map.insertWith (++) tid [(name, dyn)] m++-- | Get the last registered recorder (peek only, does not remove).+getLastRecorder :: Typeable a => IO (Maybe MockName, Maybe a)+getLastRecorder = do+  tid <- myThreadId+  atomically $ do+    store <- readTVar threadMockHistory+    case Map.lookup tid store of+      Nothing -> pure (Nothing, Nothing)+      Just [] -> pure (Nothing, Nothing)+      Just ((name, dyn) : _) -> pure (name, fromDynamic dyn)++-- | Reset the mock history for the current thread.+resetMockHistory :: IO ()+resetMockHistory = do+  tid <- myThreadId+  atomically $ modifyTVar' threadMockHistory (Map.delete tid)+++ attachVerifierToFn ::   forall fn params.   (Typeable (InvocationRecorder params)) =>@@ -85,19 +123,30 @@ lookupVerifierForFn ::   forall fn.   fn ->-  IO (Maybe (Maybe MockName, Dynamic))+  IO [(Maybe MockName, Dynamic)] lookupVerifierForFn fn = do   stable <- makeStableName fn-  let-    key = hashStableName stable-    stableFn = toFnStable stable-  store <- readTVarIO registry-  -- ONLY use direct StableName matching in the registry.-  -- Name-based resolution via lookupNameByHash here is unsafe because it can-  -- return a verifier from a previous session if the hash collided or was reused.-  case IntMap.lookup key store >>= findMatch stableFn of-    Just res -> pure (Just res)-    Nothing -> pure Nothing+  let key = hashStableName stable+  let stableFn = toFnStable stable+  +  -- 1. Try StableName lookup+  mbMatch <- atomically $ do+    m <- readTVar registry+    case IntMap.lookup key m of+      Nothing -> pure Nothing+      Just entries -> pure $ findMatch stableFn entries+      +  case mbMatch of+    Just match -> pure [match]+    Nothing -> do+      -- 2. Fallback: return thread's mock history+      --    This handles case where StableName is unstable (e.g. HPC enabled)+      tid <- myThreadId+      atomically $ do+        hist <- readTVar threadMockHistory+        case Map.lookup tid hist of+           Nothing -> pure []+           Just list -> pure list  attachDynamicVerifierToFn :: forall fn. fn -> (Maybe MockName, Dynamic) -> IO () attachDynamicVerifierToFn fn (name, payload) = do@@ -111,6 +160,8 @@   let entry = toEntry name stableFn payload   atomically $     modifyTVar' registry $ \m -> IntMap.alter (updateEntries entry stableFn) key m+  -- Save for expects and fallback lookup+  addToHistory name payload  toEntry :: Maybe MockName -> FnStableName -> Dynamic -> Entry toEntry (Just n) stableFn p = NamedEntry stableFn n p

@@ -130,6 +130,7 @@ -} runMockT :: MonadIO m => MockT m a -> m a runMockT (MockT r) = do+  liftIO Registry.resetMockHistory   defsVar <- liftIO $ newTVarIO []   expectsVar <- liftIO $ newTVarIO []   fwdRef <- liftIO $ newIORef Map.empty

@@ -20,7 +20,7 @@  import Control.Concurrent.STM (TVar, readTVarIO) import Test.MockCat.Internal.Types-import Control.Monad (guard, when, unless)+import Control.Monad (guard, when) import Data.List (elemIndex, intercalate) import Data.Maybe import Test.MockCat.Param@@ -32,7 +32,7 @@ import Data.Typeable (Typeable, eqT) import Test.MockCat.Internal.MockRegistry (lookupVerifierForFn, withAllUnitGuards) import Data.Type.Equality ((:~:) (Refl))-import Data.Dynamic (fromDynamic)+import Data.Dynamic (fromDynamic, Dynamic) import GHC.TypeLits (TypeError, ErrorMessage(..), Symbol)  -- | Class for verifying mock function.@@ -45,12 +45,16 @@   VerifyMatchType (ResolvableParamsOf m) ->   IO () verify m matchType = do-  ResolvedMock mockName recorder <- requireResolved m+  candidates <- requireResolved m+  checkCandidates candidates $ \resolvedMock ->+    doVerifyResolved resolvedMock matchType++doVerifyResolved :: (Eq params, Show params) => ResolvedMock params -> VerifyMatchType params -> IO (Maybe String)+doVerifyResolved (ResolvedMock mockName recorder) matchType = do   invocationList <- readInvocationList (invocationRef recorder)   case doVerify mockName invocationList matchType of-    Nothing -> pure ()-    Just (VerifyFailed msg) ->-      errorWithoutStackTrace msg `seq` pure ()+    Nothing -> pure Nothing+    Just (VerifyFailed msg) -> pure (Just msg)  doVerify :: (Eq a, Show a) => Maybe MockName -> InvocationList a -> VerifyMatchType a -> Maybe VerifyFailed doVerify name list (MatchAny a) = do@@ -77,8 +81,38 @@         [ "Function" <> mockNameLabel mockName <> " was never called"         ] +-- | Verify that mock was called with specific arguments using resolved mock directly.+--   This avoids StableName lookup and is HPC-safe.+verifyResolvedMatch :: (Eq params, Show params) => ResolvedMock params -> VerifyMatchType params -> IO ()+verifyResolvedMatch (ResolvedMock mockName recorder) matchType = do+  invocationList <- readInvocationList (invocationRef recorder)+  case doVerify mockName invocationList matchType of+    Nothing -> pure ()+    Just (VerifyFailed msg) ->+      errorWithoutStackTrace msg `seq` pure () +-- | Verify call count with specific arguments using resolved mock directly.+--   This avoids StableName lookup and is HPC-safe.+verifyResolvedCount :: Eq params => ResolvedMock params -> params -> CountVerifyMethod -> IO ()+verifyResolvedCount (ResolvedMock mockName recorder) v method = do+  invocationList <- readInvocationList (invocationRef recorder)+  let callCount = length (filter (v ==) invocationList)+  if compareCount method callCount+    then pure ()+    else+      errorWithoutStackTrace $+        countWithArgsMismatchMessage mockName method callCount +-- | Verify call order using resolved mock directly.+--   This avoids StableName lookup and is HPC-safe.+verifyResolvedOrder :: (Eq params, Show params) => VerifyOrderMethod -> ResolvedMock params -> [params] -> IO ()+verifyResolvedOrder method (ResolvedMock mockName recorder) matchers = do+  invocationList <- readInvocationList (invocationRef recorder)+  case doVerifyOrder method mockName invocationList matchers of+    Nothing -> pure ()+    Just (VerifyFailed msg) ->+      errorWithoutStackTrace msg `seq` pure ()+ compareCount :: CountVerifyMethod -> Int -> Bool compareCount (Equal e) a = a == e compareCount (LessThanEqual e) a = a <= e@@ -95,14 +129,14 @@   CountVerifyMethod ->   IO () verifyCount m v method = do-  ResolvedMock mockName recorder <- requireResolved m-  invocationList <- readInvocationList (invocationRef recorder)-  let callCount = length (filter (v ==) invocationList)-  if compareCount method callCount-    then pure ()-    else-      errorWithoutStackTrace $-        countWithArgsMismatchMessage mockName method callCount+  candidates <- requireResolved m+  checkCandidates candidates $ \(ResolvedMock mockName recorder) -> do+    invocationList <- readInvocationList (invocationRef recorder)+    let callCount = length (filter (v ==) invocationList)+    if compareCount method callCount+      then pure Nothing+      else+        pure $ Just $ countWithArgsMismatchMessage mockName method callCount  -- | Generate error message for count mismatch with arguments countWithArgsMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String@@ -125,12 +159,12 @@   [ResolvableParamsOf m] ->   IO () verifyOrder method m matchers = do-  ResolvedMock mockName recorder <- requireResolved m-  invocationList <- readInvocationList (invocationRef recorder)-  case doVerifyOrder method mockName invocationList matchers of-    Nothing -> pure ()-    Just (VerifyFailed msg) ->-      errorWithoutStackTrace msg `seq` pure ()+  candidates <- requireResolved m+  checkCandidates candidates $ \(ResolvedMock mockName recorder) -> do+    invocationList <- readInvocationList (invocationRef recorder)+    case doVerifyOrder method mockName invocationList matchers of+      Nothing -> pure Nothing+      Just (VerifyFailed msg) -> pure (Just msg)  doVerifyOrder ::   (Eq a, Show a) =>@@ -271,34 +305,54 @@   , Typeable (InvocationRecorder params)   ) =>   target ->-  IO (Maybe (Maybe MockName, InvocationRecorder params))+  IO [(Maybe MockName, InvocationRecorder params)] resolveForVerification target = do   let fetch = lookupVerifierForFn target   result <-     case eqT :: Maybe (params :~: ()) of       Just Refl -> withAllUnitGuards fetch       Nothing -> fetch-  case result of-    Nothing -> pure Nothing-    Just (name, dynVerifier) ->+  findCompatible result++  where+    findCompatible :: [(Maybe MockName, Dynamic)] -> IO [(Maybe MockName, InvocationRecorder params)]+    findCompatible [] = pure []+    findCompatible ((name, dynVerifier) : rest) =       case fromDynamic @(InvocationRecorder params) dynVerifier of-        Just verifier -> pure $ Just (name, verifier)-        Nothing -> pure Nothing+        Just verifier -> do+          matchRest <- findCompatible rest+          pure $ (name, verifier) : matchRest+        Nothing -> findCompatible rest  +-- | Verify that the mock was called the expected number of times+--   Returns Nothing on success, or Just errorMessage on failure.+tryVerifyCallCount ::+  Maybe MockName ->+  InvocationRecorder params ->+  CountVerifyMethod ->+  IO (Maybe String)+tryVerifyCallCount maybeName recorder method = do+  invocationList <- readInvocationList (invocationRef recorder)+  let callCount = length invocationList+  if compareCount method callCount+    then pure Nothing+    else pure $ Just $ countMismatchMessage maybeName method callCount+ -- | Verify that a function was called the expected number of times+--   Throw error if verification fails. verifyCallCount ::   Maybe MockName ->   InvocationRecorder params ->   CountVerifyMethod ->   IO () verifyCallCount maybeName recorder method = do-  invocationList <- readInvocationList (invocationRef recorder)-  let callCount = length invocationList-  unless (compareCount method callCount) $-    errorWithoutStackTrace $-      countMismatchMessage maybeName method callCount+  result <- tryVerifyCallCount maybeName recorder method+  case result of+    Nothing -> pure ()+    Just msg -> errorWithoutStackTrace msg + -- | Generate error message for count mismatch countMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String countMismatchMessage maybeName method callCount =@@ -331,11 +385,12 @@   , Typeable (InvocationRecorder params)   ) =>   target ->-  IO (ResolvedMock params)+  IO [ResolvedMock params] requireResolved target = do-  resolveForVerification target >>= \case-    Just (name, recorder) -> pure $ ResolvedMock name recorder-    Nothing -> verificationFailure+  candidates <- resolveForVerification target+  case candidates of+    [] -> verificationFailure+    _ -> pure $ map (\(name, recorder) -> ResolvedMock name recorder) candidates  verificationFailureMessage :: String verificationFailureMessage =@@ -437,8 +492,12 @@ --   This accepts both raw values and Param chains. -- --   > f `shouldBeCalled` calledWith "a"-calledWith :: params -> VerificationSpec params-calledWith = SimpleVerification+calledWith ::+  forall params.+  (ToNormalizedArg params) =>+  params ->+  VerificationSpec (NormalizeWithArg params)+calledWith = SimpleVerification . toNormalizedArg  -- | Create a simple verification without arguments. --   It verifies that the function was called at least once, with ANY arguments.@@ -517,14 +576,27 @@ class ShouldBeCalled m spec where   shouldBeCalled :: HasCallStack => m -> spec -> IO () +-- | Helper to verify multiple candidates. Passes if at least one candidate succeeds.+-- If all fail, throws the first error (or combined error).+checkCandidates :: [ResolvedMock params] -> (ResolvedMock params -> IO (Maybe String)) -> IO ()+checkCandidates [] _ = verificationFailure+checkCandidates candidates verifyFn = do+  results <- mapM verifyFn candidates+  let failures = catMaybes results+  -- If number of failures is less than number of candidates, it means at least one succeeded.+  if length failures < length candidates+    then pure ()+    else errorWithoutStackTrace $ intercalate "\n\n" failures+ -- | Instance for times spec alone (without arguments) instance   ( ResolvableMockWithParams m params   , RequireCallable "shouldBeCalled" m   ) => ShouldBeCalled m TimesSpec where   shouldBeCalled m (TimesSpec method) = do-    ResolvedMock mockName verifier <- requireResolved m-    verifyCallCount mockName verifier method+    candidates <- requireResolved m+    checkCandidates candidates $ \(ResolvedMock mockName verifier) ->+      tryVerifyCallCount mockName verifier method  -- | Instance for VerificationSpec (handles all verification types) instance {-# OVERLAPPING #-}@@ -533,45 +605,59 @@   , Show params   , RequireCallable "shouldBeCalled" m   ) => ShouldBeCalled m (VerificationSpec params) where-  shouldBeCalled m spec = case spec of-    CountVerification method args ->-      verifyCount m args method-    CountAnyVerification count ->-      do-        ResolvedMock mockName recorder <- requireResolved m-        verifyCallCount mockName recorder count+  shouldBeCalled m spec = do+    candidates <- requireResolved m+    checkCandidates candidates $ \resolvedMock ->+      verifySpec resolvedMock spec++verifySpec :: (Eq params, Show params) => ResolvedMock params -> VerificationSpec params -> IO (Maybe String)+verifySpec (ResolvedMock mockName recorder) spec = do+  invocationList <- readInvocationList (invocationRef recorder)+  case spec of+    CountVerification method args -> do+      let callCount = length (filter (args ==) invocationList)+      if compareCount method callCount+        then pure Nothing+        else pure $ Just $ countWithArgsMismatchMessage mockName method callCount+    +    CountAnyVerification method ->+      tryVerifyCallCount mockName recorder method+           OrderVerification method argsList ->-      verifyOrder method m argsList+      case doVerifyOrder method mockName invocationList argsList of+        Nothing -> pure Nothing+        Just (VerifyFailed msg) -> pure $ Just msg+             SimpleVerification args ->-      verify m (MatchAny args)-    AnyVerification ->-      do-        ResolvedMock mockName recorder <- requireResolved m-        invocationList <- readInvocationList (invocationRef recorder)-        when (null invocationList) $-          errorWithoutStackTrace $-            intercalate-              "\n"-              [ "Function" <> mockNameLabel mockName <> " was never called"-              ]+      case doVerify mockName invocationList (MatchAny args) of+        Nothing -> pure Nothing+        Just (VerifyFailed msg) -> pure $ Just msg+        +    AnyVerification -> do+      -- Logic for AnyVerification (called at least once)+      if null invocationList+        then pure $ Just $ intercalate "\n" ["Function" <> mockNameLabel mockName <> " was never called"]+        else pure Nothing  -- | Instance for Param chains (e.g., "a" ~> "b") instance {-# OVERLAPPING #-}   ( ResolvableMockWithParams m (Param a :> rest)   , Eq (Param a :> rest)   , Show (Param a :> rest)+  , RequireCallable "shouldBeCalled" m   ) => ShouldBeCalled m (Param a :> rest) where   shouldBeCalled m args =-    verify m (MatchAny args)+    shouldBeCalled m (SimpleVerification args)  -- | Instance for single Param (e.g., param "a") instance {-# OVERLAPPING #-}   ( ResolvableMockWithParams m (Param a)   , Eq (Param a)   , Show (Param a)+  , RequireCallable "shouldBeCalled" m   ) => ShouldBeCalled m (Param a) where   shouldBeCalled m args =-    verify m (MatchAny args)+    shouldBeCalled m (SimpleVerification args)  -- | Instance for raw values (e.g., "a") --   This converts raw values to Param at runtime@@ -581,6 +667,7 @@   , Show (Param a)   , Show a   , Eq a+  , RequireCallable "shouldBeCalled" m   ) => ShouldBeCalled m a where   shouldBeCalled m arg =-    verify m (MatchAny (param arg))+    shouldBeCalled m (SimpleVerification (param arg))

@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}  {- | withMock: Declarative mock expectations DSL@@ -54,12 +55,13 @@   ( ResolvableParamsOf   , ResolvableMock -  , requireResolved-  , verifyCount-  , verifyOrder   , verifyResolvedAny   , verifyCallCount+  , verifyResolvedMatch+  , verifyResolvedCount+  , verifyResolvedOrder   , ResolvedMock(..)+  , VerificationSpec(..)   , TimesSpec(..)   , times   , once@@ -71,7 +73,10 @@ import Test.MockCat.Internal.Types   ( CountVerifyMethod(..)   , VerifyOrderMethod(..)+  , VerifyMatchType(..)+  , InvocationRecorder(..)   )+import qualified Test.MockCat.Internal.MockRegistry as MockRegistry import Test.MockCat.Param (Param(..), param) import Data.Kind (Type) import Data.Proxy (Proxy(..))@@ -123,27 +128,27 @@   sequence_ actions   pure result --- | Verify a single expectation-verifyExpectation ::-  ( ResolvableMock m-  , ResolvableParamsOf m ~ params-  , Show params+-- | Verify a single expectation using already-resolved mock.+--   This avoids StableName lookup and is HPC-safe.+verifyExpectationDirect ::+  ( Show params   , Eq params   ) =>-  m ->+  ResolvedMock params ->   Expectation params ->   IO ()-verifyExpectation mockFn expectation = do-  resolved <- requireResolved mockFn+verifyExpectationDirect resolved expectation = do   case expectation of+    CountExpectation (Equal 1) args ->+      verifyResolvedMatch resolved (MatchAny args)     CountExpectation method args ->-      verifyCount mockFn args method+      verifyResolvedCount resolved args method     CountAnyExpectation count ->       verifyCallCount (resolvedMockName resolved) (resolvedMockRecorder resolved) count     OrderExpectation method argsList ->-      verifyOrder method mockFn argsList-    SimpleExpectation _ ->-      verifyResolvedAny resolved+      verifyResolvedOrder method resolved argsList+    SimpleExpectation args ->+      verifyResolvedMatch resolved (MatchAny args)     AnyExpectation ->       verifyResolvedAny resolved @@ -160,6 +165,10 @@   type ExpParams (Expectations params ()) = params   extractParams _ = Proxy +instance ExtractParams (VerificationSpec params) where+  type ExpParams (VerificationSpec params) = params+  extractParams _ = Proxy+ instance ExtractParams (fn -> Expectations params ()) where   type ExpParams (fn -> Expectations params ()) = params   extractParams _ = Proxy@@ -175,6 +184,15 @@ instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (Expectations params ()) where   buildExpectations _ = runExpectations +instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (VerificationSpec params) where+  buildExpectations _ spec =+    case spec of+      CountVerification method args -> [CountExpectation method args]+      CountAnyVerification method -> [CountAnyExpectation method]+      OrderVerification method argsList -> [OrderExpectation method argsList]+      SimpleVerification args -> [SimpleExpectation args]+      AnyVerification -> [AnyExpectation]+ -- | Instance for function form (fn -> Expectations params ()) --   This allows passing a function that receives the mock function instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (fn -> Expectations params ()) where@@ -200,8 +218,14 @@   -- Try to help type inference by using exp first   let _ = extractParams exp :: Proxy params   mockFn <- mockFnM+  -- Get the recorder from the thread-local store (set by mock/register)+  -- This avoids StableName lookup and is HPC-safe+  (mockName, mRecorder) <- liftIO $ MockRegistry.getLastRecorder @(InvocationRecorder params)+  let resolved = case mRecorder of+        Just recorder -> ResolvedMock mockName recorder+        Nothing -> error "expects: mock recorder not found. Use mock inside withMock/runMockT."   let expectations = buildExpectations mockFn exp-  let actions = map (verifyExpectation mockFn) expectations+  let actions = map (verifyExpectationDirect resolved) expectations   liftIO $ atomically $ modifyTVar' ctxVar (++ actions)   pure mockFn 

@@ -4,6 +4,7 @@ {-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -fno-hpc #-} module Property.AdditionalProps   ( prop_predicate_param_match_counts   , prop_multicase_progression@@ -19,6 +20,7 @@ import Data.Proxy (Proxy(..)) import Test.MockCat import Control.Monad.IO.Class (liftIO)+import Property.Generators (resetMockHistory)  perCall :: Int -> a -> a perCall i x = case i of@@ -32,6 +34,7 @@ -- the total recorded calls equals count of even inputs attempted. prop_predicate_param_match_counts :: Property prop_predicate_param_match_counts = forAll genVals $ \xs -> monadicIO $ do+  run resetMockHistory   -- build predicate mock: (Int -> Bool) returning True for all evens   f <- run $ mock (expect even "even" ~> True)   results <- run $ mapM (\x -> try (evaluate (f x)) :: IO (Either SomeException Bool)) xs@@ -53,6 +56,7 @@ -- saturate at the last value. prop_multicase_progression :: Property prop_multicase_progression = forAll genSeq $ \(arg, rs, extra) -> monadicIO $ do+  run resetMockHistory   f <- run $ mock $ cases [ param arg ~> r | r <- rs ]   let totalCalls = length rs + extra   -- NOTE [GHC9.4 duplicate-call counting]@@ -86,6 +90,7 @@ -- The first run enforces a single invocation; the second expects zero for a fresh mock. prop_runMockT_isolation :: Property prop_runMockT_isolation = monadicIO $ do+  run resetMockHistory   -- Run 1: expect one call   r1 <- run $ try $ runMockT $ do     f <- liftIO $ mock (param (1 :: Int) ~> True)@@ -112,6 +117,7 @@ -- list of first occurrences; reversing that list (when length >=2) fails. prop_partial_order_duplicates :: Property prop_partial_order_duplicates = forAll genDupScript $ \xs -> length xs >= 2 ==> monadicIO $ do+  run resetMockHistory   -- build mock over sequence   f <- run $ mock $ cases [ param x ~> True | x <- xs ]   run $ forM_ xs $ \x -> f x `seq` pure ()

@@ -4,10 +4,12 @@   , scriptGen   , buildUnaryMock   , runScript+  , resetMockHistory   ) where  import Test.QuickCheck import Test.MockCat+import Test.MockCat.Internal.MockRegistry (resetMockHistory)  -- | A simple script: sequence of argument values for a unary function. newtype Script a = Script { unScript :: [a] } deriving (Show, Eq)

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-hpc #-} module Property.OrderProps   ( prop_inorder_succeeds   , prop_adjacent_swap_fails@@ -17,6 +18,7 @@ -- | Property: executing a non-empty script yields exact order success. prop_inorder_succeeds :: Property prop_inorder_succeeds = forAll scriptGen $ \scr@(Script xs) -> not (null xs) ==> monadicIO $ do+  run resetMockHistory   f <- run $ buildUnaryMock scr   run $ runScript f scr   run $ f `shouldBeCalled` inOrderWith (param <$> xs)@@ -25,6 +27,7 @@ -- | Property: a single adjacent swap causes order verification failure. prop_adjacent_swap_fails :: Property prop_adjacent_swap_fails = forAll scriptGen $ \(Script xs) -> length xs >= 2 ==> monadicIO $ do+  run resetMockHistory   let distinct = nub xs   if length distinct /= length xs     then assert True  -- discard scripts with duplicates; they can mask order errors@@ -49,6 +52,7 @@ -- | Property: any non-empty subsequence (order-preserving) passes partial order check. prop_partial_order_subset_succeeds :: Property prop_partial_order_subset_succeeds = forAll scriptGen $ \scr@(Script xs) -> not (null xs) ==> monadicIO $ do+  run resetMockHistory   subset <- run $ generate $ chooseSubsequence xs   f <- run $ buildUnaryMock scr   run $ runScript f scr@@ -58,6 +62,7 @@ -- | Property: selecting two distinct values and reversing them causes partial order failure. prop_partial_order_reversed_pair_fails :: Property prop_partial_order_reversed_pair_fails = forAll scriptGen $ \scr@(Script xs) -> length xs >= 2 ==> monadicIO $ do+  run resetMockHistory   if length (nub xs) /= length xs     then assert True -- discard non-unique scripts to avoid accidental subsequences     else do

@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}+{-# OPTIONS_GHC -fno-hpc #-} module Property.ReinforcementProps   where @@ -15,6 +16,7 @@ import Control.Concurrent.Async (forConcurrently_) import UnliftIO (withRunInIO) import Test.MockCat hiding (any)+import Property.Generators (resetMockHistory)  -------------------------------------------------------------------------------- -- 1. Predicate negative: failing inputs raise & are not counted@@ -22,6 +24,7 @@  prop_predicate_negative_not_counted :: Property prop_predicate_negative_not_counted = forAll genVals $ \xs -> monadicIO $ do+  run resetMockHistory   f <- run $ mock (expect even "even" ~> True)   outcomes <- run $ mapM (\x -> (try (evaluate (f x)) :: IO (Either SomeException Bool))) xs   let evens = length (filter even xs)@@ -53,6 +56,7 @@  prop_lazy_partial_force_concurrency :: Property prop_lazy_partial_force_concurrency = forAll genPlan $ \(arg, mask) -> monadicIO $ do+  run resetMockHistory   let forcedCount = length (filter id mask)   run $ runMockT $ do     -- expectation: arg -> arg; count only forced executions@@ -81,6 +85,7 @@  prop_partial_order_interleaved_duplicates :: Property prop_partial_order_interleaved_duplicates = forAll genPair $ \(a,b) -> a /= b ==> monadicIO $ do+  run resetMockHistory   -- Pattern a a b : [a,b] subsequence succeeds, [b,a] fails.   f <- run $ mock $ cases [ param a ~> True                                 , param a ~> True

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-hpc #-} module Property.ScriptProps   ( prop_script_count_matches   ) where@@ -11,6 +12,7 @@ -- | Property: executing a generated script produces exactly that many recorded calls. prop_script_count_matches :: Property prop_script_count_matches = forAll scriptGen $ \scr@(Script xs) -> monadicIO $ do+  run resetMockHistory   f <- run $ buildUnaryMock scr   run $ runScript f scr   run $ f `shouldBeCalled` times (length xs)

@@ -9,7 +9,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}-+{-# OPTIONS_GHC -fno-hpc #-} module ReadmeVerifySpec where  import Test.Hspec

@@ -19,9 +19,11 @@ import Test.MockCat.ShouldBeCalledSpec as ShouldBeCalled import Test.MockCat.ShouldBeCalledMockMSpec as ShouldBeCalledMockM import Test.MockCat.WithMockSpec as WithMock-import Test.MockCat.ErrorDiffSpec as ErrorDiff+import Test.MockCat.ShouldBeCalledErrorDiffSpec as ShouldBeCalledErrorDiff+import Test.MockCat.WithMockErrorDiffSpec as WithMockErrorDiff import Test.MockCat.THCompareSpec as THCompare import ReadmeVerifySpec as ReadmeVerify+import qualified Test.MockCat.HPCFallbackSpec as HPCFallback import Test.MockCat.UnsafeCheck () import Test.QuickCheck (property) import qualified Property.ConcurrentCountProp as ConcurrencyProp@@ -57,8 +59,10 @@     ShouldBeCalled.spec     ShouldBeCalledMockM.spec     WithMock.spec-    ErrorDiff.spec+    ShouldBeCalledErrorDiff.spec+    WithMockErrorDiff.spec     ReadmeVerify.spec+    HPCFallback.spec     describe "Property Concurrency" $ do       it "total apply count is preserved across threads" $ property ConcurrencyProp.prop_concurrent_total_apply_count     describe "Property Lazy Evaluation" $ do

@@ -1,252 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# OPTIONS_GHC -Wno-partial-fields #-}--module Test.MockCat.ErrorDiffSpec (spec) where--import Test.Hspec (Spec, describe, it, shouldThrow, errorCall)-import Test.MockCat-import Control.Exception (evaluate)-import Prelude hiding (any)-import GHC.Generics (Generic)--data User = User { name :: String, age :: Int } deriving (Show, Eq, Generic)-data Config = Config { theme :: String, level :: Int } deriving (Show, Eq, Generic)-data ComplexUser = ComplexUser { name :: String, config :: Config } deriving (Show, Eq, Generic)-data DeepNode = Leaf Int | Node { val :: Int, next :: DeepNode } deriving (Show, Eq, Generic)--- No longer partial if we use it carefully, but let's just use it.--- Actually, to avoid the warning entirely, we could use different field names or separate types,--- but for a test it is fine. I will just use anyException for the RED phase.-data MultiLayer = MultiLayer-  { layer1 :: String,-    sub :: SubLayer-  } deriving (Show, Eq, Generic)-data SubLayer = SubLayer-  { layer2 :: String,-    items :: [DeepNode]-  } deriving (Show, Eq, Generic)--instance WrapParam User where wrap v = ExpectValue v (show v)-instance WrapParam Config where wrap v = ExpectValue v (show v)-instance WrapParam ComplexUser where wrap v = ExpectValue v (show v)-instance WrapParam DeepNode where wrap v = ExpectValue v (show v)-instance WrapParam MultiLayer where wrap v = ExpectValue v (show v)-instance WrapParam SubLayer where wrap v = ExpectValue v (show v)--spec :: Spec-spec = do-  describe "Error Message Diff" do-    it "shows diff for string arguments" do-      f <- mock $ (any :: Param String) ~> "ok"-      _ <- evaluate $ f "hello haskell"-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  expected: \"hello world\"\n\-            \   but got: \"hello haskell\"\n\-            \                   ^^^^^^^^"-      f `shouldBeCalled` "hello world" `shouldThrow` errorCall expectedError--    it "shows diff for long list" do-      f <- mock $ (any :: Param [Int]) ~> "ok"-      _ <- evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  Specific difference in `[5]`:\n\-            \    expected: 6\n\-            \     but got: 0\n\-            \              ^\n\-            \\n\-            \Full context:\n\-            \  expected: [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\-            \   but got: [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]\n\-            \                            ^^^^^^^^^^^^^^^"-      f `shouldBeCalled` [1..10] `shouldThrow` errorCall expectedError--    it "shows diff for record" do-      f <- mock $ (any :: Param User) ~> "ok"-      _ <- evaluate $ f (User "Fagen" 20)-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  Specific difference in `age`:\n\-            \    expected: 30\n\-            \     but got: 20\n\-            \              ^^\n\-            \\n\-            \Full context:\n\-            \  expected: User {name = \"Fagen\", age = 30}\n\-            \   but got: User {name = \"Fagen\", age = 20}\n\-            \                                        ^^^"-      f `shouldBeCalled` User "Fagen" 30 `shouldThrow` errorCall expectedError--    it "shows diff for inOrderWith" do-      f <- mock $ (any :: Param String) ~> "ok"-      _ <- evaluate $ f "a"-      _ <- evaluate $ f "b"-      let expectedError =-            "function was not called with the expected arguments in the expected order.\n\-            \  expected 2nd call: \"c\"\n\-            \   but got 2nd call: \"b\"\n\-            \                      ^^"-      f `shouldBeCalled` inOrderWith ["a", "c"] `shouldThrow` errorCall expectedError--    it "chooses nearest neighbor in multi-case mock" do-      f <- mock $ do-        onCase $ "aaa" ~> (100 :: Int) ~> "ok"-        onCase $ "bbb" ~> (200 :: Int) ~> "ok"--      let expectedError =-            "function was not called with the expected arguments.\n\-            \  expected one of the following:\n\-            \    \"aaa\", 100\n\-            \    \"bbb\", 200\n\-            \  but got:\n\-            \    \"aaa\", 200\n\-            \           ^^^"-      evaluate (f "aaa" 200) `shouldThrow` errorCall expectedError--    it "shows diff for nested record" do-      f <- mock $ (any :: Param ComplexUser) ~> "ok"-      _ <- evaluate $ f (ComplexUser "Alice" (Config "Light" 1))-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  Specific difference in `config.theme`:\n\-            \    expected: \"Dark\"\n\-            \     but got: \"Light\"\n\-            \               ^^^^^^\n\-            \\n\-            \Full context:\n\-            \  expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\-            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\-            \                                                                   ^^^^^^^^^^^^^^^^^^^"-      f `shouldBeCalled` ComplexUser "Alice" (Config "Dark" 1) `shouldThrow` errorCall expectedError--    it "shows diff for nested list" do-      f <- mock $ (any :: Param [[Int]]) ~> "ok"-      _ <- evaluate $ f [[1, 2], [3, 4]]-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  Specific difference in `[1][1]`:\n\-            \    expected: 5\n\-            \     but got: 4\n\-            \              ^\n\-            \\n\-            \Full context:\n\-            \  expected: [[1,2], [3,5]]\n\-            \   but got: [[1,2], [3,4]]\n\-            \                       ^^^"-      f `shouldBeCalled` [[1, 2], [3, 5]] `shouldThrow` errorCall expectedError--    it "shows multiple differences in nested record" do-      f <- mock $ (any :: Param ComplexUser) ~> "ok"-      let actual = ComplexUser "Alice" (Config "Light" 2)-          expected = ComplexUser "Bob" (Config "Dark" 1)-      _ <- evaluate $ f actual-      let expectedError =-            "function was not called with the expected arguments.\n\-            \  Specific differences:\n\-            \    - `name`:\n\-            \        expected: \"Bob\"\n\-            \         but got: \"Alice\"\n\-            \    - `config.theme`:\n\-            \        expected: \"Dark\"\n\-            \         but got: \"Light\"\n\-            \    - `config.level`:\n\-            \        expected: 1\n\-            \         but got: 2\n\-            \\n\-            \Full context:\n\-            \  expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\-            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\-            \                                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"-      f `shouldBeCalled` expected `shouldThrow` errorCall expectedError--    describe "robustness (broken formats)" do-      it "handles unbalanced braces gracefully (fallback to standard message)" do-         f <- mock $ (any :: Param String) ~> "ok"-         let actual = "{ name = \"Alice\""-             expected = "{ name = \"Bob\" }"-         _ <- evaluate $ f actual-         let expectedError =-               "function was not called with the expected arguments.\n\-               \  expected: \"{ name = \\\"Bob\\\" }\"\n\-               \   but got: \"{ name = \\\"Alice\\\"\"\n\-               \                        ^^^^^^^^"-         f `shouldBeCalled` expected `shouldThrow` errorCall expectedError--      it "handles completely broken structure strings" do-         f <- mock $ (any :: Param String) ~> "ok"-         let actual = "NotARecord {,,,,,}"-             expected = "NotARecord { a = 1 }"-         _ <- evaluate $ f actual-         let expectedError =-               "function was not called with the expected arguments.\n\-               \  expected: \"NotARecord { a = 1 }\"\n\-               \   but got: \"NotARecord {,,,,,}\"\n\-               \                         ^^^^^^^^^"-         f `shouldBeCalled` expected `shouldThrow` errorCall expectedError--    describe "extreme structural cases" do-      it "handles extremely deep nesting" do-        f <- mock $ (any :: Param DeepNode) ~> "ok"-        -- 5 layers deep-        let actual = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 0}}}}}-            expected = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 1}}}}}-        _ <- evaluate $ f actual-        let expectedError =-              "function was not called with the expected arguments.\n" <>-              "  Specific difference in `next.next.next.next.next`:\n" <>-              "    expected: Leaf 1\n" <>-              "     but got: Leaf 0\n" <>-              "              " <> replicate 5 ' ' <> "^\n" <>-              "\n" <>-              "Full context:\n" <>-              "  expected: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 1}}}}}\n" <>-              "   but got: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}\n" <>-              "            " <> replicate 115 ' ' <> "^^^^^^"-        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError--      it "shows mismatches across multiple layers" do-        f <- mock $ (any :: Param MultiLayer) ~> "ok"-        let actual = MultiLayer {layer1 = "A", sub = SubLayer {layer2 = "B", items = [Node {val = 1, next = Leaf 2}]}}-            expected = MultiLayer {layer1 = "X", sub = SubLayer {layer2 = "Y", items = [Node {val = 1, next = Leaf 3}]}}-        _ <- evaluate $ f actual-        let expectedError =-              "function was not called with the expected arguments.\n" <>-              "  Specific differences:\n" <>-              "    - `layer1`:\n" <>-              "        expected: \"X\"\n" <>-              "         but got: \"A\"\n" <>-              "    - `sub.layer2`:\n" <>-              "        expected: \"Y\"\n" <>-              "         but got: \"B\"\n" <>-              "    - `sub.items[0].next`:\n" <>-              "        expected: Leaf 3\n" <>-              "         but got: Leaf 2\n" <>-              "\n" <>-              "Full context:\n" <>-              "  expected: MultiLayer {layer1 = \"X\", sub = SubLayer {layer2 = \"Y\", items = [Node {val = 1, next = Leaf 3}]}}\n" <>-              "   but got: MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}\n" <>-              "            " <> replicate 22 ' ' <> replicate 75 '^'-        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError--      it "handles cases where almost everything is different" do-        f <- mock $ (any :: Param Config) ~> "ok"-        let actual = Config "Light" 1-            expected = Config "Dark" 99-        _ <- evaluate $ f actual-        let expectedError =-              "function was not called with the expected arguments.\n" <>-              "  Specific differences:\n" <>-              "    - `theme`:\n" <>-              "        expected: \"Dark\"\n" <>-              "         but got: \"Light\"\n" <>-              "    - `level`:\n" <>-              "        expected: 99\n" <>-              "         but got: 1\n" <>-              "\n" <>-              "Full context:\n" <>-              "  expected: Config {theme = \"Dark\", level = 99}\n" <>-              "   but got: Config {theme = \"Light\", level = 1}\n" <>-              "            " <> replicate 17 ' ' <> replicate 18 '^'-        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError

@@ -0,0 +1,59 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.MockCat.HPCFallbackSpec (spec) where++import Test.Hspec+import Test.MockCat+import Control.Exception (evaluate)+import Prelude hiding (readFile, writeFile)++spec :: Spec+spec = do+  describe "HPC Fallback Scenarios (Multiple Mocks)" do+    +    it "distinguishes mocks of different types" do+      -- Case 1: Different types should be distinguishable by type check in fallback+      f <- mock $ "a" ~> (1 :: Int)+      g <- mock $ (1 :: Int) ~> "b"+      +      -- Verify f (String -> Int)+      f "a" `shouldBe` 1+      f `shouldBeCalled` "a"+      +      -- Verify g (Int -> String)+      g 1 `shouldBe` "b"+      g `shouldBeCalled` (1 :: Int)++    it "behavior with multiple mocks of SAME type (Unnamed)" do+      -- Case 2: Same type mocks. +      -- In HPC environment (StableName broken), fallback picks based on history.+      -- Expected behavior: It might pick the wrong recorder if implementation blindly takes the first/last match.+      +      f1 <- mock $ "1" ~> (1 :: Int)+      f2 <- mock $ "2" ~> (2 :: Int)++      -- Execute both+      _ <- evaluate $ f1 "1"+      _ <- evaluate $ f2 "2"++      -- Verify f1. +      -- If fallback picks f2 (latest or first), verification might fail or see wrong calls.+      f1 `shouldBeCalled` "1" +      +      -- Verify f2+      f2 `shouldBeCalled` "2"++    it "behavior with multiple mocks of SAME type (Named)" do+      -- Case 3: Named mocks of same type.+      -- Verification should ideally use the name to disambiguate.+      +      fA <- mock (label "mockA") $ "A" ~> (1 :: Int)+      fB <- mock (label "mockB") $ "B" ~> (2 :: Int)++      _ <- evaluate $ fA "A"+      _ <- evaluate $ fB "B"++      fA `shouldBeCalled` "A"+      fB `shouldBeCalled` "B"

@@ -0,0 +1,118 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Test.MockCat.HPCNestSpec (spec) where++import Test.Hspec+import Test.MockCat+import Control.Exception (try, SomeException, evaluate)+import Control.Monad.IO.Class (liftIO)+import Data.Either (isLeft)++spec :: Spec+spec = describe "HPC Nesting and Isolation" $ do++  it "RunMockT nested in IO: outer mock with 'shouldBeCalled' becomes unverifiable inside runMockT" $ do+    outer <- mock (param "outer" ~> True)+    -- execution in IO context+    _ <- evaluate (outer "outer")++    runMockT @IO $ do+      -- runMockT resets history, so 'outer' should not be verifiable here.+      result <- liftIO $ try @SomeException (outer `shouldBeCalled` "outer")+      liftIO $ result `shouldSatisfy` isLeft++  it "RunMockT nested in IO: outer mock is verifiable AFTER runMockT returns" $ do+    outer <- mock (param "outer" ~> True)+    _ <- evaluate (outer "outer")++    runMockT @IO $ do+      pure ()++    -- Post-runMockT, history is reset. Verification should fail.+    result <- try @SomeException (outer `shouldBeCalled` "outer")+    result `shouldSatisfy` isLeft++  it "withMock (using expects) is immune to history reset" $ do+    withMock $ do+      f <- mock (param "a" ~> True) +           `expects` do+             called once `with` "a"+      +      liftIO $ do+        _ <- evaluate (f "a")+        -- Nested runMockT clears history, but expectations capture the recorder directly.+        runMockT @IO $ pure ()+        +      pure ()++  it "Sibling runMockT blocks are isolated" $ do+    runMockT @IO $ do+      f1 <- mock (param "a" ~> True)+      _ <- liftIO $ evaluate (f1 "a")+      liftIO $ f1 `shouldBeCalled` "a"+    +    runMockT @IO $ do+      f2 <- mock (param "a" ~> True)+      _ <- liftIO $ evaluate (f2 "a")+      liftIO $ f2 `shouldBeCalled` "a"++  it "Nested withMock blocks work correctly even with same-type mocks" $ do+    withMock $ do+      -- Outer mock+      outer <- mock (param "a" ~> True) +           `expects` do+             called once+      +      liftIO $ do+        _ <- evaluate (outer "a")+        +        -- Inner withMock+        withMock $ do+          -- Inner mock with SAME signature+          inner <- mock (param "a" ~> True)+               `expects` do+                 called once+          +          _ <- liftIO $ evaluate (inner "a")+          pure ()+          +      pure ()++  it "Nested runMockT: inner block clears outer block's history" $ do+    runMockT @IO $ do+      outer <- mock (param "a" ~> True)+      _ <- liftIO $ evaluate (outer "a")+      +      -- At this point, outer is verifiable+      liftIO $ outer `shouldBeCalled` "a"+      +      liftIO $ runMockT @IO $ do+        -- Inner block resets history. +        -- 'outer' (defined in parent runMockT) relies on history lookup (HPC).+        -- So verifies should fail here.+        result <- liftIO $ try @SomeException (outer `shouldBeCalled` "a")+        liftIO $ result `shouldSatisfy` isLeft+        +        -- Inner mock should work checking+        inner <- mock (param "b" ~> True)+        _ <- liftIO $ evaluate (inner "b")+        liftIO $ inner `shouldBeCalled` "b"++      -- After inner block returns, history is NOT restored (resetMockHistory is destructive).+      -- So outer mock remains broken.+      result <- liftIO $ try @SomeException (outer `shouldBeCalled` "a")+      liftIO $ result `shouldSatisfy` isLeft++  it "withMock inside runMockT works correctly" $ do+    runMockT @IO $ do+      f <- mock (param "a" ~> True)+      _ <- liftIO $ evaluate (f "a")+      +      liftIO $ withMock $ do+        g <- mock (param "b" ~> True) `expects` do called once+        _ <- liftIO $ evaluate (g "b")+        pure ()+      +      -- withMock does not reset history, so 'f' should still be verifiable+      liftIO $ f `shouldBeCalled` "a"

@@ -15,15 +15,15 @@       let f = (+ 1) :: Int -> Int       ref <- newTVarIO InvocationRecord { invocations = [] :: [Int], invocationCounts = empty }       _ <- attachVerifierToFn f (Just "name", InvocationRecorder ref ParametricFunction)-      verifier <- lookupVerifierForFn f-      case verifier of-        Just (mockName, dyn) -> do+      results <- lookupVerifierForFn f+      case results of+        [(mockName, dyn)] -> do           mockName `shouldBe` Just "name"           case (fromDynamic dyn :: Maybe (InvocationRecorder Int)) of             Just (InvocationRecorder vref _) -> do               r <- readTVarIO vref               r `shouldBe` InvocationRecord { invocations = [] :: [Int], invocationCounts = empty }             Nothing -> expectationFailure "payload dynamic mismatch"-        Nothing -> expectationFailure "lookupStubFn returned Nothing"+        _ -> expectationFailure "lookupStubFn returned unexpected number of results"  

@@ -39,10 +39,11 @@   target ->   m () ensureVerifiable target =-  liftIO $-    Verify.resolveForVerification target >>= \case-      Just _ -> pure ()-      Nothing -> Verify.verificationFailure+  liftIO $ do+    candidates <- Verify.resolveForVerification target+    case candidates of+      [] -> Verify.verificationFailure+      _ -> pure ()   instance UserInputGetter IO where

@@ -0,0 +1,253 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}+{-# OPTIONS_GHC -fno-hpc #-}++module Test.MockCat.ShouldBeCalledErrorDiffSpec (spec) where++import Test.Hspec (Spec, describe, it, shouldThrow, errorCall)+import Test.MockCat+import Control.Exception (evaluate)+import Prelude hiding (any)+import GHC.Generics (Generic)++data User = User { name :: String, age :: Int } deriving (Show, Eq, Generic)+data Config = Config { theme :: String, level :: Int } deriving (Show, Eq, Generic)+data ComplexUser = ComplexUser { name :: String, config :: Config } deriving (Show, Eq, Generic)+data DeepNode = Leaf Int | Node { val :: Int, next :: DeepNode } deriving (Show, Eq, Generic)+-- No longer partial if we use it carefully, but let's just use it.+-- Actually, to avoid the warning entirely, we could use different field names or separate types,+-- but for a test it is fine. I will just use anyException for the RED phase.+data MultiLayer = MultiLayer+  { layer1 :: String,+    sub :: SubLayer+  } deriving (Show, Eq, Generic)+data SubLayer = SubLayer+  { layer2 :: String,+    items :: [DeepNode]+  } deriving (Show, Eq, Generic)++instance WrapParam User where wrap v = ExpectValue v (show v)+instance WrapParam Config where wrap v = ExpectValue v (show v)+instance WrapParam ComplexUser where wrap v = ExpectValue v (show v)+instance WrapParam DeepNode where wrap v = ExpectValue v (show v)+instance WrapParam MultiLayer where wrap v = ExpectValue v (show v)+instance WrapParam SubLayer where wrap v = ExpectValue v (show v)++spec :: Spec+spec = do+  describe "Error Message Diff" do+    it "shows diff for string arguments" do+      f <- mock $ (any :: Param String) ~> "ok"+      _ <- evaluate $ f "hello haskell"+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  expected: \"hello world\"\n\+            \   but got: \"hello haskell\"\n\+            \                   ^^^^^^^^"+      f `shouldBeCalled` "hello world" `shouldThrow` errorCall expectedError++    it "shows diff for long list" do+      f <- mock $ (any :: Param [Int]) ~> "ok"+      _ <- evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `[5]`:\n\+            \    expected: 6\n\+            \     but got: 0\n\+            \              ^\n\+            \\n\+            \Full context:\n\+            \  expected: [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\+            \   but got: [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]\n\+            \                            ^^^^^^^^^^^^^^^"+      f `shouldBeCalled` [1..10] `shouldThrow` errorCall expectedError++    it "shows diff for record" do+      f <- mock $ (any :: Param User) ~> "ok"+      _ <- evaluate $ f (User "Fagen" 20)+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `age`:\n\+            \    expected: 30\n\+            \     but got: 20\n\+            \              ^^\n\+            \\n\+            \Full context:\n\+            \  expected: User {name = \"Fagen\", age = 30}\n\+            \   but got: User {name = \"Fagen\", age = 20}\n\+            \                                        ^^^"+      f `shouldBeCalled` User "Fagen" 30 `shouldThrow` errorCall expectedError++    it "shows diff for inOrderWith" do+      f <- mock $ (any :: Param String) ~> "ok"+      _ <- evaluate $ f "a"+      _ <- evaluate $ f "b"+      let expectedError =+            "function was not called with the expected arguments in the expected order.\n\+            \  expected 2nd call: \"c\"\n\+            \   but got 2nd call: \"b\"\n\+            \                      ^^"+      f `shouldBeCalled` inOrderWith ["a", "c"] `shouldThrow` errorCall expectedError++    it "chooses nearest neighbor in multi-case mock" do+      f <- mock $ do+        onCase $ "aaa" ~> (100 :: Int) ~> "ok"+        onCase $ "bbb" ~> (200 :: Int) ~> "ok"++      let expectedError =+            "function was not called with the expected arguments.\n\+            \  expected one of the following:\n\+            \    \"aaa\", 100\n\+            \    \"bbb\", 200\n\+            \  but got:\n\+            \    \"aaa\", 200\n\+            \           ^^^"+      evaluate (f "aaa" 200) `shouldThrow` errorCall expectedError++    it "shows diff for nested record" do+      f <- mock $ (any :: Param ComplexUser) ~> "ok"+      _ <- evaluate $ f (ComplexUser "Alice" (Config "Light" 1))+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `config.theme`:\n\+            \    expected: \"Dark\"\n\+            \     but got: \"Light\"\n\+            \               ^^^^^^\n\+            \\n\+            \Full context:\n\+            \  expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\+            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\+            \                                                                   ^^^^^^^^^^^^^^^^^^^"+      f `shouldBeCalled` ComplexUser "Alice" (Config "Dark" 1) `shouldThrow` errorCall expectedError++    it "shows diff for nested list" do+      f <- mock $ (any :: Param [[Int]]) ~> "ok"+      _ <- evaluate $ f [[1, 2], [3, 4]]+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `[1][1]`:\n\+            \    expected: 5\n\+            \     but got: 4\n\+            \              ^\n\+            \\n\+            \Full context:\n\+            \  expected: [[1,2], [3,5]]\n\+            \   but got: [[1,2], [3,4]]\n\+            \                       ^^^"+      f `shouldBeCalled` [[1, 2], [3, 5]] `shouldThrow` errorCall expectedError++    it "shows multiple differences in nested record" do+      f <- mock $ (any :: Param ComplexUser) ~> "ok"+      let actual = ComplexUser "Alice" (Config "Light" 2)+          expected = ComplexUser "Bob" (Config "Dark" 1)+      _ <- evaluate $ f actual+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific differences:\n\+            \    - `name`:\n\+            \        expected: \"Bob\"\n\+            \         but got: \"Alice\"\n\+            \    - `config.theme`:\n\+            \        expected: \"Dark\"\n\+            \         but got: \"Light\"\n\+            \    - `config.level`:\n\+            \        expected: 1\n\+            \         but got: 2\n\+            \\n\+            \Full context:\n\+            \  expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\+            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\+            \                                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"+      f `shouldBeCalled` expected `shouldThrow` errorCall expectedError++    describe "robustness (broken formats)" do+      it "handles unbalanced braces gracefully (fallback to standard message)" do+         f <- mock $ (any :: Param String) ~> "ok"+         let actual = "{ name = \"Alice\""+             expected = "{ name = \"Bob\" }"+         _ <- evaluate $ f actual+         let expectedError =+               "function was not called with the expected arguments.\n\+               \  expected: \"{ name = \\\"Bob\\\" }\"\n\+               \   but got: \"{ name = \\\"Alice\\\"\"\n\+               \                        ^^^^^^^^"+         f `shouldBeCalled` expected `shouldThrow` errorCall expectedError++      it "handles completely broken structure strings" do+         f <- mock $ (any :: Param String) ~> "ok"+         let actual = "NotARecord {,,,,,}"+             expected = "NotARecord { a = 1 }"+         _ <- evaluate $ f actual+         let expectedError =+               "function was not called with the expected arguments.\n\+               \  expected: \"NotARecord { a = 1 }\"\n\+               \   but got: \"NotARecord {,,,,,}\"\n\+               \                         ^^^^^^^^^"+         f `shouldBeCalled` expected `shouldThrow` errorCall expectedError++    describe "extreme structural cases" do+      it "handles extremely deep nesting" do+        f <- mock $ (any :: Param DeepNode) ~> "ok"+        -- 5 layers deep+        let actual = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 0}}}}}+            expected = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 1}}}}}+        _ <- evaluate $ f actual+        let expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific difference in `next.next.next.next.next`:\n" <>+              "    expected: Leaf 1\n" <>+              "     but got: Leaf 0\n" <>+              "              " <> replicate 5 ' ' <> "^\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 1}}}}}\n" <>+              "   but got: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}\n" <>+              "            " <> replicate 115 ' ' <> "^^^^^^"+        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError++      it "shows mismatches across multiple layers" do+        f <- mock $ (any :: Param MultiLayer) ~> "ok"+        let actual = MultiLayer {layer1 = "A", sub = SubLayer {layer2 = "B", items = [Node {val = 1, next = Leaf 2}]}}+            expected = MultiLayer {layer1 = "X", sub = SubLayer {layer2 = "Y", items = [Node {val = 1, next = Leaf 3}]}}+        _ <- evaluate $ f actual+        let expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific differences:\n" <>+              "    - `layer1`:\n" <>+              "        expected: \"X\"\n" <>+              "         but got: \"A\"\n" <>+              "    - `sub.layer2`:\n" <>+              "        expected: \"Y\"\n" <>+              "         but got: \"B\"\n" <>+              "    - `sub.items[0].next`:\n" <>+              "        expected: Leaf 3\n" <>+              "         but got: Leaf 2\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: MultiLayer {layer1 = \"X\", sub = SubLayer {layer2 = \"Y\", items = [Node {val = 1, next = Leaf 3}]}}\n" <>+              "   but got: MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}\n" <>+              "            " <> replicate 22 ' ' <> replicate 75 '^'+        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError++      it "handles cases where almost everything is different" do+        f <- mock $ (any :: Param Config) ~> "ok"+        let actual = Config "Light" 1+            expected = Config "Dark" 99+        _ <- evaluate $ f actual+        let expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific differences:\n" <>+              "    - `theme`:\n" <>+              "        expected: \"Dark\"\n" <>+              "         but got: \"Light\"\n" <>+              "    - `level`:\n" <>+              "        expected: 99\n" <>+              "         but got: 1\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: Config {theme = \"Dark\", level = 99}\n" <>+              "   but got: Config {theme = \"Light\", level = 1}\n" <>+              "            " <> replicate 17 ' ' <> replicate 18 '^'+        f `shouldBeCalled` expected `shouldThrow` errorCall expectedError

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-type-defaults #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# OPTIONS_GHC -fno-hpc #-} module Test.MockCat.ShouldBeCalledMockMSpec (spec) where  import Control.Exception (ErrorCall(..), try)

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-type-defaults #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# OPTIONS_GHC -fno-hpc #-} {- HLINT ignore "Use newtype instead of data" -}  module Test.MockCat.ShouldBeCalledSpec (spec) where

@@ -38,16 +38,10 @@ import Test.MockCat.Internal.Types (BuiltMock(..)) import qualified Test.MockCat.Internal.MockRegistry as Registry (register) -ensureVerifiable ::-  ( MonadIO m-  , Verify.ResolvableMock target-  ) =>-  target ->-  m ()-ensureVerifiable target =-  liftIO $ do-    m <- Verify.resolveForVerification target-    case m of { Just _ -> pure (); Nothing -> Verify.verificationFailure }+-- | No-op. Previously used StableName-based verification check, which breaks under HPC.+--   TH-generated code doesn't need this, so we make it a no-op for consistency.+ensureVerifiable :: Applicative m => a -> m ()+ensureVerifiable _ = pure ()   instance MonadIO m => FileOperation (MockT m) where

@@ -0,0 +1,278 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++module Test.MockCat.WithMockErrorDiffSpec (spec) where++import Test.Hspec (Spec, describe, it, shouldThrow, errorCall)+import Test.MockCat+import Control.Exception (evaluate)+import Control.Monad.IO.Class (liftIO)+import Prelude hiding (any)+import GHC.Generics (Generic)++data User = User { name :: String, age :: Int } deriving (Show, Eq, Generic)+data Config = Config { theme :: String, level :: Int } deriving (Show, Eq, Generic)+data ComplexUser = ComplexUser { name :: String, config :: Config } deriving (Show, Eq, Generic)+data DeepNode = Leaf Int | Node { val :: Int, next :: DeepNode } deriving (Show, Eq, Generic)++data MultiLayer = MultiLayer+  { layer1 :: String,+    sub :: SubLayer+  } deriving (Show, Eq, Generic)+data SubLayer = SubLayer+  { layer2 :: String,+    items :: [DeepNode]+  } deriving (Show, Eq, Generic)++instance WrapParam User where wrap v = ExpectValue v (show v)+instance WrapParam Config where wrap v = ExpectValue v (show v)+instance WrapParam ComplexUser where wrap v = ExpectValue v (show v)+instance WrapParam DeepNode where wrap v = ExpectValue v (show v)+instance WrapParam MultiLayer where wrap v = ExpectValue v (show v)+instance WrapParam SubLayer where wrap v = ExpectValue v (show v)++spec :: Spec+spec = do+  describe "Error Message Diff" do+    it "shows diff for string arguments" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  expected: \"hello world\"\n\+            \   but got: \"hello haskell\"\n\+            \                   ^^^^^^^^"+      withMock (do+        f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` "hello world")+        _ <- liftIO $ evaluate $ f "hello haskell"+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows diff for long list" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `[5]`:\n\+            \    expected: 6\n\+            \     but got: 0\n\+            \              ^\n\+            \\n\+            \Full context:\n\+            \  expected: [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\+            \   but got: [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]\n\+            \                            ^^^^^^^^^^^^^^^"+      withMock (do+        f <- mock ((any :: Param [Int]) ~> "ok") `expects` (called once `with` [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])+        _ <- liftIO $ evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows diff for record" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `age`:\n\+            \    expected: 30\n\+            \     but got: 20\n\+            \              ^^\n\+            \\n\+            \Full context:\n\+            \  expected: User {name = \"Fagen\", age = 30}\n\+            \   but got: User {name = \"Fagen\", age = 20}\n\+            \                                        ^^^"+      withMock (do+        f <- mock ((any :: Param User) ~> "ok") `expects` (called once `with` User "Fagen" 30)+        _ <- liftIO $ evaluate $ f (User "Fagen" 20)+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows diff for inOrderWith" do+      let expectedError =+            "function was not called with the expected arguments in the expected order.\n\+            \  expected 2nd call: \"c\"\n\+            \   but got 2nd call: \"b\"\n\+            \                      ^^"+      withMock (do+        f <- mock ((any :: Param String) ~> "ok") `expects` calledInOrder ["a", "c"]+        _ <- liftIO $ evaluate $ f "a"+        _ <- liftIO $ evaluate $ f "b"+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "chooses nearest neighbor in multi-case mock" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  expected one of the following:\n\+            \    \"aaa\", 100\n\+            \    \"bbb\", 200\n\+            \  but got:\n\+            \    \"aaa\", 200\n\+            \           ^^^"+      withMock (do+        f <- mock $ do+          onCase $ "aaa" ~> (100 :: Int) ~> "ok"+          onCase $ "bbb" ~> (200 :: Int) ~> "ok"+        _ <- liftIO $ evaluate (f "aaa" 200)+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows diff for nested record" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `config.theme`:\n\+            \    expected: \"Dark\"\n\+            \     but got: \"Light\"\n\+            \               ^^^^^^\n\+            \\n\+            \Full context:\n\+            \  expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\+            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\+            \                                                                   ^^^^^^^^^^^^^^^^^^^"+      withMock (do+        f <- mock ((any :: Param ComplexUser) ~> "ok") `expects` (called once `with` ComplexUser "Alice" (Config "Dark" 1))+        _ <- liftIO $ evaluate $ f (ComplexUser "Alice" (Config "Light" 1))+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows diff for nested list" do+      let expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific difference in `[1][1]`:\n\+            \    expected: 5\n\+            \     but got: 4\n\+            \              ^\n\+            \\n\+            \Full context:\n\+            \  expected: [[1,2], [3,5]]\n\+            \   but got: [[1,2], [3,4]]\n\+            \                       ^^^"+      withMock (do+        f <- mock ((any :: Param [[Int]]) ~> "ok") `expects` (called once `with` [[1, 2], [3, 5]])+        _ <- liftIO $ evaluate $ f [[1, 2], [3, 4]]+        pure ()+        ) `shouldThrow` errorCall expectedError++    it "shows multiple differences in nested record" do+      let actual = ComplexUser "Alice" (Config "Light" 2)+          expected = ComplexUser "Bob" (Config "Dark" 1)+          expectedError =+            "function was not called with the expected arguments.\n\+            \  Specific differences:\n\+            \    - `name`:\n\+            \        expected: \"Bob\"\n\+            \         but got: \"Alice\"\n\+            \    - `config.theme`:\n\+            \        expected: \"Dark\"\n\+            \         but got: \"Light\"\n\+            \    - `config.level`:\n\+            \        expected: 1\n\+            \         but got: 2\n\+            \\n\+            \Full context:\n\+            \  expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\+            \   but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\+            \                                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"+      withMock (do+        f <- mock ((any :: Param ComplexUser) ~> "ok") `expects` (called once `with` expected)+        _ <- liftIO $ evaluate $ f actual+        pure ()+        ) `shouldThrow` errorCall expectedError++    describe "robustness (broken formats)" do+      it "handles unbalanced braces gracefully (fallback to standard message)" do+         let actual = "{ name = \"Alice\""+             expected = "{ name = \"Bob\" }"+             expectedError =+                "function was not called with the expected arguments.\n\+                \  expected: \"{ name = \\\"Bob\\\" }\"\n\+                \   but got: \"{ name = \\\"Alice\\\"\"\n\+                \                        ^^^^^^^^"+         withMock (do+           f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected)+           _ <- liftIO $ evaluate $ f actual+           pure ()+           ) `shouldThrow` errorCall expectedError++      it "handles completely broken structure strings" do+         let actual = "NotARecord {,,,,,}"+             expected = "NotARecord { a = 1 }"+             expectedError =+                "function was not called with the expected arguments.\n\+                \  expected: \"NotARecord { a = 1 }\"\n\+                \   but got: \"NotARecord {,,,,,}\"\n\+                \                         ^^^^^^^^^"+         withMock (do+           f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected)+           _ <- liftIO $ evaluate $ f actual+           pure ()+           ) `shouldThrow` errorCall expectedError++    describe "extreme structural cases" do+      it "handles extremely deep nesting" do+        -- 5 layers deep+        let actual = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 0}}}}}+            expected = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 1}}}}}+            expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific difference in `next.next.next.next.next`:\n" <>+              "    expected: Leaf 1\n" <>+              "     but got: Leaf 0\n" <>+              "              " <> replicate 5 ' ' <> "^\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 1}}}}}\n" <>+              "   but got: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}\n" <>+              "            " <> replicate 115 ' ' <> "^^^^^^"+        withMock (do+          f <- mock ((any :: Param DeepNode) ~> "ok") `expects` (called once `with` expected)+          _ <- liftIO $ evaluate $ f actual+          pure ()+          ) `shouldThrow` errorCall expectedError++      it "shows mismatches across multiple layers" do+        let actual = MultiLayer {layer1 = "A", sub = SubLayer {layer2 = "B", items = [Node {val = 1, next = Leaf 2}]}}+            expected = MultiLayer {layer1 = "X", sub = SubLayer {layer2 = "Y", items = [Node {val = 1, next = Leaf 3}]}}+            expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific differences:\n" <>+              "    - `layer1`:\n" <>+              "        expected: \"X\"\n" <>+              "         but got: \"A\"\n" <>+              "    - `sub.layer2`:\n" <>+              "        expected: \"Y\"\n" <>+              "         but got: \"B\"\n" <>+              "    - `sub.items[0].next`:\n" <>+              "        expected: Leaf 3\n" <>+              "         but got: Leaf 2\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: MultiLayer {layer1 = \"X\", sub = SubLayer {layer2 = \"Y\", items = [Node {val = 1, next = Leaf 3}]}}\n" <>+              "   but got: MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}\n" <>+              "            " <> replicate 22 ' ' <> replicate 75 '^'+        withMock (do+          f <- mock ((any :: Param MultiLayer) ~> "ok") `expects` (called once `with` expected)+          _ <- liftIO $ evaluate $ f actual+          pure ()+          ) `shouldThrow` errorCall expectedError++      it "handles cases where almost everything is different" do+        let actual = Config "Light" 1+            expected = Config "Dark" 99+            expectedError =+              "function was not called with the expected arguments.\n" <>+              "  Specific differences:\n" <>+              "    - `theme`:\n" <>+              "        expected: \"Dark\"\n" <>+              "         but got: \"Light\"\n" <>+              "    - `level`:\n" <>+              "        expected: 99\n" <>+              "         but got: 1\n" <>+              "\n" <>+              "Full context:\n" <>+              "  expected: Config {theme = \"Dark\", level = 99}\n" <>+              "   but got: Config {theme = \"Light\", level = 1}\n" <>+              "            " <> replicate 17 ' ' <> replicate 18 '^'+        withMock (do+          f <- mock ((any :: Param Config) ~> "ok") `expects` (called once `with` expected)+          _ <- liftIO $ evaluate $ f actual+          pure ()+          ) `shouldThrow` errorCall expectedError

@@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-}@@ -68,9 +69,9 @@       case result of         Left (ErrorCall msg) -> do           let expected =-                "function was not called the expected number of times with the expected arguments.\n" <>-                "  expected: 1\n" <>-                "   but got: 0"+                "function was not called with the expected arguments.\n" <>+                "  expected: \"a\"\n" <>+                "  but the function was never called"           msg `shouldBe` expected         _ -> fail "Expected ErrorCall"