mockcat 1.4.0.0 → 1.4.1.0

raw patch · 13 files changed

+408/−118 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README-ja.md +19/−4
• README.md +16/−1
• mockcat.cabal +3/−3
• src/Test/MockCat/Internal/Types.hs +8/−3
• src/Test/MockCat/Mock.hs +36/−7
• src/Test/MockCat/MockT.hs +9/−1
• src/Test/MockCat/WithMock.hs +67/−17
• test/Spec.hs +1/−1
• test/Test/MockCat/SafetyAnalysis.hs +181/−0
• test/Test/MockCat/UnsafeCheck.hs +0/−35
• test/Test/MockCat/WithMockIOSpec.hs +22/−2
• test/Test/MockCat/WithMockSpec.hs +40/−44

@@ -6,6 +6,12 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.4.1.0] - 2026-01-12+### Improved+- **Mock Context Isolation**: Redesigned mock tracking to use local context containers within `withMock` and `runMockT`. This significantly reduces reliance on global registries and thread-local storage, ensuring better test isolation and predictability.+- **Optimization Resilience Guidance**: Added detailed documentation on choosing between `mock` and `mockM`. For functions returning `IO`, using `mockM` is the recommended way to ensure stability under GHC optimizations (like CSE) without requiring extra compiler flags.+- **Robust Registration logic**: Re-implemented internal mock registration using a capability-based approach (`RegisterMock` and `HasMockContext`), making the library's core architecture more robust and easier to maintain.+ ## [1.4.0.0] - 2026-01-10 ### Changed - **Breaking Change**: Removed the verify fallback mechanism that searched thread history when `StableName` lookup failed.

@@ -256,7 +256,7 @@ spec :: Spec spec = do   it "Function Mocking" $ do-    -- "Hello" に対して 1 を返す関数を定義 (expects は書かない)+    -- "Hello" に対して True を返す関数を定義 (expects は書かない)     f <- mock ("Hello" ~> True)          -- 実行@@ -338,11 +338,26 @@ 基本的には **`mock`** だけ覚えれば十分です。 より細かい制御が必要になった場合に、他の関数を検討してください。 -| 関数 | 検証 (`shouldBeCalled`) | IO依存 | 特徴 |+| 関数 | 検証 (`shouldBeCalled`) | IO 依存 | 特徴 | | :--- | :---: | :---: | :--- | | **`stub`** | ❌ | なし | **純粋なスタブ**。IO に依存しません。検証不要ならこれで十分です。 |-| **`mock`** | ✅ | あり(隠蔽) | **モック**。純粋関数として振る舞いますが、内部的には IO を介して呼び出し履歴を管理します。 |-| **`mockM`** | ✅ | あり(明示) | **Monadic モック**。`MockT` や `IO` の中で使い、副作用（ロギングなど）を明示的に扱えます。 |+| **`mock`** | ✅ | なし（外部管理） | **モック**。純粋関数として振る舞い、履歴を自動的に記録します。 |+| **`mockM`** | ✅ | あり（明示） | **Monadic モック**。`MockT` や `IO` の中で使い、副作用（ロギングなど）を明示的に扱えます。 |++#### mock と mockM の使い分け++対象となる関数の**戻り値の型**に合わせて選択してください。++*   **`mock` (純粋な関数向け)**:+    *   `String -> Int` のような**純粋な関数**をモックする場合に使用します。+    *   Haskell の遅延評価を尊重し、「実際に結果が評価されたタイミング」で呼び出しを記録します。これにより、使われていない無駄な呼び出しをカウントしてしまうのを防ぎます。++*   **`mockM` (IO/モナディックな関数向け)**:+    *   `String -> IO Int` のような、**`IO` や `ReaderT IO` などの `MonadIO` インスタンスを返す関数**をモックする場合に使用します。+    *   記録処理が戻り値のアクション（`IO`）自体に組み込まれているため、高度な並列テストや強力な最適化がかかる環境下でも、非常に高い予測可能性を提供します。++> [!TIP]+> 迷ったときは、**「ターゲットの関数が IO を返すなら `mockM`、そうでないなら `mock`」** と覚えておけば間違いありません。  #### 部分モック (Partial Mock): 本物の関数と混ぜて使う 

@@ -337,8 +337,23 @@ | Function | Verification (`shouldBeCalled`) | IO Dependency | Characteristics | | :--- | :---: | :---: | :--- | | **`stub`** | ❌ | None | **Pure Stub**. No IO dependency. Sufficient if verification isn't needed. |-| **`mock`** | ✅ | Yes (Hidden) | **Mock**. Behaves as a pure function, but internally manages call history via IO. |+| **`mock`** | ✅ | None (External) | **Mock**. Behaves as a pure function. Automatically records history. | | **`mockM`** | ✅ | Yes (Explicit) | **Monadic Mock**. Used within `MockT` or `IO`, allowing explicit handling of side effects (e.g., logging). |++#### Choosing between `mock` and `mockM`++Choose the function according to the **return type** of the target function.++*   **`mock` (For Pure Functions)**:+    *   Use this when mocking **pure functions** like `String -> Int`.+    *   It respects Haskell's lazy evaluation and records the call only when the result is actually evaluated. This prevents counting unnecessary calls that were never executed.++*   **`mockM` (For IO/Monadic Functions)**:+    *   Use this when mocking functions that return **`IO` or other `MonadIO` instances** (such as `ReaderT IO`), like `String -> IO Int`.+    *   Since the recording logic is built directly into the returned action (`IO`), it provides extremely high predictability even in highly concurrent tests or environments with heavy GHC optimizations.++> [!TIP]+> When in doubt, remember: **"If the function returns IO, use `mockM`. Otherwise, use `mock`."**  #### Partial Mocking: Mixing with Real Functions 

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.39.0. -- -- see: https://github.com/sol/hpack  name:           mockcat-version:        1.4.0.0+version:        1.4.1.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.@@ -114,6 +114,7 @@       Test.MockCat.Readme.ShouldBeCalledSpec       Test.MockCat.Readme.WithMockIOSpec       Test.MockCat.Readme.WithMockSpec+      Test.MockCat.SafetyAnalysis       Test.MockCat.SharedSpecDefs       Test.MockCat.ShouldBeCalledErrorDiffSpec       Test.MockCat.ShouldBeCalledMockMSpec@@ -130,7 +131,6 @@       Test.MockCat.TypeClassSpec       Test.MockCat.TypeClassTHSpec       Test.MockCat.TypeFamilySpec-      Test.MockCat.UnsafeCheck       Test.MockCat.WithMockErrorDiffSpec       Test.MockCat.WithMockIOSpec       Test.MockCat.WithMockSpec

@@ -14,6 +14,7 @@ import Control.Monad (ap) import Control.Concurrent.STM (TVar) import Data.Maybe (listToMaybe)+import Data.Dynamic (Dynamic) import GHC.IO (unsafePerformIO) import Prelude hiding (lookup) import Control.Monad.State ( State, MonadState, execState, modify )@@ -110,9 +111,13 @@ perform = unsafePerformIO  -- | Mock expectation context holds verification actions to run at the end---   of the `withMock` block. Storing `IO ()` avoids forcing concrete param---   types at registration time.-newtype WithMockContext = WithMockContext (TVar [IO ()])+--   of the `withMock` block, and a recorder list for local registration.+--   - contextVerifications: stores verification actions+--   - contextRecorders: stores mock recorders (for expects to retrieve)+data WithMockContext = WithMockContext+  { contextVerifications :: TVar [IO ()]+  , contextRecorders :: TVar [(Maybe MockName, Dynamic)]+  }  -- | Expectation specification data Expectation params where

@@ -54,22 +54,51 @@   ) where  import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (ReaderT) import Control.Monad.State (get, put) import Control.Concurrent.STM (atomically, modifyTVar') import Data.Kind (Type) import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable)+import Data.Dynamic (toDyn) import Prelude hiding (lookup) import Test.MockCat.Internal.Builder import Test.MockCat.Internal.Verify (verifyExpectationDirect) import qualified Test.MockCat.Internal.MockRegistry as MockRegistry ( register ) import Test.MockCat.Internal.Types-import Test.MockCat.WithMock (askWithMockContext)+import Test.MockCat.WithMock (askWithMockContext, addRecorderLocal) import Test.MockCat.Param import Test.MockCat.Verify import Test.MockCat.Cons (Head(..), (:>)(..))  +-- | Internal helper class for mock registration dispatch+--   This class abstracts the registration logic to allow for different+--   implementations based on the monad context.+--   - In ReaderT WithMockContext: uses local context (no unsafePerformIO)+--   - In other MonadIO contexts: uses global registry (unsafePerformIO)+class MonadIO m => RegisterMock m where+  registerMockInternal :: (Typeable params, Typeable fn)+    => Maybe MockName -> InvocationRecorder params -> fn -> m fn++-- | Safe implementation for ReaderT WithMockContext+--   Uses local context, no unsafePerformIO!+instance {-# OVERLAPPING #-} MonadIO m => +  RegisterMock (ReaderT WithMockContext m) where+  registerMockInternal name verifier fn = do+    -- Still need to call MockRegistry.register for StableName lookup compatibility+    result <- liftIO $ MockRegistry.register name verifier fn+    -- Add to local context (no unsafePerformIO!)+    addRecorderLocal name (toDyn verifier)+    pure result++-- | Fallback implementation for all other MonadIO contexts+--   Uses global registry (unsafePerformIO) for backward compatibility+instance {-# OVERLAPPABLE #-} MonadIO m => RegisterMock m where+  registerMockInternal name verifier fn =+    liftIO $ MockRegistry.register name verifier fn++ -- | Type family to convert raw values to mock parameters. --   Raw values (like "foo") are converted to Head :> Param a, --   while existing Param chains remain unchanged.@@ -189,7 +218,7 @@     BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) (toParams params) :: m (BuiltMock fn verifyParams)     _ <- liftIO $ MockRegistry.register (Just name) recorder fn     -    WithMockContext ctxRef <- liftIO askWithMockContext+    WithMockContext {contextVerifications = ctxRef} <- liftIO askWithMockContext     let resolved = ResolvedMock (Just name) recorder     let verifyAction = mapM_ (verifyExpectationDirect resolved) exps     liftIO $ atomically $ modifyTVar' ctxRef (++ [verifyAction])@@ -240,7 +269,7 @@     BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing (toParams params) :: m (BuiltMock fn verifyParams)     _ <- liftIO $ MockRegistry.register Nothing recorder fn     -    WithMockContext ctxRef <- liftIO askWithMockContext+    WithMockContext {contextVerifications = ctxRef} <- liftIO askWithMockContext     let resolved = ResolvedMock Nothing recorder     let verifyAction = mapM_ (verifyExpectationDirect resolved) exps     liftIO $ atomically $ modifyTVar' ctxRef (++ [verifyAction])@@ -284,7 +313,7 @@   mockMImpl :: a  instance-  ( MonadIO m+  ( RegisterMock m   , CreateMock p   , MockIOBuilder (ToMockParams p) fn verifyParams   , LiftFunTo fn fnM m@@ -297,10 +326,10 @@     let params = toParams p     BuiltMock { builtMockFn = fnIO, builtMockRecorder = verifier } <- buildIO Nothing params     let lifted = liftFunTo (Proxy :: Proxy m) fnIO-    liftIO $ MockRegistry.register Nothing verifier lifted+    registerMockInternal Nothing verifier lifted  instance {-# OVERLAPPING #-}-  ( MonadIO m+  ( RegisterMock m   , CreateMock p   , MockIOBuilder (ToMockParams p) fn verifyParams   , LiftFunTo fn fnM m@@ -313,7 +342,7 @@     let params = toParams p     BuiltMock { builtMockFn = fnIO, builtMockRecorder = verifier } <- buildIO (Just name) params     let lifted = liftFunTo (Proxy :: Proxy m) fnIO-    liftIO $ MockRegistry.register (Just name) verifier lifted+    registerMockInternal (Just name) verifier lifted  mockM :: CreateMockFnM a => a mockM = mockMImpl

@@ -34,6 +34,7 @@ import Data.Dynamic (Dynamic) import UnliftIO (MonadUnliftIO(..)) import Test.MockCat.Internal.Types (InvocationRecorder, WithMockContext(..))+import qualified Test.MockCat.WithMock import Test.MockCat.Verify (ResolvableParamsOf) import Control.Concurrent.MVar (MVar) import qualified Data.Map.Strict as Map@@ -74,6 +75,12 @@   withRunInIO inner = MockT $ ReaderT $ \env ->     withRunInIO $ \run -> inner (\(MockT r) -> run (runReaderT r env)) +-- | MockT has access to WithMockContext through MockTEnv+--   This instance is safe (doesn't use unsafePerformIO) because+--   MockT internally uses ReaderT MockTEnv, and MockTEnv contains+--   the WithMockContext that was set up by runMockT.+instance Monad m => Test.MockCat.WithMock.HasMockContext (MockT m) where+  getMockContext = MockT $ ReaderT $ \env -> pure (envWithMockContext env)  instance {-# OVERLAPPABLE #-} MonadReader r m => MonadReader r (MockT m) where   ask = lift ask@@ -153,7 +160,8 @@ runMockT (MockT r) = do   liftIO Registry.resetMockHistory   expectsVar <- liftIO $ newTVarIO []-  let withMockCtx = WithMockContext expectsVar+  recordersVar <- liftIO $ newTVarIO []+  let withMockCtx = WithMockContext expectsVar recordersVar   defsVar <- liftIO $ newTVarIO []   fwdRef <- liftIO $ newIORef Map.empty   let env =

@@ -19,7 +19,9 @@   ( withMock   , withMockIO   , askWithMockContext-  , expects+  , HasMockContext(..)+  , addRecorderLocal+  ,expects   , MockResult(..)   , called   , with@@ -40,15 +42,17 @@   ) where  import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (ReaderT(..), runReaderT)+import Control.Monad.Reader (ReaderT(..), runReaderT, ask) import Control.Exception (bracket_) import Control.Concurrent.STM (newTVarIO, readTVarIO, atomically, modifyTVar') import Control.Monad.State (get, put, modify)+import Data.Dynamic (Dynamic) import Test.MockCat.Verify (TimesSpec(..), times, once, never, atLeast, atMost, greaterThan, lessThan, anything, ResolvableMock, ResolvableParamsOf) import Test.MockCat.Internal.Verify (verifyExpectationDirect) import Test.MockCat.Internal.Types   ( VerifyOrderMethod(..)   , WithMockContext(..)+  , MockName   , Expectation(..)   , Expectations(..)   , runExpectations@@ -72,22 +76,25 @@   -- | Run a block with mock expectations that are automatically verified+--   This implementation does NOT use threadWithMockStore (no unsafePerformIO)+--   because the context is passed via ReaderT environment. withMock :: ReaderT WithMockContext IO a -> IO a withMock action = do   ctxVar <- newTVarIO []-  let ctx = WithMockContext ctxVar-  bracket_ (setThreadWithMockContext ctx) clearThreadWithMockContext $ do-    result <- runReaderT action ctx-    -- Verify all registered verification actions-    actions <- readTVarIO ctxVar-    sequence_ actions-    pure result+  recordersVar <- newTVarIO []+  let ctx = WithMockContext ctxVar recordersVar+  result <- runReaderT action ctx+  -- Verify all registered verification actions+  actions <- readTVarIO ctxVar+  sequence_ actions+  pure result  -- | IO version of withMock withMockIO :: IO a -> IO a withMockIO action = do   ctxVar <- newTVarIO []-  let ctx = WithMockContext ctxVar+  recordersVar <- newTVarIO []+  let ctx = WithMockContext ctxVar recordersVar   bracket_ (setThreadWithMockContext ctx) clearThreadWithMockContext $ do     result <- action     -- Verify all registered verification actions@@ -97,6 +104,33 @@  -- | Retrieve the current mock context from thread-local storage. --   Throws an error if no context is found.+-- | Capability to access mock context+--   This type class separates safe (ReaderT-based) context access+--   from unsafe (global registry-based) context access.+--+--   Instances:+--   - 'ReaderT WithMockContext m': Safe, uses 'ask' (no unsafePerformIO)+--   - 'IO': Unsafe, uses global registry (unsafePerformIO dependency)+class Monad m => HasMockContext m where+  getMockContext :: m WithMockContext++-- | Safe instance: ReaderT-based context access+--   Uses 'ask' to obtain context from the ReaderT environment.+--   This does NOT use unsafePerformIO.+instance MonadIO m => HasMockContext (ReaderT WithMockContext m) where+  getMockContext = ask++-- | Unsafe instance: IO-based context access+--   Uses global registry (threadWithMockStore) which is initialized+--   with unsafePerformIO. This is kept for backward compatibility+--   with 'withMockIO'.+instance HasMockContext IO where+  getMockContext = askWithMockContext++-- | Get WithMockContext from thread-local storage+--   This is used by the IO instance of HasMockContext.+--   It relies on the global registry (threadWithMockStore) which+--   is initialized with unsafePerformIO. askWithMockContext :: IO WithMockContext askWithMockContext = do   mCtx <- getThreadWithMockContext@@ -104,6 +138,15 @@     Just ctx -> pure ctx     Nothing -> errorWithoutStackTrace "askWithMockContext: No WithMockContext found in current thread. Use withMock or withMockIO." +-- | Add a recorder to the local context (ReaderT environment)+--   This does NOT use unsafePerformIO or global registry.+--   Used by RegisterMock instance for safe registration.+addRecorderLocal :: (HasMockContext m, MonadIO m)+  => Maybe MockName -> Dynamic -> m ()+addRecorderLocal name dyn = do+  WithMockContext {contextRecorders = ref} <- getMockContext+  liftIO $ atomically $ modifyTVar' ref ((name, dyn):)+ -- | Attach expectations to a mock function --   Supports both single expectation and multiple expectations in a do block infixl 0 `expects`@@ -168,9 +211,12 @@   expectsDispatchImpl :: m fn -> exp -> m fn  -- | Instance for normal mocks (flag ~ 'False)---   Strict matching of params+--   Uses HasMockContext to obtain context, which automatically selects:+--   - ReaderT: ask (safe, no unsafePerformIO)+--   - IO: askWithMockContext (unsafe, uses global registry) instance-  ( MonadIO m+  ( HasMockContext m+  , MonadIO m   , ResolvableMock fn   , ResolvableParamsOf fn ~ params   , ExtractParams exp@@ -182,7 +228,7 @@   ExpectsDispatchImpl 'False fn exp m   where   expectsDispatchImpl mockFnM exp = do-    WithMockContext ctxVar <- liftIO askWithMockContext+    WithMockContext {contextVerifications = ctxVar} <- getMockContext  -- Updated pattern     -- Try to help type inference by using exp first     let _ = extractParams exp :: Proxy params     mockFn <- mockFnM@@ -201,8 +247,10 @@  -- | Instance for MockResult mocks (flag ~ 'True) --   Dynamic resolution using expectation params+--   Uses HasMockContext for capability-based context access instance-  ( MonadIO m+  ( HasMockContext m+  , MonadIO m   , BuildExpectations (MockResult params) (Expectations params ()) params   , Show params   , EqParams params@@ -210,7 +258,7 @@   ExpectsDispatchImpl 'True (MockResult params) (Expectations params ()) m   where   expectsDispatchImpl mockFnM exp = do-    WithMockContext ctxVar <- liftIO askWithMockContext+    WithMockContext {contextVerifications = ctxVar} <- getMockContext  -- Updated pattern     _ <- mockFnM     (mockName, mRecorder) <- liftIO MockRegistry.getLastRecorderRaw     resolved <- case mRecorder of@@ -226,8 +274,10 @@  -- | Instance for Unit mocks (flag ~ 'True) --   Dynamic resolution using expectation params+--   Uses HasMockContext for capability-based context access instance-  ( MonadIO m+  ( HasMockContext m+  , MonadIO m   , BuildExpectations () (Expectations params ()) params   , Show params   , EqParams params@@ -235,7 +285,7 @@   ExpectsDispatchImpl 'True () (Expectations params ()) m   where   expectsDispatchImpl mockFnM exp = do-    WithMockContext ctxVar <- liftIO askWithMockContext+    WithMockContext {contextVerifications = ctxVar} <- getMockContext  -- Updated pattern     _ <- mockFnM     (mockName, mRecorder) <- liftIO MockRegistry.getLastRecorderRaw     resolved <- case mRecorder of

@@ -29,7 +29,7 @@ import Test.MockCat.THCompareSpec as THCompare import qualified Test.MockCat.MultipleMocksSpec as MultipleMocks import qualified Test.MockCat.TypeFamilySpec as TypeFamily-import Test.MockCat.UnsafeCheck ()+import Test.MockCat.SafetyAnalysis () import Test.QuickCheck () import qualified Property.ConcurrentCountProp as ConcurrencyProp import qualified Property.LazyEvalProp as LazyEvalProp

@@ -0,0 +1,181 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{- HLINT ignore "Redundant pure" -}+{- HLINT ignore "Use camelCase" -}++module Test.MockCat.SafetyAnalysis where++import Prelude hiding (any)+import Test.MockCat+import Control.Monad.IO.Class (liftIO)+import Control.Monad (void)+import GHC.IO (evaluate)++{- +  This module defines execution paths to analyze the usage of unsafePerformIO in mockcat.+  It is used to generate GHC Core dumps which are then analyzed by verify_mock_unsafe.sh.+  +  Unique return values (strings) are used for each pattern to prevent GHC +  from sharing common sub-expressions in Core, ensuring each path is analyzed distinctly.+-}++-- =============================================================================+-- Phase 1: Plain IO (5 patterns)+-- =============================================================================++path_plainIO_stub :: String -> String+path_plainIO_stub = stub (any @String ~> ("plainIO_stub" :: String))++path_plainIO_mock :: IO (String -> String)+path_plainIO_mock = mock (any @String ~> ("plainIO_mock" :: String))++path_plainIO_mock_shouldBeCalled :: IO ()+path_plainIO_mock_shouldBeCalled = do+  f <- mock (any @String ~> ("plainIO_mock_sbc" :: String))+  void $ evaluate (f "test")+  f `shouldBeCalled` "test"++path_plainIO_mockM :: IO (String -> IO String)+path_plainIO_mockM = mockM (any @String ~> ("plainIO_mockM" :: String))++path_plainIO_mockM_shouldBeCalled :: IO ()+path_plainIO_mockM_shouldBeCalled = do+  f :: (String -> IO String) <- mockM (any @String ~> ("plainIO_mockM_sbc" :: String))+  void $ f "test"+  f `shouldBeCalled` "test"+++-- =============================================================================+-- Phase 2: withMock (7 patterns)+-- =============================================================================++path_withMock_stub :: IO ()+path_withMock_stub = withMock do+  let f = stub (any @String ~> ("withMock_stub" :: String))+  liftIO $ void $ evaluate (f "test")++path_withMock_mock :: IO ()+path_withMock_mock = withMock do+  f <- mock (any @String ~> ("withMock_mock" :: String))+  liftIO $ void $ evaluate (f "test")++path_withMock_mock_expects :: IO ()+path_withMock_mock_expects = withMock do+  f <- mock (any @String ~> ("withMock_mock_exp" :: String)) `expects` (called once :: Expectations (Param String) ())+  liftIO $ void $ evaluate (f "test")++path_withMock_mock_shouldBeCalled :: IO ()+path_withMock_mock_shouldBeCalled = withMock do+  f <- mock (any @String ~> ("withMock_mock_sbc" :: String))+  liftIO $ void $ evaluate (f "test")+  liftIO $ f `shouldBeCalled` "test"++path_withMock_mockM :: IO ()+path_withMock_mockM = withMock do+  f <- mockM (any @String ~> "withMock_mockM")+  void $ f "test"+  pure ()++path_withMock_mockM_expects :: IO ()+path_withMock_mockM_expects = withMock do+  f <- mockM (any @String ~> "withMock_mockM_exp") `expects` called once+  void $ f "test"+  pure ()++path_withMock_mockM_shouldBeCalled :: IO ()+path_withMock_mockM_shouldBeCalled = withMock do+  f <- mockM (any @String ~> "withMock_mockM_sbc")+  void $ f "test"+  liftIO $ f `shouldBeCalled` "test"+++-- =============================================================================+-- Phase 3: withMockIO (7 patterns)+-- =============================================================================++path_withMockIO_stub :: IO ()+path_withMockIO_stub = withMockIO do+  let f = stub (any @String ~> "withMockIO_stub")+  void $ evaluate (f "test")++path_withMockIO_mock :: IO ()+path_withMockIO_mock = withMockIO do+  f <- mock (any @String ~> "withMockIO_mock")+  void $ evaluate (f "test")++path_withMockIO_mock_expects :: IO ()+path_withMockIO_mock_expects = withMockIO do+  f <- mock (any @String ~> "withMockIO_mock_exp") `expects` (called once :: Expectations (Param String) ())+  void $ evaluate (f "test")++path_withMockIO_mock_shouldBeCalled :: IO ()+path_withMockIO_mock_shouldBeCalled = withMockIO do+  f <- mock (any @String ~> "withMockIO_mock_sbc")+  void $ evaluate (f "test")+  f `shouldBeCalled` "test"++path_withMockIO_mockM :: IO ()+path_withMockIO_mockM = withMockIO do+  f <- mockM (any @String ~> "withMockIO_mockM")+  void $ f "test"+  pure ()++path_withMockIO_mockM_expects :: IO ()+path_withMockIO_mockM_expects = withMockIO do+  f <- mockM (any @String ~> "withMockIO_mockM_exp") `expects` called once+  void $ f "test"+  pure ()++path_withMockIO_mockM_shouldBeCalled :: IO ()+path_withMockIO_mockM_shouldBeCalled = withMockIO do+  f <- mockM (any @String ~> "withMockIO_mockM_sbc")+  void $ f "test"+  f `shouldBeCalled` "test"+++-- =============================================================================+-- Phase 4: runMockT (7 patterns)+-- =============================================================================++path_runMockT_stub :: IO ()+path_runMockT_stub = runMockT do+  let f = stub (any @String ~> "runMockT_stub")+  liftIO $ void $ evaluate (f "test")++path_runMockT_mock :: IO ()+path_runMockT_mock = runMockT do+  f <- mock (any @String ~> "runMockT_mock")+  liftIO $ void $ evaluate (f "test")++path_runMockT_mock_expects :: IO ()+path_runMockT_mock_expects = runMockT do+  f <- mock (any @String ~> "runMockT_mock_exp") `expects` (called once :: Expectations (Param String) ())+  liftIO $ void $ evaluate (f "test")++path_runMockT_mock_shouldBeCalled :: IO ()+path_runMockT_mock_shouldBeCalled = runMockT do+  f <- mock (any @String ~> "runMockT_mock_sbc")+  liftIO $ void $ evaluate (f "test")+  liftIO $ f `shouldBeCalled` "test"++path_runMockT_mockM :: IO ()+path_runMockT_mockM = runMockT do+  f <- mockM (any @String ~> "runMockT_mockM")+  void $ f "test"+  pure ()++path_runMockT_mockM_expects :: IO ()+path_runMockT_mockM_expects = runMockT do+  f <- mockM (any @String ~> "runMockT_mockM_exp") `expects` called once+  void $ f "test"+  pure ()++path_runMockT_mockM_shouldBeCalled :: IO ()+path_runMockT_mockM_shouldBeCalled = runMockT do+  f <- mockM (any @String ~> "runMockT_mockM_sbc")+  void $ f "test"+  liftIO $ f `shouldBeCalled` "test"

@@ -1,35 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}-module Test.MockCat.UnsafeCheck (module Test.MockCat.UnsafeCheck) where--import GHC.IO (unsafePerformIO)-import Test.Inspection (inspect, doesNotUse)-import Test.MockCat--simpleStubExample :: String -> Bool-simpleStubExample = stub $ "value" ~> True--monadicMockExample :: IO (String -> IO Bool)-monadicMockExample = mockM $ "value" ~> True--pureMockExample :: IO (String -> Bool)-pureMockExample = mock $ "value" ~> True--inspect $ 'simpleStubExample `doesNotUse` 'unsafePerformIO-inspect $ 'monadicMockExample `doesNotUse` 'unsafePerformIO-inspect $ 'pureMockExample `doesNotUse` 'unsafePerformIO--{---- The following check demonstrates that calling the inspection to a pure--- binding built via `mock` indeed fails (because `mock` relies on--- unsafePerformIO internally). We keep it commented out so the suite passes.-{-# NOINLINE pureMockPure #-}-pureMockPure :: String -> Bool-pureMockPure = unsafePerformIO $ do-  f <- mock $ "value" ~> True-  pure f--inspect $ 'pureMockPure `doesNotUse` 'unsafePerformIO--}-

@@ -6,9 +6,13 @@ import Test.Hspec import Test.MockCat import Control.Exception (try, ErrorCall(..), SomeException)-import Control.Concurrent (forkIO)+import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Monad (void)+import Control.Concurrent.Async (async, wait)+import Control.Monad (void, forM_, replicateM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO)+import Prelude hiding (any)  spec :: Spec spec = do@@ -53,3 +57,19 @@       case childRes of         Left e -> show e `shouldContain` "No WithMockContext found"         Right _ -> fail "Child thread should not have accessed parent context"+    +    it "stress test: many threads with many calls" $ do+      let threads = 20 :: Int+          callsPerThread = 10 :: Int+          total = threads * callsPerThread :: Int++      withMockIO $ do+        mockFn <- mockM (any @String ~> True)+          `expects` called (times total)++        withRunInIO $ \runInIO -> do+          as <- replicateM threads (async $ runInIO $ do+              forM_ [1 .. callsPerThread] $ \_ -> do+                void $ mockFn "stress"+                liftIO $ threadDelay 1)+          mapM_ wait as

@@ -8,7 +8,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -22,7 +21,7 @@ import GHC.IO (evaluate) import Control.Concurrent.Async (async, wait) import Control.Concurrent (threadDelay)-import Control.Monad (void, forM, forM_)+import Control.Monad (void, forM, forM_, replicateM) import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.IO.Class (liftIO) import Control.Exception (try, ErrorCall(..))@@ -67,23 +66,23 @@    describe "withMock basic functionality" $ do     it "simple mock with expects" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True) `expects` (called once `with` "a")         liftIO $ mockFn "a" `shouldBe` True      it "simple mock with expects using param" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True) `expects` (called once `with` param "a")         liftIO $ mockFn "a" `shouldBe` True      it "fails when not called" $ do-      withMock (do +      withMock (do         mock (any @String ~> True)           `expects` (called once `with` "a")         pure ()) `shouldThrow` anyErrorCall      it "error message when not called" $ do-      result <- try $ withMock $ do +      result <- try $ withMock $ do         mock (any @String ~> True)           `expects` (called once `with` "a")         pure ()@@ -97,7 +96,7 @@         _ -> fail "Expected ErrorCall"      it "atLeast expectation" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True) `expects` (called (atLeast 1) `with` "a")          void $ liftIO $ evaluate $ mockFn "a"@@ -105,14 +104,14 @@         void $ liftIO $ evaluate $ mockFn "a"      it "anything expectation" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` called once          void $ liftIO $ evaluate $ mockFn "a"      it "anything expectation error message when not called" $ do-      result <- try $ withMock $ do +      result <- try $ withMock $ do         mock (any @String ~> True)           `expects` called once         pure ()@@ -130,34 +129,34 @@       it "never expectation without args succeeds when not called" $ do-      withMock $ do +      withMock $ do         mock (any @String ~> True)           `expects` called never         pure ()      it "never expectation without args fails when called" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` called never         liftIO $ mockFn "a" `shouldBe` True         pure ()) `shouldThrow` anyErrorCall      it "never expectation with args succeeds when not called with that arg" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` (called never `with` "z")         liftIO $ mockFn "a" `shouldBe` True         pure ()      it "never expectation with args fails when called with that arg" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` (called never `with` "z")         liftIO $ mockFn "z" `shouldBe` True         pure ()) `shouldThrow` anyErrorCall      it "multiple expectations in do block" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 2) `with` "a"@@ -168,7 +167,7 @@         pure ()      it "multiple expectations in do block fails when not all satisfied" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 2) `with` "a"@@ -179,7 +178,7 @@         pure ()) `shouldThrow` anyErrorCall      it "multiple expectations in do block with never" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called once `with` "a"@@ -188,7 +187,7 @@         pure ()      it "multiple expectations in do block with never fails when violated" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called once `with` "a"@@ -198,7 +197,7 @@         pure ()) `shouldThrow` anyErrorCall      it "multiple expectations with different counts" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 3) `with` "a"@@ -213,7 +212,7 @@         pure ()      it "multiple expectations fails when count is insufficient" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 3) `with` "a"@@ -225,7 +224,7 @@         pure ()) `shouldThrow` anyErrorCall      it "multiple expectations fails when atLeast is not satisfied" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (atLeast 2) `with` "a"@@ -236,7 +235,7 @@         pure ()) `shouldThrow` anyErrorCall      it "multiple expectations with mixed never and count" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 2) `with` "a"@@ -248,7 +247,7 @@         pure ()      it "multiple expectations with never fails when never is violated" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 2) `with` "a"@@ -262,7 +261,7 @@    describe "withMock verification failures" $ do     it "fails when called fewer times than expected" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called (times 3) `with` "a"@@ -272,7 +271,7 @@         pure ()) `shouldThrow` anyErrorCall      it "fails when called with unexpected arguments" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called once `with` "a"@@ -281,7 +280,7 @@         pure ()) `shouldThrow` anyErrorCall      it "fails when called but never expected" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             called never `with` "z"@@ -301,7 +300,7 @@    describe "order verification" $ do     it "calledInOrder succeeds when called in correct order" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInOrder ["a", "b", "c"]@@ -312,7 +311,7 @@         pure ()      it "calledInOrder fails when called in wrong order" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInOrder ["a", "b", "c"]@@ -323,7 +322,7 @@         pure ()) `shouldThrow` anyErrorCall      it "calledInOrder fails when not all calls are made" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInOrder ["a", "b", "c"]@@ -334,7 +333,7 @@         pure ()) `shouldThrow` anyErrorCall      it "calledInSequence succeeds when sequence is followed" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInSequence ["a", "c"]@@ -345,7 +344,7 @@         pure ()      it "calledInSequence fails when sequence is violated" $ do-      withMock (do +      withMock (do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInSequence ["a", "c"]@@ -355,7 +354,7 @@         pure ()) `shouldThrow` anyErrorCall      it "calledInSequence succeeds with extra calls in between" $ do-      withMock $ do +      withMock $ do         mockFn <- mock (any @String ~> True)         pure mockFn `expects` do             calledInSequence ["a", "c"]@@ -368,10 +367,10 @@    describe "multiple mocks" $ do     it "can define multiple mocks in withMock" $ do-      withMock $ do +      withMock $ do         fn1 <- mock (any @String ~> True)         pure fn1 `expects` do-            called once `with` "a" +            called once `with` "a"          fn2 <- mock (any @String ~> any @String ~> False)         pure fn2 `expects` do@@ -384,14 +383,14 @@   describe "withMock scope isolation" $ do     it "mocks from different withMock blocks do not interfere" $ do       -- First withMock block: expect one call-      withMock $ do +      withMock $ do         fn1 <- mock (any @String ~> True)         pure fn1 `expects` do             called once `with` "a"         liftIO $ evaluate $ fn1 "a"        -- Second withMock block: expect zero (if leaked, would see 1 and fail)-      withMock $ do +      withMock $ do         mock (any @String ~> True)           `expects` do             called never `with` "a"@@ -453,17 +452,14 @@           total = threads * callsPerThread :: Int        withMock $ do-        mockFn <- mock (any ~> True)-        pure mockFn `expects` do-            called (times total)+        mockFn <- mockM (any @String ~> True)+          `expects` called (times total)          withRunInIO $ \runInIO -> do-          as <- forM [1 .. threads] $ \threadIx ->-            async $ runInIO $ do-              forM_ [1 .. callsPerThread] $ \callIx -> do-                let tag = threadIx * 1000 + callIx-                liftIO $ evaluate $ perCall tag (mockFn "stress")-                liftIO $ threadDelay 1+          as <- replicateM threads (async $ runInIO $ do+              forM_ [1 .. callsPerThread] $ \_ -> do+                void $ mockFn "stress"+                liftIO $ threadDelay 1)           mapM_ wait as      it "concurrent calls preserve order expectations" $ do