mockcat 0.6.0.0 → 1.0.0.0

raw patch · 60 files changed

+9651/−4476 lines, 60 filesdep +containersdep +inspection-testingdep +stmdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, inspection-testing, stm

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +55/−2
• README-ja.md +286/−650
• README.md +414/−843
• mockcat.cabal +42/−19
• src/Test/MockCat.hs +45/−1
• src/Test/MockCat/Cons.hs +7/−1
• src/Test/MockCat/Internal/Builder.hs +444/−0
• src/Test/MockCat/Internal/Message.hs +278/−0
• src/Test/MockCat/Internal/MockRegistry.hs +101/−0
• src/Test/MockCat/Internal/Registry/Core.hs +242/−0
• src/Test/MockCat/Internal/Types.hs +100/−0
• src/Test/MockCat/Mock.hs +304/−842
• src/Test/MockCat/MockT.hs +96/−108
• src/Test/MockCat/Param.hs +150/−58
• src/Test/MockCat/TH.hs +276/−373
• src/Test/MockCat/TH/ClassAnalysis.hs +131/−0
• src/Test/MockCat/TH/ContextBuilder.hs +107/−0
• src/Test/MockCat/TH/FunctionBuilder.hs +410/−0
• src/Test/MockCat/TH/TypeUtils.hs +101/−0
• src/Test/MockCat/TH/Types.hs +20/−0
• src/Test/MockCat/Verify.hs +586/−0
• src/Test/MockCat/WithMock.hs +287/−0
• test/Property/AdditionalProps.hs +30/−49
• test/Property/ConcurrentCountProp.hs +13/−10
• test/Property/Generators.hs +3/−3
• test/Property/LazyEvalProp.hs +14/−10
• test/Property/OrderProps.hs +10/−15
• test/Property/ParamSpecNormalizeProp.hs +3/−7
• test/Property/ParamSpecRangeMergeRandomProp.hs +4/−6
• test/Property/ReinforcementProps.hs +16/−20
• test/Property/ScriptProps.hs +4/−5
• test/ReadmeVerifySpec.hs +82/−0
• test/Spec.hs +28/−3
• test/Support/ParamSpec.hs +2/−1
• test/Test/MockCat/ConcurrencySpec.hs +17/−9
• test/Test/MockCat/Definition.hs +0/−27
• test/Test/MockCat/ErrorDiffSpec.hs +252/−0
• test/Test/MockCat/ExampleSpec.hs +103/−69
• test/Test/MockCat/Impl.hs +6/−1
• test/Test/MockCat/Internal/MockRegistrySpec.hs +29/−0
• test/Test/MockCat/MockSpec.hs +95/−847
• test/Test/MockCat/MockTSpec.hs +22/−0
• test/Test/MockCat/ParamSpec.hs +30/−20
• test/Test/MockCat/PartialMockCommonSpec.hs +302/−0
• test/Test/MockCat/PartialMockSpec.hs +220/−65
• test/Test/MockCat/PartialMockTHSpec.hs +28/−98
• test/Test/MockCat/SharedSpecDefs.hs +160/−0
• test/Test/MockCat/ShouldBeCalledMockMSpec.hs +127/−0
• test/Test/MockCat/ShouldBeCalledSpec.hs +755/−0
• test/Test/MockCat/StubSpec.hs +62/−0
• test/Test/MockCat/TH/ClassAnalysisSpec.hs +81/−0
• test/Test/MockCat/TH/ContextBuilderSpec.hs +63/−0
• test/Test/MockCat/TH/FunctionBuilderSpec.hs +134/−0
• test/Test/MockCat/TH/TypeUtilsSpec.hs +84/−0
• test/Test/MockCat/THCompareSpec.hs +499/−0
• test/Test/MockCat/TypeClassCommonSpec.hs +831/−0
• test/Test/MockCat/TypeClassSpec.hs +514/−109
• test/Test/MockCat/TypeClassTHSpec.hs +50/−205
• test/Test/MockCat/UnsafeCheck.hs +35/−0
• test/Test/MockCat/WithMockSpec.hs +461/−0

@@ -6,6 +6,59 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.0.0] - 2025-12-24+### Changed+- **DSL Reboot**: Replaced `|>` with `~>` as the primary parameter chain operator (representing the "mock arrow").+- **Terminology Shift**: Standardized terminology to "called" instead of "applied" throughout the library and error messages.+- Simplified creating/stubbing API: `f <- mock $ ...` is now the canonical way.+- Expanded structural diffing support for nested records and lists.+- Unified verification API: All verification is now handled via `shouldBeCalled`.+- **Strict by Default**: `makeMock` and `makePartialMock` now default to strict return values (implicit monadic return is disabled). `makeAutoLiftMock` was introduced for the previous behavior.++### Added+- Deep Structural Diff: Enhanced error messages with precise caret pointers for complex nested data structures.+- STM-based concurrency for mock registration and call recording.+- Infinite arity support for mock/stub building.++### Removed+- Backward compatibility with 0.x.x APIs (`stubFn`, `createMock`, `applied`, etc.).+- `makeMockWithOptions`, `makePartialMockWithOptions`, and `MockOptions` (internalized to simplify API).++### Migration Guide (0.x -> 1.0)+This release is a complete reboot. Previous code **will break**.++1.  **Operator Change**: Replace `|>` with `~>`.+    ```haskell+    -- Old+    createStubFn $ "arg" |> "result"+    +    -- New+    stub $ "arg" ~> "result"+    ```++2.  **Mock Creation**: Use `mock` / `stub` instead of `createMock` / `createStubFn`.+    ```haskell+    -- Old+    f <- createMock $ "arg" |> "result"+    +    -- New+    f <- mock $ "arg" ~> "result"+    ```++3.  **Verification**: Use `shouldBeCalled` (unified API).+    ```haskell+    -- Old+    f `shouldApplyTo` "arg"+    +    -- New+    f `shouldBeCalled` "arg"+    ```++4.  **Template Haskell Generics**:+    `makeMock` is now strict by default (requires explicit `pure` for IO actions).+    - Use `makeAutoLiftMock` for old implicit behavior.+    - Or stick to `makeMock` and add `pure` to your return values.+ ## 0.6.0.0 ### Changed - Removed the upper limit on variable arguments when creating stub functions. Previously, there was a restriction on the maximum number of arguments, but this limitation has been removed, allowing stub functions to accept an arbitrary number of arguments.@@ -28,11 +81,11 @@ - Verification helpers: `applyTimesIs`, `neverApply`.  ### Changed-- Refactored `MockT` from `StateT` to `ReaderT (IORef [Definition])` architecture.+- Refactored `MockT` from `StateT` to `ReaderT (TVar [Definition])` architecture. - Simplified Template Haskell generated constraints.  ### Fixed-- Race causing lost/double count in concurrent stub applications (strict `atomicModifyIORef'`).+- Race causing lost/double count in concurrent stub applications (strict `modifyTVar'`).  ### Removed - `unsafePerformIO` in TH-generated code.

@@ -1,766 +1,402 @@ <div align="center">-    <img src="logo.png" width="830px" align="center" style="object-fit: cover"/>+    <img src="https://raw.githubusercontent.com/pujoheadsoft/mockcat/main/logo.png" width="600px" alt="Mockcat Logo">+    <h1>Declarative mocking with a single arrow <code>~&gt;</code></h1> </div> -[![Latest release](http://img.shields.io/github/release/pujoheadsoft/mockcat.svg)](https://github.com/pujoheadsoft/mockcat/releases)-[![Test](https://github.com/pujoheadsoft/mockcat/workflows/Test/badge.svg)](https://github.com/pujoheadsoft/mockcat/actions?query=workflow%3ATest+branch%3Amain)-[![](https://img.shields.io/hackage/v/mockcat)](https://hackage.haskell.org/package/mockcat)-+<div align="center"> -## 概要-mockcat は Haskell 向けの小さなモック / スタブ DSL です。  -`arg |> arg |> 戻り値` というシンプルな書き方で「こう呼ばれたらこう返す」を並べ、関数ならそのまま使い、型クラスなら Template Haskell (`makeMock`, `makePartialMock`) で生成したスタブ関数を `runMockT` の中で走らせると自動で検証まで行われます。+[![Hackage](https://img.shields.io/hackage/v/mockcat.svg)](https://hackage.haskell.org/package/mockcat)+[![Stackage LTS](http://stackage.org/package/mockcat/badge/lts)](http://stackage.org/lts/package/mockcat)+[![Build Status](https://github.com/pujoheadsoft/mockcat/workflows/Test/badge.svg)](https://github.com/pujoheadsoft/mockcat/actions) -### 使うべきタイミング / 使わない方が良いタイミング+[🇺🇸 English](README.md) -#### 使うべきタイミング-| 状況 | mockcat が向いている理由 |-|------|---------------------------|-| 1〜数箇所だけサクッとモックしたい | `a |> b |> r` で即 DSL 化、周辺設定が少ない |-| 引数と「呼び出し回数 / 呼び出し順」まで検証したい | `shouldApplyTimes*`, `shouldApplyInOrder` 系が素直 |-| 同じ引数でも呼び出し毎に返り値を変えたい | `onCase` + 重複ケースでシーケンス制御可能（末尾は粘着 repeat） |-| 並列実行でも回数ロスや重複カウントを避けたい | IORef 原子的更新 + Property Test (並行カウント) |-| 型クラスの一部だけ差し替えたい | `makePartialMock` で必要メソッドのみモック |-| 大掛かりな DI/コンテナを入れたくない | グローバル状態なし・テストローカル |-| `IO` 戻り値を複数段階で変化させたい | `implicitMonadicReturn` + 複数ケース |+</div> -#### 使わない方が良い / 他手法が適する可能性-| ケース | 推奨される代替/補助 |-|--------|-----------------------|-| 複雑な振る舞い網羅 + 大量の依存関係 | Effect System (Polysemy / fused-effects) で全域抽象化 |-| 自動 Derive / 全メソッド一括モックしたい | より重量級モックフレームワーク |-| シナリオを Shrink 前提でプロパティベース検証 | Hedgehog (将来統合予定) |-| AST/JSON 等の構造的部分一致・差分強調が主題 | 専用マッチャライブラリ + predicate 組合せ |-| 時間/スレッド制御 (仮想クロック) が必須 | 専用シミュレーション/テストランタイム |-| 数百万回の極端なホットループ計測 | 手書き最適化スタブ (オーバーヘッド極小化) |-| プロジェクト全体を型レベル DI 設計で統一 | 素の型クラスインスタンス / ReaderT 環境 |+**Mockcat** は、Haskell のための直感的で宣言的なモックライブラリです。+専用の演算子 **Mock Arrow (`~>`)** を使うことで、関数定義と同じような感覚で、引数と振る舞いをモックとして記述できます。 -#### 設計ポリシー-* DSL の中核は極小 (`|>` + 期待マッチャ)。周辺は拡張層（ParamSpec, シナリオ DSL）は後置。 -* 「明示性 > 自動化」: 暗黙のグローバル検証なし。`runMockT` 境界で完了。 -* 並行安全性とメッセージ明快さを優先、過剰な内部最適化は後回し。 -* 侵襲的なアーキテクチャ変更を要求しない。既存テストへ差し込める。+```haskell+-- 定義 (Define)+f <- mock $ "input" ~> "output" -#### 導入 (手書きスタブから段階的移行) 手順例-1. 既存の手書きスタブを `createMock` + `stubFn` に置換 (同じ型シグネチャ温存)。-2. 必要なテストだけ `shouldApplyTo` / `shouldApplyTimes` を追加 (全部に付けない)。-3. 重複呼び出し判定や順序がテスト意図なら `shouldApplyInOrder` を追加。-4. 将来さらに fuzz / property を盛りたい場合は PoC モジュール (ParamSpec/Scenario) を検討。+-- 検証 (Verify)+f `shouldBeCalled` "input"+``` -#### FAQ 抜粋-**Q. 未評価のまま終わるとカウントされますか?**  -されません。返り値評価時点で 1 カウント。 +--- -**Q. 同じ引数ケースを複数 onCase 登録した場合の選択順は?**  -左から順に消費し、末尾に到達後は末尾を繰り返します。 +## 概念と用語 (Concepts & Terminology) -**Q. 並列呼び出しは安全?**  -`atomicModifyIORef'` による単一レコード更新でロス/二重記録防止。Property で検証。 +Mockcat は、「実行時に検証を行いますが、定義時に『満たすべき条件』を宣言できる」という設計を採用しています。 -**Q. DSL をこれ以上膨らませる予定は?**  -コアは安定志向。高度な生成は別モジュール or オプションパッケージ。 +*   **Stub (スタブ)**:+    テストを進めるために値を返すだけの存在。「どう呼ばれたか」に関心を持ちません。+    `stub` 関数は完全に純粋な関数を返します。 -**Q. 失敗時デバッグは?**  -期待 vs 実際（順序ミスマッチの場合は位置付き）＋ラベル表示。`expect (>x) "label"` で補助。 +*   **Mock (モック)**:+    スタブの機能に加え、「期待通りに呼び出されたか」を記録・検証する存在。+    `mock` 関数は、呼び出しを記録しながら値を返します。検証はテストの最後に行うことも、モック定義時に「この条件で呼ばれるはずだ」と宣言することも可能です（`expects` による宣言的検証）。  --- -### 特徴-* シンプル: `arg |> ... |> 戻り値` でスタブ関数をすぐ作れる。-* 柔軟な戻り値: 同じ引数でも呼び出しごとで値を変えたり、引数別に振り分けたりできる。-* 型クラスのモックを生成: Template Haskell によりボイラープレートを削減。-* 型クラスの部分モック: 必要な関数だけ差し替え、残りは本物で動かすことができる。-* 並列処理への対応: スタブ関数を並列に呼び出しても、正確な呼び出し回数の検証が行える。-* (PoC) QuickCheck / シナリオ DSL との統合実験進行中。+## Why Mockcat? -<details>-<summary>更新履歴</summary>+Haskell におけるモック記述を、できるだけ自然な形で行えるよう設計されています。 -- **0.6.0.0**: スタブ関数作成時の可変引数の上限を撤廃。-- **0.5.3.0**: MockT が MonadUnliftIO のインスタンスになった-- **0.5.0**: `IO a`型のスタブ関数が、適用される度に異なる値を返すことができるようになった-- **0.4.0**: 型クラスの部分的なモックを作れるようになった-- **0.3.0**: 型クラスのモックを作れるようになった-- **0.2.0**: スタブ関数が、同じ引数に対して異なる値を返せるようになった-- **0.1.0**: 1st release-</details>+Mockcat は、**「アーキテクチャに依存せず、関数の "振る舞いと意図" を宣言的に記述できる」** モックライブラリです。 -## 例-スタブ関数-```haskell--- create a stub function-stubFn <- createStubFn $ "value" |> True--- assert-stubFn "value" `shouldBe` True-```-適用の検証-```haskell--- create a mock-mock <- createMock $ "value" |> True--- stub function-let stubFunction = stubFn mock--- assert-stubFunction "value" `shouldBe` True--- verify-mock `shouldApplyTo` "value"-```-型クラス-```haskell-result <- runMockT do-  -- stub functions-  _readFile $ "input.txt" |> pack "content"-  _writeFile $ "output.txt" |> pack "content" |> ()-  -- sut-  program "input.txt" "output.txt"+「型クラス (MTL) を導入しないとテストできない」+「モックのために専用のデータ型を定義しなければならない」+（例: 型クラスを増やす／Service Handle 用のレコードを別途用意する、など） -result `shouldBe` ()-```-## スタブ関数の概要-スタブ関数は`createStubFn`関数で生成することができます。-`createStubFn`の引数は、適用が期待される引数を `|>` で連結したもので、`|>` の最後の値が関数の返り値となります。-```haskell-createStubFn $ (10 :: Int) |> "return value"-```-これは型クラスのモックにおけるスタブ関数の場合も同様です。-```haskell-runMockT do-  _readFile $ "input.txt" |> pack "content"-```-期待される引数は、条件として指定することもできます。-```haskell--- Conditions other than exact match-createStubFn $ any |> "return value"-createStubFn $ expect (> 5) "> 5" |> "return value"-createStubFn $ expect_ (> 5) |> "return value"-createStubFn $ $(expectByExpr [|(> 5)|]) |> "return value"-```-また、引数に応じて返す値を変えることも可能です。-（同じ引数に対して、別の値を返すことも可能できます。）-```haskell--- Parameterized Stub-createStubFn do-  onCase $ "a" |> "return x"-  onCase $ "b" |> "return y"-createStubFn do-  onCase $ "arg" |> "x"-  onCase $ "arg" |> "y"-```-## 検証の概要-スタブ関数の適用を検証するには、まず`createMock`関数でモックを作ります。-スタブ関数はモックから`stubFn`関数で取り出して使います。-検証はモックに対して行います。-```haskell--- create a mock-mock <- createMock $ "value" |> True--- stub function-let stubFunction = stubFn mock--- assert-stubFunction "value" `shouldBe` True--- verify-mock `shouldApplyTo` "value"-```-スタブ関数と同様に検証の場合も条件を指定することができます。-```haskell-mock `shouldApplyTo` any @String-mock `shouldApplyTo` expect_ (/= "not value")-mock `shouldApplyTo` $(expectByExpr [|(/= "not value")|])-```-また適用された回数を検証することもできます。-```haskell-mock `shouldApplyTimes` (1 :: Int) `to` "value"-mock `shouldApplyTimesGreaterThan` (0 :: Int) `to` "value"-mock `shouldApplyTimesGreaterThanEqual` (1 :: Int) `to` "value"-mock `shouldApplyTimesLessThan` (2 :: Int) `to` "value"-mock `shouldApplyTimesLessThanEqual` (1 :: Int) `to` "value"-mock `shouldApplyTimesToAnything` (1 :: Int)-```-型クラスのモックの場合は、`runMockT`を適用した際、用意したスタブ関数の適用が行われたかの検証が自動で行われます。-```haskell-result <- runMockT do-  _readFile $ "input.txt" |> pack "Content"-  _writeFile $ "output.text" |> pack "Content" |> ()-  operationProgram "input.txt" "output.text"+そんな制約から解放されます。既存の関数をそのままモックし、設計が固まりきっていない段階でもテストを書き進めることができます。 -result `shouldBe` ()-```-## 型クラスのモック-ここからはより詳しく説明していきます。-### 例-例えば次のようなモナド型クラス`FileOperation`と、`FileOperation`を使う`operationProgram`という関数が定義されているとします。-```haskell-class Monad m => FileOperation m where-  readFile :: FilePath -> m Text-  writeFile :: FilePath -> Text -> m ()+**Mockcat は、テストのために設計を固定するのではなく、設計を試すためにテストを書けることを目指しています。** -operationProgram ::-  FileOperation m =>-  FilePath ->-  FilePath ->-  m ()-operationProgram inputPath outputPath = do-  content <- readFile inputPath-  writeFile outputPath content-```+### Before / After -次のように`makeMock`関数を使うことで、型クラス`FileOperation`のモックを生成することができます。  -`makeMock [t|FileOperation|]`+Mockcat を使うことで、テスト記述は次のようになります。 -生成されるのものは次の2つです。-1. 型クラス`FileOperation`の`MockT`インスタンス-2. 型クラス`FileOperation`に定義されている関数を元としたスタブ関数  -  スタブ関数は元の関数の接頭辞に`_`が付与された関数として生成されます。  -  この場合`_readFile`と`_writeFile`が生成されます。+| | **Before: 手書き...** 😫 | **After: Mockcat** 🐱✨ |+| :--- | :--- | :--- |+| **定義 (Stub)**<br>「この引数には<br>この値を返したい」 | <pre lang="haskell">f :: String -> IO String<br>f arg = case arg of<br>  "a" -> pure "b"<br>  _   -> error "unexpected"</pre><br>_単純な分岐を書くだけでも行数を消費します。_ | <pre lang="haskell">-- 検証不要なら stub (純粋)<br>let f = stub $<br>  "a" ~> "b"<br><br><br></pre><br>_完全に純粋な関数として振る舞います。_ |+| **検証 (Verify)**<br>「正しく呼ばれたか<br>テストしたい」 | <pre lang="haskell">-- 記録の仕組みから作る必要がある<br>ref <- newIORef []<br>let f arg = do<br>      modifyIORef ref (arg:)<br>      ...<br><br>-- 検証ロジック<br>calls <- readIORef ref<br>calls \`shouldBe\` ["a"]</pre><br>_※ これはよくある一例です。実際にはさらに補助コードが増えがちです。_ | <pre lang="haskell">-- 検証したいなら mock (内部で記録)<br>f <- mock $ "a" ~> "b"<br><br>-- 検証したい内容を書くだけ<br>f \`shouldBeCalled\` "a"</pre><br>_記録は自動。<br>「何を検証するか」という本質に集中できます。_ | -モックは次のように使うことができます。-```haskell-spec :: Spec-spec = do-  it "Read, and output files" do-    result <- runMockT do-      _readFile ("input.txt" |> pack "content")-      _writeFile ("output.txt" |> pack "content" |> ())-      operationProgram "input.txt" "output.txt"+### 主な特徴 -    result `shouldBe` ()-```-スタブ関数には、関数の適用が期待される引数を `|>` で連結して渡します。  -`|>` の最後の値が関数の返り値となります。+*   **Haskell ネイティブな DSL**: 冗長なデータコンストラクタや専用の記法を覚えなくても、関数定義と同じ感覚 (`引数 ~> 戻り値`) で自然に記述できます。+*   **アーキテクチャ非依存**: MTL (型クラス)、Service Handle (レコード)、あるいは純粋な関数。どのような設計パターンを採用していても、最小単位で導入可能です。+*   **値ではなく「条件」で検証**: 引数が `Eq` インスタンスを持っていなくても問題ありません。値の一致だけでなく、「どのような性質を満たすべきか」という条件 (Predicate) で検証できます。+*   **圧倒的に親切なエラー**: テスト失敗時、どこが違うのかを「構造差分」で表示します。+    ```text+    Expected arguments were not called.+      expected: [Record { name = "Alice", age = 20 }]+       but got: [Record { name = "Alice", age = 21 }]+                                                ^^+    ```+*   **意図を導く型設計**: 型はあなたの記述を縛るものではなく、テストの意図（何を期待しているか）を自然に表現させるために存在します。 -モックは`runMockT`で実行します。 -### 検証-実行の後、スタブ関数が期待通りに適用されたか検証が行われます。  -例えば、上記の例のスタブ関数`_writeFile`の適用が期待される引数を`"content"`から`"edited content"`に書き換えてみます。-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "content")-  _writeFile ("output.txt" |> pack "edited content" |> ())-  operationProgram "input.txt" "output.txt"-```-テストを実行すると、テストは失敗し、次のエラーメッセージが表示されます。-```console-uncaught exception: ErrorCall-function `_writeFile` was not applied to the expected arguments.-  expected: "output.txt","edited content"-  but got: "output.txt","content"-```+--- -また次のようにテスト対象で使用している関数に対応するスタブ関数を使用しなかったとします。-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "content")-  -- _writeFile ("output.txt" |> pack "content" |> ())-  operationProgram "input.txt" "output.txt"-```-この場合もテストを実行すると、テストは失敗し、次のエラーメッセージが表示されます。-```console-no answer found stub function `_writeFile`.-```+## クイックスタート -### 適用回数を検証-例えば、次のように特定の文字列を含んでいる場合は`writeFile`を適用させない場合のテストを書きたいとします。-```haskell-operationProgram inputPath outputPath = do-  content <- readFile inputPath-  unless (pack "ngWord" `isInfixOf` content) $-    writeFile outputPath content-```+以下のコードをコピペすれば、今すぐ Mockcat を体験できます。 -これは次のように`expectApplyTimes`関数（旧: `applyTimesIs`）を使うことで実現できます。-```haskell-import Test.MockCat as M-...-it "Read, and output files (contain ng word)" do-  result <- runMockT do-    _readFile ("input.txt" |> pack "contains ngWord")-    _writeFile ("output.txt" |> M.any |> ()) `expectApplyTimes` 0-    operationProgram "input.txt" "output.txt"+### インストール -  result `shouldBe` ()+`package.yaml`:+```yaml+dependencies:+  - mockcat ```-`0`を指定することで適用されなかったことを検証できます。 -あるいは`neverApply`関数を使うことで同じことが実現できます。-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "contains ngWord")-  neverApply $ _writeFile ("output.txt" |> M.any |> ())-  operationProgram "input.txt" "output.txt"+または `.cabal`:+```cabal+build-depends:+    mockcat ``` -`M.any`は任意の値にマッチするパラメーターです。-この例では`M.any`を使って、あらゆる値に対して`writeFile`関数が適用されないことを検証しています。--後述しますが、mockcatは`M.any`以外にも様々なパラメーターを用意しています。+### 最初のテスト (`Main.hs` / `Spec.hs`) -### 定数関数のモック-mockcatは定数関数もモックにできます。-`MonadReader`をモックにし、`ask`のスタブ関数を使ってみます。 ```haskell-data Environment = Environment { inputPath :: String, outputPath :: String }--operationProgram ::-  MonadReader Environment m =>-  FileOperation m =>-  m ()-operationProgram = do-  (Environment inputPath outputPath) <- ask-  content <- readFile inputPath-  writeFile outputPath content+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications #-}+import Test.Hspec+import Test.MockCat -makeMock [t|MonadReader Environment|]+main :: IO ()+main = hspec spec  spec :: Spec spec = do-  it "Read, and output files (with MonadReader)" do-    r <- runMockT do-      _ask (Environment "input.txt" "output.txt")-      _readFile ("input.txt" |> pack "content")-      _writeFile ("output.txt" |> pack "content" |> ())-      operationProgram-    r `shouldBe` ()-```-ここで、`ask`を使わないようにしてみます。-```haskell-operationProgram = do-  content <- readFile "input.txt"-  writeFile "output.txt" content-```-するとテスト実行に失敗し、スタブ関数が適用されなかったことが表示されます。-```haskell-It has never been applied function `_ask`-```-### `IO a`型の値を返すモック-通常定数関数は同じ値を返しますが、`IO a`型の値を返すモックの場合のみ、適用する度に別の値を返すようなモックを作ることができます。-例えば型クラス`Teletype`とテスト対象の関数`echo`が定義されているとします。-`echo`は、`readTTY`が返す値によって異なる動作をします。-```haskell-class Monad m => Teletype m where-  readTTY :: m String-  writeTTY :: String -> m ()+  it "Quick Start Demo" do+    -- 1. モックを作成 ("Hello" を受け取ったら 42 を返す)+    f <- mock $ "Hello" ~> (42 :: Int) -echo :: Teletype m => m ()-echo = do-  i <- readTTY-  case i of-    "" -> pure ()-    _  -> writeTTY i >> echo+    -- 2. 関数として使う+    let result = f "Hello"+    result `shouldBe` 42++    -- 3. 呼び出されたことを検証+    f `shouldBeCalled` "Hello" ```-  `readTTY`が`""`以外を返した場合は、再帰的に呼び出されることを検証したいでしょう。-  そのためには、一度のテストの中で`readTTY`が異なる値を返せる必要があります。-  これを実現するためには、`implicitMonadicReturn`オプションを指定してモックを作ります。-  `implicitMonadicReturn`を使うことで、スタブ関数が明示的にモナディックな値を返せるようになります。++---++### At a Glance: Matchers+| Matcher | Description | Example |+| :--- | :--- | :--- |+| **`any`** | どんな値でも許可 | `f <- mock $ any ~> True` |+| **`expect`** | 条件(述語)で検証 | `f <- mock $ expect (> 5) "gt 5" ~> True` |+| **`"val"`** | 値の一致 (Eq) | `f <- mock $ "val" ~> True` |+| **`inOrder`** | 順序検証 | ``f `shouldBeCalled` inOrderWith ["a", "b"]`` |+| **`inPartial`**| 部分順序 | ``f `shouldBeCalled` inPartialOrderWith ["a", "c"]`` |++---++## 使い方ガイド (User Guide)++Mockcat は、テストの目的や好みに応じて 2 つの検証スタイルをサポートしています。++1.  **事後検証スタイル (Spy)**:+    とりあえずモックで振る舞いを定義して実行し、後から `shouldBeCalled` で検証するスタイル。探索的なテストや、セットアップを簡単に済ませたい場合に適しています。（以下のセクション 1, 2 で主に使用）+2.  **事前期待スタイル (Declarative/Expectation)**:+    定義と同時に「こう呼ばれるべき」という期待を記述するスタイル。厳密なインタラクションのテストに適しています。（以下のセクション 3 で解説）++### 1. 関数のモック (`mock`) - [基本]++最も基本的な使い方です。特定の引数に対して値を返す関数を作ります。+ ```haskell-makeMockWithOptions [t|Teletype|] options { implicitMonadicReturn = False }+-- "a" -> "b" -> True を返す関数+f <- mock $ "a" ~> "b" ~> True ```-これによりテストでは、`onCase`を使って、1回目の適用では`""`以外の値を返し、2回目の適用では`""`を返すような動作をさせることが可能になります。++**柔軟なマッチング**:+具体的な値だけでなく、条件（述語）を指定することもできます。+ ```haskell-result <- runMockT do-  _readTTY $ do-    onCase $ pure @IO "a"-    onCase $ pure @IO ""+-- 任意の文字列 (param any)+f <- mock $ any ~> True -  _writeTTY $ "a" |> pure @IO ()-  echo-result `shouldBe` ()+-- 条件式 (expect)+f <- mock $ expect (> 5) "> 5" ~> True ```-### 部分的なモック-`makePartialMock`関数を使うと、型クラスに定義された関数の一部だけをモックにできます。 -例えば次のような型クラスと関数があったとします。  -`getUserInput`がテスト対象の関数です。-```haskell-data UserInput = UserInput String deriving (Show, Eq)+### 2. 型クラスのモック (`makeMock`) -class Monad m => UserInputGetter m where-  getInput :: m String-  toUserInput :: String -> m (Maybe UserInput)+既存の型クラスをそのままテストに持ち込みたい場合に使います。Template Haskell を使って、既存の型クラスからモックを自動生成します。 -getUserInput :: UserInputGetter m => m (Maybe UserInput)-getUserInput = do-  i <- getInput-  toUserInput i-```-この例では、一部本物の関数を使いたいので、次のように`IO`インスタンスを定義します。 ```haskell-instance UserInputGetter IO where-  getInput = getLine-  toUserInput "" = pure Nothing-  toUserInput a = (pure . Just . UserInput) a+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}++class Monad m => FileSystem m where+  readFile :: FilePath -> m String+  writeFile :: FilePath -> String -> m ()++-- [Strict Mode] デフォルトの動作。「mock」関数と挙動が一致します。+-- 戻り値の型が `m a` の場合、スタブ定義の右辺には `m a` 型の値（例: `pure @IO "value"`, `throwIO Error`）を記述する必要があります。+-- Haskell の型システムに対して正直で、明示的な記述を好む場合に推奨されます。+makeMock [t|FileSystem|]++-- [Auto-Lift Mode] 利便性重視のモード。+-- 純粋な値を自動的にモナド（m String など）に包んで返します。+makeAutoLiftMock [t|FileSystem|] ```-テストは次のようになります。-```haskell-makePartialMock [t|UserInputGetter|] +テストコード内では `runMockT` ブロックを使用します。++```haskell spec :: Spec spec = do-  it "Get user input (has input)" do-    a <- runMockT do-      _getInput "value"-      getUserInput-    a `shouldBe` Just (UserInput "value")+  it "filesystem test" do+    result <- runMockT do+      -- [Strict Mode] (makeMock 使用時): 明示的に pure で包む+      _readFile $ "config.txt" ~> pure @IO "debug=true"+      _writeFile $ "log.txt" ~> "start" ~> pure @IO () -  it "Get user input (no input)" do-    a <- runMockT do-      _getInput ""-      getUserInput-    a `shouldBe` Nothing+      -- [Auto-Lift Mode] (makeAutoLiftMock 使用時): 値は自動的に包まれる (便利)+      -- _readFile $ "config.txt" ~> "debug=true"++      -- テスト対象コードの実行（モックが注入される）+      myProgram "config.txt"+    +    result `shouldBe` () ``` -### スタブ関数の名前を変える-生成されるスタブ関数の接頭辞と接尾辞はオプションで変更することができます。  -例えば次のように指定すると、`stub_readFile_fn`と`stub_writeFile_fn`関数が生成されます。+### 3. 宣言的な検証 (`withMock` / `expects`)++定義と同時に期待値を記述するスタイルです。スコープを抜ける時に自動的に検証が走ります。+「定義」と「検証」を近くに書きたい場合に便利です。+ ```haskell-makeMockWithOptions [t|FileOperation|] options { prefix = "stub_", suffix = "_fn" }+withMock $ do+  -- 定義と同時に期待値(expects)を書く+  f <- mock (any ~> True)+    `expects` do+      called once `with` "arg"++  -- 実行+  f "arg" ```-オプションが指定されない場合はデフォルトで`_`になります。 -### makeMockが生成するコード-使用する上で意識する必要はありませんが、`makeMock`関数は次のようなコードを生成します。+> [!NOTE]+> `runMockT` ブロックの中でも、同様に `expects` を使った宣言的検証が可能です。+> つまり、「モック生成」と「期待値宣言」が１つのブロック内で完結する統一された体験を提供します。++### 4. 柔軟な検証（マッチャー）++引数が `Eq` インスタンスを持っていなくても、あるいは特定の値に依存したくない場合でも、「どのような条件を満たすべきか」という**意図**で検証できます。+Mockcat は、値の一致だけでなく、関数の性質を検証するための**マッチャー**を提供しています。++#### 任意の値を許可 (`any`)+ ```haskell--- MockTインスタンス-instance (Monad m) => FileOperation (MockT m) where-  readFile :: Monad m => FilePath -> MockT m Text-  writeFile :: Monad m => FilePath -> Text -> MockT m ()+-- どんな引数で呼ばれても True を返す+f <- mock $ any ~> True -_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), Monad m) => params -> MockT m ()-_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), Monad m) => params -> MockT m ()+-- 何でもいいから呼ばれたことを検証+f `shouldBeCalled` any ``` -## 関数のモック-mockcatはモナド型クラスのモックだけでなく、通常の関数のモックを作ることもできます。  -モナド型のモックとは異なり、元になる関数は不要です。+#### 条件を指定して検証 (`expect`) -### 使用例+任意の値ではなく、「条件（述語）」を使って検証できます。+`Eq` を持たない型（関数など）や、部分的な一致を確認したい場合に強力です。+ ```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+-- 引数が "error" で始まる場合のみ False を返す+f <- mock $ do+  onCase $ expect (\s -> "error" `isPrefixOf` s) "start with error" ~> False+  onCase $ any ~> True+``` -spec :: Spec-spec = do-  it "使い方の例" do-    -- モックの生成("value"を適用すると、純粋な値Trueを返す)-    mock <- createMock $ "value" |> True+### 5. 高度な機能 - [応用] -    -- モックからスタブ関数を取り出す-    let stubFunction = stubFn mock+#### mock vs stub vs mockM の使い分け -    -- 関数の適用結果を検証-    stubFunction "value" `shouldBe` True+基本的には **`mock`** だけ覚えれば十分です。+より細かい制御が必要になった場合に、他の関数を検討してください。 -    -- 期待される値("value")が適用されたかを検証-    mock `shouldApplyTo` "value"+| 関数 | 検証 (`shouldBeCalled`) | IO依存 | 特徴 |+| :--- | :---: | :---: | :--- |+| **`stub`** | ❌ | なし | **純粋なスタブ**。IO に依存しません。検証不要ならこれで十分です。 |+| **`mock`** | ✅ | あり(隠蔽) | **モック**。純粋関数として振る舞いますが、内部的には IO を介して呼び出し履歴を管理します。 |+| **`mockM`** | ✅ | あり(明示) | **Monadic モック**。`MockT` や `IO` の中で使い、副作用（ロギングなど）を明示的に扱えます。 | -```+#### 部分モック (Partial Mock): 本物の関数と混ぜて使う -### スタブ関数-スタブ関数を直接作るには `createStubFn` 関数を使います。  -検証が不要な場合は、こちらを使うとよいでしょう。+一部のメソッドだけモックに差し替え、残りは本物の実装を使いたい場合に便利です。+ ```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+-- [Strict Mode]+makePartialMock [t|FileSystem|] -spec :: Spec-spec = do-  it "スタブ関数を生成することができる" do-    -- 生成-    f <- createStubFn $ "param1" |> "param2" |> pure @IO ()+-- [Auto-Lift Mode]+-- makeAutoLiftMock と同様に、Partial Mock にも Auto-Lift 版があります。+makeAutoLiftPartialMock [t|FileSystem|] -    -- 適用-    actual <- f "param1" "param2"+instance FileSystem IO where ... -- 本物のインスタンスも必要 -    -- 検証-    actual `shouldBe` ()-```-`createStubFn` 関数には、関数が適用されることを期待する引数を `|>` で連結して渡します。-`|>` の最後の値が関数の返り値となります。+test = runMockT do+  _readFile $ "test" ~> pure @IO "content" -- readFile だけモック化 (Strict)+  -- or+  -- _readFile $ "test" ~> "content" -- (Auto-Lift) -スタブ関数が期待されていない引数に適用された場合はエラーとなります。-```console-uncaught exception: ErrorCall-Expected arguments were not applied to the function.-  expected: "value"-  but got: "valuo"+  program -- writeFile は本物の IO インスタンスが走る ```-### 名前付きスタブ関数-スタブ関数には名前を付けることができます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat -spec :: Spec-spec = do-  it "named stub" do-    f <- createNamedStubFn "named stub" $ "x" |> "y" |> True-    f "x" "z" `shouldBe` True-```-期待した引数に適用されなかった場合に出力されるエラーメッセージには、この名前が含まれるようになります。-```console-uncaught exception: ErrorCall-Expected arguments were not applied to the function `named stub`.-  expected: "x","y"-  but got: "x","z"-```+#### IO アクションを返す (Monadic Return) -### 定数スタブ関数-定数を返すようなスタブ関数を作るには`createConstantMock`もしくは`createNamedConstantMock`関数を使います。  +`IO` を返す関数で、呼び出しごとに副作用（結果）を変えたい場合に使います。  ```haskell-spec :: Spec-spec = do-  it "createConstantMock" do-    m <- createConstantMock "foo"-    stubFn m `shouldBe` "foo"-    shouldApplyToAnything m--  it "createNamedConstantMock" do-    m <- createNamedConstantMock "const" "foo"-    stubFn m `shouldBe` "foo"-    shouldApplyToAnything m+f <- mock $ do+  onCase $ "get" ~> pure @IO 1 -- 1回目+  onCase $ "get" ~> pure @IO 2 -- 2回目 ``` -### 柔軟なスタブ関数-`createStubFn` 関数に具体的な値ではなく、条件式を与えることで、柔軟なスタブ関数を生成できます。  -これを使うと、任意の値や、特定のパターンに合致する文字列などに対して期待値を返すことができます。  -これはモナド型のモックを生成した際のスタブ関数も同様です。-### any-`any` は任意の値にマッチします。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat-import Prelude hiding (any)+#### 名前付きモック -spec :: Spec-spec = do-  it "any" do-    f <- createStubFn $ any |> "return value"-    f "something" `shouldBe` "return value"-```-Preludeに同名の関数が定義されているため、`import Prelude hiding (any)`としています。+エラーメッセージに関数名を表示させたい場合は、ラベルを付けられます。 -### 条件式-`expect`関数を使うと任意の条件式を扱えます。  -`expect`関数は条件式とラベルをとります。  -ラベルは条件式にマッチしなかった場合のエラーメッセージに使われます。 ```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "expect" do-    f <- createStubFn $ expect (> 5) "> 5" |> "return value"-    f 6 `shouldBe` "return value"+f <- mock (label "myAPI") $ "arg" ~> True ``` -### ラベルなし条件式-`expect_` は `expect` のラベルなし版です。  -エラーメッセージには [some condition] と表示されます。+--- -```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+## リファレンス & レシピ (Encyclopedia) -spec :: Spec-spec = do-  it "expect_" do-    f <- createStubFn $ expect_ (> 5) |> "return value"-    f 6 `shouldBe` "return value"-```+※ このセクションは、困ったときの辞書として使ってください。 -### Template Haskellを使った条件式-`expectByExp`を使うと、`Q Exp`型の値として条件式を扱えます。  -エラーメッセージには条件式を文字列化したものが使われます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TemplateHaskell #-}-import Test.Hspec-import Test.MockCat+### 検証マッチャ一覧 (`shouldBeCalled`) -spec :: Spec-spec = do-  it "expectByExpr" do-    f <- createStubFn $ $(expectByExpr [|(> 5)|]) |> "return value"-    f 6 `shouldBe` "return value"-```+| マッチャ | 説明 | 例 |+| :--- | :--- | :--- |+| `x` (値そのもの) | その値で呼ばれたか | ``f `shouldBeCalled` (10 :: Int)`` |+| `times n` | 回数指定 | ``f `shouldBeCalled` (times 3 `with` "arg")`` |+| `once` | 1回だけ | ``f `shouldBeCalled` (once `with` "arg")`` |+| `never` | 呼ばれていない | ``f `shouldBeCalled` never`` |+| `atLeast n` | n回以上 | ``f `shouldBeCalled` atLeast 2`` |+| `atMost n` | n回以下 | ``f `shouldBeCalled` atMost 5`` |+| `anything` | 引数は何でも良い(回数不問) | ``f `shouldBeCalled` anything`` |+| `inOrderWith [...]` | 厳密な順序 | ``f `shouldBeCalled` inOrderWith ["a", "b"]`` |+| `inPartialOrderWith [...]` | 部分的順序（間飛びOK） | ``f `shouldBeCalled` inPartialOrderWith ["a", "c"]`` | -### 適用される引数ごとに異なる値を返すスタブ関数-`onCase`関数を使うと引数ごとに異なる値を返すスタブ関数を作れます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+### パラメータマッチャ一覧（引数定義） -spec :: Spec-spec = do-  it "multi" do-    f <- createStubFn do-      onCase $ "a" |> "return x"-      onCase $ "b" |> "return y"+| マッチャ | 説明 | 例 |+| :--- | :--- | :--- |+| `any` | 任意の値 | `any ~> True` |+| `expect pred label` | 条件式 | `expect (>0) "positive" ~> True` |+| `expect_ pred` | ラベルなし | `expect_ (>0) ~> True` | -    f "a" `shouldBe` "return x"-    f "b" `shouldBe` "return y"-```+### 宣言的検証 DSL (`expects`) -### 同じ引数に適用されたとき異なる値を返すスタブ関数-`onCase`関数を使うとき、引数が同じで返り値が異なるようにすると、同じ引数に適用しても異なる値を返すスタブ関数を作れます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat-import GHC.IO (evaluate)+`expects` ブロックでは、呼び出しに関する期待を宣言的に記述できます。+`expects` で使用できる構文は、`shouldBeCalled` と同じ語彙を共有しています。 -spec :: Spec-spec = do-  it "Return different values for the same argument" do-    f <- createStubFn do-      onCase $ "arg" |> "x"-      onCase $ "arg" |> "y"+| 構文 | 意味 |+| :--- | :--- |+| `called` | 呼び出しに関する期待の開始 |+| `once` | 1 回だけ呼ばれる |+| `times n` | n 回呼ばれる |+| `never` | 呼ばれない |+| `with arg` | 引数の期待値 |+| `with matcher` | マッチャを用いた引数検証 | -    -- Do not allow optimization to remove duplicates.-    v1 <- evaluate $ f "arg"-    v2 <- evaluate $ f "arg"-    v3 <- evaluate $ f "arg"-    v1 `shouldBe` "x"-    v2 `shouldBe` "y"-    v3 `shouldBe` "y" -- After the second time, “y” is returned.-```-あるいは`cases`関数を使うこともできます。-```haskell-f <--  createStubFn $-    cases-      [ "a" |> "return x",-        "b" |> "return y"-      ]+### よくある質問 (FAQ) -f "a" `shouldBe` "return x"-f "b" `shouldBe` "return y"-```+<details>+<summary><strong>Q. 未評価の遅延評価はどう扱われますか？</strong></summary>+A. カウントされません。Mockcat は「結果が評価された時点」で呼び出しを記録します (Honest Laziness)。これにより、不要な計算による誤検知を防ぎます。+</details> -## 検証-### 期待される引数に適用されたか検証する-期待される引数に適用されたかは `shouldApplyTo` 関数で検証することができます。  -検証を行う場合は、`createStubFn` 関数ではなく `createMock` 関数でモックを作る必要があります。-この場合スタブ関数は `stubFn` 関数でモックから取り出して使います。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+<details>+<summary><strong>Q. 並列テストで使えますか？</strong></summary>+A. はい。内部で `TVar` を使用してアトミックにカウントしているため、`mapConcurrently` などで並列に呼ばれても正確に記録されます。+</details> -spec :: Spec-spec = do-  it "stub & verify" do-    -- create a mock-    mock <- createMock $ "value" |> True-    -- stub function-    let stubFunction = stubFn mock-    -- assert-    stubFunction "value" `shouldBe` True-    -- verify-    mock `shouldApplyTo` "value"-```-### 注-適用されたという記録は、スタブ関数の返り値が評価される時点で行われます。  -したがって、検証は返り値の評価後に行う必要があります。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+<details>+<summary><strong>Q. `makeMock` が生成するコードは何ですか？</strong></summary>+A. 指定された型クラスの `MockT m` インスタンスと、各メソッドに対応する `_メソッド名` というスタブ生成関数定義です。+</details> -spec :: Spec-spec = do-  it "Verification does not work" do-    mock <- createMock $ "expect arg" |> "return value"-    -- 引数の適用は行うが返り値は評価しない-    let _ = stubFn mock "expect arg"-    mock `shouldApplyTo` "expect arg"-```-```console-uncaught exception: ErrorCall-Expected arguments were not applied to the function.-  expected: "expect arg"-  but got: Never been called.-```+<details>+<summary><strong>Q. 厳密な定義では Spy ではないですか？</strong></summary>+A. はい、xUnit Patterns 等の定義に従えば、事後検証を行う Mockcat のモックは **Test Spy** に分類されます。<br>+しかし、近年の多くのライブラリ（Jest, Mockito 等）がこれらを包括して「モック」と呼称していること、および用語の乱立による混乱を避けるため、本ライブラリでは **"Mock"** という用語で統一しています。+</details> -### 期待される引数に適用された回数を検証する-期待される引数が適用された回数は `shouldApplyTimes` 関数で検証することができます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+## ヒントとトラブルシューティング -spec :: Spec-spec = do-  it "shouldApplyTimes" do-    m <- createMock $ "value" |> True-    print $ stubFn m "value"-    print $ stubFn m "value"-    m `shouldApplyTimes` (2 :: Int) `to` "value"-```+### `any` と `Prelude.any` の名前衝突+`Test.MockCat` をインポートすると、パラメータマッチャの `any` が `Prelude.any` と衝突することがあります。+その場合は `Prelude` の `any` を隠すか、修飾名を使用してください。 -### 何かしらに適用されたかを検証する-関数が何かしらに適用されたかは、`shouldApplyToAnything`関数で検証することができます。+```haskell+import Prelude hiding (any)+-- または+import qualified Test.MockCat as MC+``` -### 何かしらに適用された回数を検証する-関数が何かしらに適用されたかの回数は、`shouldApplyTimesToAnything`関数で検証することができます。+### `OverloadedStrings` 使用時の型推論エラー+`OverloadedStrings` 拡張を有効にしている場合、文字列リテラルの型が曖昧になり、エラーが発生することがあります。+その場合は明示的に型注釈を付けてください。 -### 期待される順序で適用されたかを検証する-期待される順序で適用されたかは `shouldApplyInOrder` 関数で検証することができます。 ```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "shouldApplyInOrder" do-    m <- createMock $ any |> True |> ()-    print $ stubFn m "a" True-    print $ stubFn m "b" True-    m-      `shouldApplyInOrder` [ "a" |> True,-                             "b" |> True-                           ]+mock $ ("value" :: String) ~> True ``` -### 期待される順序で適用されたかを検証する(部分一致)-`shouldApplyInOrder` 関数は適用の順序を厳密に検証しますが、  -`shouldApplyInPartialOrder` 関数は適用の順序が部分的に一致しているかを検証することができます。-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat+--- -spec :: Spec-spec = do-  it "shouldApplyInPartialOrder" do-    m <- createMock $ any |> True |> ()-    print $ stubFn m "a" True-    print $ stubFn m "b" True-    print $ stubFn m "c" True-    m-      `shouldApplyInPartialOrder` [ "a" |> True,-                                    "c" |> True-                                  ]-```+_Happy Mocking!_ 🐱

@@ -1,844 +1,415 @@ <div align="center">-    <img src="logo.png" width="830px" align="center" style="object-fit: cover"/>-</div>--[![Latest release](http://img.shields.io/github/release/pujoheadsoft/mockcat.svg)](https://github.com/pujoheadsoft/mockcat/releases)-[![Test](https://github.com/pujoheadsoft/mockcat/workflows/Test/badge.svg)](https://github.com/pujoheadsoft/mockcat/actions?query=workflow%3ATest+branch%3Amain)-[![](https://img.shields.io/hackage/v/mockcat)](https://hackage.haskell.org/package/mockcat)--## Overview-mockcat is a lightweight, declarative mocking & stubbing DSL for Haskell.--You describe expected applications using a left‑to‑right pipeline (`arg |> arg |> returnValue`) and then either:-* run function mocks directly, or-* generate typeclass mocks via Template Haskell (`makeMock`, `makePartialMock`) and run them inside `runMockT` with automatic verification.--[日本語版 README はこちら](https://github.com/pujoheadsoft/mockcat/blob/master/README-ja.md)--### Features-* Small surface: describe a case with `arg |> ... |> result` – no separate expectation language-* Concurrency‑safe counting: parallel applications don’t lose or double count-* Honest laziness: an unevaluated result doesn’t register as a call; nothing is forced behind your back-* Flexible returns: change results per argument or per occurrence (including identical args later)-* Partial mocking: generate only the methods you care about with `makePartialMock`-* Monadic return variation: for `IO a` you can vary the monadic result across calls-* Clear failures: messages show the raw arguments and matcher labels directly-* Low ceremony constant stubs: `createConstantMock` / `createNamedConstantMock`-* Template Haskell helpers: `makeMock` to cut boilerplate for typeclasses-* No hidden global state: tests stay isolated--### Tested Versions-mockcat is continuously tested in CI across these configurations (see `.github/workflows/Test.yml`):--| GHC | Cabal | OS |-|-----|-------|----|-| 9.2.8 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows |-| 9.4.8 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows |-| 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 |--Notes:-* The `tested-with` stanza in the cabal file reflects the same GHC list.-* Other patch releases within the same minor series typically work; open an issue if you hit a snag.-* Older GHCs (< 9.2) are not targeted due to dependency bounds and modern TH/unliftio requirements.--Designed to be something you can pick up to stub one or two spots and then forget again – more a handy extension of regular Haskell testing than a new framework.--### When should you use mockcat?-Use it when the following resonate:--| Situation | Why mockcat helps |-|-----------|-------------------|-| You only need 1–3 small mocks and don’t want a heavy framework | Single expression `a |> b |> r` expectations stay lightweight |-| You want argument + occurrence sensitive returns | Multiple `onCase` (including duplicate args) choose per call deterministically |-| Verifying exact / partial order matters | Built‑in `shouldApplyInOrder` / `shouldApplyInPartialOrder` without extra harness |-| Need to assert precise call counts (including zero) | `expectApplyTimes`, `expectNever`, plus granular `shouldApplyTimes*` APIs |-| Concurrency: parallel tasks must not lose counts | Atomic recording + per‑call evaluation semantics tested with property tests |-| You prefer explicit, non‑magical DSL | Only `|>` and a few combinators (`any`, `expect`, `expect_`, TH expectByExpr) |-| You mix real + mocked methods in a typeclass | `makePartialMock` keeps untouched members real |-| Occasional tests, not an application‑wide inversion setup | Zero global registry; opt‑in per test |-| Need monadic variation for `IO` results | Repeated cases + monadic explicit returns under `implicitMonadicReturn` |--### When should you NOT use mockcat?-Consider alternatives if:--| Case | Probably better with |-|------|---------------------|-| Large system with dozens of interacting behaviors and deep expectations | A fuller test double / simulation layer or effect system (e.g. Polysemy / fused‑effects) |-| You want automatic generation of all mocks and default fallbacks | Dedicated auto‑deriving mock frameworks |-| Property‑based orchestration of complex multi‑step protocols with shrinking | Use Hedgehog directly (future integration planned) |-| You require record‑style structured matchers (e.g. JSON diff, partial AST pattern) | Custom predicate functions or a richer matcher library layered on top |-| You need time‑travel / virtual clock / deterministic scheduling | A purpose built simulation or effect runtime |-| Performance micro‑bench harness of millions of calls | Hand coded stub (mockcat overhead is small but non‑zero) |-| Cross‑module pervasive dependency injection | Typeclass instances / reader environment without mocks |--### Design philosophy & trade‑offs-* Favors readability of individual expectations over bulk generation.-* Explicit over implicit: no hidden global state; verification is opt‑in or at `runMockT` boundary.-* Encourages shrinking scope: mocks local to the test file; does not push architectural rewrites.-* Leaves advanced generation (scenarios, property fuzz) as optional layering – PoCs exist, but core stays minimal.-* Concurrency correctness prioritized above micro‑optimizing hot paths.--### Migrating from handwritten stubs-If you already write tiny handmade stubs:-1. Replace the stub body with `createMock` + `stubFn`.-2. Inline expectation in the test (keep original type signature).-3. Add verification only where it increases confidence (don’t verify everything by habit).--### Interoperability notes-| Layer | Status | Notes |-|-------|--------|-------|-| QuickCheck integration | PoC | ParamSpec → Gen, scenario DSL prototypes |-| Hedgehog integration | Planned | Will focus on shrinking ordered call sequences |-| Effect systems (Polysemy / fused‑effects) | Manual | Wrap `MockT` inside effect stack or lift via newtype derivation |-| Benchmarking | Planned | Criterion harness template (compare hand stub vs mockcat) |--### FAQ (selected)-**Q. Does mockcat force results strictly?**  -No. A call is recorded when the return value is evaluated; unevaluated results don’t count.--**Q. How are duplicate argument cases resolved?**  -Left‑to‑right; once the last variant is reached it repeats (sticky tail).--**Q. Thread safety?**  -All state mutations use a single `IORef` with atomic modification; properties cover contention scenarios.--**Q. Will the DSL expand a lot?**  -Core is intentionally stable; higher level generators / scenario DSL live in optional modules.--**Q. How to debug a mismatch?**  -Failure message lists expected vs actual (or sequence diff). Add labels via `expect (>x) "label"` for clarity.-------### Quick Start--Function mock:-```haskell-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = it "simple function mock" do-  m <- createMock $ "input" |> 42-  stubFn m "input" `shouldBe` 42-  m `shouldApplyTo` "input"-```--Typeclass mock:-```haskell-{-# LANGUAGE TemplateHaskell #-}-import Test.Hspec-import Test.MockCat--class Monad m => KV m where-  getKV :: String -> m (Maybe String)-  putKV :: String -> String -> m ()--makeMock [t|KV|]--program :: KV m => m (Maybe String)-program = do-  putKV "k" "v"-  getKV "k"--spec :: Spec-spec = it "kv" do-  r <- runMockT do-    _putKV ("k" |> "v" |> ())-    _getKV ("k" |> Just "v")-    program-  r `shouldBe` Just "v"-```--Non‑invocation (two styles):-```haskell-  _putKV ("x" |> "y" |> ()) `expectApplyTimes` 0  -- (legacy name: applyTimesIs)-  neverApply $ _putKV ("x" |> "y" |> ())-```--### Core Concepts (Brief)-* Pipeline DSL: `a |> b |> returnValue` describes one expected application.-* Matchers: `any`, `expect p label`, `expect_ p`, `$(expectByExpr [| predicate |])`.-* Argument‑dependent returns: `onCase` or `cases [...]` (including differing values for same arg on later occurrences).-* Counting: `expectApplyTimes` (legacy: `applyTimesIs`), `expectNever` (legacy: `neverApply`), plus `shouldApplyTimes*` predicates on mocks.-* Ordering: `shouldApplyInOrder`, `shouldApplyInPartialOrder`.-* Concurrency: Call recorded only when result evaluated; counting atomic.-* Partial mocks: `makePartialMock` for generating only some methods.-* Monadic return variation (`IO a`): enable with `implicitMonadicReturn` option.--### Concurrency & Laziness Semantics-Within `runMockT`:-1. Each evaluated application contributes 1 count (atomic IORef).-2. Unforced results are not recorded.-3. Order checks reflect evaluation order, not mere start time.-4. Finish async work before verification.-5. Fresh state per `runMockT` – no cross‑test leakage.--### Architecture Notes (≥ 0.5.3.0)-Refactor from `StateT` to `ReaderT (IORef [Definition])` to:-* Provide lawful `MonadUnliftIO` instance for safe `withRunInIO` / `async`.-* Remove lost/double count races via strict `atomicModifyIORef'`.-* Eliminate `unsafePerformIO` & hidden global state.-* Simplify TH output & reduce constraint noise.--Migration: internal `(modify/get)` swapped to `addDefinition/getDefinitions` (via `MonadMockDefs`). Public DSL unchanged.--<details>-<summary><strong>Update History</strong></summary>--* **0.6.0.0**: Removed the upper limit on variable arguments when creating stub functions.-* **0.5.3.0**: `MockT` now implements `MonadUnliftIO`; concurrency safety clarified; removal of `unsafePerformIO`.-* **0.5.0**: `IO a` stubs can return different values on successive applications.-* **0.4.0**: Partial mocks for typeclasses.-* **0.3.0**: Typeclass mocks.-* **0.2.0**: Argument‑dependent return values (including differing values for identical args).-* **0.1.0**: Initial release.-</details>------Below is the full expanded reference (legacy detailed sections). Collapse if you only need the quick start.--<details>-<summary><strong>Full Reference (expanded)</strong></summary>--<!-- BEGIN FULL REFERENCE (original content, lightly normalized) -->-## Examples-Stub Function-```haskell--- create a stub function-stubFn <- createStubFn $ "value" |> True--- assert-stubFn "value" `shouldBe` True-```-Verification-```haskell--- create a mock-mock <- createMock $ "value" |> True--- stub function-let stubFunction = stubFn mock--- assert-stubFunction "value" `shouldBe` True--- verify-mock `shouldApplyTo` "value"-```-Mock of Type Class-```haskell-result <- runMockT do-  -- stub functions-  _readFile $ "input.txt" |> pack "content"-  _writeFile $ "output.txt" |> pack "content" |> ()-  -- sut-  program "input.txt" "output.txt"--result `shouldBe` ()-```-## Stub Function Overview-Stub functions can be created with the `createStubFn` function.  -The arguments of `createStubFn` are the arguments expected to be applied, concatenated by `|>`, where the last value of `|>` is the return value of the function.-```haskell-createStubFn $ (10 :: Int) |> "return value"-```-The same is true for stub functions in typeclass mocks.-```haskell-runMockT do-  _readFile $ "input.txt" |> pack "content"-```-Expected arguments can also be specified as conditions.-```haskell--- Conditions other than exact match-createStubFn $ any |> "return value"-createStubFn $ expect (> 5) "> 5" |> "return value"-createStubFn $ expect_ (> 5) |> "return value"-createStubFn $ $(expectByExpr [|(> 5)|]) |> "return value"-```-It is also possible to change the value returned depending on the argument.  -(It is also possible to return different values for the same argument.)-```haskell--- Parameterized Stub-createStubFn do-  onCase $ "a" |> "return x"-  onCase $ "b" |> "return y"-createStubFn do-  onCase $ "arg" |> "x"-  onCase $ "arg" |> "y"-```-## Verification Overview-To verify the application of a stub function, first create a mock with the `createMock` function.  -Stub functions are retrieved from the mock with the `stubFn` function and used.  -Verification is performed on the mock.-```haskell--- create a mock-mock <- createMock $ "value" |> True--- stub function-let stubFunction = stubFn mock--- assert-stubFunction "value" `shouldBe` True--- verify-mock `shouldApplyTo` "value"-```-As with stub functions, conditions can be specified in the case of verification.-```haskell-mock `shouldApplyTo` any @String-mock `shouldApplyTo` expect_ (/= "not value")-mock `shouldApplyTo` $(expectByExpr [|(/= "not value")|])-```-You can also verify the number of times it has been applied.-```haskell-mock `shouldApplyTimes` (1 :: Int) `to` "value"-mock `shouldApplyTimesGreaterThan` (0 :: Int) `to` "value"-mock `shouldApplyTimesGreaterThanEqual` (1 :: Int) `to` "value"-mock `shouldApplyTimesLessThan` (2 :: Int) `to` "value"-mock `shouldApplyTimesLessThanEqual` (1 :: Int) `to` "value"-mock `shouldApplyTimesToAnything` (1 :: Int)-```-In the case of typeclass mocks, when `runMockT` is applied, verification that the prepared stub functions have been applied is performed automatically.-```haskell-result <- runMockT do-  _readFile $ "input.txt" |> pack "Content"-  _writeFile $ "output.text" |> pack "Content" |> ()-  operationProgram "input.txt" "output.text"--result `shouldBe` ()-```-## Mock of monad type class-### Example usage-For example, suppose the following monad type class `FileOperation` and a function `operationProgram` that uses `FileOperation` are defined.-```haskell-class Monad m => FileOperation m where-  readFile :: FilePath -> m Text-  writeFile :: FilePath -> Text -> m ()--operationProgram ::-  FileOperation m =>-  FilePath ->-  FilePath ->-  m ()-operationProgram inputPath outputPath = do-  content <- readFile inputPath-  writeFile outputPath content-```--You can generate a mock of the typeclass `FileOperation` by using the `makeMock` function as follows  -`makeMock [t|FileOperation|]`--Then following two things will be generated: -1. a `MockT` instance of typeclass `FileOperation`-2. a stub function based on a function defined in the typeclass `FileOperation`  -  Stub functions are created as functions with `_` prefix added to the original function.  -  In this case, `_readFile` and `_writeFile` are generated.--Mocks can be used as follows.-```haskell-spec :: Spec-spec = do-  it "Read, and output files" do-    result <- runMockT do-      _readFile ("input.txt" |> pack "content")-      _writeFile ("output.txt" |> pack "content" |> ())-      operationProgram "input.txt" "output.txt"--    result `shouldBe` ()-```-Stub functions are passed arguments that are expected to be applied to the function, concatenated by `|>`.  -The last value of `|>` is the return value of the function.--Mocks are run with `runMockT`.--### Verification-After execution, the stub function is verified to see if it is applied as expected.  -For example, the expected argument of the stub function `_writeFile` in the above example is changed from `"content"` to `"edited content"`.-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "content")-  _writeFile ("output.txt" |> pack "edited content" |> ())-  operationProgram "input.txt" "output.txt"-```-If you run the test, the test will fail and you will get the following error message.-```console-uncaught exception: ErrorCall-function `_writeFile` was not applied to the expected arguments.-  expected: "output.txt", "edited content"-  but got: "output.txt", "content"-```--Suppose also that you did not use the stub function corresponding to the function you are using in your test case, as follows-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "content")-  -- _writeFile ("output.txt" |> pack "content" |> ())-  operationProgram "input.txt" "output.txt"-```-Again, when you run the test, the test fails and you get the following error message.-```console-no answer found stub function `_writeFile`.-```-## Verify the number of times applied-For example, suppose you want to write a test for not applying `_writeFile` if it contains a specific string as follows.-```haskell-operationProgram inputPath outputPath = do-  content <- readFile inputPath-  unless (pack "ngWord" `isInfixOf` content) $-    writeFile outputPath content-```-This can be accomplished by using the `expectApplyTimes` function (legacy name: `applyTimesIs`) as follows.-```haskell-import Test.MockCat as M-...-it "Read, and output files (contain ng word)" do-  result <- runMockT do-    _readFile ("input.txt" |> pack "contains ngWord")-    _writeFile ("output.txt" |> M.any |> ()) `expectApplyTimes` 0-    operationProgram "input.txt" "output.txt"--  result `shouldBe` ()-```-You can verify that it was not applied by specifying `0`.-Or you can use the `neverApply` function to accomplish the same thing.-```haskell-result <- runMockT do-  _readFile ("input.txt" |> pack "contains ngWord")-  neverApply $ _writeFile ("output.txt" |> M.any |> ())-  operationProgram "input.txt" "output.txt"-```-`M.any` is a parameter that matches any value.  -This example uses `M.any` to verify that the `writeFile` function does not apply to any value.-As described below, mockcat provides a variety of parameters other than `M.any`.--### Mock constant functions-mockcat can also mock constant functions.  -Let's mock `MonadReader` and use the `ask` stub function.-```haskell-data Environment = Environment { inputPath :: String, outputPath :: String }--operationProgram ::: MonadReader Environment m =>-  MonadReader Environment m =>-  FileOperation m =>-  m ()-operationProgram = do-  (Environment inputPath outputPath) <- ask-  content <- readFile inputPath-  writeFile outputPath content--makeMock [t|MonadReader Environment|]--spec :: Spec-spec = do-  it "Read, and output files (with MonadReader)" do-    r <- runMockT do-      _ask (Environment "input.txt" "output.txt")-      _readFile ("input.txt" |> pack "content")-      _writeFile ("output.txt" |> pack "content" |> ())-      operationProgram-    r `shouldBe` ()-```-Now let's try to avoid using `ask`.-```haskell-operationProgram = do-  content <- readFile "input.txt"-  writeFile "output.txt" content-```-Then the test run fails and you will see that the stub function was not applied.-```haskell-It has never been applied function `_ask`-```-### Mock that returns a value of type `IO a`.-Normally constant functions return the same value, but only for mocks that return a value of type `IO a`, you can create a mock that returns a different value each time it is applied.  -For example, suppose a typeclass `Teletype` and a function `echo` to be tested are defined.  -The `echo` will behave differently depending on the value returned by `readTTY`.-```haskell-class Monad m => Teletype m where-  readTTY :: m String-  writeTTY :: String -> m ()--echo :: Teletype m => m ()-echo = do-  i <- readTTY-  case i of-    "" -> pure ()-    _  -> writeTTY i >> echo-```-You will want to verify that if `readTTY` returns anything other than `""`, it is called recursively.  -To do this, we need to be able to have `readTTY` return different values in a single test.  -To achieve this, create a mock with the `implicitMonadicReturn` option.-Using `implicitMonadicReturn` allows stub functions to explicitly return monadic values.-```haskell-makeMockWithOptions [t|Teletype|] options { implicitMonadicReturn = False }-```-This allows the test to use `onCase` to have a behavior where the first application returns a value other than `""` and the second application returns `""`.-```haskell-result <- runMockT do-  _readTTY $ do-    onCase $ pure @IO "a"-    onCase $ pure @IO ""--  _writeTTY $ "a" |> pure @IO ()-  echo-result `shouldBe` ()-```-### Partial mocking-The `makePartialMock` function can be used to mock only a part of a function defined in a typeclass.-For example, suppose you have the following typeclasses and functions.  -`getUserInput` is the function to be tested.-```haskell-data UserInput = UserInput String deriving (Show, Eq)--class Monad m => UserInputGetter m where-  getInput :: m String-  toUserInput :: String -> m (Maybe UserInput)--getUserInput :: UserInputGetter m => m (Maybe UserInput)-getUserInput = do-  i <- getInput-  toUserInput i-```-In this example, we want to use real functions, so we define an `IO` instance as follows.-```haskell-instance UserInputGetter IO where-  getInput = getLine-  toUserInput "" = pure Nothing-  toUserInput a = (pure . Just . UserInput) a-```-The test will look like this.-```haskell-makePartialMock [t|UserInputGetter|]--spec :: Spec-spec = do-  it "Get user input (has input)" do-    a <- runMockT do-      _getInput "value"-      getUserInput-    a `shouldBe` Just (UserInput "value")--  it "Get user input (no input)" do-    a <- runMockT do-      _getInput ""-      getUserInput-    a `shouldBe` Nothing-```-### Rename stub functions-The prefix and suffix of the generated stub functions can optionally be changed.  -For example, the following will generate the functions `stub_readFile_fn` and `stub_writeFile_fn`.-```haskell-makeMockWithOptions [t|FileOperation|] options { prefix = "stub_", suffix = "_fn" }-```-If no options are specified, it defaults to `_`.-### Code generated by makeMock-Although you do not need to be aware of it, the `makeMock` function generates the following code.-```haskell--- MockT instance-instance (Monad m) => FileOperation (MockT m) where-  readFile :: Monad m => FilePath -> MockT m Text-  writeFile :: Monad m => FilePath -> Text -> MockT m ()--_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), Monad m) => params -> MockT m ()-_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), Monad m) => params -> MockT m ()-```-## Mocking functions-In addition to mocking monad type classes, mockcat can also mock regular functions.  -Unlike monad type mocks, the original function is not required.-### Example usage-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "usage example" do-    -- create a mock (applying "value" returns the pure value True)-    mock <- createMock $ "value" |> True-    -- extract a stub function from a mock-    let stubFunction = stubFn mock-    -- verify the result of applying the function-    stubFunction "value" `shouldBe` True-    -- verify that the expected value ("value") has been applied-    mock `shouldApplyTo` "value"-```-## Stub functions-To create a stub function directly, use the `createStubFn` function.  -If you don't need verification, you can use this one.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "can generate stub functions" do-    -- generate-    f <- createStubFn $ "param1" |> "param2" |> pure @IO ()-    -- apply-    actual <- f "param1" "param2"-    -- Verification-    actual `shouldBe` ()-```-The `createStubFn` function is passed a sequence of `|>` arguments that the function is expected to apply.-The last value of `|>` is the return value of the function.-If the stub function is applied to an argument it is not expected to be applied to, an error is returned.-```console-Uncaught exception: ErrorCall-Expected arguments were not applied to the function.-  expected: "value"-  but got: "valuo"-```-### Named Stub Functions-You can name stub functions.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "named stub" do-  f <- createNamedStubFn "named stub" $ "x" |> "y" |> True-    f "x" "z" `shouldBe` True-```-The error message printed when a stub function is not applied to an expected argument will include this name.-```console-uncaught exception: ErrorCall-Expected arguments were not applied to the function `named stub`.-  expected: "x","y"-  but got: "x","z"-```-### Constant stub functions-To create a stub function that returns a constant, use the `createConstantMock` or `createNamedConstantMock` function.  -```haskell-spec :: Spec-spec = do-  it "createConstantMock" do-    m <- createConstantMock "foo"-    stubFn m `shouldBe` "foo"-    shouldApplyToAnything m-  it "createNamedConstantMock" do-    m <- createNamedConstantMock "const" "foo"-    stubFn m `shouldBe` "foo"-    shouldApplyToAnything m-```-### Flexible stub functions-Flexible stub functions can be generated by giving the `createStubFn` function a conditional expression rather than a concrete value.  -This can be used to return expected values for arbitrary values or strings that match a specific pattern.  -This is also true for the stub function when generating a mock of a monad type.-### any-any matches any value.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat-import Prelude hiding (any)--spec :: Spec-spec = do-  it "any" do-    f <- createStubFn $ any |> "return value"-    f "something" `shouldBe` "return value"-```-Since a function with the same name is defined in Prelude, we use import Prelude hiding (any).-### Condition Expressions-Using the expect function, you can handle arbitrary condition expressions.  -The expect function takes a condition expression and a label.  -The label is used in the error message if the condition is not met.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "expect" do-    f <- createStubFn $ expect (> 5) "> 5" |> "return value"-    f 6 `shouldBe` "return value"-```-### Condition Expressions without Labels-`expect_` is a label-free version of expect.  -The error message will show [some condition].-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "expect_" do-    f <- createStubFn $ expect_ (> 5) |> "return value"-    f 6 `shouldBe` "return value"-```-### Condition Expressions using Template Haskell-Using expectByExp, you can handle condition expressions as values of type Q Exp.  -The error message will include the string representation of the condition expression.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TemplateHaskell #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "expectByExpr" do-    f <- createStubFn $ $(expectByExpr [|(> 5)|]) |> "return value"-    f 6 `shouldBe` "return value"-```-### Stub functions that return different values for each argument applied-By applying the `createStubFn` function to a list of x |> y format, you can create a stub function that returns a different value for each argument you apply.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat-import Prelude hiding (and)--spec :: Spec-spec = do-  it "multi" do-    f <- createStubFn do-      onCase $ "a" |> "return x"-      onCase $ "b" |> "return y"-    f "a" `shouldBe` "return x"-    f "b" `shouldBe` "return y"-```-Alternatively, you can use the `cases` function.-```haskell-f <--  createStubFn $-    cases-      [ "a" |> "return x",-        "b" |> "return y"-      ]-f "a" `shouldBe` "return x"-f "b" `shouldBe` "return y"-```-### Stub functions that return different values when applied to the same argument-When the `createStubFn` function is applied to a list of x |> y format, with the same arguments but different return values, you can create stub functions that return different values when applied to the same arguments.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat-import GHC.IO (evaluate)--spec :: Spec-spec = do-  it "Return different values for the same argument" do-    f <- createStubFn $ do-      onCase $ "arg" |> "x"-      onCase $ "arg" |> "y"-    v1 <- evaluate $ f "arg"-    v2 <- evaluate $ f "arg"-    v3 <- evaluate $ f "arg"-    v1 `shouldBe` "x"-    v2 `shouldBe` "y"-    v3 `shouldBe` "y" -- After the second time, "y" is returned.-```-### Verify that expected arguments are applied-The `shouldApplyTo` function can be used to verify that a stub function has been applied to the expected arguments.  -If you want to verify this, you need to create a mock with the `createMock` function instead of the `createStubFn` function.  -In this case, stub functions are taken from the mock with the `stubFn` function.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "stub & verify" do-    mock <- createMock $ "value" |> True-    let stubFunction = stubFn mock-    stubFunction "value" `shouldBe` True-    mock `shouldApplyTo` "value"-```-### Note-The record that it has been applied is made at the time the return value of the stub function is evaluated.  -Therefore, verification must occur after the return value is evaluated.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "Verification does not work" do-    mock <- createMock $ "expect arg" |> "return value"-    let _ = stubFn mock "expect arg"-    mock `shouldApplyTo` "expect arg"-```-```console-uncaught exception: ErrorCall-Expected arguments were not applied to the function.-  expected: "expect arg"-  but got: Never been called.-```-### Verify the number of times the stub function was applied to the expected argument-The number of times a stub function is applied to an expected argument can be verified with the `shouldApplyTimes` function.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "shouldApplyTimes" do-    m <- createMock $ "value" |> True-    print $ stubFn m "value"-    print $ stubFn m "value"-    m `shouldApplyTimes` (2 :: Int) `to` "value"-```-### Verify that a function has been applied to something-You can verify that a function has been applied to something with the `shouldApplyToAnything` function.-### Verify the number of times a function has been applied to something-The number of times a function has been applied to something can be verified with the `shouldApplyTimesToAnything` function.-### Verify that stub functions are applied in the expected order-The `shouldApplyInOrder` function can be used to verify that the order in which they were applied is the expected order.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE Type Applications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "shouldApplyInOrder" do-    m <- createMock $ any |> True |> ()-    print $ stubFn m "a" True-    print $ stubFn m "b" True-    m-      `shouldApplyInOrder` [ "a" |> True,-                             "b" |> True-                           ]-```-### Verify that they were applied in the expected order (partial match)-While the `shouldApplyInOrder` function verifies the exact order of application,  -The `shouldApplyInPartialOrder` function allows you to verify that the order of application is partially matched.-```haskell-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}-import Test.Hspec-import Test.MockCat--spec :: Spec-spec = do-  it "shouldApplyInPartialOrder" do-    m <- createMock $ any |> True |> ()-    print $ stubFn m "a" True-    print $ stubFn m "b" True-    print $ stubFn m "c" True-    m-      `shouldApplyInPartialOrder` [ "a" |> True,-                                    "c" |> True-                                  ]-```-<!-- END FULL REFERENCE -->--</details>+    <img src="https://raw.githubusercontent.com/pujoheadsoft/mockcat/main/logo.png" width="600px" alt="Mockcat Logo">+    <h1>Declarative mocking with a single arrow <code>~&gt;</code></h1>+</div>++<div align="center">++[![Hackage](https://img.shields.io/hackage/v/mockcat.svg)](https://hackage.haskell.org/package/mockcat)+[![Stackage LTS](http://stackage.org/package/mockcat/badge/lts)](http://stackage.org/lts/package/mockcat)+[![Build Status](https://github.com/pujoheadsoft/mockcat/workflows/Test/badge.svg)](https://github.com/pujoheadsoft/mockcat/actions)++[🇯🇵 Japanese (日本語)](README-ja.md)++</div>++**Mockcat** is a lightweight, declarative mocking library for Haskell.  +By using the dedicated **Mock Arrow (`~>`)** operator, you can describe mock behavior with the same ease as defining standard functions.++```haskell+-- Define+f <- mock $ "input" ~> "output"++-- Verify+f `shouldBeCalled` "input"+```++---++## Concepts & Terminology++Mockcat adopts a design where "verification happens at runtime, but 'conditions to be met' can be declared at definition time."++*   **Stub**:+    Exists solely to keep the test moving by returning values. It does not care "how it was called".+    The `stub` function returns a completely pure function.++*   **Mock**:+    In addition to stubbing, it records and verifies "was it called as expected?".+    The `mock` function returns a value while recording calls. Verification can be done at the end of the test, or declared as "it must be called this way" at definition time.++---++## Why Mockcat?++There's no need to brace yourself when writing mocks in Haskell.++Mockcat is a mocking library that **"allows you to declaratively describe function behavior and intent without depending on specific architectures."**++"I can't test unless I introduce Typeclasses (MTL)."+"I have to define dedicated data types just for mocking."+(e.g., adding extra Typeclasses or Service Handle records just for testing)++You are freed from such constraints. You can mock existing functions as they are, and start writing tests even when the design isn't fully solidified.++**Mockcat aims to let you write tests to explore design, rather than forcing you to fixate the design just for testing.**++### Before / After++See how simple writing tests in Haskell can be.++| | **Before: Handwritten...** 😫 | **After: Mockcat** 🐱✨ |+| :--- | :--- | :--- |+| **Definition (Stub)**<br>"I want to return<br>this value for this arg" | <pre lang="haskell">f :: String -> IO String<br>f arg = case arg of<br>  "a" -> pure "b"<br>  _   -> error "unexpected"</pre><br>_Even simple branching consumes many lines._ | <pre lang="haskell">-- Use stub if verification is unneeded (Pure)<br>let f = stub $<br>  "a" ~> "b"<br><br><br></pre><br>_Behaves as a completely pure function._ |+| **Verification (Verify)**<br>"I want to test<br>if it was called correctly" | <pre lang="haskell">-- Need to implement recording logic<br>ref <- newIORef []<br>let f arg = do<br>      modifyIORef ref (arg:)<br>      ...<br><br>-- Verification logic<br>calls <- readIORef ref<br>calls \`shouldBe\` ["a"]</pre><br>_※ This is just one example. Real-world setups often require even more boilerplate._ | <pre lang="haskell">-- Use mock if verification is needed (Recorded internally)<br>f <- mock $ "a" ~> "b"<br><br>-- Just state what you want to verify<br>f \`shouldBeCalled\` "a"</pre><br>_Recording is automatic.<br>Focus on the "Why" and "What", not the "How"._ |++### Key Features++*   **Haskell Native DSL**: No need to memorize redundant data constructors or specialized notation. Write mocks naturally, just like function definitions (`arg ~> return`).+*   **Architecture Agnostic**: Whether using MTL (Typeclasses), Service Handle (Records), or pure functions—Mockcat adapts to your design choice with minimal friction.+*   **Verify by "Condition", not just Value**: Works even if arguments lack `Eq` instances. You can verify based on "what properties it should satisfy" (Predicates) rather than just strict equality.+*   **Helpful Error Messages**: Shows "structural diffs" on failure, highlighting exactly what didn't match.+    ```text+    Expected arguments were not called.+      expected: [Record { name = "Alice", age = 20 }]+       but got: [Record { name = "Alice", age = 21 }]+                                                ^^+    ```+*   **Intent-Driven Types**: Types exist not to restrict you, but to naturally guide you in expressing your testing intent.+++---++## Quick Start++Copy and paste the code below to experience Mockcat right now.++### Installation++`package.yaml`:+```yaml+dependencies:+  - mockcat+```++Or `.cabal`:+```cabal+build-depends:+    mockcat+```++### First Test (`Main.hs` / `Spec.hs`)++```haskell+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications #-}+import Test.Hspec+import Test.MockCat++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  it "Quick Start Demo" do+    -- 1. Create a mock (Return 42 when receiving "Hello")+    f <- mock $ "Hello" ~> (42 :: Int)++    -- 2. Use it as a function+    let result = f "Hello"+    result `shouldBe` 42++    -- 3. Verify it was called+    f `shouldBeCalled` "Hello"+```++---++### At a Glance: Matchers+| Matcher | Description | Example |+| :--- | :--- | :--- |+| **`any`** | Matches any value | `f <- mock $ any ~> True` |+| **`expect`** | Matches condition | `f <- mock $ expect (> 5) "gt 5" ~> True` |+| **`"val"`** | Matches value (Eq) | `f <- mock $ "val" ~> True` |+| **`inOrder`** | Order verification | ``f `shouldBeCalled` inOrderWith ["a", "b"]`` |+| **`inPartial`**| Partial order | ``f `shouldBeCalled` inPartialOrderWith ["a", "c"]`` |++---++## User Guide++Mockcat supports two verification styles depending on your testing needs and preferences.++1.  **Post-Verification Style (Spy)**:+    Define mock behavior, run the code, and verify afterwards using `shouldBeCalled`.  +    Ideal for exploratory testing or simple setups. (Used mainly in Sections 1 & 2 below)+2.  **Pre-Expectation Style (Declarative/Expectation)**:+    Describe "how it should be called" at the definition time.  +    Ideal for strict interaction testing. (Explained in Section 3)++### 1. Function Mocking (`mock`) - [Basic]++The most basic usage. Creates a function that returns values for specific arguments.++```haskell+-- Function that returns True for "a" -> "b"+f <- mock $ "a" ~> "b" ~> True+```++**Flexible Matching**:+You can specify conditions (predicates) instead of concrete values.++```haskell+-- Arbitrary string (param any)+f <- mock $ any ~> True++-- Condition (expect)+f <- mock $ expect (> 5) "> 5" ~> True+```++### 2. Typeclass Mocking (`makeMock`)++Useful when you want to bring existing typeclasses directly into your tests. Generates mocks from existing typeclasses using Template Haskell.++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}++class Monad m => FileSystem m where+  readFile :: FilePath -> m String+  writeFile :: FilePath -> String -> m ()++-- [Strict Mode] Default behavior. Consistent with 'mock'.+-- If the return type is `m a`, the stub definition must return a value of type `m a` (e.g., `pure @IO "value"`, `throwIO Error`).+-- Recommended when you prefer explicit descriptions faithful to Haskell's type system.+makeMock [t|FileSystem|]++-- [Auto-Lift Mode] Convenience-focused mode.+-- Automatically wraps pure values into the monad (m String).+makeAutoLiftMock [t|FileSystem|]+```++Use `runMockT` block in your tests.++```haskell+spec :: Spec+spec = do+  it "filesystem test" do+    result <- runMockT do+      -- [Strict Mode] (if using makeMock)+      _readFile $ "config.txt" ~> pure @IO "debug=true"+      _writeFile $ "log.txt" ~> "start" ~> pure @IO ()++      -- [Auto-Lift Mode] (if using makeAutoLiftMock)+      -- _readFile $ "config.txt" ~> "debug=true"++      -- Run code under test (mock injected)+      myProgram "config.txt"+    +    result `shouldBe` ()+```++### 3. Declarative Verification (`withMock` / `expects`)++A style where you describe expectations at definition time. Verification runs automatically when exiting the scope.+Useful when you want "Definition" and "Verification" to be written close together.++```haskell+withMock $ do+  -- Write expectations (expects) at definition time+  f <- mock (any ~> True)+    `expects` do+      called once `with` "arg"++  -- Execution+  f "arg"+```++> [!NOTE]+> You can also use `expects` for declarative verification inside `runMockT` blocks.+> This provides a unified experience where "Mock Creation" and "Expectation Declaration" complete within a single block.++### 4. Flexible Verification (Matchers)++Even if arguments don't have `Eq` instances, or you don't want to depend on specific values, you can verify based on **intent**—"what condition should be met".+Mockcat provides **matchers** to verify properties of functions, not just value equality.++#### Allow Any Value (`any`)++```haskell+-- Return True regardless of the argument+f <- mock $ any ~> True++-- Verify that it was called (arguments don't matter)+f `shouldBeCalled` any+```++#### Verify with Conditions (`expect`)++You can verify using "conditions (predicates)" instead of arbitrary values.+Powerfully useful for types without `Eq` (like functions) or when checking partial matches.++```haskell+-- Return False only if the argument starts with "error"+f <- mock $ do+  onCase $ expect (\s -> "error" `isPrefixOf` s) "start with error" ~> False+  onCase $ any ~> True+```++### 5. Advanced Features - [Advanced]++#### mock vs stub vs mockM++In most cases, **`mock`** is all you need.+Consider other functions only when you need finer control.++| 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. |+| **`mockM`** | ✅ | Yes (Explicit) | **Monadic Mock**. Used within `MockT` or `IO`, allowing explicit handling of side effects (e.g., logging). |++#### Partial Mocking: Mixing with Real Functions++Useful when you want to replace only some methods with mocks while using real implementations for others.++```haskell+-- [Strict Mode]+makePartialMock [t|FileSystem|]++-- [Auto-Lift Mode]+-- Just like makeAutoLiftMock, there is an Auto-Lift version for Partial Mock.+makeAutoLiftPartialMock [t|FileSystem|]++instance FileSystem IO where ... -- Real instance is also required++test = runMockT do+  _readFile $ "test" ~> pure @IO "content" -- Only mock readFile (Strict)+  -- or+  -- _readFile $ "test" ~> "content" -- (Auto-Lift)++  program -- writeFile runs the real IO instance+```++#### Monadic Return (`IO a`)++Used when you want a function returning `IO` to have different side effects (results) for each call.++```haskell+f <- mock $ do+  onCase $ "get" ~> pure @IO 1 -- 1st call+  onCase $ "get" ~> pure @IO 2 -- 2nd call+```++#### Named Mocks++You can attach labels to display function names in error messages.++```haskell+f <- mock (label "myAPI") $ "arg" ~> True+```++---++## Encyclopedia (Feature Reference)++※ Use this section as a dictionary when you get stuck.++### Verification Matchers (`shouldBeCalled`)++| Matcher | Description | Example |+| :--- | :--- | :--- |+| `x` (Value itself) | Was called with that value | ``f `shouldBeCalled` (10 :: Int)`` |+| `times n` | Exact count | ``f `shouldBeCalled` (times 3 `with` "arg")`` |+| `once` | Exactly once | ``f `shouldBeCalled` (once `with` "arg")`` |+| `never` | Never called | ``f `shouldBeCalled` never`` |+| `atLeast n` | n or more times | ``f `shouldBeCalled` atLeast 2`` |+| `atMost n` | n or fewer times | ``f `shouldBeCalled` atMost 5`` |+| `anything` | Any argument (count ignored) | ``f `shouldBeCalled` anything`` |+| `inOrderWith [...]` | Strict order | ``f `shouldBeCalled` inOrderWith ["a", "b"]`` |+| `inPartialOrderWith [...]` | Partial order (skips allowed) | ``f `shouldBeCalled` inPartialOrderWith ["a", "c"]`` |++### Parameter Matchers (Definition)++| Matcher | Description | Example |+| :--- | :--- | :--- |+| `any` | Any value | `any ~> True` |+| `expect pred label` | Condition | `expect (>0) "positive" ~> True` |+| `expect_ pred` | No label | `expect_ (>0) ~> True` |++### Declarative Verification DSL (`expects`)++In `expects` blocks, you can describe expectations declaratively.+The syntax used in `expects` shares the same vocabulary as `shouldBeCalled`.++| Syntax | Description |+| :--- | :--- |+| `called` | Start expectation |+| `once` | Called exactly once |+| `times n` | Called n times |+| `never` | Never called |+| `with arg` | Expected argument |+| `with matcher` | Argument verification with matcher |++### FAQ++<details>+<summary><strong>Q. How are unevaluated lazy values handled?</strong></summary>+A. They are not counted. Mockcat records calls only "when the result is evaluated" (Honest Laziness). This prevents false positives from unneeded calculations.+</details>++<details>+<summary><strong>Q. Can I use it in parallel tests?</strong></summary>+A. Yes. Internally uses `TVar` to count atomically, so it records accurately even when called in parallel via `mapConcurrently`, etc.+</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>++<details>+<summary><strong>Q. Isn't this strictly a Spy?</strong></summary>+A. Yes, according to definitions like xUnit Patterns, Mockcat's mocks which verify after execution are classified as **Test Spies**.<br>+However, since many modern libraries (Jest, Mockito, etc.) group these under "Mock", and to avoid confusion from terminology proliferation, this library unifies them under the term **"Mock"**.+</details>++## Tips and Troubleshooting++### Name collision with `Prelude.any`+The `any` parameter matcher from `Test.MockCat` may conflict with `Prelude.any`.+To resolve this, hide `any` from Prelude or use a qualified name.++```haskell+import Prelude hiding (any)+-- or+import qualified Test.MockCat as MC+```++### Ambiguous types with `OverloadedStrings`+If you have `OverloadedStrings` enabled, string literals may cause ambiguity errors.+Add explicit type annotations to resolve this.++```haskell+mock $ ("value" :: String) ~> True+```++---++## Tested Versions+mockcat is continuously tested in CI across these configurations:++| GHC | Cabal | OS |+|-----|-------|----|+| 9.2.8 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows |+| 9.4.8 | 3.10.3.0 / 3.12.1.0 | Ubuntu, macOS, Windows |+| 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 |++_Happy Mocking!_ 🐱

@@ -1,24 +1,14 @@ 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:        0.6.0.0-synopsis:       Mock library for test in Haskell.-description:    mockcat is a small mocking / stubbing DSL for Haskell tests.-                .-                Features:-                .-                * Describe expectations with left-to-right pipelines: `arg |> ... |> result`-                * Generate typeclass mocks via Template Haskell (`makeMock`, `makePartialMock`)-                * Create standalone function stubs (`createStubFn`, constant mocks)-                * Flexible return behaviour: vary by argument or occurrence (including identical args later)-                * Optional per-call variation for `IO a` results-                * Concurrency-safe counting and explicit lazy semantics (unevaluated results are not recorded)-                * Simple verification helpers (apply count predicates, ordering checks)-                * Partial adoption: mock only selected methods; no hidden global state+version:        1.0.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.                 .                 See README for full examples: <https://github.com/pujoheadsoft/mockcat#readme> category:       Testing@@ -26,7 +16,7 @@ bug-reports:    https://github.com/pujoheadsoft/mockcat/issues author:         funnycat <pujoheadsoft@gmail.com> maintainer:     funnycat <pujoheadsoft@gmail.com>-copyright:      2024 funnycat+copyright:      2025 funnycat license:        MIT license-file:   LICENSE build-type:     Simple@@ -50,10 +40,22 @@       Test.MockCat       Test.MockCat.AssociationList       Test.MockCat.Cons+      Test.MockCat.Internal.Builder+      Test.MockCat.Internal.Message+      Test.MockCat.Internal.MockRegistry+      Test.MockCat.Internal.Registry.Core+      Test.MockCat.Internal.Types       Test.MockCat.Mock       Test.MockCat.MockT       Test.MockCat.Param       Test.MockCat.TH+      Test.MockCat.TH.ClassAnalysis+      Test.MockCat.TH.ContextBuilder+      Test.MockCat.TH.FunctionBuilder+      Test.MockCat.TH.Types+      Test.MockCat.TH.TypeUtils+      Test.MockCat.Verify+      Test.MockCat.WithMock   other-modules:       Paths_mockcat   hs-source-dirs:@@ -61,7 +63,9 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -fprint-potential-instances -Wredundant-constraints   build-depends:       base >=4.7 && <5-    , mtl >=2.3.1 && <2.4+    , containers >=0.6 && <0.8+    , mtl >=2.2.2 && <2.4+    , stm ==2.5.*     , template-haskell >=2.18 && <2.24     , text >=2.0 && <2.2     , transformers >=0.5.6 && <0.7@@ -83,20 +87,36 @@       Property.ParamSpecRangeMergeRandomProp       Property.ReinforcementProps       Property.ScriptProps+      ReadmeVerifySpec       Support.ParamSpec       Support.ParamSpecNormalize       Test.MockCat.AssociationListSpec       Test.MockCat.ConcurrencySpec       Test.MockCat.ConsSpec-      Test.MockCat.Definition+      Test.MockCat.ErrorDiffSpec       Test.MockCat.ExampleSpec       Test.MockCat.Impl+      Test.MockCat.Internal.MockRegistrySpec       Test.MockCat.MockSpec+      Test.MockCat.MockTSpec       Test.MockCat.ParamSpec+      Test.MockCat.PartialMockCommonSpec       Test.MockCat.PartialMockSpec       Test.MockCat.PartialMockTHSpec+      Test.MockCat.SharedSpecDefs+      Test.MockCat.ShouldBeCalledMockMSpec+      Test.MockCat.ShouldBeCalledSpec+      Test.MockCat.StubSpec+      Test.MockCat.TH.ClassAnalysisSpec+      Test.MockCat.TH.ContextBuilderSpec+      Test.MockCat.TH.FunctionBuilderSpec+      Test.MockCat.TH.TypeUtilsSpec+      Test.MockCat.THCompareSpec+      Test.MockCat.TypeClassCommonSpec       Test.MockCat.TypeClassSpec       Test.MockCat.TypeClassTHSpec+      Test.MockCat.UnsafeCheck+      Test.MockCat.WithMockSpec       Paths_mockcat   hs-source-dirs:       test@@ -105,10 +125,13 @@       QuickCheck >=2.14 && <2.17     , async >=2.2.4 && <2.3     , base >=4.7 && <5+    , containers >=0.6 && <0.8     , hashable >=1.4 && <1.6     , hspec >=2.11 && <2.13+    , inspection-testing >=0.4 && <0.6     , mockcat-    , mtl >=2.3.1 && <2.4+    , mtl >=2.2.2 && <2.4+    , stm ==2.5.*     , template-haskell >=2.18 && <2.24     , text >=2.0 && <2.2     , transformers >=0.5.6 && <0.7

@@ -1,9 +1,52 @@+{-|+Module      : Test.MockCat+Description : Declarative mocking with a single arrow '~>'+Copyright   : (c) Setup, 2025+License     : MIT+Maintainer  : kenji++MOCKCAT is a lightweight, declarative mocking library for Haskell.+It provides a unified way to create stubs and mocks using the dedicated 'Mock Arrow' operator ('~>').++= Quick Start++> {-# LANGUAGE BlockArguments #-}+> import Test.Hspec+> import Test.MockCat+>+> spec :: Spec+> spec = do+>   it "Quick Start" do+>     -- 1. Create a mock ('Hello' -> 42)+>     f <- mock $ "Hello" ~> (42 :: Int)+>+>     -- 2. Use it+>     f "Hello" `shouldBe` 42+>+>     -- 3. Verify it was called+>     f `shouldBeCalled` "Hello"++= Concepts++* __Stub__: A pure function ('stub') that stands in for a dependency. It returns fixed values but does not record calls.+* __Mock__: A verifiable function ('mock' / 'mockM') that records its interactions. Use 'shouldBeCalled' to verify them.+* __Mock Arrow ('~>')__: The core operator for defining expectations. @arg1 ~> arg2 ~> result@.++= Main Components++* "Test.MockCat.Mock": Core functions for creating mocks and stubs ('mock', 'stub').+* "Test.MockCat.Param": Parameter matchers ('any', 'expect', '~>').+* "Test.MockCat.Verify": Verification functions ('shouldBeCalled', 'once', 'times').+* "Test.MockCat.TH": Template Haskell generators for typeclasses ('makeMock').++-} module Test.MockCat   ( module Test.MockCat.Mock,     module Test.MockCat.Cons,     module Test.MockCat.Param,     module Test.MockCat.MockT,-    module Test.MockCat.TH+    module Test.MockCat.TH,+    module Test.MockCat.WithMock   ) where @@ -12,3 +55,4 @@ import Test.MockCat.Param import Test.MockCat.MockT import Test.MockCat.TH+import Test.MockCat.WithMock

@@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}-module Test.MockCat.Cons ((:>)(..)) where+module Test.MockCat.Cons ((:>)(..), Head(..)) where  data a :> b = a :> b @@ -11,3 +11,9 @@   (a :> b) == (a2 :> b2) = (a == a2) && (b == b2)  infixr 8 :>++-- | Marker type for constant value mock functions.+--   Used to distinguish constant values (Head :> Param r) from+--   regular mock functions (Param a :> rest).+data Head = Head+  deriving (Eq, Show)

@@ -0,0 +1,444 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use null" #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+module Test.MockCat.Internal.Builder where+++import Control.Concurrent.STM+  ( TVar+  , atomically+  , modifyTVar'+  , newTVarIO+  , readTVar+  , readTVarIO+  , writeTVar+  )+import Data.Maybe+import Test.MockCat.Cons (Head(..), (:>)(..))+import Test.MockCat.Param+import Test.MockCat.AssociationList (lookup, update, insert, empty, member)+import Prelude hiding (lookup)+import Control.Monad.State+import Test.MockCat.Internal.Types+import Test.MockCat.Internal.Message++-- | Class for building a curried function.+-- The purpose of this class is to automatically generate and provide+-- an implementation for the corresponding curried function type (such as `a -> b -> ... -> IO r`)+-- when given the argument list type of the mock (`Param a :> Param b :> ...`).+-- @args@ is the argument list type of the mock.+-- @r@ is the return type of the function.+-- @fn@ is the curried function type.+class BuildCurried args r fn | args r -> fn where+  buildCurriedImpl :: (args -> IO r) -> fn++-- | Build a curried function that returns an IO result.+buildCurried :: forall args r fn. BuildCurried args r fn => (args -> IO r) -> fn+buildCurried = buildCurriedImpl++instance (WrapParam a, fn ~ (a -> r)) => BuildCurried (Param a) r fn where+  buildCurriedImpl f a = perform (f (wrap a))++instance+  ( BuildCurried rest r fn+  , WrapParam a+  , fn' ~ (a -> fn)+  ) =>+  BuildCurried (Param a :> rest) r fn'+  where+  buildCurriedImpl input a =+    buildCurriedImpl @rest @r @fn (input . (\rest -> wrap a :> rest))++-- | Class for building a curried pure function without relying on IO.+class BuildCurriedPure args r fn | args r -> fn where+  buildCurriedPureImpl :: (args -> r) -> fn++-- | Build a curried function that returns a pure result.+buildCurriedPure :: forall args r fn. BuildCurriedPure args r fn => (args -> r) -> fn+buildCurriedPure = buildCurriedPureImpl++instance (WrapParam a, fn ~ (a -> r)) => BuildCurriedPure (Param a) r fn where+  buildCurriedPureImpl f a = f (wrap a)++instance+  ( BuildCurriedPure rest r fn+  , WrapParam a+  , fn' ~ (a -> fn)+  ) =>+  BuildCurriedPure (Param a :> rest) r fn'+  where+  buildCurriedPureImpl input a =+    buildCurriedPureImpl @rest @r @fn (input . (\rest -> wrap a :> rest))++-- | Class for building a curried function whose result stays in IO.+class BuildCurriedIO args r fn | args r -> fn where+  buildCurriedIOImpl :: (args -> IO r) -> fn++-- | Build a curried IO function without hiding the IO layer.+buildCurriedIO :: forall args r fn. BuildCurriedIO args r fn => (args -> IO r) -> fn+buildCurriedIO = buildCurriedIOImpl++instance (WrapParam a, fn ~ (a -> IO r)) => BuildCurriedIO (Param a) r fn where+  buildCurriedIOImpl f a = f (wrap a)++instance+  ( BuildCurriedIO rest r fn+  , WrapParam a+  , fn' ~ (a -> fn)+  ) =>+  BuildCurriedIO (Param a :> rest) r fn'+  where+  buildCurriedIOImpl input a =+    buildCurriedIOImpl @rest @r @fn (input . (\rest -> wrap a :> rest))++-- | Class for creating a stub corresponding to the parameter description.+class MockBuilder params fn verifyParams | params -> fn, params -> verifyParams where+  build ::+    MonadIO m =>+    Maybe MockName ->+    params ->+    m (BuiltMock fn verifyParams)++-- | New name for `build` to make intent explicit.+--   `buildMock` constructs a mock function and its verifier.+buildMock ::+  ( MonadIO m+  , MockBuilder params fn verifyParams+  ) =>+  Maybe MockName ->+  params ->+  m (BuiltMock fn verifyParams)+buildMock = build++-- | Instance for building a stub for a constant IO action.+instance+  MockBuilder (IO r) (IO r) ()+  where+  build _ action = do+    ref <- liftIO $ newTVarIO invocationRecord+    let+      fn = do+        result <- action+        liftIO $ appendCalledParams ref ()+        pure result+      recorder = InvocationRecorder ref IOConstant+    pure (BuiltMock fn recorder)++-- | Instance for building a stub for a constant value (with Head marker).+instance+  MockBuilder (Head :> Param r) r ()+  where+  build _ (Head :> params) = do+    ref <- liftIO $ newTVarIO invocationRecord+    let v = value params+        fn = perform $ do+          liftIO $ appendCalledParams ref ()+          pure v+        recorder = InvocationRecorder ref PureConstant+    pure (BuiltMock fn recorder)++-- | Instance for building a stub for a value (backward compatibility).+instance+  MockBuilder (Param r) r ()+  where+  build _ params = do+    ref <- liftIO $ newTVarIO invocationRecord+    let v = value params+        fn = perform $ do+          liftIO $ appendCalledParams ref ()+          pure v+        recorder = InvocationRecorder ref PureConstant+    pure (BuiltMock fn recorder)++-- | Instance for building a stub for `Cases (IO a) ()`.+instance MockBuilder (Cases (IO a) ()) (IO a) () where+  build _ cases = do+    let params = runCase cases+    ref <- liftIO $ newTVarIO invocationRecord+    let fn = do+          count <- readInvocationCount ref ()+          let index = min count (length params - 1)+              r = safeIndex params index+          appendCalledParams ref ()+          incrementInvocationCount ref ()+          fromJust r+        recorder = InvocationRecorder ref IOConstant+    pure (BuiltMock fn recorder)++-- | Overlapping instance for building a stub when parameters are provided as 'Cases'.+instance {-# OVERLAPPABLE #-}+  ( ParamConstraints params args r+  , BuildCurried args r fn+  ) => MockBuilder (Cases params ()) fn args where+  build name cases = do+    let paramsList = runCase cases+    buildWithRecorder (\ref inputParams -> executeInvocation ref (casesInvocationStep name paramsList inputParams))++-- | Overlapping instance for building a stub defined via chained 'Param'.+instance {-# OVERLAPPABLE #-}+  ( p ~ (Param a :> rest)+  , ParamConstraints p args r+  , BuildCurried args r fn+  ) => MockBuilder (Param a :> rest) fn args where+  build name params =+    buildWithRecorder (\ref inputParams -> executeInvocation ref (singleInvocationStep name params inputParams))++-- | Class for building mocks whose resulting functions stay in IO.+class MockIOBuilder params fn verifyParams | params -> fn, params -> verifyParams where+  buildIO ::+    MonadIO m =>+    Maybe MockName ->+    params ->+    m (BuiltMock fn verifyParams)++instance {-# OVERLAPPABLE #-}+  ( ParamConstraints params args r+  , BuildCurriedIO args r fn+  ) => MockIOBuilder (Cases params ()) fn args where+  buildIO name cases = do+    let paramsList = runCase cases+    buildWithRecorderIO (\ref inputParams -> executeInvocation ref (casesInvocationStep name paramsList inputParams))++instance {-# OVERLAPPABLE #-}+  ( p ~ (Param a :> rest)+  , ParamConstraints p args r+  , BuildCurriedIO args r fn+  ) => MockIOBuilder (Param a :> rest) fn args where+  buildIO name params =+    buildWithRecorderIO (\ref inputParams -> executeInvocation ref (singleInvocationStep name params inputParams))+++buildWithRecorder ::+  ( MonadIO m+  , BuildCurried args r fn+  ) =>+  (TVar (InvocationRecord args) -> args -> IO r) ->+  m (BuiltMock fn args)+buildWithRecorder handler = do+  ref <- liftIO $ newTVarIO invocationRecord+  let fn = buildCurried (handler ref)+      recorder = InvocationRecorder ref ParametricFunction+  pure (BuiltMock fn recorder)++buildWithRecorderIO ::+  ( MonadIO m+  , BuildCurriedIO args r fn+  ) =>+  (TVar (InvocationRecord args) -> args -> IO r) ->+  m (BuiltMock fn args)+buildWithRecorderIO handler = do+  ref <- liftIO $ newTVarIO invocationRecord+  let fn = buildCurriedIO (handler ref)+      recorder = InvocationRecorder ref ParametricFunction+  pure (BuiltMock fn recorder)++invocationRecord :: InvocationRecord params+invocationRecord =+  InvocationRecord+    { invocations = mempty+    , invocationCounts = empty+    }++appendCalledParams :: TVar (InvocationRecord params) -> params -> IO ()+appendCalledParams ref inputParams =+  atomically $+    modifyTVar' ref $ \record ->+      record+        { invocations = invocations record ++ [inputParams]+        }++readInvocationCount :: Eq params => TVar (InvocationRecord params) -> params -> IO Int+readInvocationCount ref params = do+  record <- readTVarIO ref+  pure $ fromMaybe 0 (lookup params (invocationCounts record))++incrementInvocationCount :: Eq params => TVar (InvocationRecord params) -> params -> IO ()+incrementInvocationCount ref inputParams =+  atomically $+    modifyTVar' ref $ \record ->+      record+        { invocationCounts = incrementCount inputParams (invocationCounts record)+        }++incrementCount :: Eq k => k -> InvocationCounts k -> InvocationCounts k+incrementCount key list =+  if member key list then update (+ 1) key list+  else insert key 1 list++runCase :: Cases a b -> [a]+runCase (Cases s) = execState s []++p :: (Show a, Eq a) => a -> Param a+p v = ExpectValue v (show v)++class StubBuilder params fn | params -> fn where+  buildStub :: Maybe MockName -> params -> fn++-- | Instance for building a mock for a constant function.+instance+  StubBuilder (IO r) (IO r)+  where+  buildStub _ = id++-- | Instance for building a mock for a function with a single parameter.+instance+  StubBuilder (Param r) r+  where+  buildStub _ = value++-- | Instance for building a mock for a function with multiple parameters.+instance StubBuilder (Cases (IO a) ()) (IO a) where+  buildStub _ cases = do+    let params = runCase cases+    s <- liftIO $ newTVarIO invocationRecord+    (do+      count <- readInvocationCount s ()+      let index = min count (length params - 1)+          r = safeIndex params index+      appendCalledParams s ()+      incrementInvocationCount s ()+      fromJust r)++-- | Overlapping instance for building a mock for a function with multiple parameters.+-- This instance is used when the parameter type is a 'Cases' type.+instance {-# OVERLAPPABLE #-}+  ( ParamConstraints params args r+  , BuildCurried args r fn+  , BuildCurriedPure args r fn+  ) => StubBuilder (Cases params ()) fn where+  buildStub name cases = do+    let paramsList = runCase cases+    buildCurriedPure (findReturnValueWithPure name paramsList)++instance {-# OVERLAPPABLE #-}+  ( p ~ (Param a :> rest)+  , ParamConstraints p args r+  , BuildCurried args r fn+  , BuildCurriedPure args r fn+  ) => StubBuilder (Param a :> rest) fn where+  buildStub name params = buildCurriedPure (extractReturnValue name params)++type ParamConstraints params args r =+  ( ProjectionArgs params+  , ProjectionReturn params+  , ArgsOf params ~ args+  , ReturnOf params ~ Param r+  , Eq args+  , Show args+  )++extractReturnValue :: ParamConstraints params args r => Maybe MockName -> params -> args -> r+extractReturnValue name params inputParams = do+  validateOnly name (projArgs params) inputParams `seq` returnValue params++validateOnly :: (Eq a, Show a) => Maybe MockName -> a -> a -> ()+validateOnly name expected actual = do+  validateParamsPure name expected actual++validateParamsPure :: (Eq a, Show a) => Maybe MockName -> a -> a -> ()+validateParamsPure name expected actual =+  if expected == actual+    then ()+    else errorWithoutStackTrace $ message name expected actual++findReturnValueWithPure ::+  ( ParamConstraints params args r+  ) =>+  Maybe MockName ->+  InvocationList params ->+  args ->+  r+findReturnValueWithPure name paramsList inputParams = do+  let+    expectedArgs = projArgs <$> paramsList+    r = findReturnValuePure paramsList inputParams+  fromMaybe (errorWithoutStackTrace $ messageForMultiMock name expectedArgs inputParams) r++findReturnValuePure ::+  ( ParamConstraints params args r+  ) =>+  InvocationList params ->+  args ->+  Maybe r+findReturnValuePure paramsList inputParams = do+  let matchedParams = filter (\params -> projArgs params == inputParams) paramsList+  case matchedParams of+    [] -> Nothing+    _ -> do+      returnValue <$> safeIndex matchedParams 0++type InvocationStep args r = InvocationRecord args -> (InvocationRecord args, Either Message r)++executeInvocation ::+  TVar (InvocationRecord args) ->+  InvocationStep args r ->+  IO r+executeInvocation ref step = do+  result <-+    atomically $ do+      current <- readTVar ref+      let (next, outcome) = step current+      writeTVar ref next+      pure outcome+  either errorWithoutStackTrace pure result++singleInvocationStep ::+  ParamConstraints params args r =>+  Maybe MockName ->+  params ->+  args ->+  InvocationStep args r+singleInvocationStep name params inputParams record@InvocationRecord {invocations, invocationCounts} = do+  let expected = projArgs params+  if expected == inputParams+    then+      (InvocationRecord {+        invocations = invocations ++ [inputParams]+      , invocationCounts = invocationCounts+      }, Right (returnValue params))+    else (record, Left $ message name expected inputParams)++casesInvocationStep ::+  ParamConstraints params args r =>+  Maybe MockName ->+  InvocationList params ->+  args ->+  InvocationStep args r+casesInvocationStep name paramsList inputParams InvocationRecord {invocations, invocationCounts} = do+  let newInvocations = invocations ++ [inputParams]+      matchedParams = filter (\params -> projArgs params == inputParams) paramsList+      expectedArgs = projArgs <$> paramsList+    in case matchedParams of+        [] ->+          ( InvocationRecord {invocations = newInvocations, invocationCounts},+            Left (messageForMultiMock name expectedArgs inputParams)+          )+        _ ->+          let calledCount = fromMaybe 0 (lookup inputParams invocationCounts)+              index = min calledCount (length matchedParams - 1)+              nextCounter = incrementCount inputParams invocationCounts+              nextRecord =+                InvocationRecord+                  { invocations = newInvocations,+                    invocationCounts = nextCounter+                  }+            in case safeIndex matchedParams index of+                Nothing ->+                  ( nextRecord,+                    Left (messageForMultiMock name expectedArgs inputParams)+                  )+                Just selected ->+                  (nextRecord, Right (returnValue selected))

@@ -0,0 +1,278 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+module Test.MockCat.Internal.Message where++import Data.List (intercalate, maximumBy, elemIndex)+import Data.Ord (comparing)+import Data.Char (isLower)+import Data.Text (pack, replace, unpack)+import Test.MockCat.Internal.Types++message :: Show a => Maybe MockName -> a -> a -> String+message name expected actual =+  let expectedStr = formatStr (show expected)+      actualStr = formatStr (show actual)+      diffLine = "            " <> diffPointer expectedStr actualStr+      mainMessage = "function" <> mockNameLabel name <> " was not called with the expected arguments."+   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+                 ]++diffPointer :: String -> String -> String+diffPointer expected actual =+  let commonPrefixLen = length $ takeWhile id $ zipWith (==) expected actual+      diffLen = max (length expected) (length actual) - commonPrefixLen+   in replicate commonPrefixLen ' ' <> replicate diffLen '^'++mockNameLabel :: Maybe MockName -> String+mockNameLabel = maybe mempty (" " <>) . enclose "`"++enclose :: String -> Maybe String -> Maybe String+enclose e = fmap (\v -> e <> v <> e)++-- Normalize a show-produced string for consistency in diffs+formatStr :: String -> String+formatStr s+  | null s = s+  | head s == '(' && last s == ')' = "(" <> formatInner (init (tail s)) <> ")"+  | head s == '[' && last s == ')' = "[" <> formatInner (init (tail s)) <> "]" -- Wait, mismatch parens? No, just typo in my thought.+  | head s == '[' && last s == ']' = "[" <> formatInner (init (tail s)) <> "]"+  | head s == '{' && last s == '}' = "{" <> formatInner (init (tail s)) <> "}"+  | otherwise = formatInner s+  where+    formatInner inner =+      let tokens = map (trim . quoteToken . trim) (splitByComma inner)+       in intercalate ", " tokens++-- Helper: quote a token if it looks like an unquoted alpha token+quoteToken :: String -> String+quoteToken s+  | null s = s+  | head s == '"' = s+  | head s == '(' = s+  | head s == '[' = s+  | any isSpecial s = s -- Don't quote if it contains special characters indicating it's not a simple token+  | not (null s) && isLower (head s) = '"' : s ++ "\""+  | otherwise = s+  where+    isSpecial c = c `elem` "{}= "++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+        [] ->+           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,+    diffExpected :: String,+    diffActual :: String+  }+  deriving (Show, Eq)++formatDifferences :: [Difference] -> String+formatDifferences [d] = +  let label = if null (diffPath d) then "Specific difference:" else "Specific difference in `" <> diffPath d <> "`:"+   in intercalate "\n"+        [ "  " <> label,+          "    expected: " <> diffExpected d,+          "     but got: " <> diffActual d,+          "              " <> diffPointer (diffExpected d) (diffActual d)+        ]+formatDifferences ds = +  "  Specific differences:\n" <> intercalate "\n" (map formatDiff ds)+  where+    formatDiff d =+      let pathLabel = if null (diffPath d) then "root" else "`" <> diffPath d <> "`"+       in intercalate "\n"+            [ "    - " <> pathLabel <> ":",+              "        expected: " <> diffExpected d,+              "         but got: " <> diffActual d+            ]++structuralDiff :: String -> String -> [Difference]+structuralDiff = structuralDiff' ""++structuralDiff' :: String -> String -> String -> [Difference]+structuralDiff' path expected actual =+  if isList expected && isList actual+    then+      let items1 = extractListItems expected+          items2 = extractListItems actual+          -- We need to track indices for lists+          indexedMismatches = filter (\(_, (i1, i2)) -> i1 /= i2) (zip [0 :: Int ..] (zip items1 items2))+      in concatMap (\(idx, (i1, i2)) ->+           let newPath = path <> "[" <> show idx <> "]"+               nested = structuralDiff' newPath i1 i2+            in if null nested+                 then [Difference newPath i1 i2]+                 else nested+         ) indexedMismatches+    else if isRecord expected && isRecord actual+      then+        let fields1 = extractFields expected+            fields2 = extractFields actual+            mismatches = filter (\(f1, f2) -> f1 /= f2 && isField f1 && isField f2) (zip fields1 fields2)+         in concatMap (\(f1, f2) -> +              let fieldName = getFieldName f1+                  val1 = getFieldValue f1+                  val2 = getFieldValue f2+                  newPath = if null path then fieldName else path <> "." <> fieldName+                  nested = structuralDiff' newPath val1 val2+               in if null nested+                    then [Difference newPath val1 val2]+                    else nested+            ) mismatches+    else []++-- utilities for message formatting+trim :: String -> String+trim = f . f+  where+    f = reverse . dropWhile (== ' ')++splitByComma :: String -> [String]+splitByComma = go (0 :: Int) (0 :: Int) (0 :: Int) ""+  where+    go _ _ _ acc [] = if null acc then [] else [trim $ reverse acc]+    go p l b acc (c : cs)+      | c == '(' = go (p + 1) l b (c : acc) cs+      | c == ')' = go (max 0 (p - 1)) l b (c : acc) cs+      | c == '[' = go p (l + 1) b (c : acc) cs+      | c == ']' = go p (max 0 (l - 1)) b (c : acc) cs+      | c == '{' = go p l (b + 1) (c : acc) cs+      | c == '}' = go p l (max 0 (b - 1)) (c : acc) cs+      | c == ',' && p == 0 && l == 0 && b == 0 = (trim $ reverse acc) : go 0 0 0 "" cs+      | otherwise = go p l b (c : acc) cs++formatInvocationList :: Show a => InvocationList a -> String+formatInvocationList invocationList+  | null invocationList = "Function was never called"+  | length invocationList == 1 =+    -- show single element without surrounding list brackets, but quote tokens appropriately+    let s = formatStr (show (head invocationList))+     in s+  | otherwise =+    -- for multiple invocations, show as a list but ensure tokens are quoted where appropriate+    let ss = map (formatStr . show) invocationList+     in "[" <> intercalate ", " ss <> "]"++_replace :: Show a => String -> a -> String+_replace r s = unpack $ replace (pack r) (pack "") (pack (show s))++messageForMultiMock :: Show a => Maybe MockName -> [a] -> a -> String+messageForMultiMock name expecteds actual =+  let expectedStrs = map (formatStr . show) expecteds+      actualStr = formatStr (show actual)+      nearest = chooseNearest actualStr expectedStrs+   in intercalate+        "\n"+        [ "function" <> mockNameLabel name <> " was not called with the expected arguments.",+          "  expected one of the following:",+          intercalate "\n" $ ("    " <>) <$> expectedStrs,+          "  but got:",+          "    " <> actualStr,+          "    " <> diffPointer nearest actualStr+        ]++chooseNearest :: String -> [String] -> String+chooseNearest _ [] = ""+chooseNearest actual expectations =+  let commonPrefixLen s1 s2 = length $ takeWhile id $ zipWith (==) s1 s2+      scores = map (\e -> (commonPrefixLen actual e, e)) expectations+   in snd $ maximumBy (comparing fst) scores+++isRecord :: String -> Bool+isRecord s = '{' `elem` s && '}' `elem` s++extractFields :: String -> [String]+extractFields s = maybe [] splitByComma (extractInner '{' '}' s)++extractInner :: Char -> Char -> String -> Maybe String+extractInner open close s =+  case dropWhile (/= open) s of+    (x:rest) | x == open -> Just (takeBalanced (1 :: Int) rest)+    _ -> Nothing+  where+    takeBalanced :: Int -> String -> String+    takeBalanced 0 _ = ""+    takeBalanced _ [] = ""+    takeBalanced n (c:cs)+      | c == open = c : takeBalanced (n+1) cs+      | c == close = if n == 1 then "" else c : takeBalanced (n-1) cs+      | otherwise = c : takeBalanced n cs++isField :: String -> Bool+isField = ('=' `elem`)++getFieldName :: String -> String+getFieldName = trim . takeWhile (/= '=')++getFieldValue :: String -> String+getFieldValue = trim . drop 1 . dropWhile (/= '=')++isList :: String -> Bool+isList s = not (null s) && head s == '[' && last s == ']'++extractListItems :: String -> [String]+extractListItems s = maybe [] splitByComma (extractInner '[' ']' s)++listMismatchIndex :: [String] -> [String] -> Maybe Int+listMismatchIndex s1 s2 = elemIndex False (zipWith (==) s1 s2)++verifyOrderFailedMesssage :: Show a => VerifyOrderResult a -> String+verifyOrderFailedMesssage VerifyOrderResult {index, calledValue, expectedValue} =+  let callIndex = showHumanReadable (index + 1)+      expectedStr = formatStr (show expectedValue)+      actualStr = formatStr (show calledValue)+      prefix = "   but got " <> callIndex <> " call: "+      spaces = replicate (length prefix) ' '+   in intercalate+        "\n"+        [ "  expected " <> callIndex <> " call: " <> expectedStr,+          prefix <> actualStr,+          spaces <> diffPointer expectedStr actualStr+        ]+  where+    showHumanReadable :: Int -> String+    showHumanReadable 1 = "1st"+    showHumanReadable 2 = "2nd"+    showHumanReadable 3 = "3rd"+    showHumanReadable n = show n <> "th"

@@ -0,0 +1,101 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+module Test.MockCat.Internal.MockRegistry+  ( attachVerifierToFn+  , lookupVerifierForFn+  , register+  , registerUnitMeta+  , lookupUnitMeta+  , UnitMeta+  , withUnitGuard+  , withAllUnitGuards+  , markUnitUsed+  , isGuardActive+  ) where++import Test.MockCat.Internal.Registry.Core+  ( attachVerifierToFn+  , lookupVerifierForFn+  , registerUnitMeta+  , lookupUnitMeta+  , UnitMeta+  , withUnitGuard+  , withAllUnitGuards+  , markUnitUsed+  , isGuardActive+  )+import GHC.IO (evaluate)+import Control.Concurrent.STM (TVar, atomically, writeTVar)+import Test.MockCat.Internal.Types (MockName, InvocationRecorder(..), InvocationRecord, perform)+import Data.Proxy (Proxy(..))+import Data.Dynamic+import Test.MockCat.Internal.Builder (invocationRecord, appendCalledParams)+import Type.Reflection (TyCon, splitApps, typeRep, typeRepTyCon)+import Data.Typeable (eqT)+import Data.Type.Equality ((:~:) (Refl))++ioTyCon :: TyCon+ioTyCon = typeRepTyCon (typeRep @(IO ()))++isIOType :: forall a. Typeable a => Proxy a -> Bool+isIOType _ =+  case splitApps (typeRep @a) of+    (tc, _) -> tc == ioTyCon++-- | Wrap a function value for unit-typed stubs so that calls are tracked.+-- This uses the UnitMeta guard to avoid double-counting when both the tracked+-- and base values are registered. The wrapper will mark the unit meta used and+-- append an invocation to the recorder's TVar when appropriate.+wrapUnitStub ::+  forall fn.+  Typeable fn =>+  TVar (InvocationRecord ()) ->+  UnitMeta ->+  fn ->+  fn+wrapUnitStub ref meta value =+  let trackedValue = perform $ do+        guardActive <- isGuardActive meta+        if guardActive || isIOType (Proxy :: Proxy fn)+          then pure value+          else do+            markUnitUsed meta+            appendCalledParams ref ()+            pure value+  in+    trackedValue+++-- | Register a recorder for a function in the global mock registry.+-- This handles the special '()' (unit) case by creating a tracked wrapper+-- and registering both the tracked and base values so StableName lookup+-- succeeds regardless of which closure is later passed for verification.+register ::+  forall fn params.+  ( Typeable params+  , Typeable (InvocationRecorder params)+  , Typeable fn+  ) =>+  Maybe MockName ->+  InvocationRecorder params ->+  fn ->+  IO fn+register name recorder@(InvocationRecorder {invocationRef = ref}) fn = do+  baseValue <- evaluate fn+  case eqT :: Maybe (params :~: ()) of+    Just Refl -> do+      meta <- registerUnitMeta ref+      atomically $ writeTVar ref invocationRecord+      let trackedValue = wrapUnitStub ref meta baseValue+      withUnitGuard meta $ do+        attachVerifierToFn trackedValue (name, recorder)+        attachVerifierToFn baseValue (name, recorder)+      pure trackedValue+    Nothing -> do+      attachVerifierToFn baseValue (name, recorder)+      pure baseValue+

@@ -0,0 +1,242 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}++module Test.MockCat.Internal.Registry.Core+  ( attachVerifierToFn+  , lookupVerifierForFn+  , attachDynamicVerifierToFn+  , createOverlay+  , installOverlay+  , clearOverlay+  , registerUnitMeta+  , lookupUnitMeta+  , UnitMeta+  , withUnitGuard+  , withAllUnitGuards+  , markUnitUsed+  , isGuardActive+  ) where++import Control.Concurrent.STM+  ( TVar+  , atomically+  , modifyTVar'+  , newTVarIO+  , readTVar+  , readTVarIO+  , writeTVar+  )+import Control.Exception (bracket_)+import Control.Monad (forM_)+import Data.Dynamic (Dynamic, toDyn)+import Data.Typeable (Typeable)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import System.IO.Unsafe (unsafePerformIO)+import Test.MockCat.Internal.Types (MockName, InvocationRecorder(..))+import System.Mem.StableName (StableName, eqStableName, hashStableName, makeStableName)++data SomeStableName = forall a. SomeStableName (StableName a)++instance Eq SomeStableName where+  (SomeStableName sn1) == (SomeStableName sn2) = sn1 `eqStableName` sn2++type FnStableName = SomeStableName++data Entry+  = Entry !FnStableName !Dynamic+  | NamedEntry !FnStableName !MockName !Dynamic++stableFnName :: Entry -> FnStableName+stableFnName (Entry fn _) = fn+stableFnName (NamedEntry fn _ _) = fn++mockName :: Entry -> Maybe MockName+mockName (NamedEntry _ name _) = Just name+mockName _ = Nothing++entryPayload :: Entry -> Dynamic+entryPayload (Entry _ payload) = payload+entryPayload (NamedEntry _ _ payload) = payload++toFnStable :: forall a. StableName a -> FnStableName+toFnStable = SomeStableName++sameFnStable :: FnStableName -> FnStableName -> Bool+sameFnStable a b = a == b++type Registry = IntMap [Entry]++registry :: TVar Registry+registry = (unsafePerformIO $ newTVarIO IntMap.empty) :: TVar Registry+++attachVerifierToFn ::+  forall fn params.+  (Typeable (InvocationRecorder params)) =>+  fn ->+  (Maybe MockName, InvocationRecorder params) ->+  IO ()+attachVerifierToFn fn (name, payload) = attachDynamicVerifierToFn fn (name, toDyn payload)++lookupVerifierForFn ::+  forall fn.+  fn ->+  IO (Maybe (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++attachDynamicVerifierToFn :: forall fn. fn -> (Maybe MockName, Dynamic) -> IO ()+attachDynamicVerifierToFn fn (name, payload) = do+  -- Record stable-name of the passed function+  stable <- makeStableName fn+  let stableFn = toFnStable stable+  let passedKey = hashStableName stable+  -- Always attach to the passed function stable-name directly.+  -- Avoiding lookupFnByName here prevents cross-session identity pollution.+  let key = passedKey+  let entry = toEntry name stableFn payload+  atomically $+    modifyTVar' registry $ \m -> IntMap.alter (updateEntries entry stableFn) key m++toEntry :: Maybe MockName -> FnStableName -> Dynamic -> Entry+toEntry (Just n) stableFn p = NamedEntry stableFn n p+toEntry Nothing stableFn p = Entry stableFn p++updateEntries :: Entry -> FnStableName -> Maybe [Entry] -> Maybe [Entry]+updateEntries entry stableFn (Just entries) = Just $ entry : filterSameFnStable stableFn entries+updateEntries entry _        Nothing        = Just [entry]++filterSameFnStable :: FnStableName -> [Entry] -> [Entry]+filterSameFnStable stableFn = filter (not . sameFnStable stableFn . stableFnName)++findMatch :: FnStableName -> [Entry] -> Maybe (Maybe MockName, Dynamic)+findMatch _ [] = Nothing+findMatch target  (entry : rest)+  | sameFnStable target (stableFnName entry) = Just (mockName entry, entryPayload entry)+  | otherwise = findMatch target rest++++++++type UnitStableName = SomeStableName++data UnitMeta = UnitMeta+  { unitGuardRef :: TVar Bool+  , unitUsedRef :: TVar Bool+  }++data UnitEntry = UnitEntry !UnitStableName !UnitMeta++unitEntryStable :: UnitEntry -> UnitStableName+unitEntryStable (UnitEntry stable _) = stable++unitEntryMeta :: UnitEntry -> UnitMeta+unitEntryMeta (UnitEntry _ meta) = meta++toUnitStable :: forall a. StableName a -> UnitStableName+toUnitStable = SomeStableName++sameUnitStable :: UnitStableName -> UnitStableName -> Bool+sameUnitStable a b = a == b++type UnitRegistry = IntMap [UnitEntry]++unitRegistry :: TVar UnitRegistry+unitRegistry = (unsafePerformIO $ newTVarIO IntMap.empty) :: TVar UnitRegistry++-- | Per-run overlay registry (optional).+data Overlay = Overlay++-- | Run the given IO action with a per-run overlay registry active.+-- The overlay is cleaned up after the action completes.+createOverlay :: IO Overlay+createOverlay = pure Overlay++installOverlay :: Overlay -> IO ()+installOverlay _ = pure ()++clearOverlay :: IO ()+clearOverlay = pure ()++++registerUnitMeta :: TVar ref -> IO UnitMeta+registerUnitMeta ref = do+  stable <- makeStableName ref+  let key = hashStableName stable+      unitStable = toUnitStable stable+  fresh <- createUnitMeta+  atomically $ do+    store <- readTVar unitRegistry+    case IntMap.lookup key store of+      Just entries ->+        case findUnit unitStable entries of+          Just existing -> pure existing+          Nothing -> do+            let newEntries = UnitEntry unitStable fresh : entries+            writeTVar unitRegistry (IntMap.insert key newEntries store)+            pure fresh+      Nothing -> do+        writeTVar unitRegistry (IntMap.insert key [UnitEntry unitStable fresh] store)+        pure fresh++lookupUnitMeta :: TVar ref -> IO (Maybe UnitMeta)+lookupUnitMeta ref = do+  stable <- makeStableName ref+  let key = hashStableName stable+      unitStable = toUnitStable stable+  store <- readTVarIO unitRegistry+  pure $ IntMap.lookup key store >>= findUnit unitStable++withUnitGuard :: UnitMeta -> IO a -> IO a+withUnitGuard meta =+  bracket_+    (atomically $ writeTVar (unitGuardRef meta) True)+    (atomically $ writeTVar (unitGuardRef meta) False)++withAllUnitGuards :: IO a -> IO a+withAllUnitGuards = bracket_ (setAllUnitGuards True) (setAllUnitGuards False)++markUnitUsed :: UnitMeta -> IO ()+markUnitUsed meta = atomically $ writeTVar (unitUsedRef meta) True++isGuardActive :: UnitMeta -> IO Bool+isGuardActive meta = readTVarIO (unitGuardRef meta)++createUnitMeta :: IO UnitMeta+createUnitMeta = do+  guardRef <- newTVarIO False+  usedRef <- newTVarIO False+  pure UnitMeta {unitGuardRef = guardRef, unitUsedRef = usedRef}++findUnit :: UnitStableName -> [UnitEntry] -> Maybe UnitMeta+findUnit _ [] = Nothing+findUnit target (entry : rest)+  | sameUnitStable target (unitEntryStable entry) = Just (unitEntryMeta entry)+  | otherwise = findUnit target rest++setAllUnitGuards :: Bool -> IO ()+setAllUnitGuards flag =+  atomically $ do+    store <- readTVar unitRegistry+    forM_ (concat (IntMap.elems store)) $ \entry ->+      writeTVar (unitGuardRef (unitEntryMeta entry)) flag++

@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use null" #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Test.MockCat.Internal.Types where++import Control.Monad (ap)+import Control.Concurrent.STM (TVar)+import Data.Maybe+import GHC.IO (unsafePerformIO)+import Test.MockCat.AssociationList (AssociationList)+import Prelude hiding (lookup)+import Control.Monad.State ( State )++data InvocationRecorder params = InvocationRecorder+  { invocationRef :: TVar (InvocationRecord params)+  , functionNature :: FunctionNature+  }++-- | Result of building a mock: function plus its recorder.+data BuiltMock fn params = BuiltMock+  { builtMockFn :: fn+  , builtMockRecorder :: InvocationRecorder params+  }++data FunctionNature+  = PureConstant+  | IOConstant+  | ParametricFunction+  deriving (Eq, Show)++type InvocationList params = [params]+type InvocationCounts params = AssociationList params Int++data InvocationRecord params = InvocationRecord {+  invocations :: InvocationList params,+  invocationCounts :: InvocationCounts params+}+  deriving (Eq, Show)++data CountVerifyMethod+  = Equal Int+  | LessThanEqual Int+  | GreaterThanEqual Int+  | LessThan Int+  | GreaterThan Int++instance Show CountVerifyMethod where+  show (Equal e) = show e+  show (LessThanEqual e) = "<= " <> show e+  show (LessThan e) = "< " <> show e+  show (GreaterThanEqual e) = ">= " <> show e+  show (GreaterThan e) = "> " <> show e++newtype Cases a b = Cases (State [a] b)++instance Functor (Cases a) where+  fmap f (Cases s) = Cases (fmap f s)++instance Applicative (Cases a) where+  pure x = Cases $ pure x+  (<*>) = ap++instance Monad (Cases a) where+  (Cases m) >>= f = Cases $ do+    result <- m+    let (Cases newState) = f result+    newState++newtype VerifyFailed = VerifyFailed Message++data VerifyOrderMethod+  = ExactlySequence+  | PartiallySequence++data VerifyOrderResult a = VerifyOrderResult+  { index :: Int,+    calledValue :: a,+    expectedValue :: a+  }++type Message = String++data VerifyMatchType a = MatchAny a | MatchAll a++type MockName = String++safeIndex :: [a] -> Int -> Maybe a+safeIndex xs n+  | n < 0 = Nothing+  | otherwise = listToMaybe (drop n xs)++{-# NOINLINE perform #-}+perform :: IO a -> a+perform = unsafePerformIO

@@ -1,845 +1,307 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Use null" #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE InstanceSigs #-}--{- | This module provides the following functions.--  - Create mocks that can be stubbed and verified.--  - Create stub function.--  - Verify applied mock function.--}-module Test.MockCat.Mock-  ( Mock,-    MockBuilder,-    build,-    createMock,-    createNamedMock,-    createConstantMock,-    createNamedConstantMock,-    createStubFn,-    createNamedStubFn,-    stubFn,-    shouldApplyTo,-    shouldApplyTimes,-    shouldApplyInOrder,-    shouldApplyInPartialOrder,-    shouldApplyTimesGreaterThanEqual,-    shouldApplyTimesLessThanEqual,-    shouldApplyTimesGreaterThan,-    shouldApplyTimesLessThan,-    shouldApplyToAnything,-    shouldApplyTimesToAnything,-    to,-    onCase,-    cases,-    casesIO-  )-where--import Control.Monad (guard, when, ap)-import Data.Function ((&))-import Data.Char (isLower)-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')-import Data.List (elemIndex, intercalate)-import Data.Maybe-import Data.Text (pack, replace, unpack)-import GHC.IO (unsafePerformIO)-import Test.MockCat.Cons-import Test.MockCat.Param-import Test.MockCat.AssociationList (AssociationList, lookup, update, insert, empty, member)-import Prelude hiding (lookup)-import GHC.Stack (HasCallStack)-import Control.Monad.Trans-import Control.Monad.State--data Mock fn params = Mock (Maybe MockName) fn (Verifier params)--type MockName = String--newtype Verifier params = Verifier (IORef (AppliedRecord params))--{- | Create a mock.-From this mock, you can generate stub functions and verify the functions.--  @-  import Test.Hspec-  import Test.MockCat-  ...-  it "stub & verify" do-    -- create a mock-    m \<- createMock $ "value" |\> True-    -- stub function-    let f = stubFn m-    -- assert-    f "value" \`shouldBe\` True-    -- verify-    m \`shouldApplyTo\` "value"-  @--  If you do not need verification and only need stub functions, you can use @'mockFun'@.---}-createMock ::-  (MonadIO m, MockBuilder params fn verifyParams) =>-  params ->-  m (Mock fn verifyParams)-createMock params = liftIO $ build Nothing params--{- | Create a constant mock.-From this mock, you can generate constant functions and verify the functions.--  @-  import Test.Hspec-  import Test.MockCat-  ...-  it "stub & verify" do-    m \<- createConstantMock "foo"-    stubFn m \`shouldBe\` "foo"-    shouldApplyToAnything m-  @--}-createConstantMock :: MonadIO m => a -> m (Mock a ())-createConstantMock a = liftIO $ build Nothing $ param a--{- | Create a named mock. If the test fails, this name is used. This may be useful if you have multiple mocks.--  @-  import Test.Hspec-  import Test.MockCat-  ...-  it "named mock" do-    m \<- createNamedMock "mock" $ "value" |\> True-    stubFn m "value" \`shouldBe\` True-  @--}-createNamedMock ::-  (MonadIO m, MockBuilder params fn verifyParams) =>-  MockName ->-  params ->-  m (Mock fn verifyParams)-createNamedMock name params = liftIO $ build (Just name) params---- | Create a named constant mock.-createNamedConstantMock :: MonadIO m => MockName -> fn -> m (Mock fn ())-createNamedConstantMock name a = liftIO $ build (Just name) (param a)---- | Extract the stub function from the mock.-stubFn :: Mock fn v -> fn-stubFn (Mock _ f _) = f--{- | Create a stub function.-  @-  import Test.Hspec-  import Test.MockCat-  ...-  it "stub function" do-    f \<- createStubFn $ "value" |\> True-    f "value" \`shouldBe\` True-  @--}-createStubFn ::-  (MonadIO m, MockBuilder params fn verifyParams) =>-  params ->-  m fn-createStubFn params = stubFn <$> createMock params---- | Create a named stub function.-createNamedStubFn ::-  (MonadIO m, MockBuilder params fn verifyParams) =>-  String ->-  params ->-  m fn-createNamedStubFn name params = stubFn <$> createNamedMock name params---- | Class for building a curried function.--- The purpose of this class is to automatically generate and provide--- an implementation for the corresponding curried function type (such as `a -> b -> ... -> IO r`)--- when given the argument list type of the mock (`Param a :> Param b :> ...`).--- @args@ is the argument list type of the mock.--- @r@ is the return type of the function.--- @fn@ is the curried function type.-class BuildCurried args r fn | args r -> fn where-  -- | Build a curried function.-  -- Accept a function that combines all arguments and convert it into a curried function.-  buildCurried :: (args -> IO r) -> fn---- | Base case: The last parameter.--- Converts a single-argument function (Param a -> IO r) into a final--- curried function (a -> r) by performing the IO action.-instance BuildCurried (Param a) r (a -> r) where-  buildCurried :: (Param a -> IO r) -> a -> r-  buildCurried a2r a = perform $ a2r (param a)---- | Recursive case: Consumes the head parameter and generates the next curried function.--- Generates a function of type (a -> fn) that immediately calls the next--- 'BuildCurried' instance with the remaining arguments.-instance BuildCurried rest r fn-      => BuildCurried (Param a :> rest) r (a -> fn) where-  buildCurried :: ((Param a :> rest) -> IO r) -> a -> fn-  buildCurried args2r a = buildCurried (\rest -> args2r (p a :> rest))---- | Class for creating a mock corresponding to the parameter.-class MockBuilder params fn verifyParams | params -> fn, params -> verifyParams where-  -- build a mock-  build :: MonadIO m => Maybe MockName -> params -> m (Mock fn verifyParams)---- | Instance for building a mock for a constant function.-instance-  MockBuilder (IO r) (IO r) ()-  where-  build name a = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (do-      liftIO $ appendAppliedParams s ()-      a)---- | Instance for building a mock for a function with a single parameter.-instance-  MockBuilder (Param r) r ()-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    let v = value params-    makeMock name s $ perform (do-      liftIO $ appendAppliedParams s ()-      pure v)---- | Instance for building a mock for a function with multiple parameters.-instance MockBuilder (Cases (IO a) ()) (IO a) () where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (do-      count <- readAppliedCount s ()-      let index = min count (length params - 1)-          r = safeIndex params index-      appendAppliedParams s ()-      incrementAppliedParamCount s ()-      fromJust r)---- | Overlapping instance for building a mock for a function with multiple parameters.--- This instance is used when the parameter type is a 'Cases' type.-instance {-# OVERLAPPABLE #-}-  ( ProjectionArgs params-  , ProjectionReturn params-  , ArgsOf params ~ args-  , ReturnOf params ~ Param r-  , BuildCurried args r fn-  , Eq args-  , Show args-  ) => MockBuilder (Cases params ()) fn args where-  build name cases = do-    let paramsList = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (buildCurried (\inputParams -> findReturnValueWithStore name paramsList inputParams s))---- | Overlapping instance for building a mock for a function with multiple parameters.--- This instance is used when the parameter type is a 'Param a :> rest' type.-instance {-# OVERLAPPABLE #-}-  ( p ~ (Param a :> rest)-  , ProjectionArgs p-  , ProjectionReturn p-  , ArgsOf p ~ args-  , ReturnOf p ~ Param r-  , BuildCurried args r fn-  , Eq args-  , Show args-  ) => MockBuilder (Param a :> rest) fn args where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (buildCurried (\inputParams -> extractReturnValueWithValidate name params inputParams s))--p :: a -> Param a-p = param--makeMock :: MonadIO m => Maybe MockName -> IORef (AppliedRecord params) -> fn -> m (Mock fn params)-makeMock name l fn = pure $ Mock name fn (Verifier l)--extractReturnValueWithValidate ::-  ( ProjectionArgs params-  , ProjectionReturn params-  , ArgsOf params ~ args-  , ReturnOf params ~ Param r-  , Eq args-  , Show args-  ) =>-  Maybe MockName ->-  params ->-  args ->-  IORef (AppliedRecord args) ->-  IO r-extractReturnValueWithValidate name params inputParams s = do-  validateWithStoreParams name s (projArgs params) inputParams-  pure $ returnValue params--findReturnValueWithStore ::-  ( ProjectionArgs params-  , ProjectionReturn params-  , ArgsOf params ~ args-  , ReturnOf params ~ Param r-  , Eq args-  , Show args-  ) =>-  Maybe MockName ->-  AppliedParamsList params ->-  args ->-  IORef (AppliedRecord args) ->-  IO r-findReturnValueWithStore name paramsList inputParams ref = do-  appendAppliedParams ref inputParams-  let expectedArgs = projArgs <$>paramsList-  r <- findReturnValue paramsList inputParams ref-  maybe-    (errorWithoutStackTrace $ messageForMultiMock name expectedArgs inputParams)-    pure-    r--findReturnValue ::-  ( ProjectionArgs params-  , ProjectionReturn params-  , ArgsOf params ~ args-  , ReturnOf params ~ Param r-  , Eq args-  ) =>-  AppliedParamsList params ->-  args ->-  IORef (AppliedRecord args) ->-  IO (Maybe r)-findReturnValue paramsList inputParams ref = do-  let matchedParams = filter (\params -> projArgs params == inputParams) paramsList-  case matchedParams of-    [] -> pure Nothing-    _ -> do-      count <- readAppliedCount ref inputParams-      let index = min count (length matchedParams - 1)-      incrementAppliedParamCount ref inputParams-      pure $ returnValue <$> safeIndex matchedParams index--validateWithStoreParams :: (Eq a, Show a) => Maybe MockName -> IORef (AppliedRecord a) -> a -> a -> IO ()-validateWithStoreParams name ref expected actual = do-  validateParams name expected actual-  appendAppliedParams ref actual--validateParams :: (Eq a, Show a) => Maybe MockName -> a -> a -> IO ()-validateParams name expected actual =-  if expected == actual-    then pure ()-    else errorWithoutStackTrace $ message name expected actual---- Helper: quote a token if it looks like an unquoted alpha token-quoteToken :: String -> String-quoteToken s-  | null s = s-  | head s == '"' = s-  | head s == '(' = s-  | head s == '[' = s-  | not (null s) && isLower (head s) = '"' : s ++ "\""-  | otherwise = s---- Quote a show-produced string when appropriate for error messages.-showForMessage :: String -> String-showForMessage s =-  -- if it's a parenthesised compound, keep as-is; otherwise quote alpha-only tokens-  let trimmed = s-   in if not (null trimmed) && head trimmed == '(' && last trimmed == ')'-        then trimmed-        else quoteToken trimmed--message :: Show a => Maybe MockName -> a -> a -> String-message name expected actual =-  intercalate-    "\n"-    [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",-      "  expected: " <> showForMessage (show expected),-      "   but got: " <> showForMessage (show actual)-    ]--messageForMultiMock :: Show a => Maybe MockName -> [a] -> a -> String-messageForMultiMock name expecteds actual =-  let fmtExpected e =-        let s = show e-            -- if it's parenthesised compound, strip outer parens then quote inner alpha tokens-            inner = if not (null s) && head s == '(' && last s == ')' then init (tail s) else s-            tokens = map (trim . quoteToken . trim) (splitByComma inner)-         in intercalate "," tokens-   in intercalate-        "\n"-        [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",-          "  expected one of the following:",-          intercalate "\n" $ ("    " <>) . fmtExpected <$> expecteds,-          "  but got:",-          ("    " <>) . fmtExpected $ actual-        ]--mockNameLabel :: Maybe MockName -> String-mockNameLabel = maybe mempty (" " <>) . enclose "`"--enclose :: String -> Maybe String -> Maybe String-enclose e = fmap (\v -> e <> v <> e)---- verify-data VerifyMatchType a = MatchAny a | MatchAll a---- | Class for verifying mock function.-class Verify params input where-  -- | Verifies that the function has been applied to the expected arguments.-  shouldApplyTo :: HasCallStack => Mock fn params -> input -> IO ()--instance (Eq a, Show a) => Verify (Param a) a where-  shouldApplyTo v a = verify v (MatchAny (param a))--instance (Eq a, Show a) => Verify a a where-  shouldApplyTo v a = verify v (MatchAny a)--verify :: (Eq params, Show params) => Mock fn params -> VerifyMatchType params -> IO ()-verify (Mock name _ (Verifier ref)) matchType = do-  appliedParamsList <- readAppliedParamsList ref-  let result = doVerify name appliedParamsList matchType-  result & maybe (pure ()) (\(VerifyFailed msg) -> errorWithoutStackTrace msg)--newtype VerifyFailed = VerifyFailed Message--type Message = String--doVerify :: (Eq a, Show a) => Maybe MockName -> AppliedParamsList a -> VerifyMatchType a -> Maybe VerifyFailed-doVerify name list (MatchAny a) = do-  guard $ notElem a list-  pure $ verifyFailedMessage name list a-doVerify name list (MatchAll a) = do-  guard $ Prelude.any (a /=) list-  pure $ verifyFailedMessage name list a--verifyFailedMessage :: Show a => Maybe MockName -> AppliedParamsList a -> a -> VerifyFailed-verifyFailedMessage name appliedParams expected =-  VerifyFailed $-    intercalate-      "\n"-      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",-        "  expected: " <> showForMessage (show expected),-        "   but got: " <> formatAppliedParamsList appliedParams-      ]---- utilities for message formatting-trim :: String -> String-trim = f . f-  where-    f = reverse . dropWhile (== ' ')--splitByComma :: String -> [String]-splitByComma s = case break (== ',') s of-  (a, ',' : rest) -> a : splitByComma rest-  (a, _) -> [a]--formatAppliedParamsList :: Show a => AppliedParamsList a -> String-formatAppliedParamsList appliedParams-  | null appliedParams = "It has never been applied"-  | length appliedParams == 1 =-    -- show single element without surrounding list brackets, but quote tokens appropriately-    let s = show (head appliedParams)-        inner = if not (null s) && head s == '(' && last s == ')' then init (tail s) else s-        tokens = map (trim . quoteToken . trim) (splitByComma inner)-     in intercalate "," tokens-  | otherwise =-    -- for multiple applied params, show as a list but ensure tokens are quoted where appropriate-    let ss = map show appliedParams-        processed = map (\t -> let inner = if not (null t) && head t == '(' && last t == ')' then init (tail t) else t-                                in intercalate "," $ map (trim . quoteToken . trim) (splitByComma inner)) ss-     in show processed--_replace :: Show a => String -> a -> String-_replace r s = unpack $ replace (pack r) (pack "") (pack (show s))--class VerifyCount countType params a where-  -- | Verify the number of times a function has been applied to an argument.-  ---  -- @-  -- import Test.Hspec-  -- import Test.MockCat-  -- ...-  -- it "verify to applied times." do-  --   m \<- createMock $ "value" |\> True-  --   print $ stubFn m "value"-  --   print $ stubFn m "value"-  --   m \`shouldApplyTimes\` (2 :: Int) \`to\` "value" -  -- @-  ---  shouldApplyTimes :: HasCallStack => Eq params => Mock fn params -> countType -> a -> IO ()--instance VerifyCount CountVerifyMethod (Param a) a where-  shouldApplyTimes v count a = verifyCount v (param a) count--instance VerifyCount Int (Param a) a where-  shouldApplyTimes v count a = verifyCount v (param a) (Equal count)--instance {-# OVERLAPPABLE #-} VerifyCount CountVerifyMethod a a where-  shouldApplyTimes v count a = verifyCount v a count--instance {-# OVERLAPPABLE #-} VerifyCount Int a a where-  shouldApplyTimes v count a = verifyCount v a (Equal count)--data CountVerifyMethod-  = Equal Int-  | LessThanEqual Int-  | GreaterThanEqual Int-  | LessThan Int-  | GreaterThan Int--instance Show CountVerifyMethod where-  show (Equal e) = show e-  show (LessThanEqual e) = "<= " <> show e-  show (LessThan e) = "< " <> show e-  show (GreaterThanEqual e) = ">= " <> show e-  show (GreaterThan e) = "> " <> show e--compareCount :: CountVerifyMethod -> Int -> Bool-compareCount (Equal e) a = a == e-compareCount (LessThanEqual e) a = a <= e-compareCount (LessThan e) a = a < e-compareCount (GreaterThanEqual e) a = a >= e-compareCount (GreaterThan e) a = a > e--verifyCount :: Eq params => Mock fn params -> params -> CountVerifyMethod -> IO ()-verifyCount (Mock name _ (Verifier ref)) v method = do-  appliedParamsList <- readAppliedParamsList ref-  let appliedCount = length (filter (v ==) appliedParamsList)-  if compareCount method appliedCount-    then pure ()-    else-      errorWithoutStackTrace $-        intercalate-          "\n"-          [ "function" <> mockNameLabel name <> " was not applied the expected number of times to the expected arguments.",-            "  expected: " <> show method,-            "   but got: " <> show appliedCount-          ]--to :: (a -> IO ()) -> a -> IO ()-to f = f--class VerifyOrder params input where-  -- | Verify functions are applied in the expected order.-  ---  -- @-  -- import Test.Hspec-  -- import Test.MockCat-  -- import Prelude hiding (any)-  -- ...-  -- it "verify order of apply" do-  --   m \<- createMock $ any |\> True |\> ()-  --   print $ stubFn m "a" True-  --   print $ stubFn m "b" True-  --   m \`shouldApplyInOrder\` ["a" |\> True, "b" |\> True]-  -- @-  shouldApplyInOrder :: HasCallStack => Mock fn params -> [input] -> IO ()--  -- | Verify that functions are applied in the expected order.-  ---  -- Unlike @'shouldApplyInOrder'@, not all applications need to match exactly.-  ---  -- As long as the order matches, the verification succeeds.-  shouldApplyInPartialOrder :: HasCallStack => Mock fn params -> [input] -> IO ()--instance (Eq a, Show a) => VerifyOrder (Param a) a where-  shouldApplyInOrder v a = verifyOrder ExactlySequence v $ param <$> a-  shouldApplyInPartialOrder v a = verifyOrder PartiallySequence v $ param <$> a--instance {-# OVERLAPPABLE #-} (Eq a, Show a) => VerifyOrder a a where-  shouldApplyInOrder = verifyOrder ExactlySequence-  shouldApplyInPartialOrder = verifyOrder PartiallySequence--data VerifyOrderMethod-  = ExactlySequence-  | PartiallySequence--verifyOrder ::-  (Eq params, Show params) =>-  VerifyOrderMethod ->-  Mock fn params ->-  [params] ->-  IO ()-verifyOrder method (Mock name _ (Verifier ref)) matchers = do-  appliedParamsList <- readAppliedParamsList ref-  let result = doVerifyOrder method name appliedParamsList matchers-  result & maybe (pure ()) (\(VerifyFailed msg) -> errorWithoutStackTrace msg)--doVerifyOrder ::-  (Eq a, Show a) =>-  VerifyOrderMethod ->-  Maybe MockName ->-  AppliedParamsList a ->-  [a] ->-  Maybe VerifyFailed-doVerifyOrder ExactlySequence name appliedValues expectedValues-  | length appliedValues /= length expectedValues = do-      pure $ verifyFailedOrderParamCountMismatch name appliedValues expectedValues-  | otherwise = do-      let unexpectedOrders = collectUnExpectedOrder appliedValues expectedValues-      guard $ length unexpectedOrders > 0-      pure $ verifyFailedSequence name unexpectedOrders-doVerifyOrder PartiallySequence name appliedValues expectedValues-  | length appliedValues < length expectedValues = do-      pure $ verifyFailedOrderParamCountMismatch name appliedValues expectedValues-  | otherwise = do-      guard $ isOrderNotMatched appliedValues expectedValues-      pure $ verifyFailedPartiallySequence name appliedValues expectedValues--verifyFailedPartiallySequence :: Show a => Maybe MockName -> AppliedParamsList a -> [a] -> VerifyFailed-verifyFailedPartiallySequence name appliedValues expectedValues =-  VerifyFailed $-    intercalate-      "\n"-      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order.",-        "  expected order:",-        intercalate "\n" $ ("    " <>) . show <$> expectedValues,-        "  but got:",-        intercalate "\n" $ ("    " <>) . show <$> appliedValues-      ]--isOrderNotMatched :: Eq a => AppliedParamsList a -> [a] -> Bool-isOrderNotMatched appliedValues expectedValues =-  isNothing $-    foldl-      ( \candidates e -> do-          candidates >>= \c -> do-            index <- elemIndex e c-            Just $ drop (index + 1) c-      )-      (Just appliedValues)-      expectedValues--verifyFailedOrderParamCountMismatch :: Maybe MockName -> AppliedParamsList a -> [a] -> VerifyFailed-verifyFailedOrderParamCountMismatch name appliedValues expectedValues =-  VerifyFailed $-    intercalate-      "\n"-      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order (count mismatch).",-        "  expected: " <> show (length expectedValues),-        "   but got: " <> show (length appliedValues)-      ]--verifyFailedSequence :: Show a => Maybe MockName -> [VerifyOrderResult a] -> VerifyFailed-verifyFailedSequence name fails =-  VerifyFailed $-    intercalate-      "\n"-      ( ("function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order.") : (verifyOrderFailedMesssage <$> fails)-      )--verifyOrderFailedMesssage :: Show a => VerifyOrderResult a -> String-verifyOrderFailedMesssage VerifyOrderResult {index, appliedValue, expectedValue} =-  let appliedCount = showHumanReadable (index + 1)-   in intercalate-        "\n"-        [ "  expected " <> appliedCount <> " applied: " <> show expectedValue,-          "   but got " <> appliedCount <> " applied: " <> show appliedValue-        ]-  where-    showHumanReadable :: Int -> String-    showHumanReadable 1 = "1st"-    showHumanReadable 2 = "2nd"-    showHumanReadable 3 = "3rd"-    showHumanReadable n = show n <> "th"--data VerifyOrderResult a = VerifyOrderResult-  { index :: Int,-    appliedValue :: a,-    expectedValue :: a-  }--collectUnExpectedOrder :: Eq a => AppliedParamsList a -> [a] -> [VerifyOrderResult a]-collectUnExpectedOrder appliedValues expectedValues =-  catMaybes $-    mapWithIndex-      ( \i expectedValue -> do-          let appliedValue = appliedValues !! i-          guard $ expectedValue /= appliedValue-          pure VerifyOrderResult {index = i, appliedValue, expectedValue}-      )-      expectedValues--mapWithIndex :: (Int -> a -> b) -> [a] -> [b]-mapWithIndex f xs = [f i x | (i, x) <- zip [0 ..] xs]---- | Verify that the function has been applied to the expected arguments at least the expected number of times.-shouldApplyTimesGreaterThanEqual ::-  (VerifyCount CountVerifyMethod params a, Eq params) =>-  Mock fn params ->-  Int ->-  a ->-  IO ()-shouldApplyTimesGreaterThanEqual m i = shouldApplyTimes m (GreaterThanEqual i)---- | Verify that the function is applied to the expected arguments less than or equal to the expected number of times.-shouldApplyTimesLessThanEqual ::-  (VerifyCount CountVerifyMethod params a, Eq params) =>-  Mock fn params ->-  Int ->-  a ->-  IO ()-shouldApplyTimesLessThanEqual m i = shouldApplyTimes m (LessThanEqual i)---- | Verify that the function has been applied to the expected arguments a greater number of times than expected.-shouldApplyTimesGreaterThan ::-  (VerifyCount CountVerifyMethod params a, Eq params) =>-  Mock fn params ->-  Int ->-  a ->-  IO ()-shouldApplyTimesGreaterThan m i = shouldApplyTimes m (GreaterThan i)---- | Verify that the function has been applied to the expected arguments less than the expected number of times.-shouldApplyTimesLessThan ::-  (VerifyCount CountVerifyMethod params a, Eq params) =>-  Mock fn params ->-  Int ->-  a ->-  IO ()-shouldApplyTimesLessThan m i = shouldApplyTimes m (LessThan i)--type AppliedParamsList params = [params]-type AppliedParamsCounter params = AssociationList params Int--data AppliedRecord params = AppliedRecord {-  appliedParamsList :: AppliedParamsList params,-  appliedParamsCounter :: AppliedParamsCounter params-}--appliedRecord :: AppliedRecord params-appliedRecord = AppliedRecord {-  appliedParamsList = mempty,-  appliedParamsCounter = empty-}--readAppliedParamsList :: IORef (AppliedRecord params) -> IO (AppliedParamsList params)-readAppliedParamsList ref = do-  record <- readIORef ref-  pure $ appliedParamsList record--readAppliedCount :: Eq params => IORef (AppliedRecord params) -> params -> IO Int-readAppliedCount ref params = do-  record <- readIORef ref-  let count = appliedParamsCounter record-  pure $ fromMaybe 0 (lookup params count)--appendAppliedParams :: IORef (AppliedRecord params) -> params -> IO ()-appendAppliedParams ref inputParams = do-  atomicModifyIORef' ref (\AppliedRecord {appliedParamsList, appliedParamsCounter} ->-    let newRecord = AppliedRecord {-          appliedParamsList = appliedParamsList ++ [inputParams],-          appliedParamsCounter = appliedParamsCounter-        }-    in (newRecord, ()))--incrementAppliedParamCount :: Eq params => IORef (AppliedRecord params) -> params -> IO ()-incrementAppliedParamCount ref inputParams = do-  atomicModifyIORef' ref (\AppliedRecord {appliedParamsList, appliedParamsCounter} ->-    let newRecord = AppliedRecord {-          appliedParamsList = appliedParamsList,-          appliedParamsCounter = incrementCount inputParams appliedParamsCounter-        }-    in (newRecord, ()))--incrementCount :: Eq k => k -> AppliedParamsCounter k -> AppliedParamsCounter k-incrementCount key list =-  if member key list then update (+ 1) key list-  else insert key 1 list--safeIndex :: [a] -> Int -> Maybe a-safeIndex xs n-  | n < 0 = Nothing-  | otherwise = listToMaybe (drop n xs)---- | Verify that it was apply to anything.-shouldApplyToAnything :: HasCallStack => Mock fn params -> IO ()-shouldApplyToAnything (Mock name _ (Verifier ref)) = do-  appliedParamsList <- readAppliedParamsList ref-  when (null appliedParamsList) $ error $ "It has never been applied function" <> mockNameLabel name---- | Verify that it was apply to anything (times).-shouldApplyTimesToAnything :: Mock fn params -> Int -> IO ()-shouldApplyTimesToAnything (Mock name _ (Verifier ref)) count = do-  appliedParamsList <- readAppliedParamsList ref-  let appliedCount = length appliedParamsList-  when (count /= appliedCount) $-        errorWithoutStackTrace $-        intercalate-          "\n"-          [ "function" <> mockNameLabel name <> " was not applied the expected number of times.",-            "  expected: " <> show count,-            "   but got: " <> show appliedCount-          ]--newtype Cases a b = Cases (State [a] b)--instance Functor (Cases a) where-  fmap f (Cases s) = Cases (fmap f s)--instance Applicative (Cases a) where-  pure x = Cases $ pure x-  (<*>) = ap--instance Monad (Cases a) where-  (Cases m) >>= f = Cases $ do-    result <- m-    let (Cases newState) = f result-    newState--runCase :: Cases a b -> [a]-runCase (Cases s) = execState s []--{- | Make a case for stub functions.  -This can be used to create stub functions that return different values depending on their arguments.--  @-  it "test" do-    f <--      createStubFn $ do-        onCase $ "a" |> "return x"-        onCase $ "b" |> "return y"--    f "a" `shouldBe` "return x"-    f "b" `shouldBe` "return y"-  @--}-onCase :: a -> Cases a ()-onCase a = Cases $ do-  st <- get-  put (st ++ [a])--{- | Make a list of patterns of arguments and returned values.  -This can be used to create stub functions that return different values depending on their arguments.--  @-  it "test" do-    f <--      createStubFn $ cases [-        "a" |> "return x",-        "b" |> "return y"-      ]--    f "a" `shouldBe` "return x"-    f "b" `shouldBe` "return y"-  @--}-cases :: [a] -> Cases a ()-cases a = Cases $ put a--{- | IO version of @'cases'@.  -@casesIO ["a", ""]@ has the same meaning as @cases [ pure \@IO "a", pure \@IO ""]@.--}-casesIO :: [a] -> Cases (IO a) ()-casesIO = Cases . (put . map pure)--{-# NOINLINE perform #-}-perform :: IO a -> a-perform = unsafePerformIO+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{- | Utilities for constructing verifiable stub functions.+     This module provides the core functions for creating mocks and stubs.++     = Key Functions+     * 'mock': Create a verifiable mock function (records calls).+     * 'stub': Create a pure stub function (no recording).+     * 'mockM': Create a monadic mock function (allows explicit side effects).+-}+module Test.MockCat.Mock+  ( MockBuilder+  , buildMock+  , mock+  , mockM+  , createNamedMockFnWithParams+  , stub+  , shouldBeCalled+  , times+  , atLeast+  , atMost+  , greaterThan+  , lessThan+  , once+  , never+  , inOrder+  , inPartialOrder+  , inOrderWith+  , inPartialOrderWith+  , calledWith+  , anything+  , withArgs+  , onCase+  , cases+  , casesIO+  , label+  , Label+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State (get, put)+import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import Data.Typeable (Typeable)+import Prelude hiding (lookup)+import Test.MockCat.Internal.Builder+import qualified Test.MockCat.Internal.MockRegistry as MockRegistry ( register )+import Test.MockCat.Internal.Types+import Test.MockCat.Param+import Test.MockCat.Verify+import Test.MockCat.Cons (Head(..), (:>)(..))++-- | 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.+type family ToMockParams p where+  ToMockParams (Param a :> rest) = Param a :> rest  -- Already a Param chain, keep as is+  ToMockParams (Param a) = Param a                  -- Single Param, keep as is+  ToMockParams (Cases a b) = Cases a b              -- Cases, keep as is+  ToMockParams (IO a) = IO a                        -- IO, keep as is+  ToMockParams (Head :> a) = Head :> a              -- Already has Head, keep as is+  ToMockParams a = Head :> Param a                  -- Raw value, wrap with Head :> Param++-- | Type class for converting values to mock parameters.+class CreateMock p where+  toParams :: p -> ToMockParams p++-- Instance for Param chains (most specific - should match first)+instance {-# OVERLAPPING #-} CreateMock (Param a :> rest) where+  toParams = id++-- Instance for single Param+instance {-# OVERLAPPING #-} CreateMock (Param a) where+  toParams = id++-- Instance for Cases+instance {-# OVERLAPPING #-} CreateMock (Cases a b) where+  toParams = id++-- Instance for IO+instance {-# OVERLAPPING #-} CreateMock (IO a) where+  toParams = id++-- Instance for Head :> Param r (constant values)+instance {-# OVERLAPPING #-} CreateMock (Head :> Param r) where+  toParams = id++-- Instance for raw values (fallback)+-- This handles raw values by wrapping them with Head :> Param+-- We need to ensure this doesn't match Param chains, Cases, IO, or Head types+instance {-# OVERLAPPABLE #-}+  ( ToMockParams b ~ (Head :> Param b)+  , Normalize b ~ Param b+  , Typeable b+  , ToParamArg b+  ) => CreateMock b where+    toParams value = Head :> toParamArg value++-- | Label type for naming mock functions.+newtype Label = Label MockName++-- | Label function for naming mock functions.+--   Use it with 'mock' to provide a name for the mock function.+--   +--   @+--   f <- mock (label "mockName") $ "a" ~> "b"+--   @+label :: MockName -> Label+label = Label++-- | Type class for creating mock functions with optional name.+class CreateMockFn a where+  mockImpl :: a++-- | Type class for creating stub functions with optional name.+class CreateStubFn a where+  stubImpl :: a++-- | Create a mock function with verification hooks attached (unnamed version).+--   The returned function mimics a pure function (via 'unsafePerformIO') but records its calls for later verification.+--+--   > f <- mock $ "a" ~> "b"+--   > f "a" `shouldBe` "b"+--   > f `shouldBeCalled` "a"+instance+  ( MonadIO m+  , CreateMock p+  , MockBuilder (ToMockParams p) fn verifyParams+  , Typeable verifyParams+  , Typeable fn+  ) =>+  CreateMockFn (p -> m fn)+  where+  mockImpl p = do+    let params = toParams p+    BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing params+    liftIO $ MockRegistry.register Nothing recorder fn++-- | Create a named mock function.+--   The name is used in error messages to help you identify which mock failed.+--+--   > f <- mock (label "MyAPI") $ "a" ~> "b"+instance {-# OVERLAPPING #-}+  ( MonadIO m+  , CreateMock p+  , MockBuilder (ToMockParams p) fn verifyParams+  , Typeable verifyParams+  , Typeable fn+  ) =>+  CreateMockFn (Label -> p -> m fn)+  where+  mockImpl (Label name) p = do+    let params = toParams p+    BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) params+    liftIO $ MockRegistry.register (Just name) recorder fn++-- | Create a mock function with verification hooks attached.+--+-- This function can be used in two ways:+--+-- 1. Without a name:+--    @+--    f <- mock $ "a" ~> "b"+--    @+--+-- 2. With a name (using 'label'):+--    @+--    f <- mock (label "mockName") $ "a" ~> "b"+--    @+--+-- The function creates a verifiable stub that records calls+-- and can be verified via the unified 'shouldBeCalled' API.+-- The function internally uses 'unsafePerformIO' to make the returned function+-- appear pure, but it requires 'MonadIO' for creation.+mock :: CreateMockFn a => a+mock = mockImpl++-- | Type class for creating monadic mock functions without unsafePerformIO.+class CreateMockFnM a where+  mockMImpl :: a++instance+  ( MonadIO m+  , CreateMock p+  , MockIOBuilder (ToMockParams p) fn verifyParams+  , LiftFunTo fn fnM m+  , Typeable verifyParams+  , Typeable fnM+  ) =>+  CreateMockFnM (p -> m fnM)+  where+  mockMImpl p = do+    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++instance {-# OVERLAPPING #-}+  ( MonadIO m+  , CreateMock p+  , MockIOBuilder (ToMockParams p) fn verifyParams+  , LiftFunTo fn fnM m+  , Typeable verifyParams+  , Typeable fnM+  ) =>+  CreateMockFnM (Label -> p -> m fnM)+  where+  mockMImpl (Label name) p = do+    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++mockM :: CreateMockFnM a => a+mockM = mockMImpl++-- | Internal function for TH code that already has MockBuilder constraint.+--   This avoids CreateNamedMock instance resolution issues in generated code.+createNamedMockFnWithParams ::+  ( MonadIO m+  , MockBuilder params fn verifyParams+  , Typeable verifyParams+  , Typeable fn+  ) =>+  MockName ->+  params ->+  m fn+createNamedMockFnWithParams name params = do+  BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) params+  liftIO $ MockRegistry.register (Just name) recorder fn+++-- | Create a pure stub function without verification hooks.+--   Useful when you only need to return values and don't care about verification.+--   This is completely pure and safe.+--+--   > let f = stub $ "a" ~> "b"+instance StubBuilder params fn => CreateStubFn (params -> fn) where+  stubImpl = buildStub Nothing++-- | Create a named pure stub function without verification hooks (named version).+--+-- The provided name is used in failure messages.+-- This function creates a simple stub that returns values based on the provided+-- parameters, but does not support verification. Use 'mock' if you need+-- verification capabilities.+--+-- @+-- let f = stub (label "stubName") $ "a" ~> "b"+-- @+instance {-# OVERLAPPING #-} StubBuilder params fn => CreateStubFn (Label -> params -> fn) where+  stubImpl (Label name) = buildStub (Just name)++{- | Create a pure stub function without verification hooks.++This function can be used in two ways:++1. Without a name:+   @+   let f = stub $ "a" ~> "b"+   @++2. With a name (using 'label'):+   @+   let f = stub (label "stubName") $ "a" ~> "b"+   @++This function creates a simple stub that returns values based on the provided+parameters, but does not support verification. Use 'mock' if you need+verification capabilities.+-}+stub :: CreateStubFn a => a+stub = stubImpl++{- | Register a stub case within a 'Cases' builder. -}+onCase :: a -> Cases a ()+onCase a = Cases $ do+  st <- get+  put (st ++ [a])++{- | Define stub cases from a list of patterns. -}+cases :: [a] -> Cases a ()+cases a = Cases $ put a++{- | IO variant of 'cases'. -}+casesIO :: [a] -> Cases (IO a) ()+casesIO = Cases . (put . map pure)++class LiftFunTo funIO funM (m :: Type -> Type) | funIO m -> funM where+  liftFunTo :: Proxy m -> funIO -> funM++instance MonadIO m => LiftFunTo (IO r) (m r) m where+  liftFunTo _ = liftIO++instance LiftFunTo restIO restM m => LiftFunTo (a -> restIO) (a -> restM) m where+  liftFunTo proxy f a = liftFunTo proxy (f a)++

@@ -3,46 +3,64 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-} module Test.MockCat.MockT (-  MockT(..), Definition(..),+  MockT(..), Definition(..), Verification(..),   runMockT,-  applyTimesIs,-  expectApplyTimes,-  neverApply,-  expectNever,   MonadMockDefs(..)   ) where+import Control.Concurrent.STM+  ( TVar+  , atomically+  , modifyTVar'+  , newTVarIO+  , readTVarIO+  ) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Reader (ReaderT(..), runReaderT)-import GHC.TypeLits (KnownSymbol)-import Data.Data (Proxy)-import Test.MockCat.Mock (Mock, shouldApplyTimesToAnything)-import Data.Foldable (for_)+import Control.Monad.Reader (ReaderT(..), runReaderT, asks)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Data.Data (Proxy, Typeable)+import Data.IORef (newIORef, IORef)+import Data.Dynamic (Dynamic) import UnliftIO (MonadUnliftIO(..))-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')+import Test.MockCat.Internal.Types (InvocationRecorder)+import Test.MockCat.Verify (ResolvableParamsOf)+import Test.MockCat.WithMock (WithMockContext(..), MonadWithMockContext(..))+import Control.Concurrent.MVar (MVar)+import qualified Data.Map.Strict as Map+import qualified Test.MockCat.Internal.Registry.Core as Registry -{- | MockT is a thin wrapper over @ReaderT (IORef [Definition])@ providing+{- | MockT is a thin wrapper over @ReaderT MockTEnv@ providing      mock/stub registration and post-run verification.  Concurrency safety (summary):-  * Within a single 'runMockT' invocation, concurrent applications of stub+  * Within a single 'runMockT' invocation, concurrent calls of stub     functions are recorded without lost or double counts. This is achieved via-    atomic modifications ('atomicModifyIORef'').+    STM updates ('modifyTVar'').   * The /moment/ a call is recorded is when the stub's return value is evaluated;-    if you only create an application but never force the result, it will not+    if you only create a call but never force the result, it will not     appear in the verification log.   * Order-sensitive checks reflect evaluation order, not necessarily wall-clock     start order between threads.-  * Perform verification (e.g. 'shouldApplyTimes', 'expectApplyTimes') after all+  * Perform verification (e.g. 'shouldBeCalled', `expects`) after all     parallel work has completed; running it mid-flight may observe fewer calls     simply because some results are still lazy.-  * Each 'runMockT' call uses a fresh IORef store; mocks are not shared across+  * Each 'runMockT' call uses a fresh TVar store; mocks are not shared across     separate 'runMockT' boundaries. -}-newtype MockT m a = MockT { unMockT :: ReaderT (IORef [Definition]) m a }+data MockTEnv = MockTEnv+  { envDefinitions :: TVar [Definition]+  , envWithMockContext :: WithMockContext+  , envNameForwarders :: IORef (Map.Map String (Either Dynamic (MVar Dynamic)))+  }++newtype MockT m a = MockT { unMockT :: ReaderT MockTEnv m a }   deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)  class Monad m => MonadMockDefs m where@@ -50,17 +68,33 @@   getDefinitions :: m [Definition]  instance MonadUnliftIO m => MonadUnliftIO (MockT m) where-  withRunInIO inner = MockT $ ReaderT $ \ref ->-    withRunInIO $ \run -> inner (\(MockT r) -> run (runReaderT r ref))+  withRunInIO inner = MockT $ ReaderT $ \env ->+    withRunInIO $ \run -> inner (\(MockT r) -> run (runReaderT r env)) -data Definition = forall f p sym. KnownSymbol sym => Definition {+instance {-# OVERLAPPING #-} Monad m => MonadWithMockContext (MockT m) where+  askWithMockContext = MockT $ asks envWithMockContext+++data Definition =+  forall f params sym.+  ( KnownSymbol sym+  , Typeable f+  , Typeable params+  , params ~ ResolvableParamsOf f+  , Typeable (InvocationRecorder params)+  ) =>+  Definition {   symbol :: Proxy sym,-  mock :: Mock f p,-  verify :: Mock f p -> IO ()+  mockFunction :: f,  -- Restore to f for type safety+  verification :: Verification f } +data Verification f+  = NoVerification+  | Verification (f -> IO ())+ {- | Run MockT monad.-  After run, verification is performed to see if the stub function has been applied.+  After run, verification is performed to see if the stub function has been called.    @   import Test.Hspec@@ -86,8 +120,8 @@   spec = do     it "test runMockT" do       result \<- runMockT do-        _readFile $ "input.txt" |\> pack "content"-        _writeFile $ "output.text" |\> pack "content" |\> ()+        _readFile $ "input.txt" ~> pack "content"+        _writeFile $ "output.text" ~> pack "content" ~> ()         operationProgram "input.txt" "output.text"        result `shouldBe` ()@@ -96,89 +130,43 @@ -} runMockT :: MonadIO m => MockT m a -> m a runMockT (MockT r) = do-  ref <- liftIO $ newIORef []-  a <- runReaderT r ref-  defs <- liftIO $ readIORef ref-  for_ defs (\(Definition _ m v) -> liftIO $ v m)+  defsVar <- liftIO $ newTVarIO []+  expectsVar <- liftIO $ newTVarIO []+  fwdRef <- liftIO $ newIORef Map.empty+  let env =+        MockTEnv+          { envDefinitions = defsVar+          , envWithMockContext = WithMockContext expectsVar+          , envNameForwarders = fwdRef+          }+  -- Run user code with a per-run overlay registry active so registry writes/read+  -- during this MockT invocation are isolated to this run.+  overlay <- liftIO Registry.createOverlay+  liftIO $ Registry.installOverlay overlay+  a <- runReaderT r env+  actions <- liftIO $ readTVarIO expectsVar+  liftIO $ sequence_ actions+  liftIO Registry.clearOverlay   pure a -{- | (Preferred: 'expectApplyTimes'; legacy: 'applyTimesIs')-  Specify how many times a stub function (or group of stub definitions) must-  be applied (to /any/ arguments). The function patches the verification-  predicate for the provided stub definitions so that, after 'runMockT'-  completes, the total number of evaluated applications is checked.--  Concurrency & laziness notes:-    * Counting is thread-safe: each evaluated application contributes exactly 1.-    * An application is only counted once its return value is evaluated; ensure-      your test forces (e.g. via @shouldBe@ or sequencing) all stub results-      before relying on the count.-    * Invoke 'expectApplyTimes' (or legacy 'applyTimesIs') inside the 'runMockT' block during setup; do not-      call it after the block ends.--  @-  import Test.Hspec-  import Test.MockCat-  ...--  class (Monad m) => FileOperation m where-    writeFile :: FilePath -\> Text -\> m ()-    readFile :: FilePath -\> m Text--  operationProgram ::-    FileOperation m =>-    FilePath ->-    FilePath ->-    m ()-  operationProgram inputPath outputPath = do-    content <- readFile inputPath-    when (content == pack "ng") $ writeFile outputPath content--  makeMock [t|FileOperation|]--  spec :: Spec-  spec = do-    it "test runMockT" do-      result <- runMockT do-        _readFile ("input.txt" |> pack "content")-        _writeFile ("output.text" |> pack "content" |> ()) `expectApplyTimes` 0-        operationProgram "input.txt" "output.text"--      result `shouldBe` ()--  @---}-applyTimesIs :: MonadIO m => MockT m () -> Int -> MockT m ()-applyTimesIs (MockT inner) a = MockT $ ReaderT $ \ref -> do-  tmp <- liftIO $ newIORef []-  _ <- runReaderT inner tmp-  defs <- liftIO $ readIORef tmp-  let patched = map (\(Definition s m _) -> Definition s m (`shouldApplyTimesToAnything` a)) defs-  liftIO $ atomicModifyIORef' ref (\xs -> (xs ++ patched, ()))-  pure ()---- | Preferred clearer alias for 'applyTimesIs'. Use this in new code.-expectApplyTimes :: MonadIO m => MockT m () -> Int -> MockT m ()-expectApplyTimes = applyTimesIs--neverApply :: MonadIO m => MockT m () -> MockT m ()-neverApply (MockT inner) = MockT $ ReaderT $ \ref -> do-  tmp <- liftIO $ newIORef []-  _ <- runReaderT inner tmp-  defs <- liftIO $ readIORef tmp-  let patched = map (\(Definition s m _) -> Definition s m (`shouldApplyTimesToAnything` 0)) defs-  liftIO $ atomicModifyIORef' ref (\xs -> (xs ++ patched, ()))-  pure ()---- | Alias for 'neverApply' providing naming symmetry with 'expectApplyTimes'.-expectNever :: MonadIO m => MockT m () -> MockT m ()-expectNever = neverApply- instance MonadIO m => MonadMockDefs (MockT m) where-  addDefinition d = MockT $ ReaderT $ \ref -> liftIO $ atomicModifyIORef' ref (\xs -> (xs ++ [d], ()))-  getDefinitions = MockT $ ReaderT $ \ref -> liftIO $ readIORef ref+  addDefinition d = MockT $ ReaderT $ \env -> liftIO $ do+    atomically $ modifyTVar' (envDefinitions env) $ \xs ->+      case d of+        Definition sym _ _ ->+          let name = symbolVal sym+              exists = any (\(Definition sym' _ _) -> symbolVal sym' == name) xs+           in if exists then xs else xs ++ [d]+    pure ()+  getDefinitions = MockT $ ReaderT $ \env -> liftIO $ readTVarIO (envDefinitions env) -instance MonadIO m => MonadMockDefs (ReaderT (IORef [Definition]) m) where-  addDefinition d = ReaderT $ \ref -> liftIO $ atomicModifyIORef' ref (\xs -> (xs ++ [d], ()))-  getDefinitions = ReaderT $ \ref -> liftIO $ readIORef ref+instance MonadIO m => MonadMockDefs (ReaderT MockTEnv m) where+  addDefinition d = ReaderT $ \env -> liftIO $ do+    atomically $ modifyTVar' (envDefinitions env) $ \xs ->+      case d of+        Definition sym _ _ ->+          let name = symbolVal sym+              exists = any (\(Definition sym' _ _) -> symbolVal sym' == name) xs+           in if exists then xs else xs ++ [d]+  getDefinitions = ReaderT $ \env -> liftIO $ readTVarIO (envDefinitions env)+  -- Note: ReaderT variant intentionally returns raw store (used by internal runners).

@@ -1,22 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE MultiParamTypeClasses #-} --- | This module is a parameter of the mock function.------ This parameter can be used when creating and verifying the mock.+-- | This module provides types and functions for representing mock parameters.+-- Parameters are used both for setting up expectations and for verification. module Test.MockCat.Param   ( Param(..),+    WrapParam(..),     value,     param,-    (|>),+    ConsGen(..),     expect,     expect_,     any,@@ -26,91 +28,157 @@     ReturnOf,     ProjectionReturn,     projReturn,-    returnValue+    returnValue,+    Normalize,+    ToParamArg(..)   ) where -import Test.MockCat.Cons ((:>) (..))+import Test.MockCat.Cons ((:>) (..), Head(..)) import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (any)+import Data.Typeable (Typeable, typeOf)+import Foreign.Ptr (Ptr, ptrToIntPtr, castPtr, IntPtr)+import qualified Data.Text as T (Text) -data Param v-  = ExpectValue v-  | ExpectCondition (v -> Bool) String+infixr 0 ~> -instance (Eq a) => Eq (Param a) where-  (ExpectValue a) == (ExpectValue b) = a == b-  (ExpectValue a) == (ExpectCondition m2 _) = m2 a-  (ExpectCondition m1 _) == (ExpectValue b) = m1 b-  (ExpectCondition _ l1) == (ExpectCondition _ l2) = l1 == l2+data Param v where+  -- | A parameter that expects a specific value.+  ExpectValue :: (Show v, Eq v) => v -> String -> Param v+  -- | A parameter that expects a value satisfying a condition.+  ExpectCondition :: (v -> Bool) -> String -> Param v+  -- | A parameter that wraps a value without Eq or Show constraints.+  ValueWrapper :: v -> String -> Param v -type family ShowResult a where-  ShowResult String = String-  ShowResult a = String+-- | Class for wrapping raw values into Param.+-- For types with Show and Eq, it uses ExpectValue to enable comparison and display.+-- For other types, it uses ValueWrapper.+class WrapParam a where+  wrap :: a -> Param a -class ShowParam a where-  showParam :: a -> ShowResult a+instance {-# OVERLAPPING #-} WrapParam String where+  wrap s = ExpectValue s (show s) -instance {-# OVERLAPPING #-} ShowParam (Param String) where-  showParam (ExpectCondition _ l) = l-  showParam (ExpectValue a) = a+instance {-# OVERLAPPING #-} WrapParam Int where+  wrap v = ExpectValue v (show v) -instance {-# INCOHERENT #-} (Show a) => ShowParam (Param a) where-  showParam (ExpectCondition _ l) = l-  showParam (ExpectValue a) = show a+instance {-# OVERLAPPING #-} WrapParam Integer where+  wrap v = ExpectValue v (show v) -instance (ShowParam (Param a)) => Show (Param a) where-  show = showParam+instance {-# OVERLAPPING #-} WrapParam Bool where+  wrap v = ExpectValue v (show v) +instance {-# OVERLAPPING #-} WrapParam Double where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPING #-} WrapParam Float where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPING #-} WrapParam Char where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPING #-} WrapParam T.Text where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPING #-} (Show a, Eq a) => WrapParam [a] where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPING #-} (Show a, Eq a) => WrapParam (Maybe a) where+  wrap v = ExpectValue v (show v)++instance {-# OVERLAPPABLE #-} WrapParam a where+  wrap v = ValueWrapper v "ValueWrapper"++instance Eq (Param a) where+  (ExpectValue a _) == (ExpectValue b _) = a == b+  (ExpectValue a _) == (ExpectCondition m2 _) = m2 a+  (ExpectCondition m1 _) == (ExpectValue b _) = m1 b+  (ExpectCondition _ l1) == (ExpectCondition _ l2) = l1 == l2+  ValueWrapper a _ == ExpectCondition m _ = m a+  ExpectCondition m _ == ValueWrapper a _ = m a+  ExpectValue a _ == ValueWrapper b _ = a == b+  ValueWrapper a _ == ExpectValue b _ = a == b+  ValueWrapper _ _ == ValueWrapper _ _ = False++instance Show (Param v) where+  show (ExpectValue _ l) = l+  show (ExpectCondition _ l) = l+  show (ValueWrapper _ l) = l+ value :: Param v -> v-value (ExpectValue a) = a-value _ = error "not implement"+value (ExpectValue a _) = a+value (ValueWrapper a _) = a+value _ = error "not implemented" -param :: v -> Param v-param = ExpectValue+-- | Create a Param from a value. Requires Eq and Show.+param :: (Show v, Eq v) => v -> Param v+param v = ExpectValue v (show v) -class ConsGen a b r | a b -> r where-  (|>) :: a -> b -> r -instance {-# OVERLAPPING #-} (Param a ~ a', (Param b :> c) ~ bc) => ConsGen a (Param b :> c) (a' :> bc) where-  (|>) a = (:>) (param a)-instance {-# OVERLAPPING #-} ((Param b :> c) ~ bc) => ConsGen (Param a) (Param b :> c) (Param a :> bc) where-  (|>) = (:>)-instance ConsGen (Param a) (Param b) (Param a :> Param b) where-  (|>) = (:>)-instance {-# OVERLAPPABLE #-} ((Param b) ~ b') => ConsGen (Param a) b (Param a :> b') where-  (|>) a b = (:>) a (param b)-instance {-# OVERLAPPABLE #-} ((Param a) ~ a') => ConsGen a (Param b) (a' :> Param b) where-  (|>) a = (:>) (param a)-instance {-# OVERLAPPABLE #-} (Param a ~ a', Param b ~ b') => ConsGen a b (a' :> b') where-  (|>) a b = (:>) (param a) (param b)+-- | Type family to untie the knot for ConsGen instances+type family Normalize a where+  Normalize (a :> b) = a :> b+  Normalize (Param a) = Param a+  Normalize a = Param a -infixr 8 |>+class ToParamArg a where+  toParamArg :: a -> Normalize a --- | Make a parameter to which any value is expected to apply.-any :: Param a-any = unsafeCoerce (ExpectCondition (const True) "any")+instance {-# OVERLAPPING #-} (Typeable (a -> b)) => ToParamArg (a -> b) where+  toParamArg f = ExpectCondition (compareFunction f) (showFunction f) -{- | Create a conditional parameter.+instance {-# OVERLAPPING #-} ToParamArg (Param a) where+  toParamArg = id -   When applying a mock function, if the argument does not satisfy this condition, an error occurs.+instance {-# OVERLAPPABLE #-} (Normalize a ~ Param a, WrapParam a) => ToParamArg a where+  toParamArg = wrap -   In this case, the specified label is included in the error message.+class ToParamResult b where+  toParamResult :: b -> Normalize b++instance {-# OVERLAPPING #-} ToParamResult (Param a) where+  toParamResult = id++instance {-# OVERLAPPING #-} ToParamResult (a :> b) where+  toParamResult = id++instance {-# OVERLAPPABLE #-} (Normalize b ~ Param b, WrapParam b) => ToParamResult b where+  toParamResult = wrap++class ConsGen a b where+  (~>) :: a -> b -> Normalize a :> Normalize b++instance (ToParamArg a, ToParamResult b) => ConsGen a b where+  (~>) a b = (:>) (toParamArg a) (toParamResult b)++-- | Make a parameter to which any value is expected to apply.+--   Use with type application to specify the type: @any \@String@+--+--   > f <- mock $ any ~> True+any :: forall a. Param a+any = ExpectCondition (const True) "any"++{- | Create a conditional parameter with a label.+    When calling a mock function, if the argument does not satisfy this condition, an error occurs.+    In this case, the specified label is included in the error message.++    > expect (>5) ">5" -} expect :: (a -> Bool) -> String -> Param a expect = ExpectCondition -{- | Create a conditional parameter.--  In applied a mock function, if the argument does not satisfy this condition, an error occurs.+{- | Create a conditional parameter without a label.+  The error message is displayed as "[some condition]". -  Unlike @'expect'@, it does not require a label, but the error message is displayed as [some condition].+  > expect_ (>5) -} expect_ :: (a -> Bool) -> Param a expect_ f = ExpectCondition f "[some condition]"  -- | The type of the argument parameters of the parameters. type family ArgsOf params where+  ArgsOf (Head :> Param r) = ()                        -- Constant value has no arguments   ArgsOf (Param a :> Param r) = Param a   ArgsOf (Param a :> rest) = Param a :> ArgsOf rest @@ -118,6 +186,9 @@ class ProjectionArgs params where   projArgs :: params -> ArgsOf params +instance {-# OVERLAPPING #-} ProjectionArgs (Head :> Param r) where+  projArgs (_ :> _) = ()+ instance {-# OVERLAPPING #-} ProjectionArgs (Param a :> Param r) where   projArgs (a :> _) = a @@ -129,12 +200,16 @@  -- | The type of the return parameter of the parameters. type family ReturnOf params where+  ReturnOf (Head :> Param r) = Param r                 -- Constant value returns Param r   ReturnOf (Param a :> Param r) = Param r   ReturnOf (Param a :> rest) = ReturnOf rest  class ProjectionReturn param where   projReturn :: param -> ReturnOf param +instance {-# OVERLAPPING #-} ProjectionReturn (Head :> Param r) where+  projReturn (_ :> r) = r+ instance {-# OVERLAPPING #-} ProjectionReturn (Param a :> Param r) where   projReturn (_ :> r) = r @@ -146,3 +221,20 @@  returnValue :: (ProjectionReturn params, ReturnOf params ~ Param r) => params -> r returnValue = value . projReturn++-- | Get the pointer address of a value (used for both comparison and display)+getPtrAddr :: forall a. a -> IntPtr+getPtrAddr x = ptrToIntPtr (castPtr (unsafeCoerce x :: Ptr ()))++-- | Helper function to compare function values using pointer equality+-- Uses the same pointer calculation as showFunction for consistency+compareFunction :: forall a. a -> a -> Bool+compareFunction x y = getPtrAddr x == getPtrAddr y++-- | Show function using type information and a pointer hash+showFunction :: forall a. Typeable a => a -> String+showFunction x =+  let typeStr = show (typeOf x)+      -- Use the same pointer address calculation as compareFunction+      ptrAddr = show (getPtrAddr x)+   in typeStr ++ "@" ++ ptrAddr

@@ -1,35 +1,31 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-}  module Test.MockCat.TH   ( showExp,     expectByExpr,     makeMock,-    makeMockWithOptions,-    MockOptions (..),-    options,+    makeAutoLiftMock,     makePartialMock,-    makePartialMockWithOptions,+    makeAutoLiftPartialMock,   ) where -import Control.Monad (guard, unless)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.Data (Proxy (..))-import Data.Function ((&))-import Data.List (elemIndex, find, nub)-import Data.Maybe (fromMaybe, isJust)-import Data.Text (pack, splitOn, unpack)-import GHC.TypeLits (KnownSymbol, symbolVal)+import Control.Monad (unless)+import Data.List (elemIndex, nub)+import Data.Maybe (catMaybes)+import qualified Data.Map.Strict as Map+ import Language.Haskell.TH   ( Cxt,     Dec (..),@@ -41,27 +37,60 @@     Pat (..),     Pred,     Q,-    Quote (newName),     TyVarBndr (..),+    TySynEqn (..),+    TypeFamilyHead (..),     Type (..),     isExtEnabled,     mkName,     pprint,     reify,-    Inline (NoInline),-    RuleMatch (FunLike),-    Phases (AllPhases),   ) import Language.Haskell.TH.Lib import Language.Haskell.TH.PprLib (Doc, hcat, parens, text) import Language.Haskell.TH.Syntax (nameBase)-import Test.MockCat.Cons-import Test.MockCat.Mock+import Test.MockCat.Mock () import Test.MockCat.MockT+import Test.MockCat.TH.ClassAnalysis+  ( ClassName2VarNames(..),+    VarName2ClassNames(..),+    filterClassInfo,+    filterMonadicVarInfos,+    getClassName,+    getClassNames,+    toClassInfos,+    VarAppliedType(..),+    applyVarAppliedTypes )+import Test.MockCat.TH.ContextBuilder+  ( MockType (..),+    buildContext,+    getTypeVarName,+    getTypeVarNames,+    tyVarBndrToType,+    applyFamilyArg,+    convertTyVarBndr+  )+import Test.MockCat.TH.TypeUtils+  ( splitApps,+    substituteType+  )+import Test.MockCat.TH.FunctionBuilder+  ( createFnName,+    typeToNames,+    safeIndex,+    MockFnContext(..)+    , buildMockFnContext+    , buildMockFnDeclarations+    , createNoInlinePragma+    , generateInstanceMockFnBody+    , generateInstanceRealFnBody+  )+import Test.MockCat.TH.Types (MockOptions(..), options)+import Test.MockCat.Verify () import Test.MockCat.Param-import Unsafe.Coerce (unsafeCoerce) import Prelude as P + showExp :: Q Exp -> Q String showExp qexp = show . pprintExp <$> qexp @@ -104,7 +133,7 @@  -- | Create a conditional parameter based on @Q Exp@. -----  In applying a mock function, if the argument does not satisfy this condition, an error is raised.+--  In calling a mock function, if the argument does not satisfy this condition, an error is raised. -- --  The conditional expression is displayed in the error message. expectByExpr :: Q Exp -> Q Exp@@ -112,47 +141,38 @@   str <- showExp qf   [|ExpectCondition $qf str|] -data MockType = Total | Partial deriving (Eq) --- | Options for generating mocks.------  - prefix: Stub function prefix---  - suffix: stub function suffix---  - implicitMonadicReturn: If True, the return value of the stub function is wrapped in a monad automatically.---                           If Else, the return value of stub function is not wrapped in a monad,  so required explicitly return monadic values.-data MockOptions = MockOptions {prefix :: String, suffix :: String, implicitMonadicReturn :: Bool} --- | Default Options.------  Stub function names are prefixed with “_”.-options :: MockOptions-options = MockOptions {prefix = "_", suffix = "", implicitMonadicReturn = True}---- | Create a mock of the typeclasses that returns a monad according to the `MockOptions`.+-- | Create a mock of a typeclasses that returns a monad. -- --  Given a monad type class, generate the following. -- --  - MockT instance of the given typeclass --  - A stub function corresponding to a function of the original class type.--- The name of stub function is the name of the original function with a “_” appended.+-- The name of stub function is the name of the original function with a "_" appended. --+--  The prefix can be changed.+--  In that case, use `makeMockWithOptions`.+-- --  @ --  class (Monad m) => FileOperation m where --    writeFile :: FilePath -\> Text -\> m () --    readFile :: FilePath -\> m Text -----  makeMockWithOptions [t|FileOperation|] options { prefix = "stub_" }+--  makeMock [t|FileOperation|] -----  it "test runMockT" do---    result \<- runMockT do---      stub_readFile $ "input.txt" |\> pack "content"---      stub_writeFile $ "output.text" |\> pack "content" |\> ()---      somethingProgram+--  spec :: Spec+--  spec = do+--    it "test runMockT" do+--      result \<- runMockT do+--        _readFile $ "input.txt" ~> pack "content"+--        _writeFile $ "output.text" ~> pack "content" ~> ()+--        somethingProgram -----    result `shouldBe` ()+--      result `shouldBe` () --  @-makeMockWithOptions :: Q Type -> MockOptions -> Q [Dec]-makeMockWithOptions = flip doMakeMock Total+makeMock :: Q Type -> Q [Dec]+makeMock t = doMakeMock t Total options  -- | Create a mock of a typeclasses that returns a monad. --@@ -160,30 +180,29 @@ -- --  - MockT instance of the given typeclass --  - A stub function corresponding to a function of the original class type.--- The name of stub function is the name of the original function with a “_” appended.+-- The name of stub function is the name of the original function with a "_" appended. -----  The prefix can be changed.---  In that case, use `makeMockWithOptions`.+--  This function automatically wraps the return value in a monad (Implicit Monadic Return). -- --  @ --  class (Monad m) => FileOperation m where --    writeFile :: FilePath -\> Text -\> m () --    readFile :: FilePath -\> m Text -----  makeMock [t|FileOperation|]+--  makeAutoLiftMock [t|FileOperation|] -- --  spec :: Spec --  spec = do --    it "test runMockT" do --      result \<- runMockT do---        _readFile $ "input.txt" |\> pack "content"---        _writeFile $ "output.text" |\> pack "content" |\> ()+--        _readFile $ "input.txt" ~> pack "content"+--        _writeFile $ "output.text" ~> pack "content" ~> () --        somethingProgram -- --      result `shouldBe` () --  @-makeMock :: Q Type -> Q [Dec]-makeMock t = doMakeMock t Total options+makeAutoLiftMock :: Q Type -> Q [Dec]+makeAutoLiftMock t = doMakeMock t Total (options { implicitMonadicReturn = True })  -- | Create a partial mock of a typeclasses that returns a monad. --@@ -191,7 +210,7 @@ -- --  - MockT instance of the given typeclass --  - A stub function corresponding to a function of the original class type.--- The name of stub function is the name of the original function with a “_” appended.+-- The name of stub function is the name of the original function with a "_" appended. -- --  For functions that are not stubbed in the test, the real function is used as appropriate for the context. --@@ -229,47 +248,212 @@ makePartialMock :: Q Type -> Q [Dec] makePartialMock t = doMakeMock t Partial options --- | `makePartialMock` with options-makePartialMockWithOptions :: Q Type -> MockOptions -> Q [Dec]-makePartialMockWithOptions = flip doMakeMock Partial+-- | `makePartialMock` with `implicitMonadicReturn = True` by default.+makeAutoLiftPartialMock :: Q Type -> Q [Dec]+makeAutoLiftPartialMock t = doMakeMock t Partial (options { implicitMonadicReturn = True }) ++ doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]-doMakeMock t mockType options = do-  verifyExtension DataKinds-  verifyExtension FlexibleInstances-  verifyExtension FlexibleContexts+doMakeMock qType mockType options = do+  verifyRequiredExtensions+  ty <- qType+  let className = getClassName ty+  classMetadata <- loadClassMetadata className+  monadVarName <- selectMonadVarName classMetadata+  makeMockDecs+    ty+    mockType+    className+    monadVarName+    (cmContext classMetadata)+    (cmTypeVars classMetadata)+    (cmDecs classMetadata)+    options -  ty <- t-  className <- getClassName <$> t+verifyRequiredExtensions :: Q ()+verifyRequiredExtensions =+  mapM_+    verifyExtension+    [DataKinds, FlexibleInstances, FlexibleContexts, TypeFamilies] -  reify className >>= \case+loadClassMetadata :: Name -> Q ClassMetadata+loadClassMetadata className = do+  info <- reify className+  case info of     ClassI (ClassD _ _ [] _ _) _ ->       fail $ "A type parameter is required for class " <> show className-    ClassI (ClassD cxt _ typeVars _ decs) _ -> do-      monadVarNames <- getMonadVarNames cxt typeVars-      case nub monadVarNames of-        [] -> fail "Monad parameter not found."-        (monadVarName : rest)-          | length rest > 1 -> fail "Monad parameter must be unique."-          | otherwise -> makeMockDecs ty mockType className monadVarName cxt typeVars decs options-    t -> error $ "unsupported type: " <> show t+    ClassI (ClassD cxt _ typeVars _ decs) _ ->+      pure $+        ClassMetadata+          { cmName = className,+            cmContext = cxt,+            cmTypeVars = map convertTyVarBndr typeVars,+            cmDecs = decs+          }+    other -> error $ "unsupported type: " <> show other +selectMonadVarName :: ClassMetadata -> Q Name+selectMonadVarName metadata = do+  monadVarNames <- getMonadVarNames (cmContext metadata) (cmTypeVars metadata)+  case nub monadVarNames of+    [] -> fail "Monad parameter not found."+    (monadVarName : rest)+      | length rest > 1 -> fail "Monad parameter must be unique."+      | otherwise -> pure monadVarName+ makeMockDecs :: Type -> MockType -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec] makeMockDecs ty mockType className monadVarName cxt typeVars decs options = do   let classParamNames = filter (className /=) (getClassNames ty)       newTypeVars = drop (length classParamNames) typeVars       varAppliedTypes = zipWith (\t i -> VarAppliedType t (safeIndex classParamNames i)) (getTypeVarNames typeVars) [0 ..]+      sigDecs = [dec | dec@(SigD _ _) <- decs]+      typeFamilyHeads =+        [head | OpenTypeFamilyD head <- decs] +++        [head | ClosedTypeFamilyD head _ <- decs] +  let typeInstDecs = map (createTypeInstanceDec monadVarName) typeFamilyHeads+      instanceBodyDecs = map (createInstanceFnDec mockType options) sigDecs ++ typeInstDecs+      fullCxt = buildContext cxt mockType className monadVarName newTypeVars varAppliedTypes+  (superClassDecs, predsToDrop) <-+    deriveSuperClassInstances+      mockType+      monadVarName+      newTypeVars+      varAppliedTypes+      options+      cxt+  let filteredCxt = filter (`notElem` predsToDrop) fullCxt   instanceDec <-     instanceD-      (createCxt cxt mockType className monadVarName newTypeVars varAppliedTypes)+      (pure filteredCxt)       (createInstanceType ty monadVarName newTypeVars)-      (map (createInstanceFnDec mockType options) decs)+      instanceBodyDecs+  mockFnDecs <- concat <$> mapM (mockDec mockType monadVarName varAppliedTypes options) sigDecs -  mockFnDecs <- concat <$> mapM (createMockFnDec monadVarName varAppliedTypes options) decs+  pure $ superClassDecs ++ (instanceDec : mockFnDecs) -  pure $ instanceDec : mockFnDecs+deriveSuperClassInstances ::+  MockType ->+  Name ->+  [TyVarBndr a] ->+  [VarAppliedType] ->+  MockOptions ->+  Cxt ->+  Q ([Dec], [Pred])+deriveSuperClassInstances mockType _ _ _ _ _+  | mockType /= Total = pure ([], [])+deriveSuperClassInstances _ monadVarName typeVars varAppliedTypes _ cxt = do+  results <- mapM (deriveSuperClassInstance monadVarName typeVars varAppliedTypes) cxt+  let valid = catMaybes results+  pure (map fst valid, map snd valid) +deriveSuperClassInstance ::+  Name ->+  [TyVarBndr a] ->+  [VarAppliedType] ->+  Pred ->+  Q (Maybe (Dec, Pred))+deriveSuperClassInstance _ _ varAppliedTypes pred = do+  superInfo <- resolveSuperClassInfo pred+  maybe (pure Nothing) (buildSuperClassDerivation varAppliedTypes) superInfo+  where+    resolveSuperClassInfo :: Pred -> Q (Maybe SuperClassInfo)+    resolveSuperClassInfo target =+      case splitApps target of+        (ConT superName, args) -> do+          info <- reify superName+          pure $+            case info of+              ClassI (ClassD superCxt _ superTypeVars _ superDecs) _ ->+                Just $ SuperClassInfo superName args superCxt (map convertTyVarBndr superTypeVars) superDecs+              _ -> Nothing+        _ -> pure Nothing++    buildSuperClassDerivation ::+      [VarAppliedType] ->+      SuperClassInfo ->+      Q (Maybe (Dec, Pred))+    buildSuperClassDerivation appliedTypes info+      | superClassHasMethods info = pure Nothing+      | otherwise = do+          superMonadVars <- getMonadVarNames (scContext info) (scTypeVars info)+          case superMonadVars of+            [superMonadVar] -> buildMockInstance appliedTypes info superMonadVar+            _ -> pure Nothing++    buildMockInstance ::+      [VarAppliedType] ->+      SuperClassInfo ->+      Name ->+      Q (Maybe (Dec, Pred))+    buildMockInstance appliedTypes info superMonadVar = do+      let superVarNames = map getTypeVarName (scTypeVars info)+      if length superVarNames /= length (scArgs info)+        then pure Nothing+        else do+          let (contextPreds, instanceType) =+                buildInstancePieces appliedTypes info superMonadVar superVarNames+          instanceDec <- instanceD (pure contextPreds) (pure instanceType) []+          pure $ Just (instanceDec, instanceType)++    buildInstancePieces ::+      [VarAppliedType] ->+      SuperClassInfo ->+      Name ->+      [Name] ->+      ([Pred], Pred)+    buildInstancePieces appliedTypes info superMonadVar superVarNames =+      let substitutedArgs = map (applyVarAppliedTypes appliedTypes) (scArgs info)+          subMap = Map.fromList (zip superVarNames substitutedArgs)+          instanceArgs =+            map+              (buildInstanceArg appliedTypes superMonadVar subMap)+              superVarNames+          instanceType = foldl AppT (ConT (scName info)) instanceArgs+          contextPreds =+            map+              (applyVarAppliedTypes appliedTypes . substituteType subMap)+              (scContext info)+       in (contextPreds, instanceType)++    buildInstanceArg ::+      [VarAppliedType] ->+      Name ->+      Map.Map Name Type ->+      Name ->+      Type+    buildInstanceArg appliedTypes superMonadVar subMap var =+      let applied = applyVarAppliedTypes appliedTypes (lookupType subMap var)+       in if var == superMonadVar+            then AppT (ConT ''MockT) applied+            else applied++    lookupType :: Map.Map Name Type -> Name -> Type+    lookupType subMap key = Map.findWithDefault (VarT key) key subMap++    superClassHasMethods :: SuperClassInfo -> Bool+    superClassHasMethods = P.any isSignature . scDecs++    isSignature (SigD _ _) = True+    isSignature _ = False+++data SuperClassInfo = SuperClassInfo+  { scName :: Name,+    scArgs :: [Type],+    scContext :: Cxt,+    scTypeVars :: [TyVarBndr ()],+    scDecs :: [Dec]+  }++data ClassMetadata = ClassMetadata+  { cmName :: Name,+    cmContext :: Cxt,+    cmTypeVars :: [TyVarBndr ()],+    cmDecs :: [Dec]+  }+ getMonadVarNames :: Cxt -> [TyVarBndr a] -> Q [Name] getMonadVarNames cxt typeVars = do   let parentClassInfos = toClassInfos cxt@@ -282,28 +466,6 @@    pure $ (\(VarName2ClassNames n _) -> n) <$> filterMonadicVarInfos varInfos -getTypeVarNames :: [TyVarBndr a] -> [Name]-getTypeVarNames = map getTypeVarName--getTypeVarName :: TyVarBndr a -> Name-getTypeVarName (PlainTV name _) = name-getTypeVarName (KindedTV name _ _) = name--toClassInfos :: Cxt -> [ClassName2VarNames]-toClassInfos = map toClassInfo--toClassInfo :: Pred -> ClassName2VarNames-toClassInfo (AppT t1 t2) = do-  let (ClassName2VarNames name vars) = toClassInfo t1-  ClassName2VarNames name (vars ++ getTypeNames t2)-toClassInfo (ConT name) = ClassName2VarNames name []-toClassInfo _ = error "Unsupported Type structure"--getTypeNames :: Pred -> [Name]-getTypeNames (VarT name) = [name]-getTypeNames (ConT name) = [name]-getTypeNames _ = []- collectVarInfos :: [ClassName2VarNames] -> [VarName2ClassNames] -> Q [VarName2ClassNames] collectVarInfos classInfos = mapM (collectVarInfo classInfos) @@ -336,68 +498,18 @@           result <- concat <$> mapM (collectVarClassNames_ typeVarName) parentClassInfos           pure $ cName : result -filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames]-filterClassInfo name = filter (hasVarName name)-  where-    hasVarName :: Name -> ClassName2VarNames -> Bool-    hasVarName name (ClassName2VarNames _ varNames) = name `elem` varNames--filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames]-filterMonadicVarInfos = filter hasMonadInVarInfo--hasMonadInVarInfo :: VarName2ClassNames -> Bool-hasMonadInVarInfo (VarName2ClassNames _ classNames) = ''Monad `elem` classNames--createCxt :: [Pred] -> MockType -> Name -> Name -> [TyVarBndr a] -> [VarAppliedType] -> Q [Pred]-createCxt cxt mockType className monadVarName tyVars varAppliedTypes = do-  newCxtRaw <- mapM (createPred monadVarName) cxt--  let isRedundantMonad (AppT (ConT m) (VarT v)) = m == ''Monad && v == monadVarName-      isRedundantMonad _ = False-      newCxt = filter (not . isRedundantMonad) newCxtRaw--  monadIOAppT <- appT (conT ''MonadIO) (varT monadVarName)--  let classInfos = toClassInfos newCxt-      hasMonadIO = P.any (\(ClassName2VarNames c _) -> c == ''MonadIO) classInfos-      addedMonads = [monadIOAppT | not hasMonadIO]--  pure $ case mockType of-    Total -> newCxt ++ addedMonads-    Partial -> do-      let classAppT = constructClassAppT className $ toVarTs tyVars-          varAppliedClassAppT = updateType classAppT varAppliedTypes-      newCxt ++ addedMonads ++ [varAppliedClassAppT]--toVarTs :: [TyVarBndr a] -> [Type]-toVarTs tyVars = VarT <$> getTypeVarNames tyVars--constructClassAppT :: Name -> [Type] -> Type-constructClassAppT className = foldl AppT (ConT className)--createPred :: Name -> Pred -> Q Pred-createPred monadVarName a@(AppT t@(ConT ty) b@(VarT varName))-  | monadVarName == varName && ty == ''Monad = pure a-  | monadVarName == varName && ty /= ''Monad = appT (pure t) (appT (conT ''MockT) (varT varName))-  | otherwise = appT (createPred monadVarName t) (pure b)-createPred monadVarName (AppT ty a@(VarT varName))-  | monadVarName == varName = appT (pure ty) (appT (conT ''MockT) (varT varName))-  | otherwise = appT (createPred monadVarName ty) (pure a)-createPred monadVarName (AppT ty1 ty2) = appT (createPred monadVarName ty1) (createPred monadVarName ty2)-createPred _ ty = pure ty- createInstanceType :: Type -> Name -> [TyVarBndr a] -> Q Type createInstanceType className monadName tvbs = do-  types <- mapM (tyVarBndrToType monadName) tvbs+  let types = fmap (tyVarBndrToType monadName) tvbs   pure $ foldl AppT className types -tyVarBndrToType :: Name -> TyVarBndr a -> Q Type-tyVarBndrToType monadName (PlainTV name _)-  | monadName == name = appT (conT ''MockT) (varT monadName)-  | otherwise = varT name-tyVarBndrToType monadName (KindedTV name _ _)-  | monadName == name = appT (conT ''MockT) (varT monadName)-  | otherwise = varT name+createTypeInstanceDec :: Name -> TypeFamilyHead -> Q Dec+createTypeInstanceDec monadVarName (TypeFamilyHead familyName tfVars _ _) = do+  let lhsArgs = map (applyFamilyArg monadVarName) tfVars+      rhsArgs = map (VarT . getTypeVarName) tfVars+      lhsType = foldl AppT (ConT familyName) lhsArgs+      rhsType = foldl AppT (ConT familyName) rhsArgs+  pure $ TySynInstD (TySynEqn Nothing lhsType rhsType)  createInstanceFnDec :: MockType -> MockOptions -> Dec -> Q Dec createInstanceFnDec mockType options (SigD fnName funType) = do@@ -415,226 +527,17 @@   funD fnName [fnClause] createInstanceFnDec _ _ dec = fail $ "unsuported dec: " <> pprint dec -generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp-generateInstanceMockFnBody fnNameStr args r options = do-  returnExp <- if options.implicitMonadicReturn-    then [| pure $(varE r) |]-    else [| lift $(varE r) |]-  [|-    MockT $ do-      defs <- getDefinitions-      let mock =-            defs-              & findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr)))-              & fromMaybe (error $ "no answer found stub function `" ++ fnNameStr ++ "`.")-          $(bangP $ varP r) = $(generateStubFn args [|mock|])-      $(pure returnExp)-    |] -generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp-generateInstanceRealFnBody fnName fnNameStr args r options = do-  returnExp <- if options.implicitMonadicReturn-    then [| pure $(varE r) |]-    else [| lift $(varE r) |]-  [|-    MockT $ do-      defs <- getDefinitions-      case findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr))) defs of-        Just mock -> do-          let $(bangP $ varP r) = $(generateStubFn args [|mock|])-          $(pure returnExp)-        Nothing -> lift $ $(foldl appE (varE fnName) args)-    |] -generateStubFn :: [Q Exp] -> Q Exp -> Q Exp-generateStubFn [] = $([|generateConstantStubFn|])-generateStubFn args = $([|generateNotConstantsStubFn args|])--generateNotConstantsStubFn :: [Q Exp] -> Q Exp -> Q Exp-generateNotConstantsStubFn args mock = foldl appE [|stubFn $(mock)|] args--generateConstantStubFn :: Q Exp -> Q Exp-generateConstantStubFn mock = [|stubFn $(mock)|]--createMockFnDec :: Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]-createMockFnDec monadVarName varAppliedTypes options (SigD sigFnName ty) = do-  let fnName = createFnName sigFnName options-      mockFnName = mkName fnName-      params = mkName "p"-      updatedType = updateType ty varAppliedTypes-      fnType = if options.implicitMonadicReturn-        then createMockBuilderFnType monadVarName updatedType-        else updatedType--  fnDecs <- if isNotConstantFunctionType ty then-    doCreateMockFnDecs fnName mockFnName params fnType monadVarName updatedType-  else-    if options.implicitMonadicReturn then-      doCreateConstantMockFnDecs fnName mockFnName fnType monadVarName-    else-      doCreateEmptyVerifyParamMockFnDecs fnName mockFnName params fnType monadVarName updatedType--  pragmaDec <- pragInlD mockFnName NoInline FunLike AllPhases-+mockDec :: MockType -> Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]+mockDec mockType monadVarName varAppliedTypes options (SigD sigFnName ty) = do+  let ctx = buildMockFnContext mockType monadVarName varAppliedTypes options sigFnName ty+  fnDecs <- buildMockFnDeclarations ctx+  pragmaDec <- createNoInlinePragma (mockFnName ctx)   pure $ pragmaDec : fnDecs+mockDec _ _ _ _ dec = fail $ "unsupport dec: " <> pprint dec -createMockFnDec _ _ _ dec = fail $ "unsupport dec: " <> pprint dec -doCreateMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]-doCreateMockFnDecs funNameStr mockFunName params funType monadVarName updatedType = do-  newFunSig <- do-    let verifyParams = createMockBuilderVerifyParams updatedType-    sigD-      mockFunName-      [t|-        (MockBuilder $(varT params) ($(pure funType)) ($(pure verifyParams)), MonadIO $(varT monadVarName)) =>-        $(varT params) ->-        MockT $(varT monadVarName) ()-        |]--  createMockFn <- [|createNamedMock|]--  mockBody <- createMockBody funNameStr createMockFn-  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]--  pure $ newFunSig : [newFun]--doCreateConstantMockFnDecs :: (Quote m) => String -> Name -> Type -> Name -> m [Dec]-doCreateConstantMockFnDecs funNameStr mockFunName ty monadVarName = do-  newFunSig <- sigD mockFunName [t|(MonadIO $(varT monadVarName)) => $(pure ty) -> MockT $(varT monadVarName) ()|]-  createMockFn <- [|createNamedConstantMock|]-  mockBody <- createMockBody funNameStr createMockFn-  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]-  pure $ newFunSig : [newFun]---- MockBuilder constraints, but verifyParams are empty.-doCreateEmptyVerifyParamMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]-doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funType monadVarName updatedType = do-  newFunSig <- do-    let verifyParams = createMockBuilderVerifyParams updatedType-    sigD-      mockFunName-      [t|-        (MockBuilder $(varT params) ($(pure funType)) (), MonadIO $(varT monadVarName)) =>-        $(varT params) ->-        MockT $(varT monadVarName) ()-        |]--  createMockFn <- [|createNamedMock|]--  mockBody <- createMockBody funNameStr createMockFn-  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]--  pure $ newFunSig : [newFun]--createMockBody :: (Quote m) => String -> Exp -> m Exp-createMockBody funNameStr createMockFn =-  [|-    MockT $ do-      mockInstance <- liftIO $ $(pure createMockFn) $(litE (stringL funNameStr)) p-      addDefinition-        ( Definition-            (Proxy :: Proxy $(litT (strTyLit funNameStr)))-            mockInstance-            shouldApplyToAnything-        )-    |]--isNotConstantFunctionType :: Type -> Bool-isNotConstantFunctionType (AppT (AppT ArrowT _) _) = True-isNotConstantFunctionType (AppT t1 t2) = isNotConstantFunctionType t1 || isNotConstantFunctionType t2-isNotConstantFunctionType (TupleT _) = False-isNotConstantFunctionType (ForallT _ _ t) = isNotConstantFunctionType t-isNotConstantFunctionType _ = False--updateType :: Type -> [VarAppliedType] -> Type-updateType (AppT (VarT v1) (VarT v2)) varAppliedTypes = do-  let x = maybe (VarT v1) ConT (findClass v1 varAppliedTypes)-      y = maybe (VarT v2) ConT (findClass v2 varAppliedTypes)-  AppT x y-updateType ty _ = ty--hasClass :: Name -> [VarAppliedType] -> Bool-hasClass varName = P.any (\(VarAppliedType v c) -> (v == varName) && isJust c)--findClass :: Name -> [VarAppliedType] -> Maybe Name-findClass varName types = do-  guard $ hasClass varName types-  (VarAppliedType _ c) <- find (\(VarAppliedType v _) -> v == varName) types-  c--createFnName :: Name -> MockOptions -> String-createFnName funName options = do-  options.prefix <> nameBase funName <> options.suffix--createMockBuilderFnType :: Name -> Type -> Type-createMockBuilderFnType monadVarName a@(AppT (VarT var) ty)-  | monadVarName == var = ty-  | otherwise = a-createMockBuilderFnType monadVarName (AppT ty ty2) = AppT ty (createMockBuilderFnType monadVarName ty2)-createMockBuilderFnType monadVarName (ForallT _ _ ty) = createMockBuilderFnType monadVarName ty-createMockBuilderFnType _ ty = ty--createMockBuilderVerifyParams :: Type -> Type-createMockBuilderVerifyParams (AppT (AppT ArrowT ty) (AppT (VarT _) _)) = AppT (ConT ''Param) ty-createMockBuilderVerifyParams (AppT (AppT ArrowT ty) ty2) =-  AppT (AppT (ConT ''(:>)) (AppT (ConT ''Param) ty)) (createMockBuilderVerifyParams ty2)-createMockBuilderVerifyParams (AppT (VarT _) (ConT c)) = AppT (ConT ''Param) (ConT c)-createMockBuilderVerifyParams (ForallT _ _ ty) = createMockBuilderVerifyParams ty-createMockBuilderVerifyParams a = a--findParam :: (KnownSymbol sym) => Proxy sym -> [Definition] -> Maybe a-findParam pa definitions = do-  let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions-  fmap (\(Definition _ mock _) -> unsafeCoerce mock) definition--typeToNames :: Type -> [Q Name]-typeToNames (AppT (AppT ArrowT _) t2) = newName "a" : typeToNames t2-typeToNames (ForallT _ _ ty) = typeToNames ty-typeToNames _ = []--getClassName :: Type -> Name-getClassName (ConT name) = name-getClassName (AppT ty _) = getClassName ty-getClassName d = error $ "unsupported class definition: " <> show d--getClassNames :: Type -> [Name]-getClassNames (AppT (ConT name1) (ConT name2)) = [name1, name2]-getClassNames (AppT ty (ConT name)) = getClassNames ty ++ [name]-getClassNames (AppT ty1 ty2) = getClassNames ty1 ++ getClassNames ty2-getClassNames _ = []--data ClassName2VarNames = ClassName2VarNames Name [Name]--instance Show ClassName2VarNames where-  show (ClassName2VarNames cName varNames) = showClassDef cName varNames--data VarName2ClassNames = VarName2ClassNames Name [Name]--instance Show VarName2ClassNames where-  show (VarName2ClassNames varName classNames) = show varName <> " class is " <> unwords (showClassName <$> classNames)--data VarAppliedType = VarAppliedType {name :: Name, appliedClassName :: Maybe Name}-  deriving (Show)--showClassName :: Name -> String-showClassName n = splitLast "." $ show n--showClassDef :: Name -> [Name] -> String-showClassDef className varNames = showClassName className <> " " <> unwords (show <$> varNames)--splitLast :: String -> String -> String-splitLast delimiter = last . split delimiter--split :: String -> String -> [String]-split delimiter str = unpack <$> splitOn (pack delimiter) (pack str)--safeIndex :: [a] -> Int -> Maybe a-safeIndex [] _ = Nothing-safeIndex (x : _) 0 = Just x-safeIndex (_ : xs) n-  | n < 0 = Nothing-  | otherwise = safeIndex xs (n - 1)  verifyExtension :: Extension -> Q () verifyExtension e = isExtEnabled e >>= flip unless (fail $ "Language extensions `" ++ show e ++ "` is required.")

@@ -0,0 +1,131 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Test.MockCat.TH.ClassAnalysis+  ( ClassName2VarNames (..),+    VarName2ClassNames (..),+    toClassInfos,+    toClassInfo,+    getTypeNames,+    filterClassInfo,+    filterMonadicVarInfos,+    hasMonadInVarInfo,+    getClassName,+    getClassNames,+    VarAppliedType (..),+    applyVarAppliedTypes,+    updateType,+    findClass,+    hasClass+  )+where++import Control.Monad (guard)+import Data.List (find)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Text (pack, splitOn, unpack)+import Language.Haskell.TH+  ( Name,+    Pred,+    Type (..),+  )++data ClassName2VarNames = ClassName2VarNames Name [Name]++instance Show ClassName2VarNames where+  show (ClassName2VarNames cName varNames) = showClassDef cName varNames++data VarName2ClassNames = VarName2ClassNames Name [Name]++instance Show VarName2ClassNames where+  show (VarName2ClassNames varName classNames) = show varName <> " class is " <> unwords (showClassName <$> classNames)++toClassInfos :: [Pred] -> [ClassName2VarNames]+toClassInfos = map toClassInfo++toClassInfo :: Pred -> ClassName2VarNames+toClassInfo (AppT t1 t2) =+  let (ClassName2VarNames name vars) = toClassInfo t1+   in ClassName2VarNames name (vars ++ getTypeNames t2)+toClassInfo (ConT name) = ClassName2VarNames name []+toClassInfo _ = error "Unsupported Type structure"++getTypeNames :: Pred -> [Name]+getTypeNames (VarT name) = [name]+getTypeNames (ConT name) = [name]+getTypeNames _ = []++filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames]+filterClassInfo name = filter (hasVarName name)+  where+    hasVarName :: Name -> ClassName2VarNames -> Bool+    hasVarName target (ClassName2VarNames _ varNames) = target `elem` varNames++filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames]+filterMonadicVarInfos = filter hasMonadInVarInfo++hasMonadInVarInfo :: VarName2ClassNames -> Bool+hasMonadInVarInfo (VarName2ClassNames _ classNames) = ''Monad `elem` classNames++getClassName :: Type -> Name+getClassName (ConT name) = name+getClassName (AppT ty _) = getClassName ty+getClassName d = error $ "unsupported class definition: " <> show d++getClassNames :: Type -> [Name]+getClassNames (AppT (ConT name1) (ConT name2)) = [name1, name2]+getClassNames (AppT ty (ConT name)) = getClassNames ty ++ [name]+getClassNames (AppT ty1 ty2) = getClassNames ty1 ++ getClassNames ty2+getClassNames _ = []++showClassName :: Name -> String+showClassName n = splitLast "." $ show n++showClassDef :: Name -> [Name] -> String+showClassDef className varNames = showClassName className <> " " <> unwords (show <$> varNames)++splitLast :: String -> String -> String+splitLast delimiter = last . split delimiter++split :: String -> String -> [String]+split delimiter str = unpack <$> splitOn (pack delimiter) (pack str)++data VarAppliedType = VarAppliedType Name (Maybe Name)+  deriving (Show)++applyVarAppliedTypes :: [VarAppliedType] -> Type -> Type+applyVarAppliedTypes varAppliedTypes = transform+  where+    mapping =+      Map.fromList+        [ (varName, className)+        | VarAppliedType varName (Just className) <- varAppliedTypes+        ]+    transform (VarT n) =+      case Map.lookup n mapping of+        Just className -> ConT className+        Nothing -> VarT n+    transform (AppT t1 t2) = AppT (transform t1) (transform t2)+    transform (SigT t k) = SigT (transform t) k+    transform (ParensT t) = ParensT (transform t)+    transform (InfixT t1 n t2) = InfixT (transform t1) n (transform t2)+    transform (UInfixT t1 n t2) = UInfixT (transform t1) n (transform t2)+    transform (ForallT tvs ctx t) = ForallT tvs (map transform ctx) (transform t)+    transform t = t++updateType :: Type -> [VarAppliedType] -> Type+updateType (AppT (VarT v1) (VarT v2)) varAppliedTypes =+  let x = maybe (VarT v1) ConT (findClass v1 varAppliedTypes)+      y = maybe (VarT v2) ConT (findClass v2 varAppliedTypes)+   in AppT x y+updateType ty _ = ty++hasClass :: Name -> [VarAppliedType] -> Bool+hasClass varName = any (\(VarAppliedType v c) -> v == varName && isJust c)++findClass :: Name -> [VarAppliedType] -> Maybe Name+findClass varName types = do+  guard $ hasClass varName types+  (VarAppliedType _ c) <- find (\(VarAppliedType v _) -> v == varName) types+  c++

@@ -0,0 +1,107 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Test.MockCat.TH.ContextBuilder+  ( -- Constraint rewrite+    liftConstraint,+    -- MonadVar helpers+    mockTType,+    tyVarBndrToType,+    applyFamilyArg,+    -- Context builder+    MockType (..),+    buildContext,+    toVarTs,+    constructClassAppT,+    getTypeVarNames,+    getTypeVarName,+    convertTyVarBndr+  )+where+import Language.Haskell.TH+  ( Name,+    TyVarBndr (..),+    Type (..),+    Pred+  )+import Control.Monad.IO.Class (MonadIO)+import Test.MockCat.MockT (MockT)+import Test.MockCat.TH.ClassAnalysis (ClassName2VarNames (..), toClassInfos, VarAppliedType (..), updateType)++-- | Rewrite constraint types to use 'MockT' for the monad variable where needed.+liftConstraint :: Name -> Type -> Type+liftConstraint monadVarName = go+  where+    go predTy@(AppT (ConT ty) (VarT varName))+      | monadVarName == varName && ty == ''Monad = predTy+      | monadVarName == varName =+          AppT (ConT ty) (AppT (ConT ''MockT) (VarT varName))+    go (AppT ty (VarT varName))+      | monadVarName == varName =+          AppT ty (AppT (ConT ''MockT) (VarT varName))+    go (AppT t1 t2) = AppT (go t1) (go t2)+    go ty = ty++-- MonadVar helpers+mockTType :: Name -> Type+mockTType monadVarName = AppT (ConT ''MockT) (VarT monadVarName)++liftTyVar :: Name -> Name -> Type+liftTyVar monadVarName varName+  | monadVarName == varName = mockTType monadVarName+  | otherwise = VarT varName++tyVarBndrToType :: Name -> TyVarBndr a -> Type+tyVarBndrToType monadVarName (PlainTV binderName _) = liftTyVar monadVarName binderName+tyVarBndrToType monadVarName (KindedTV binderName _ _) = liftTyVar monadVarName binderName++applyFamilyArg :: Name -> TyVarBndr a -> Type+applyFamilyArg = tyVarBndrToType++-- Context builder+data MockType = Total | Partial+  deriving (Eq)++buildContext ::+  [Pred] ->+  MockType ->+  Name ->+  Name ->+  [TyVarBndr a] ->+  [VarAppliedType] ->+  [Pred]+buildContext cxt mockType className monadVarName tyVars varAppliedTypes =+  let newCxtRaw = fmap (liftConstraint monadVarName) cxt++      isRedundantMonad (AppT (ConT m) (VarT v)) = m == ''Monad && v == monadVarName+      isRedundantMonad _ = False+      newCxt = filter (not . isRedundantMonad) newCxtRaw++      monadIOAppT = AppT (ConT ''MonadIO) (VarT monadVarName)++      classInfos = toClassInfos newCxt+      hasMonadIO = any (\(ClassName2VarNames c _) -> c == ''MonadIO) classInfos+      addedMonads = [monadIOAppT | not hasMonadIO]+   in case mockType of+        Total -> newCxt ++ addedMonads+        Partial ->+          let classAppT = constructClassAppT className $ toVarTs tyVars+              varAppliedClassAppT = updateType classAppT varAppliedTypes+           in newCxt ++ addedMonads ++ [varAppliedClassAppT]++toVarTs :: [TyVarBndr a] -> [Type]+toVarTs tyVars = VarT <$> getTypeVarNames tyVars++constructClassAppT :: Name -> [Type] -> Type+constructClassAppT className = foldl AppT (ConT className)++getTypeVarNames :: [TyVarBndr a] -> [Name]+getTypeVarNames = map getTypeVarName++getTypeVarName :: TyVarBndr a -> Name+getTypeVarName (PlainTV varName _) = varName+getTypeVarName (KindedTV varName _ _) = varName++convertTyVarBndr :: TyVarBndr a -> TyVarBndr ()+convertTyVarBndr (PlainTV n _) = PlainTV n ()+convertTyVarBndr (KindedTV n _ k) = KindedTV n () k++

@@ -0,0 +1,410 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Test.MockCat.TH.FunctionBuilder+  ( createMockBuilderVerifyParams+  , createMockBuilderFnType+  , MockFnContext(..)+  , MockFnBuilder(..)+  , buildMockFnContext+  , buildMockFnDeclarations+  , determineMockFnBuilder+  , createNoInlinePragma+  , doCreateMockFnDecs+  , doCreateConstantMockFnDecs+  , doCreateEmptyVerifyParamMockFnDecs+  , createMockBody+  , createTypeablePreds+  , partialAdditionalPredicates+  , createFnName+  , findParam+  , typeToNames+  , safeIndex+  , generateInstanceMockFnBody+  , generateInstanceRealFnBody+  , generateStubFn+  )+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Language.Haskell.TH+  ( Dec (..),+    Exp (..),+    Name,+    Pred,+    Q,+    Quote,+    Type (..),+    TyVarBndr(..),+    Inline (NoInline),+    RuleMatch (FunLike),+    Phases (AllPhases),+    mkName,+    newName+  )+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax (nameBase, Specificity (SpecifiedSpec))+import Test.MockCat.Mock ( MockBuilder )+import qualified Test.MockCat.Internal.MockRegistry as Registry+import Test.MockCat.Internal.Builder (buildMock)+import Test.MockCat.Internal.Types (BuiltMock(..))+import Test.MockCat.Cons (Head(..), (:>)(..))+import Test.MockCat.MockT+  ( MockT (..),+    Definition (..),+    getDefinitions,+    addDefinition+  )+import Test.MockCat.TH.TypeUtils+  ( isNotConstantFunctionType,+    needsTypeable,+    collectTypeVars,+    collectTypeableTargets+  )+import Test.MockCat.TH.ContextBuilder+  ( MockType (..)+  )+import Test.MockCat.TH.ClassAnalysis+  ( VarAppliedType (..),+    updateType+  )+import Test.MockCat.Verify (ResolvableParamsOf)+import Data.Dynamic (Dynamic, toDyn)+import Data.Proxy (Proxy(..))+import Data.List (find, nubBy)+import Data.Typeable (Typeable)+import Language.Haskell.TH.Ppr (pprint)+import Unsafe.Coerce (unsafeCoerce)+import GHC.TypeLits (KnownSymbol, symbolVal)+ ++import Test.MockCat.Param (Param, param)+import Test.MockCat.TH.Types (MockOptions(..))++createMockBuilderVerifyParams :: Type -> Type+createMockBuilderVerifyParams (AppT (AppT ArrowT ty) (AppT (VarT _) _)) =+  AppT (ConT ''Param) ty+createMockBuilderVerifyParams (AppT (AppT ArrowT ty) ty2) =+  AppT+    (AppT (ConT ''(:>)) (AppT (ConT ''Param) ty))+    (createMockBuilderVerifyParams ty2)+createMockBuilderVerifyParams (AppT (VarT _) _) = TupleT 0+createMockBuilderVerifyParams (AppT (ConT _) _) = TupleT 0+createMockBuilderVerifyParams (ForallT _ _ ty) = createMockBuilderVerifyParams ty+createMockBuilderVerifyParams (VarT _) = TupleT 0+createMockBuilderVerifyParams (ConT _) = TupleT 0+createMockBuilderVerifyParams _ = TupleT 0++createMockBuilderFnType :: Name -> Type -> Type+createMockBuilderFnType monadVarName a@(AppT (VarT var) ty)+  | monadVarName == var = ty+  | otherwise = a+createMockBuilderFnType monadVarName (AppT ty ty2) =+  AppT ty (createMockBuilderFnType monadVarName ty2)+createMockBuilderFnType monadVarName (ForallT _ _ ty) =+  createMockBuilderFnType monadVarName ty+createMockBuilderFnType _ ty = ty++partialAdditionalPredicates :: Type -> Type -> [Pred]+partialAdditionalPredicates funType verifyParams =+  [ AppT+      (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) funType))+      verifyParams+  | not (null (collectTypeVars funType))+  ]++-- Helper to create Typeable predicates using the smart collection logic+createTypeablePreds :: [Type] -> [Pred]+createTypeablePreds targets =+  [ AppT (ConT ''Typeable) t+  | t <- nubBy (\a b -> pprint a == pprint b) (concatMap collectTypeableTargets targets)+  , needsTypeable t+  ]+++data MockFnContext = MockFnContext+  { mockType :: MockType,+    monadVarName :: Name,+    mockOptions :: MockOptions,+    originalType :: Type,+    fnNameStr :: String,+    mockFnName :: Name,+    paramsName :: Name,+    updatedType :: Type,+    fnType :: Type+  }++data MockFnBuilder = VariadicBuilder | ConstantImplicitBuilder | ConstantExplicitBuilder++buildMockFnContext ::+  MockType ->+  Name ->+  [VarAppliedType] ->+  MockOptions ->+  Name ->+  Type ->+  MockFnContext+buildMockFnContext mockType monadVarName varAppliedTypes mockOptions sigFnName ty =+  let fnNameStr = createFnName sigFnName mockOptions+      mockFnName = mkName fnNameStr+      params = mkName "p"+      updatedType = updateType ty varAppliedTypes+      fnType =+        if mockOptions.implicitMonadicReturn+          then createMockBuilderFnType monadVarName updatedType+          else updatedType+   in MockFnContext+        { mockType,+          monadVarName,+          mockOptions,+          originalType = ty,+          fnNameStr,+          mockFnName,+          paramsName = params,+          updatedType,+          fnType+        }++buildMockFnDeclarations :: MockFnContext -> Q [Dec]+buildMockFnDeclarations ctx@MockFnContext{mockType, fnNameStr, mockFnName, paramsName, fnType, monadVarName, updatedType} =+  case determineMockFnBuilder ctx of+    VariadicBuilder ->+      doCreateMockFnDecs mockType fnNameStr mockFnName paramsName fnType monadVarName updatedType+    ConstantImplicitBuilder ->+      doCreateConstantMockFnDecs mockType fnNameStr mockFnName fnType monadVarName+    ConstantExplicitBuilder ->+      doCreateEmptyVerifyParamMockFnDecs fnNameStr mockFnName paramsName fnType monadVarName updatedType++determineMockFnBuilder :: MockFnContext -> MockFnBuilder+determineMockFnBuilder ctx+  | isNotConstantFunctionType (originalType ctx) = VariadicBuilder+  | (mockOptions ctx).implicitMonadicReturn = ConstantImplicitBuilder+  | otherwise = ConstantExplicitBuilder++createNoInlinePragma :: Name -> Q Dec+createNoInlinePragma name = pragInlD name NoInline FunLike AllPhases++doCreateMockFnDecs :: (Quote m) => MockType -> String -> Name -> Name -> Type -> Name -> Type -> m [Dec]+doCreateMockFnDecs mockType funNameStr mockFunName params funType monadVarName updatedType = do+  newFunSig <- do+    let verifyParams = createMockBuilderVerifyParams updatedType+        mockBuilderPred =+          AppT (AppT (AppT (ConT ''MockBuilder) (VarT params)) funType) verifyParams+        eqConstraint =+          [ AppT+              (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) funType))+              verifyParams+          | not (null (collectTypeVars funType))+          ]+        baseCtx =+          ([mockBuilderPred | verifyParams /= TupleT 0])+            ++ [AppT (ConT ''MonadIO) (VarT monadVarName)]+        typeablePreds = createTypeablePreds [funType, verifyParams]+        ctx = case mockType of+          Partial ->+            baseCtx ++ partialAdditionalPredicates funType verifyParams ++ typeablePreds+          Total ->+            baseCtx ++ eqConstraint ++ typeablePreds+        resultType =+          AppT+            (AppT ArrowT (VarT params))+            (AppT (AppT (ConT ''MockT) (VarT monadVarName)) funType)+    sigD mockFunName (pure (ForallT [] ctx resultType))++  mockBody <- createMockBody funNameStr [|p|] funType+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]++  pure $ newFunSig : [newFun]++doCreateConstantMockFnDecs :: (Quote m) => MockType -> String -> Name -> Type -> Name -> m [Dec]+doCreateConstantMockFnDecs Partial funNameStr mockFunName _ monadVarName = do+  stubVar <- newName "r"+  let ctx =+        [ AppT+            (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) (VarT stubVar)))+            (TupleT 0)+        , AppT (ConT ''MonadIO) (VarT monadVarName)+        , AppT (ConT ''Typeable) (VarT stubVar)+        , AppT (ConT ''Show) (VarT stubVar)+        , AppT (ConT ''Eq) (VarT stubVar)+        ]+      resultType =+        AppT+          (AppT ArrowT (VarT stubVar))+          (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (VarT stubVar))+  newFunSig <-+    sigD+      mockFunName+      ( pure+          (ForallT+              [ PlainTV stubVar SpecifiedSpec+              , PlainTV monadVarName SpecifiedSpec+              ]+              ctx+              resultType+          )+      )+  headParam <- [|Head :> param p|]+  mockBody <- createMockBody funNameStr (pure headParam) (VarT stubVar)+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]+  pure $ newFunSig : [newFun]+doCreateConstantMockFnDecs Total funNameStr mockFunName ty monadVarName = do+  (newFunSig, funTypeForBody) <- case ty of+    AppT (ConT _) (VarT mv) | mv == monadVarName -> do+      a <- newName "a"+      let ctx =+            [ AppT (ConT ''MonadIO) (VarT monadVarName)+            , AppT (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) (VarT a))) (TupleT 0)+            , AppT (ConT ''Typeable) (VarT a)+            , AppT (ConT ''Show) (VarT a)+            , AppT (ConT ''Eq) (VarT a)+            ]+          resultType =+            AppT+              (AppT ArrowT (VarT a))+              (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (VarT a))+      sig <- sigD+        mockFunName+        ( pure+            (ForallT+                [PlainTV a SpecifiedSpec, PlainTV monadVarName SpecifiedSpec]+                ctx+                resultType+            )+        )+      pure (sig, VarT a)+    _ -> do+      let headParamType = AppT (AppT (ConT ''(:>)) (ConT ''Head)) (AppT (ConT ''Param) ty)+          verifyParams' = createMockBuilderVerifyParams ty+          mockBuilderPred' = AppT (AppT (AppT (ConT ''MockBuilder) headParamType) ty) (TupleT 0)+          ctx =+            [ AppT (ConT ''MonadIO) (VarT monadVarName)+            ]+            ++ ([mockBuilderPred' | verifyParams' /= TupleT 0])+            ++ createTypeablePreds [ty]+          resultType =+            AppT+              (AppT ArrowT ty)+              (AppT (AppT (ConT ''MockT) (VarT monadVarName)) ty)+      sig <- sigD mockFunName (pure (ForallT [PlainTV monadVarName SpecifiedSpec] ctx resultType))+      pure (sig, ty)+  headParam <- [|Head :> param p|]+  mockBody <- createMockBody funNameStr (pure headParam) funTypeForBody+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]+  pure $ newFunSig : [newFun]++doCreateEmptyVerifyParamMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]+doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funType monadVarName updatedType = do+  newFunSig <- do+    let verifyParams = createMockBuilderVerifyParams updatedType+        mockBuilderPred = AppT (AppT (AppT (ConT ''MockBuilder) (VarT params)) funType) verifyParams+        eqConstraint =+          [ AppT+              (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) funType))+              verifyParams+          | not (null (collectTypeVars funType))+          ]+        ctx =+          [mockBuilderPred]+            ++ [AppT (ConT ''MonadIO) (VarT monadVarName)]+            ++ eqConstraint+            ++ createTypeablePreds [funType, verifyParams]+        resultType =+          AppT+            (AppT ArrowT (VarT params))+            (AppT (AppT (ConT ''MockT) (VarT monadVarName)) funType)+    sigD mockFunName (pure (ForallT [] ctx resultType))++  mockBody <- createMockBody funNameStr [|p|] funType+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]++  pure $ newFunSig : [newFun]++createMockBody :: (Quote m) => String -> m Exp -> Type -> m Exp+createMockBody funNameStr paramsExp _funType = do+  params <- paramsExp+  [|+    MockT $ do+      -- Build the mock instance and its verifier directly so we have access+      -- to the verifier value (avoids runtime type-mismatch when resolving).+      BuiltMock { builtMockFn = mockInstance, builtMockRecorder = verifier } <- liftIO $ buildMock (Just $(litE (stringL funNameStr))) $(pure params)+      -- Register and get the canonical wrapper (preserved for async safety)+      canonicalInstance <- liftIO $ Registry.register (Just $(litE (stringL funNameStr))) verifier mockInstance+      addDefinition+        ( Definition+            (Proxy :: Proxy $(litT (strTyLit funNameStr)))+            canonicalInstance+            NoVerification+        )+      pure canonicalInstance+    |]++createFnName :: Name -> MockOptions -> String+createFnName funName opts = do+  opts.prefix <> nameBase funName <> opts.suffix++findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe Dynamic+findParam pa definitions = do+  let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions+  fmap (\(Definition _ mockFunction _) -> toDyn mockFunction) definition++typeToNames :: Type -> [Q Name]+typeToNames (AppT (AppT ArrowT _) t2) = newName "a" : typeToNames t2+typeToNames (ForallT _ _ ty) = typeToNames ty+typeToNames _ = []++safeIndex :: [a] -> Int -> Maybe a+safeIndex [] _ = Nothing+safeIndex (x : _) 0 = Just x+safeIndex (_ : xs) n+  | n < 0 = Nothing+  | otherwise = safeIndex xs (n - 1)+++generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp+generateInstanceMockFnBody fnNameStr args r opts = do+  returnExp <- if opts.implicitMonadicReturn+    then [| pure $(varE r) |]+    else [| lift $(varE r) |]++  [|+    MockT $ do+      defs <- getDefinitions+      let findDef = find (\(Definition s _ _) -> symbolVal s == $(litE (stringL fnNameStr))) defs+      case findDef of+        Just (Definition _ mf _) -> do+          let mock = unsafeCoerce mf+          let $(bangP $ varP r) = $(generateStubFn args [|mock|])+          $(pure returnExp)+        Nothing -> error $ "no answer found stub function `" ++ fnNameStr ++ "`."+    |]++generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp+generateInstanceRealFnBody fnName fnNameStr args r opts = do+  returnExp <- if opts.implicitMonadicReturn+    then [| pure $(varE r) |]+    else [| lift $(varE r) |]+  [|+    MockT $ do+      defs <- getDefinitions+      let findDef = find (\(Definition s _ _) -> symbolVal s == $(litE (stringL fnNameStr))) defs+      case findDef of+        Just (Definition _ mf _) -> do+          let mock = unsafeCoerce mf+          let $(bangP $ varP r) = $(generateStubFn args [|mock|])+          $(pure returnExp)+        Nothing -> lift $ $(foldl appE (varE fnName) args)+    |]++generateStubFn :: [Q Exp] -> Q Exp -> Q Exp+generateStubFn [] mock = mock+generateStubFn args mock = foldl appE mock args++

@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Test.MockCat.TH.TypeUtils+  ( splitApps,+    substituteType,+    isNotConstantFunctionType,+    collectTypeVars,+    needsTypeable,+    collectTypeableTargets,+    isStandardTypeCon+  )+where++import qualified Data.Map.Strict as Map+import Language.Haskell.TH (Name, Type (..))+import Test.MockCat.Param (Param)+import Test.MockCat.Cons ((:>))++splitApps :: Type -> (Type, [Type])+splitApps ty = go ty []+  where+    go (Language.Haskell.TH.AppT t1 t2) acc = go t1 (t2 : acc)+    go t acc = (t, acc)++substituteType :: Map.Map Language.Haskell.TH.Name Language.Haskell.TH.Type -> Language.Haskell.TH.Type -> Language.Haskell.TH.Type+substituteType subMap = go+  where+    go (Language.Haskell.TH.VarT name) = Map.findWithDefault (Language.Haskell.TH.VarT name) name subMap+    go (Language.Haskell.TH.AppT t1 t2) = Language.Haskell.TH.AppT (go t1) (go t2)+    go (Language.Haskell.TH.SigT t k) = Language.Haskell.TH.SigT (go t) k+    go (Language.Haskell.TH.ParensT t) = Language.Haskell.TH.ParensT (go t)+    go (Language.Haskell.TH.InfixT t1 n t2) = Language.Haskell.TH.InfixT (go t1) n (go t2)+    go (Language.Haskell.TH.UInfixT t1 n t2) = Language.Haskell.TH.UInfixT (go t1) n (go t2)+    go (Language.Haskell.TH.ForallT tvs ctx t) = Language.Haskell.TH.ForallT tvs (map go ctx) (go t)+    go t = t++isNotConstantFunctionType :: Type -> Bool+isNotConstantFunctionType (AppT (AppT ArrowT _) _) = True+isNotConstantFunctionType (AppT t1 t2) = isNotConstantFunctionType t1 || isNotConstantFunctionType t2+isNotConstantFunctionType (TupleT _) = False+isNotConstantFunctionType (ForallT _ _ t) = isNotConstantFunctionType t+isNotConstantFunctionType _ = False++needsTypeable :: Type -> Bool+needsTypeable = go+  where+    go (ForallT _ _ t) = go t+    go (AppT t1 t2) = go t1 || go t2+    go (SigT t _) = go t+    go (VarT _) = True+    go (ParensT t) = go t+    go (InfixT t1 _ t2) = go t1 || go t2+    go (UInfixT t1 _ t2) = go t1 || go t2+    go (ImplicitParamT _ t) = go t+    go _ = False++collectTypeVars :: Type -> [Name]+collectTypeVars (VarT name) = [name]+collectTypeVars (AppT t1 t2) = collectTypeVars t1 ++ collectTypeVars t2+collectTypeVars (SigT t _) = collectTypeVars t+collectTypeVars (ParensT t) = collectTypeVars t+collectTypeVars (InfixT t1 _ t2) = collectTypeVars t1 ++ collectTypeVars t2+collectTypeVars (UInfixT t1 _ t2) = collectTypeVars t1 ++ collectTypeVars t2+collectTypeVars (ForallT _ _ t) = collectTypeVars t+collectTypeVars (ImplicitParamT _ t) = collectTypeVars t+collectTypeVars _ = []++collectTypeableTargets :: Type -> [Type]+collectTypeableTargets ty =+  case ty of+    VarT _ -> [ty]+    AppT _ _ ->+      let (f, args) = splitApps ty+      in if isStandardTypeCon f+         then concatMap collectTypeableTargets args+         else [ty]+    SigT t _ -> collectTypeableTargets t+    ParensT t -> collectTypeableTargets t+    InfixT t1 _ t2 -> collectTypeableTargets t1 ++ collectTypeableTargets t2+    UInfixT t1 _ t2 -> collectTypeableTargets t1 ++ collectTypeableTargets t2+    ForallT _ _ t -> collectTypeableTargets t+    _ -> []++isStandardTypeCon :: Type -> Bool+isStandardTypeCon ArrowT = True+isStandardTypeCon ListT = True+isStandardTypeCon (TupleT _) = True+isStandardTypeCon (ConT n) =+  n `elem`+    [ ''Maybe+    , ''IO+    , ''Either+    , ''[]+    , ''(,)+    , ''(,,)+    , ''(,,,)+    , ''(,,,,)+    , ''Param+    , ''(:>)+    ]+isStandardTypeCon _ = False+

@@ -0,0 +1,20 @@+module Test.MockCat.TH.Types+  ( MockOptions(..)+  , options+  )+where++-- | Options for generating mocks.+--+--  - prefix: Stub function prefix+--  - suffix: stub function suffix+--  - implicitMonadicReturn: If True, the return value of the stub function is wrapped in a monad automatically.+data MockOptions = MockOptions {prefix :: String, suffix :: String, implicitMonadicReturn :: Bool}++-- | Default Options.+--+--  Stub function names are prefixed with "_".+options :: MockOptions+options = MockOptions {prefix = "_", suffix = "", implicitMonadicReturn = False}++

@@ -0,0 +1,586 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use null" #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module Test.MockCat.Verify where++import Control.Concurrent.STM (TVar, readTVarIO)+import Test.MockCat.Internal.Types+import Control.Monad (guard, when, unless)+import Data.List (elemIndex, intercalate)+import Data.Maybe+import Test.MockCat.Param+import Prelude hiding (lookup)+import GHC.Stack (HasCallStack)+import Test.MockCat.Internal.Message+import Data.Kind (Type, Constraint)+import Test.MockCat.Cons ((:>))+import Data.Typeable (Typeable, eqT)+import Test.MockCat.Internal.MockRegistry (lookupVerifierForFn, withAllUnitGuards)+import Data.Type.Equality ((:~:) (Refl))+import Data.Dynamic (fromDynamic)+import GHC.TypeLits (TypeError, ErrorMessage(..), Symbol)++-- | Class for verifying mock function.+verify ::+  ( ResolvableMock m+  , Eq (ResolvableParamsOf m)+  , Show (ResolvableParamsOf m)+  ) =>+  m ->+  VerifyMatchType (ResolvableParamsOf m) ->+  IO ()+verify m matchType = do+  ResolvedMock mockName recorder <- requireResolved m+  invocationList <- readInvocationList (invocationRef recorder)+  case doVerify mockName invocationList matchType of+    Nothing -> pure ()+    Just (VerifyFailed msg) ->+      errorWithoutStackTrace msg `seq` pure ()++doVerify :: (Eq a, Show a) => Maybe MockName -> InvocationList a -> VerifyMatchType a -> Maybe VerifyFailed+doVerify name list (MatchAny a) = do+  guard $ notElem a list+  pure $ verifyFailedMessage name list a+doVerify name list (MatchAll a) = do+  guard $ Prelude.any (a /=) list+  pure $ verifyFailedMessage name list a++readInvocationList :: TVar (InvocationRecord params) -> IO (InvocationList params)+readInvocationList ref = do+  record <- readTVarIO ref+  pure $ invocations record++-- | Verify that a resolved mock function was called at least once.+--   This is used internally by typeclass mock verification.+verifyResolvedAny :: ResolvedMock params -> IO ()+verifyResolvedAny (ResolvedMock mockName recorder) = do+  invocationList <- readInvocationList (invocationRef recorder)+  when (null invocationList) $+    errorWithoutStackTrace $+      intercalate+        "\n"+        [ "Function" <> mockNameLabel mockName <> " was never called"+        ]++++compareCount :: CountVerifyMethod -> Int -> Bool+compareCount (Equal e) a = a == e+compareCount (LessThanEqual e) a = a <= e+compareCount (LessThan e) a = a < e+compareCount (GreaterThanEqual e) a = a >= e+compareCount (GreaterThan e) a = a > e++verifyCount ::+  ( ResolvableMock m+  , Eq (ResolvableParamsOf m)+  ) =>+  m ->+  ResolvableParamsOf m ->+  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++-- | Generate error message for count mismatch with arguments+countWithArgsMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String+countWithArgsMismatchMessage mockName method callCount =+  intercalate+    "\n"+    [ "function" <> mockNameLabel mockName <> " was not called the expected number of times with the expected arguments.",+      "  expected: " <> show method,+      "   but got: " <> show callCount+    ]++++verifyOrder ::+  (ResolvableMock m+  , Eq (ResolvableParamsOf m)+  , Show (ResolvableParamsOf m)) =>+  VerifyOrderMethod ->+  m ->+  [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 ()++doVerifyOrder ::+  (Eq a, Show a) =>+  VerifyOrderMethod ->+  Maybe MockName ->+  InvocationList a ->+  [a] ->+  Maybe VerifyFailed+doVerifyOrder ExactlySequence name calledValues expectedValues+  | length calledValues /= length expectedValues = do+      pure $ verifyFailedOrderParamCountMismatch name calledValues expectedValues+  | otherwise = do+      let unexpectedOrders = collectUnExpectedOrder calledValues expectedValues+      guard $ length unexpectedOrders > 0+      pure $ verifyFailedSequence name unexpectedOrders+doVerifyOrder PartiallySequence name calledValues expectedValues+  | length calledValues < length expectedValues = do+      pure $ verifyFailedOrderParamCountMismatch name calledValues expectedValues+  | otherwise = do+      guard $ isOrderNotMatched calledValues expectedValues+      pure $ verifyFailedPartiallySequence name calledValues expectedValues++verifyFailedPartiallySequence :: Show a => Maybe MockName -> InvocationList a -> [a] -> VerifyFailed+verifyFailedPartiallySequence name calledValues expectedValues =+  VerifyFailed $+    intercalate+      "\n"+      [ "function" <> mockNameLabel name <> " was not called with the expected arguments in the expected order.",+        "  expected order:",+        intercalate "\n" $ ("    " <>) . show <$> expectedValues,+        "  but got:",+        intercalate "\n" $ ("    " <>) . show <$> calledValues+      ]++isOrderNotMatched :: Eq a => InvocationList a -> [a] -> Bool+isOrderNotMatched calledValues expectedValues =+  isNothing $+    foldl+      ( \candidates e -> do+          candidates >>= \c -> do+            index <- elemIndex e c+            Just $ drop (index + 1) c+      )+      (Just calledValues)+      expectedValues++verifyFailedOrderParamCountMismatch :: Maybe MockName -> InvocationList a -> [a] -> VerifyFailed+verifyFailedOrderParamCountMismatch name calledValues expectedValues =+  VerifyFailed $+    intercalate+      "\n"+      [ "function" <> mockNameLabel name <> " was not called with the expected arguments in the expected order (count mismatch).",+        "  expected: " <> show (length expectedValues),+        "   but got: " <> show (length calledValues)+      ]++verifyFailedSequence :: Show a => Maybe MockName -> [VerifyOrderResult a] -> VerifyFailed+verifyFailedSequence name fails =+  VerifyFailed $+    intercalate+      "\n"+      ( ("function" <> mockNameLabel name <> " was not called with the expected arguments in the expected order.") : (verifyOrderFailedMesssage <$> fails)+      )++++collectUnExpectedOrder :: Eq a => InvocationList a -> [a] -> [VerifyOrderResult a]+collectUnExpectedOrder calledValues expectedValues =+  catMaybes $+    mapWithIndex+      ( \i expectedValue -> do+          let calledValue = calledValues !! i+          guard $ expectedValue /= calledValue+          pure VerifyOrderResult {index = i, calledValue = calledValue, expectedValue}+      )+      expectedValues++mapWithIndex :: (Int -> a -> b) -> [a] -> [b]+mapWithIndex f xs = [f i x | (i, x) <- zip [0 ..] xs]++-- Legacy shouldApply* helpers removed. Use shouldBeCalled API instead.++type family PrependParam a rest where+  PrependParam a () = Param a+  PrependParam a rest = Param a :> rest++type family FunctionParams fn where+  FunctionParams (a -> fn) = PrependParam a (FunctionParams fn)+  FunctionParams fn = ()++type family ResolvableParamsOf target :: Type where+  ResolvableParamsOf (a -> fn) = FunctionParams (a -> fn)+  ResolvableParamsOf target = ()++type family Or (a :: Bool) (b :: Bool) :: Bool where+  Or 'True _ = 'True+  Or _ 'True = 'True+  Or 'False 'False = 'False++type family Not (a :: Bool) :: Bool where+  Not 'True = 'False+  Not 'False = 'True++type family IsFunctionType target :: Bool where+  IsFunctionType (_a -> _b) = 'True+  IsFunctionType _ = 'False++type family IsIOType target :: Bool where+  IsIOType (IO _) = 'True+  IsIOType _ = 'False++type family IsPureConstant target :: Bool where+  IsPureConstant target = Not (Or (IsFunctionType target) (IsIOType target))++type family RequireCallable (fn :: Symbol) target :: Constraint where+  RequireCallable fn target =+    RequireCallableImpl fn (IsPureConstant target) target++type family RequireCallableImpl (fn :: Symbol) (isPure :: Bool) target :: Constraint where+  RequireCallableImpl fn 'True target =+    TypeError+      ( 'Text fn ':<>: 'Text " is not available for pure constant mocks."+          ':$$: 'Text "  target type: " ':<>: 'ShowType target+          ':$$: 'Text "  hint: convert it into a callable mock or use shouldBeCalled with 'anything'."+      )+  RequireCallableImpl _ 'False _ = ()++-- | Constraint alias for resolvable mock types.+type ResolvableMock m = (Typeable (ResolvableParamsOf m), Typeable (InvocationRecorder (ResolvableParamsOf m)))++-- | Constraint alias for resolvable mock types with specific params.+type ResolvableMockWithParams m params = (ResolvableParamsOf m ~ params, ResolvableMock m)++resolveForVerification ::+  forall target params.+  ( params ~ ResolvableParamsOf target+  , Typeable params+  , Typeable (InvocationRecorder params)+  ) =>+  target ->+  IO (Maybe (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) ->+      case fromDynamic @(InvocationRecorder params) dynVerifier of+        Just verifier -> pure $ Just (name, verifier)+        Nothing -> pure Nothing+++-- | Verify that a function was called the expected number of times+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++-- | Generate error message for count mismatch+countMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String+countMismatchMessage maybeName method callCount =+  intercalate+    "\n"+    [ "function" <> mockNameLabel maybeName <> " was not called the expected number of times.",+      "  expected: " <> showCountMethod method,+      "   but got: " <> show callCount+    ]+  where+    showCountMethod (Equal n) = show n+    showCountMethod (LessThanEqual n) = "<= " <> show n+    showCountMethod (GreaterThanEqual n) = ">= " <> show n+    showCountMethod (LessThan n) = "< " <> show n+    showCountMethod (GreaterThan n) = "> " <> show n++verificationFailure :: IO a+verificationFailure =+  errorWithoutStackTrace verificationFailureMessage++data ResolvedMock params = ResolvedMock {+  resolvedMockName :: Maybe MockName,+  resolvedMockRecorder :: InvocationRecorder params+}++requireResolved ::+  forall target params.+  ( params ~ ResolvableParamsOf target+  , Typeable params+  , Typeable (InvocationRecorder params)+  ) =>+  target ->+  IO (ResolvedMock params)+requireResolved target = do+  resolveForVerification target >>= \case+    Just (name, recorder) -> pure $ ResolvedMock name recorder+    Nothing -> verificationFailure++verificationFailureMessage :: String+verificationFailureMessage =+  intercalate+    "\n"+    [ "Error: 'shouldBeCalled' can only verify functions created by 'mock'.",+      "",+      "The value you passed could not be recognized as a mock function.",+      "",+      "This usually happens in one of the following cases:",+      "  - You passed a normal (non-mock) function.",+      "  - You passed a stub or value not created via 'mock' / 'mockIO'.",+      "  - You are trying to verify a value that was never registered as a mock.",+      "",+      "How to fix it:",+      "  1. Make sure you created the function with 'mock' (or 'mockIO' for IO)",+      "     before calling 'shouldBeCalled'.",+      "  2. Pass that mock value directly to 'shouldBeCalled'",+      "     (not the original function or a plain value).",+      "",+      "If this message still appears, check that:",+      "  - You are not passing a pure constant.",+      "  - The mock value is still in scope where 'shouldBeCalled' is used.",+      "",+      "Tip: If you prefer automatic verification,",+      "consider using 'withMock', which runs all expectations at the end",+      "of the block."+    ]++-- ============================================+-- shouldBeCalled API+-- ============================================++-- | Verification specification for shouldBeCalled+data VerificationSpec params where+  -- | Count verification with specific arguments+  CountVerification :: CountVerifyMethod -> params -> VerificationSpec params+  -- | Count verification without arguments (any arguments)+  CountAnyVerification :: CountVerifyMethod -> VerificationSpec params+  -- | Order verification+  OrderVerification :: VerifyOrderMethod -> [params] -> VerificationSpec params+  -- | Simple verification with arguments (at least once)+  SimpleVerification :: params -> VerificationSpec params+  -- | Simple verification without arguments (at least once, any arguments)+  AnyVerification :: VerificationSpec params++-- | Times condition for count verification+newtype TimesSpec = TimesSpec CountVerifyMethod++-- | Create a times condition for exact count.+--+--   > f `shouldBeCalled` times 3+--   > f `shouldBeCalled` (times 3 `with` "arg")+times :: Int -> TimesSpec+times n = TimesSpec (Equal n)++-- | Create a times condition for at least count (>=).+--+--   > f `shouldBeCalled` atLeast 1+atLeast :: Int -> TimesSpec+atLeast n = TimesSpec (GreaterThanEqual n)++-- | Create a times condition for at most count (<=).+--+--   > f `shouldBeCalled` atMost 2+atMost :: Int -> TimesSpec+atMost n = TimesSpec (LessThanEqual n)++-- | Create a times condition for greater than count (>).+greaterThan :: Int -> TimesSpec+greaterThan n = TimesSpec (GreaterThan n)++-- | Create a times condition for less than count (<).+lessThan :: Int -> TimesSpec+lessThan n = TimesSpec (LessThan n)++-- | Create a times condition for exactly once.+--   Equivalent to 'times 1'.+once :: TimesSpec+once = TimesSpec (Equal 1)++-- | Create a times condition for never (zero times).+--   Equivalent to 'times 0'.+never :: TimesSpec+never = TimesSpec (Equal 0)++-- | Order condition for order verification+newtype OrderSpec = OrderSpec VerifyOrderMethod++-- | Create an order condition for exact sequence+inOrder :: OrderSpec+inOrder = OrderSpec ExactlySequence++-- | Create an order condition for partial sequence+inPartialOrder :: OrderSpec+inPartialOrder = OrderSpec PartiallySequence++-- | Create a simple verification with arguments.+--   This accepts both raw values and Param chains.+--+--   > f `shouldBeCalled` calledWith "a"+calledWith :: params -> VerificationSpec params+calledWith = SimpleVerification++-- | Create a simple verification without arguments.+--   It verifies that the function was called at least once, with ANY arguments.+--+--   > f `shouldBeCalled` anything+anything :: forall params. VerificationSpec params+anything = AnyVerification++-- | Type class for combining times condition with arguments+class WithArgs spec params where+  type WithResult spec params :: Type+  with :: spec -> params -> WithResult spec params++-- | Instance for times condition with arguments+instance (Eq params, Show params) => WithArgs TimesSpec params where+  type WithResult TimesSpec params = VerificationSpec params+  with (TimesSpec method) = CountVerification method++-- | Type family to normalize argument types for 'withArgs'+type family NormalizeWithArg a :: Type where+  NormalizeWithArg (Param a :> rest) = Param a :> rest+  NormalizeWithArg (Param a) = Param a+  NormalizeWithArg a = Param a++-- | Type class to normalize argument types (to Param or Param chain)+class ToNormalizedArg a where+  toNormalizedArg :: a -> NormalizeWithArg a++instance ToNormalizedArg (Param a :> rest) where+  toNormalizedArg = id++instance ToNormalizedArg (Param a) where+  toNormalizedArg = id++instance {-# OVERLAPPABLE #-} (NormalizeWithArg a ~ Param a, WrapParam a) => ToNormalizedArg a where+  toNormalizedArg = wrap++++-- | New function for combining times condition with arguments (supports raw values)+--   This will replace 'with' once the old 'with' is removed+withArgs ::+  forall params.+  ( ToNormalizedArg params+  , Eq (NormalizeWithArg params)+  , Show (NormalizeWithArg params)+  ) => TimesSpec -> params -> VerificationSpec (NormalizeWithArg params)+withArgs (TimesSpec method) args = CountVerification method (toNormalizedArg args)++infixl 8 `withArgs`++-- | Verify that the mock was called with the specified sequence of arguments in exact order.+--+--   > f `shouldBeCalled` inOrderWith ["a", "b"]+inOrderWith ::+  forall params.+  ( ToNormalizedArg params+  , Eq (NormalizeWithArg params)+  , Show (NormalizeWithArg params)+  ) => [params] -> VerificationSpec (NormalizeWithArg params)+inOrderWith args = OrderVerification ExactlySequence (map toNormalizedArg args)++-- | Verify that the mock was called with the specified sequence of arguments, allowing other calls in between.+--+--   > f `shouldBeCalled` inPartialOrderWith ["a", "c"]+--   > -- This passes if calls were: "a", "b", "c"+inPartialOrderWith ::+  forall params.+  ( ToNormalizedArg params+  , Eq (NormalizeWithArg params)+  , Show (NormalizeWithArg params)+  ) => [params] -> VerificationSpec (NormalizeWithArg params)+inPartialOrderWith args = OrderVerification PartiallySequence (map toNormalizedArg args)++-- | Main verification function class+class ShouldBeCalled m spec where+  shouldBeCalled :: HasCallStack => m -> spec -> IO ()++-- | 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++-- | Instance for VerificationSpec (handles all verification types)+instance {-# OVERLAPPING #-}+  ( ResolvableMockWithParams m params+  , Eq params+  , 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+    OrderVerification method argsList ->+      verifyOrder method m argsList+    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"+              ]++-- | Instance for Param chains (e.g., "a" ~> "b")+instance {-# OVERLAPPING #-}+  ( ResolvableMockWithParams m (Param a :> rest)+  , Eq (Param a :> rest)+  , Show (Param a :> rest)+  ) => ShouldBeCalled m (Param a :> rest) where+  shouldBeCalled m args =+    verify m (MatchAny args)++-- | Instance for single Param (e.g., param "a")+instance {-# OVERLAPPING #-}+  ( ResolvableMockWithParams m (Param a)+  , Eq (Param a)+  , Show (Param a)+  ) => ShouldBeCalled m (Param a) where+  shouldBeCalled m args =+    verify m (MatchAny args)++-- | Instance for raw values (e.g., "a")+--   This converts raw values to Param at runtime+instance {-# OVERLAPPABLE #-}+  ( ResolvableMockWithParams m (Param a)+  , Eq (Param a)+  , Show (Param a)+  , Show a+  , Eq a+  ) => ShouldBeCalled m a where+  shouldBeCalled m arg =+    verify m (MatchAny (param arg))