diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/README-ja.md b/README-ja.md
--- a/README-ja.md
+++ b/README-ja.md
@@ -1,766 +1,402 @@
-
+
+
Declarative mocking with a single arrow ~>
-## 概要
-mockcat は Haskell 向けの小さなモック / スタブ DSL です。
-`arg |> arg |> 戻り値` というシンプルな書き方で「こう呼ばれたらこう返す」を並べ、関数ならそのまま使い、型クラスなら Template Haskell (`makeMock`, `makePartialMock`) で生成したスタブ関数を `runMockT` の中で走らせると自動で検証まで行われます。
+[](https://hackage.haskell.org/package/mockcat)
+[](http://stackage.org/lts/package/mockcat)
+[](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` + 複数ケース |
+
-#### 使わない方が良い / 他手法が適する可能性
-| ケース | 推奨される代替/補助 |
-|--------|-----------------------|
-| 複雑な振る舞い網羅 + 大量の依存関係 | 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?
-
-更新履歴
+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
-
+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)**
「この引数には
この値を返したい」 | f :: String -> IO String
f arg = case arg of
"a" -> pure "b"
_ -> error "unexpected"
_単純な分岐を書くだけでも行数を消費します。_ | -- 検証不要なら stub (純粋)
let f = stub $
"a" ~> "b"
_完全に純粋な関数として振る舞います。_ |
+| **検証 (Verify)**
「正しく呼ばれたか
テストしたい」 | -- 記録の仕組みから作る必要がある
ref <- newIORef []
let f arg = do
modifyIORef ref (arg:)
...
-- 検証ロジック
calls <- readIORef ref
calls \`shouldBe\` ["a"]
_※ これはよくある一例です。実際にはさらに補助コードが増えがちです。_ | -- 検証したいなら mock (内部で記録)
f <- mock $ "a" ~> "b"
-- 検証したい内容を書くだけ
f \`shouldBeCalled\` "a"
_記録は自動。
「何を検証するか」という本質に集中できます。_ |
-モックは次のように使うことができます。
-```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"
-```
+
+Q. 未評価の遅延評価はどう扱われますか？
+A. カウントされません。Mockcat は「結果が評価された時点」で呼び出しを記録します (Honest Laziness)。これにより、不要な計算による誤検知を防ぎます。
+
-## 検証
-### 期待される引数に適用されたか検証する
-期待される引数に適用されたかは `shouldApplyTo` 関数で検証することができます。
-検証を行う場合は、`createStubFn` 関数ではなく `createMock` 関数でモックを作る必要があります。
-この場合スタブ関数は `stubFn` 関数でモックから取り出して使います。
-```haskell
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeApplications #-}
-import Test.Hspec
-import Test.MockCat
+
+Q. 並列テストで使えますか？
+A. はい。内部で `TVar` を使用してアトミックにカウントしているため、`mapConcurrently` などで並列に呼ばれても正確に記録されます。
+
-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
+
+Q. `makeMock` が生成するコードは何ですか？
+A. 指定された型クラスの `MockT m` インスタンスと、各メソッドに対応する `_メソッド名` というスタブ生成関数定義です。
+
-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.
-```
+
+Q. 厳密な定義では Spy ではないですか？
+A. はい、xUnit Patterns 等の定義に従えば、事後検証を行う Mockcat のモックは **Test Spy** に分類されます。
+しかし、近年の多くのライブラリ（Jest, Mockito 等）がこれらを包括して「モック」と呼称していること、および用語の乱立による混乱を避けるため、本ライブラリでは **"Mock"** という用語で統一しています。
+
-### 期待される引数に適用された回数を検証する
-期待される引数が適用された回数は `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!_ 🐱
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,844 +1,415 @@
-
-
-Update History
-
-* **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.
-
-
----
-Below is the full expanded reference (legacy detailed sections). Collapse if you only need the quick start.
-
-
-Full Reference (expanded)
-
-
-## 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
- ]
-```
-
-
-
+
+ Declarative mocking with a single arrow ~>
+
+
+
+
+[](https://hackage.haskell.org/package/mockcat)
+[](http://stackage.org/lts/package/mockcat)
+[](https://github.com/pujoheadsoft/mockcat/actions)
+
+[🇯🇵 Japanese (日本語)](README-ja.md)
+
+
+
+**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)**
"I want to return
this value for this arg" | f :: String -> IO String
f arg = case arg of
"a" -> pure "b"
_ -> error "unexpected"
_Even simple branching consumes many lines._ | -- Use stub if verification is unneeded (Pure)
let f = stub $
"a" ~> "b"
_Behaves as a completely pure function._ |
+| **Verification (Verify)**
"I want to test
if it was called correctly" | -- Need to implement recording logic
ref <- newIORef []
let f arg = do
modifyIORef ref (arg:)
...
-- Verification logic
calls <- readIORef ref
calls \`shouldBe\` ["a"]
_※ This is just one example. Real-world setups often require even more boilerplate._ | -- Use mock if verification is needed (Recorded internally)
f <- mock $ "a" ~> "b"
-- Just state what you want to verify
f \`shouldBeCalled\` "a"
_Recording is automatic.
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
+
+
+Q. How are unevaluated lazy values handled?
+A. They are not counted. Mockcat records calls only "when the result is evaluated" (Honest Laziness). This prevents false positives from unneeded calculations.
+
+
+
+Q. Can I use it in parallel tests?
+A. Yes. Internally uses `TVar` to count atomically, so it records accurately even when called in parallel via `mapConcurrently`, etc.
+
+
+
+Q. What code does `makeMock` generate?
+A. It generates a `MockT m` instance for the specified typeclass, and stub generation function definitions named `_methodName` corresponding to each method.
+
+
+
+Q. Isn't this strictly a Spy?
+A. Yes, according to definitions like xUnit Patterns, Mockcat's mocks which verify after execution are classified as **Test Spies**.
+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"**.
+
+
+## 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!_ 🐱
diff --git a/mockcat.cabal b/mockcat.cabal
--- a/mockcat.cabal
+++ b/mockcat.cabal
@@ -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:
category: Testing
@@ -26,7 +16,7 @@
bug-reports: https://github.com/pujoheadsoft/mockcat/issues
author: funnycat
maintainer: funnycat
-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
diff --git a/src/Test/MockCat.hs b/src/Test/MockCat.hs
--- a/src/Test/MockCat.hs
+++ b/src/Test/MockCat.hs
@@ -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
diff --git a/src/Test/MockCat/Cons.hs b/src/Test/MockCat/Cons.hs
--- a/src/Test/MockCat/Cons.hs
+++ b/src/Test/MockCat/Cons.hs
@@ -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)
diff --git a/src/Test/MockCat/Internal/Builder.hs b/src/Test/MockCat/Internal/Builder.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/Builder.hs
@@ -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))
diff --git a/src/Test/MockCat/Internal/Message.hs b/src/Test/MockCat/Internal/Message.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/Message.hs
@@ -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"
diff --git a/src/Test/MockCat/Internal/MockRegistry.hs b/src/Test/MockCat/Internal/MockRegistry.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/MockRegistry.hs
@@ -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
+
diff --git a/src/Test/MockCat/Internal/Registry/Core.hs b/src/Test/MockCat/Internal/Registry/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/Registry/Core.hs
@@ -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
+
+
diff --git a/src/Test/MockCat/Internal/Types.hs b/src/Test/MockCat/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/Types.hs
@@ -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
diff --git a/src/Test/MockCat/Mock.hs b/src/Test/MockCat/Mock.hs
--- a/src/Test/MockCat/Mock.hs
+++ b/src/Test/MockCat/Mock.hs
@@ -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)
+
+
diff --git a/src/Test/MockCat/MockT.hs b/src/Test/MockCat/MockT.hs
--- a/src/Test/MockCat/MockT.hs
+++ b/src/Test/MockCat/MockT.hs
@@ -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).
diff --git a/src/Test/MockCat/Param.hs b/src/Test/MockCat/Param.hs
--- a/src/Test/MockCat/Param.hs
+++ b/src/Test/MockCat/Param.hs
@@ -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
diff --git a/src/Test/MockCat/TH.hs b/src/Test/MockCat/TH.hs
--- a/src/Test/MockCat/TH.hs
+++ b/src/Test/MockCat/TH.hs
@@ -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.")
diff --git a/src/Test/MockCat/TH/ClassAnalysis.hs b/src/Test/MockCat/TH/ClassAnalysis.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/TH/ClassAnalysis.hs
@@ -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
+
+
diff --git a/src/Test/MockCat/TH/ContextBuilder.hs b/src/Test/MockCat/TH/ContextBuilder.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/TH/ContextBuilder.hs
@@ -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
+
+
diff --git a/src/Test/MockCat/TH/FunctionBuilder.hs b/src/Test/MockCat/TH/FunctionBuilder.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/TH/FunctionBuilder.hs
@@ -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
+
+
diff --git a/src/Test/MockCat/TH/TypeUtils.hs b/src/Test/MockCat/TH/TypeUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/TH/TypeUtils.hs
@@ -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
+
diff --git a/src/Test/MockCat/TH/Types.hs b/src/Test/MockCat/TH/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/TH/Types.hs
@@ -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}
+
+
diff --git a/src/Test/MockCat/Verify.hs b/src/Test/MockCat/Verify.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Verify.hs
@@ -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))
diff --git a/src/Test/MockCat/WithMock.hs b/src/Test/MockCat/WithMock.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/WithMock.hs
@@ -0,0 +1,287 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+{- | withMock: Declarative mock expectations DSL
+
+This module provides a declarative way to define mock functions with expectations
+that are automatically verified when the 'withMock' block completes.
+
+Example:
+
+@
+withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called once `with` "a"
+
+ evaluate $ mockFn "a"
+@
+-}
+module Test.MockCat.WithMock
+ ( withMock
+ , expects
+ , called
+ , with
+ , calledInOrder
+ , calledInSequence
+ , times
+ , once
+ , never
+ , atLeast
+ , anything
+ , WithMockContext(..)
+ , MonadWithMockContext(..)
+ , Expectation(..)
+ , Expectations(..)
+ ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (ReaderT(..), runReaderT, MonadReader(..), ask)
+import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, modifyTVar', atomically)
+import Control.Monad.State (State, get, put, modify, execState)
+import Test.MockCat.Verify
+ ( ResolvableParamsOf
+ , ResolvableMock
+
+ , requireResolved
+ , verifyCount
+ , verifyOrder
+ , verifyResolvedAny
+ , verifyCallCount
+ , ResolvedMock(..)
+ , TimesSpec(..)
+ , times
+ , once
+ , never
+ , atLeast
+ , anything
+
+ )
+import Test.MockCat.Internal.Types
+ ( CountVerifyMethod(..)
+ , VerifyOrderMethod(..)
+ )
+import Test.MockCat.Param (Param(..), param)
+import Data.Kind (Type)
+import Data.Proxy (Proxy(..))
+
+-- | Mock expectation context holds verification actions to run at the end
+-- of the `withMock` block. Storing `IO ()` avoids forcing concrete param
+-- types at registration time.
+newtype WithMockContext = WithMockContext (TVar [IO ()])
+
+class Monad m => MonadWithMockContext m where
+ askWithMockContext :: m WithMockContext
+
+instance {-# OVERLAPPABLE #-} (Monad m, MonadReader WithMockContext m) => MonadWithMockContext m where
+ askWithMockContext = ask
+
+-- | Expectation specification
+data Expectation params where
+ -- | Count expectation with specific arguments
+ CountExpectation :: CountVerifyMethod -> params -> Expectation params
+ -- | Count expectation without arguments (any arguments)
+ CountAnyExpectation :: CountVerifyMethod -> Expectation params
+ -- | Order expectation
+ OrderExpectation :: VerifyOrderMethod -> [params] -> Expectation params
+ -- | Simple expectation (at least once) with arguments
+ SimpleExpectation :: params -> Expectation params
+ -- | Simple expectation (at least once) without arguments
+ AnyExpectation :: Expectation params
+
+-- | Expectations builder (Monad instance for do syntax)
+newtype Expectations params a = Expectations (State [Expectation params] a)
+ deriving (Functor, Applicative, Monad)
+
+-- | Run Expectations to get a list of expectations
+runExpectations :: Expectations params a -> [Expectation params]
+runExpectations (Expectations s) = execState s []
+
+-- | Add an expectation to the builder
+addExpectation :: Expectation params -> Expectations params ()
+addExpectation exp = Expectations $ modify (++ [exp])
+
+-- | Run a block with mock expectations that are automatically verified
+withMock :: ReaderT WithMockContext IO a -> IO a
+withMock action = do
+ ctxVar <- newTVarIO []
+ let ctx = WithMockContext ctxVar
+ result <- runReaderT action ctx
+ -- Verify all registered verification actions
+ actions <- readTVarIO ctxVar
+ sequence_ actions
+ pure result
+
+-- | Verify a single expectation
+verifyExpectation ::
+ ( ResolvableMock m
+ , ResolvableParamsOf m ~ params
+ , Show params
+ , Eq params
+ ) =>
+ m ->
+ Expectation params ->
+ IO ()
+verifyExpectation mockFn expectation = do
+ resolved <- requireResolved mockFn
+ case expectation of
+ CountExpectation method args ->
+ verifyCount mockFn args method
+ CountAnyExpectation count ->
+ verifyCallCount (resolvedMockName resolved) (resolvedMockRecorder resolved) count
+ OrderExpectation method argsList ->
+ verifyOrder method mockFn argsList
+ SimpleExpectation _ ->
+ verifyResolvedAny resolved
+ AnyExpectation ->
+ verifyResolvedAny resolved
+
+-- | Attach expectations to a mock function
+-- Supports both single expectation and multiple expectations in a do block
+infixl 0 `expects`
+
+-- | Type class to extract params type from an expectation expression
+class ExtractParams exp where
+ type ExpParams exp :: Type
+ extractParams :: exp -> Proxy (ExpParams exp)
+
+instance ExtractParams (Expectations params ()) where
+ type ExpParams (Expectations params ()) = params
+ extractParams _ = Proxy
+
+instance ExtractParams (fn -> Expectations params ()) where
+ type ExpParams (fn -> Expectations params ()) = params
+ extractParams _ = Proxy
+
+-- | Register expectations for a mock function
+-- Accepts an Expectations builder
+-- The params type is inferred from the mock function type or the expectation
+class BuildExpectations fn exp where
+ buildExpectations :: fn -> exp -> [Expectation (ResolvableParamsOf fn)]
+
+-- | Instance for direct Expectations value
+-- The params type must match ResolvableParamsOf fn
+instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (Expectations params ()) where
+ buildExpectations _ = runExpectations
+
+-- | Instance for function form (fn -> Expectations params ())
+-- This allows passing a function that receives the mock function
+instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (fn -> Expectations params ()) where
+ buildExpectations fn f = runExpectations (f fn)
+
+expects ::
+ forall m fn exp params.
+ ( MonadIO m
+ , MonadWithMockContext m
+ , ResolvableMock fn
+ , ResolvableParamsOf fn ~ params
+ , ExtractParams exp
+ , ExpParams exp ~ params
+ , BuildExpectations fn exp
+ , Show params
+ , Eq params
+ ) =>
+ m fn ->
+ exp ->
+ m fn
+expects mockFnM exp = do
+ (WithMockContext ctxVar) <- askWithMockContext
+ -- Try to help type inference by using exp first
+ let _ = extractParams exp :: Proxy params
+ mockFn <- mockFnM
+ let expectations = buildExpectations mockFn exp
+ let actions = map (verifyExpectation mockFn) expectations
+ liftIO $ atomically $ modifyTVar' ctxVar (++ actions)
+ pure mockFn
+
+-- | Create a count expectation builder
+-- The params type is inferred from the mock function in expects
+-- Use type application to specify params when needed: called @(Param String) once
+-- | Class-based called builder so that the `params` type can be resolved
+-- via instance selection in the `expects` context.
+-- This version uses a type class to help type inference by allowing
+-- the params type to be inferred from the context where it's used.
+class Called params where
+ called :: TimesSpec -> Expectations params ()
+
+-- | Default instance that works for any params type
+instance {-# OVERLAPPABLE #-} Called params where
+ called (TimesSpec method) = do
+ addExpectation (CountAnyExpectation method)
+
+-- | Combine expectations with arguments
+-- Accepts both raw values (like "a") and Param values (like param "a")
+class WithArgs exp args params | exp args -> params where
+ with :: exp -> args -> Expectations params ()
+
+instance {-# OVERLAPPING #-}
+ WithArgs (Expectations params ()) params params
+ where
+ with expM args = do
+ expM
+ -- Extract the last expectation (last in list, since addExpectation appends) and modify it to include args
+ Expectations $ do
+ exps <- get
+ case reverse exps of
+ [] -> error "with: no expectation to add arguments to"
+ (CountAnyExpectation method : rest) -> do
+ put (reverse rest)
+ modify (++ [CountExpectation method args])
+ _ -> error "with: can only add arguments to count-only expectations"
+
+instance {-# OVERLAPPABLE #-}
+ (params ~ Param a, Show a, Eq a) =>
+ WithArgs (Expectations params ()) a params
+ where
+ with expM rawValue = do
+ expM
+ -- Extract the last expectation (last in list, since addExpectation appends) and modify it to include args
+ Expectations $ do
+ exps <- get
+ case reverse exps of
+ [] -> error "with: no expectation to add arguments to"
+ (CountAnyExpectation method : rest) -> do
+ put (reverse rest)
+ modify (++ [CountExpectation method (param rawValue)])
+ _ -> error "with: can only add arguments to count-only expectations"
+
+
+
+
+-- | Create an order expectation
+-- Accepts both Param values and raw values
+class CalledInOrder args params | args -> params where
+ calledInOrder :: args -> Expectations params ()
+
+-- | Convenience instance: infer params from function argument type @a@
+instance
+ (params ~ Param a, Show a, Eq a) =>
+ CalledInOrder [a] params
+ where
+ calledInOrder args =
+ addExpectation (OrderExpectation ExactlySequence (map param args))
+
+-- | Create a partial order expectation
+-- Accepts both Param values and raw values
+class CalledInSequence args params | args -> params where
+ calledInSequence :: args -> Expectations params ()
+
+-- | Convenience instance: infer params from function argument type @a@
+instance
+ (params ~ Param a, Show a, Eq a) =>
+ CalledInSequence [a] params
+ where
+ calledInSequence args =
+ addExpectation (OrderExpectation PartiallySequence (map param args))
+
diff --git a/test/Property/AdditionalProps.hs b/test/Property/AdditionalProps.hs
--- a/test/Property/AdditionalProps.hs
+++ b/test/Property/AdditionalProps.hs
@@ -2,42 +2,45 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -O0 #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
module Property.AdditionalProps
( prop_predicate_param_match_counts
, prop_multicase_progression
, prop_runMockT_isolation
- , prop_neverApply_unused
, prop_partial_order_duplicates
) where
import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
import Control.Exception (try, SomeException, evaluate)
-import Control.Monad (replicateM, replicateM_, forM, forM_)
+import Control.Monad (forM, forM_)
import Data.List (nub)
import Data.Proxy (Proxy(..))
import Test.MockCat
import Control.Monad.IO.Class (liftIO)
-import Test.MockCat.MockT (MockT(..), Definition(..), runMockT, MonadMockDefs(..))
+perCall :: Int -> a -> a
+perCall i x = case i of
+ _ -> x
+
--------------------------------------------------------------------------------
-- 21. PredicateParam property
--------------------------------------------------------------------------------
-- | Property: A predicate Param (expect even) accepts only matching values and
--- the total recorded applications equals count of even inputs attempted.
+-- the total recorded calls equals count of even inputs attempted.
prop_predicate_param_match_counts :: Property
prop_predicate_param_match_counts = forAll genVals $ \xs -> monadicIO $ do
-- build predicate mock: (Int -> Bool) returning True for all evens
- m <- run $ createMock (expect even "even" |> True)
- let f = stubFn m
+ f <- run $ mock (expect even "even" ~> True)
results <- run $ mapM (\x -> try (evaluate (f x)) :: IO (Either SomeException Bool)) xs
let successes = length [ () | Right _ <- results ]
expected = length (filter even xs)
-- sanity: every success came from an even value
assert (all even [ x | (x, Right _) <- zip xs results ])
-- counts should match
- run $ m `shouldApplyTimesToAnything` expected
+ run $ f `shouldBeCalled` times expected
assert (successes == expected)
where
genVals = resize 40 $ listOf (arbitrary :: Gen Int)
@@ -50,26 +53,27 @@
-- saturate at the last value.
prop_multicase_progression :: Property
prop_multicase_progression = forAll genSeq $ \(arg, rs, extra) -> monadicIO $ do
- m <- run $ createMock $ cases [ param arg |> r | r <- rs ]
- let f = stubFn m
- totalCalls = length rs + extra
+ f <- run $ mock $ cases [ param arg ~> r | r <- rs ]
+ let totalCalls = length rs + extra
-- NOTE [GHC9.4 duplicate-call counting]
-- On GHC 9.4 we observed that using @replicateM totalCalls (evaluate (f arg))@
- -- can result in only a single side‑effect (application recording) when all
+ -- can result in only a single side‑effect (call recording) when all
-- of (argument,result) pairs are identical. The optimizer (or full laziness
-- even under -O0) may float the pure expression @f arg@ and share it.
-- We intentionally inject the loop index via a seq so each iteration has a
-- syntactically distinct thunk, ensuring the unsafePerformIO body runs per call.
- vals <- run $ forM [1 .. totalCalls] $ \i -> evaluate (case i of { _ -> f arg })
+ vals <- run $
+ forM [1 .. totalCalls] $ \i ->
+ evaluate (perCall i (f arg))
let (prefix, suffix) = splitAt (length rs) vals
assert (prefix == rs)
assert (all (== last rs) suffix)
- run $ m `shouldApplyTimesToAnything` totalCalls
+ run $ f `shouldBeCalled` times totalCalls
where
genSeq = do
arg <- arbitrary :: Gen Int
Positive len <- arbitrary :: Gen (Positive Int)
- let capped = 1 + (len `mod` 5) -- keep small (1..5)
+ let capped = 1 + len `mod` 5 -- keep small (1..5)
rs <- vectorOf capped (arbitrary :: Gen Int)
extra <- chooseInt (0,3)
pure (arg, rs, extra)
@@ -78,50 +82,28 @@
-- 23. runMockT isolation property
--------------------------------------------------------------------------------
--- | Two independent runMockT invocations must not leak application counts.
--- First run uses expectApplyTimes 1; second run expects 0 for a freshly built mock.
+-- | Two independent runMockT invocations must not leak call counts.
+-- The first run enforces a single invocation; the second expects zero for a fresh mock.
prop_runMockT_isolation :: Property
prop_runMockT_isolation = monadicIO $ do
- -- Run 1: expect one application
+ -- Run 1: expect one call
r1 <- run $ try $ runMockT $ do
- m <- liftIO $ createMock (param (1 :: Int) |> True)
- addDefinition Definition { symbol = Proxy @"iso", mock = m, verify = \m' -> m' `shouldApplyTimesToAnything` 1 }
- let f = stubFn m
+ f <- liftIO $ mock (param (1 :: Int) ~> True)
+ addDefinition Definition { symbol = Proxy @"iso", mockFunction = f, verification = Verification (\m' -> m' `shouldBeCalled` times 1) }
liftIO $ f 1 `seq` pure ()
case r1 of
Left (_ :: SomeException) -> assert False
Right () -> assert True
-- Run 2: expect zero (if leaked, would see 1 and fail)
r2 <- run $ try $ runMockT $ do
- m <- liftIO $ createMock (param (1 :: Int) |> True)
- addDefinition Definition { symbol = Proxy @"iso", mock = m, verify = \m' -> m' `shouldApplyTimesToAnything` 0 }
+ f <- liftIO $ mock (param (1 :: Int) ~> True)
+ addDefinition Definition { symbol = Proxy @"iso", mockFunction = f, verification = Verification (\m' -> m' `shouldBeCalled` times 0) }
pure ()
case r2 of
Left (_ :: SomeException) -> assert False
Right () -> assert True
---------------------------------------------------------------------------------
--- 24. neverApply unused property
---------------------------------------------------------------------------------
--- | A definition not invoked verifies zero applications while another is used.
-prop_neverApply_unused :: Property
-prop_neverApply_unused = forAll (chooseInt (0,5)) $ \n -> monadicIO $ do
- r <- run $ try $ runMockT $ do
- -- used mock
- mUsed <- liftIO $ createMock (param (0 :: Int) |> True)
- addDefinition Definition { symbol = Proxy @"used", mock = mUsed, verify = \m' -> m' `shouldApplyTimesToAnything` n }
- -- unused mock
- mUnused <- liftIO $ createMock (param (42 :: Int) |> True)
- addDefinition Definition { symbol = Proxy @"unused", mock = mUnused, verify = \m' -> m' `shouldApplyTimesToAnything` 0 }
- let f = stubFn mUsed
- -- See NOTE [GHC9.4 duplicate-call counting] above: make each application
- -- depend on the loop index to avoid sharing; case forces dependence.
- liftIO $ forM_ [1 .. n] $ \i -> evaluate (case i of { _ -> f 0 })
- case r of
- Left (_ :: SomeException) -> assert False
- Right () -> assert True
-
--------------------------------------------------------------------------------
-- 25. Partial order duplicates property
--------------------------------------------------------------------------------
@@ -131,18 +113,17 @@
prop_partial_order_duplicates :: Property
prop_partial_order_duplicates = forAll genDupScript $ \xs -> length xs >= 2 ==> monadicIO $ do
-- build mock over sequence
- m <- run $ createMock $ cases [ param x |> True | x <- xs ]
- let f = stubFn m
- run $ sequence_ [ f x `seq` pure () | x <- xs ]
+ f <- run $ mock $ cases [ param x ~> True | x <- xs ]
+ run $ forM_ xs $ \x -> f x `seq` pure ()
let uniques = nub xs
-- success case
- run $ m `shouldApplyInPartialOrder` (param <$> uniques)
+ run $ f `shouldBeCalled` inPartialOrderWith (param <$> uniques)
assert True
-- failure case (if we have at least two unique values)
case uniques of
(_:_:_) | isClusterOrdered uniques xs -> do
let reversed = reverse uniques
- e <- run $ (try (m `shouldApplyInPartialOrder` (param <$> reversed)) :: IO (Either SomeException ()))
+ e <- run (try (f `shouldBeCalled` inPartialOrderWith (param <$> reversed)) :: IO (Either SomeException ()))
case e of
Left _ -> assert True
Right _ -> assert False
@@ -150,7 +131,7 @@
where
genDupScript = do
Positive len <- arbitrary :: Gen (Positive Int)
- let size = 2 + (len `mod` 6) -- 2..7
+ let size = 2 + len `mod` 6 -- 2..7
base <- vectorOf size (arbitrary :: Gen Int)
-- ensure at least one duplicate by forcing first element copy if all distinct
pure $ ensureDup base
diff --git a/test/Property/ConcurrentCountProp.hs b/test/Property/ConcurrentCountProp.hs
--- a/test/Property/ConcurrentCountProp.hs
+++ b/test/Property/ConcurrentCountProp.hs
@@ -3,9 +3,10 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
-module Property.ConcurrentCountProp
- ( prop_concurrent_total_apply_count
- ) where
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+module Property.ConcurrentCountProp where
import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
@@ -15,28 +16,30 @@
import Test.MockCat hiding (any)
import qualified Test.MockCat as MC (any)
--- ローカル並行アクション用クラス (既存 ConcurrencySpec を再利用せず独立定義)
+-- Class for local concurrent actions (defined independently instead of reusing existing ConcurrencySpec)
class Monad m => PropConcurrencyAction m where
propAction :: Int -> m Int
-makeMock [t|PropConcurrencyAction|]
+makeAutoLiftMock [t|PropConcurrencyAction|]
--- | 並行に複数スレッドから同じモック関数を呼び出しても、合計呼び出し回数が失われずに記録されることを検証する property。
--- 引数: threads (1..20), callsPerThread (1..30)
+-- | Property verifying that the total number of calls is recorded without loss even when the same mock function is called concurrently from multiple threads.
+-- Arguments: threads (1..20), callsPerThread (1..30)
prop_concurrent_total_apply_count :: Property
prop_concurrent_total_apply_count =
forAll (chooseInt (1,20)) $ \threads ->
forAll (chooseInt (1,30)) $ \callsPerThread ->
monadicIO $ do
let totalCalls = threads * callsPerThread
- -- runMockT 内で applyTimesIs により期待回数を事前宣言し、並行呼び出し後に自動検証させる
+ -- Pre-declare expected count with `expects` inside `runMockT`, and have it automatically verified after concurrent calls.
run $ runMockT $ do
- _propAction (MC.any |> (1 :: Int)) `applyTimesIs` totalCalls
+ _ <- _propAction (MC.any ~> (1 :: Int))
+ `expects` do
+ called (times totalCalls)
parallelInvoke threads callsPerThread
pure ()
assert True
--- 並行に propAction を呼び出す
+-- Call propAction concurrently
parallelInvoke :: (PropConcurrencyAction m, MonadUnliftIO m) => Int -> Int -> m ()
parallelInvoke threads callsPerThread = withRunInIO $ \runInIO -> do
as <- replicateM threads (async $ runInIO $ replicateM_ callsPerThread (propAction 42 >> pure ()))
diff --git a/test/Property/Generators.hs b/test/Property/Generators.hs
--- a/test/Property/Generators.hs
+++ b/test/Property/Generators.hs
@@ -20,9 +20,9 @@
pure (Script xs)
-- | Build a mock (Int -> Bool) whose allowed arguments are exactly the script values, each returning True.
-buildUnaryMock :: Script Int -> IO (Mock (Int -> Bool) (Param Int))
-buildUnaryMock (Script []) = createMock (param 0 |> True) -- degenerate, never invoked
-buildUnaryMock (Script xs) = createMock $ cases [ param a |> True | a <- xs ]
+buildUnaryMock :: Script Int -> IO (Int -> Bool)
+buildUnaryMock (Script []) = mock (param 0 ~> True) -- degenerate, never invoked
+buildUnaryMock (Script xs) = mock $ cases [ param a ~> True | a <- xs ]
-- | Execute the script against the provided stub function, forcing each Bool.
runScript :: (Int -> Bool) -> Script Int -> IO ()
diff --git a/test/Property/LazyEvalProp.hs b/test/Property/LazyEvalProp.hs
--- a/test/Property/LazyEvalProp.hs
+++ b/test/Property/LazyEvalProp.hs
@@ -3,28 +3,30 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-module Property.LazyEvalProp
- ( prop_lazy_unforced_not_counted
- , prop_lazy_forced_counted
- ) where
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+module Property.LazyEvalProp where
-import Test.QuickCheck
+import Test.QuickCheck hiding (once)
import Test.QuickCheck.Monadic (monadicIO, run, assert)
import Test.MockCat hiding (any)
-- | Unary action so we can register a concrete expected argument & return value.
--- We test that constructing (but not forcing) the application does not count.
+-- We test that constructing (but not forcing) the call does not count.
class Monad m => LazyUnaryAction m where
lazyUnaryAction :: Int -> m Int
-makeMock [t|LazyUnaryAction|]
+makeAutoLiftMock [t|LazyUnaryAction|]
-- | Property: if we declare an expectation but never force (execute) the action,
--- the recorded application count remains 0.
+-- the recorded call count remains 0.
prop_lazy_unforced_not_counted :: Property
prop_lazy_unforced_not_counted = monadicIO $ do
run $ runMockT $ do
- _lazyUnaryAction (param (10 :: Int) |> (42 :: Int)) `applyTimesIs` 0
+ _ <- _lazyUnaryAction (param (10 :: Int) ~> (42 :: Int))
+ `expects` do
+ called never
-- Do NOT force the call; only build a thunk.
let _thunk :: MockT IO Int
_thunk = lazyUnaryAction 10
@@ -35,7 +37,9 @@
prop_lazy_forced_counted :: Property
prop_lazy_forced_counted = monadicIO $ do
run $ runMockT $ do
- _lazyUnaryAction (param (10 :: Int) |> (7 :: Int)) `applyTimesIs` 1
+ _ <- _lazyUnaryAction (param (10 :: Int) ~> (7 :: Int))
+ `expects` do
+ called once
v <- lazyUnaryAction 10 -- forcing the monadic action executes the mock
v `seq` pure () -- ensure result is evaluated (WHNF for Int)
assert True
diff --git a/test/Property/OrderProps.hs b/test/Property/OrderProps.hs
--- a/test/Property/OrderProps.hs
+++ b/test/Property/OrderProps.hs
@@ -8,20 +8,18 @@
import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
-import Control.Exception (try, SomeException, evaluate)
+import Control.Exception (try, SomeException)
import Data.Maybe (listToMaybe)
import Data.List (nub)
-import Test.MockCat (shouldApplyInOrder, shouldApplyInPartialOrder, stubFn)
+import Test.MockCat (shouldBeCalled, inOrderWith, inPartialOrderWith, param)
import Property.Generators
-import Test.MockCat (param)
-- | Property: executing a non-empty script yields exact order success.
prop_inorder_succeeds :: Property
prop_inorder_succeeds = forAll scriptGen $ \scr@(Script xs) -> not (null xs) ==> monadicIO $ do
- m <- run $ buildUnaryMock scr
- let f = stubFn m
+ f <- run $ buildUnaryMock scr
run $ runScript f scr
- run $ m `shouldApplyInOrder` (param <$> xs)
+ run $ f `shouldBeCalled` inOrderWith (param <$> xs)
assert True
-- | Property: a single adjacent swap causes order verification failure.
@@ -33,10 +31,9 @@
else do
i <- run $ generate $ chooseInt (0, length xs - 2)
let swapped = take i xs ++ [xs !! (i+1), xs !! i] ++ drop (i+2) xs
- m <- run $ buildUnaryMock (Script xs)
- let f = stubFn m
+ f <- run $ buildUnaryMock (Script xs)
run $ runScript f (Script xs)
- e <- run $ (try (m `shouldApplyInOrder` (param <$> swapped)) :: IO (Either SomeException ()))
+ e <- run $ (try (f `shouldBeCalled` inOrderWith (param <$> swapped)) :: IO (Either SomeException ()))
case e of
Left _ -> assert True
Right _ -> assert False
@@ -53,10 +50,9 @@
prop_partial_order_subset_succeeds :: Property
prop_partial_order_subset_succeeds = forAll scriptGen $ \scr@(Script xs) -> not (null xs) ==> monadicIO $ do
subset <- run $ generate $ chooseSubsequence xs
- m <- run $ buildUnaryMock scr
- let f = stubFn m
+ f <- run $ buildUnaryMock scr
run $ runScript f scr
- run $ m `shouldApplyInPartialOrder` (param <$> subset)
+ run $ f `shouldBeCalled` inPartialOrderWith (param <$> subset)
assert True
-- | Property: selecting two distinct values and reversing them causes partial order failure.
@@ -69,11 +65,10 @@
case listToMaybe pairs of
Nothing -> assert True
Just (i,j) -> do
- m <- run $ buildUnaryMock scr
- let f = stubFn m
+ f <- run $ buildUnaryMock scr
run $ runScript f scr
let reversed = [xs!!j, xs!!i]
- e <- run $ (try (m `shouldApplyInPartialOrder` (param <$> reversed)) :: IO (Either SomeException ()))
+ e <- run $ (try (f `shouldBeCalled` inPartialOrderWith (param <$> reversed)) :: IO (Either SomeException ()))
case e of
Left _ -> assert True
Right _ -> assert False
diff --git a/test/Property/ParamSpecNormalizeProp.hs b/test/Property/ParamSpecNormalizeProp.hs
--- a/test/Property/ParamSpecNormalizeProp.hs
+++ b/test/Property/ParamSpecNormalizeProp.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MonoLocalBinds #-}
module Property.ParamSpecNormalizeProp (spec, prop_enum_duplicate_equivalence) where
import Test.Hspec
@@ -10,7 +8,6 @@
import Data.List (nub)
import Support.ParamSpec (ParamSpec(..))
import Support.ParamSpecNormalize
-import Data.Hashable (Hashable)
-- Generator for small ParamSpec Int
-- Avoid empty enum (library contract), but include duplicates.
@@ -29,8 +26,7 @@
xs <- vectorOf n smallInt
pure (PSEnum xs)
rangeSpec = do
- a <- smallInt; b <- smallInt
- pure (PSRangeInt a b)
+ a <- smallInt; PSRangeInt a <$> smallInt
pretty :: ParamSpec Int -> String
pretty ps = case ps of
@@ -64,7 +60,7 @@
it "acceptance equivalence on sample domain" $ prop_acceptance_equivalence
it "enum duplicate equivalence" $ prop_enum_duplicate_equivalence
--- Property A: Enum に重複があっても正規化後の形が期待通り (単一点→NExact / 複数→NEnum uniq)
+-- Property A: Verify that the normalized form is as expected even if Enum has duplicates (single point -> NExact / multiple -> NEnum uniq)
prop_enum_duplicate_equivalence :: Property
prop_enum_duplicate_equivalence = forAll genDupEnum $ \(xs :: [Int]) ->
let n = normalise (PSEnum xs)
@@ -83,5 +79,5 @@
baseLen <- choose (1,5)
base <- vectorOf baseLen (choose (-5,5))
dupFactor <- choose (0,3)
- extras <- concat <$> mapM (\v -> vectorOf dupFactor (pure v)) base
+ extras <- concat <$> mapM (vectorOf dupFactor . pure) base
shuffle (base ++ extras)
diff --git a/test/Property/ParamSpecRangeMergeRandomProp.hs b/test/Property/ParamSpecRangeMergeRandomProp.hs
--- a/test/Property/ParamSpecRangeMergeRandomProp.hs
+++ b/test/Property/ParamSpecRangeMergeRandomProp.hs
@@ -1,6 +1,4 @@
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MonoLocalBinds #-}
module Property.ParamSpecRangeMergeRandomProp (spec) where
import Test.Hspec
@@ -8,26 +6,26 @@
import Support.ParamSpec (ParamSpec(..))
import Support.ParamSpecNormalize
--- ランダムに Range / Exact を生成し normaliseManyInt の受理集合と元集合の OR が一致するか検証
+-- Generates Range / Exact randomly and verifies that the OR of the accepted set of normaliseManyInt matches the original set.
spec :: Spec
spec = describe "ParamSpec Int range merge randomized" $ do
it "acceptance equivalence on sampled domain" $ property prop_range_merge_acceptance
-newtype PSList = PSList { unPSList :: [ParamSpec Int] }
+newtype PSList = PSList [ParamSpec Int]
instance Show PSList where show _ = ""
prop_range_merge_acceptance :: Property
prop_range_merge_acceptance = forAll genPSList $ \(PSList ps) ->
forAll sampleDomain $ \xs ->
let n = normaliseManyInt ps
- in conjoin [ acceptsNormal n x === any (\p -> acceptsParamSpec p x) ps | x <- xs ]
+ in conjoin [ acceptsNormal n x === any (`acceptsParamSpec` x) ps | x <- xs ]
where
genPSList = PSList <$> genParamSpecs
genParamSpecs = sized $ \sz -> do
k <- choose (0, min 8 (sz+2))
vectorOf k genOne
genOne = frequency
- [ (4, do l <- small; h <- small; pure (PSRangeInt l h))
+ [ (4, do l <- small; PSRangeInt l <$> small;)
, (1, PSExact <$> small)
]
small = choose (-20,20)
diff --git a/test/Property/ReinforcementProps.hs b/test/Property/ReinforcementProps.hs
--- a/test/Property/ReinforcementProps.hs
+++ b/test/Property/ReinforcementProps.hs
@@ -3,22 +3,18 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
module Property.ReinforcementProps
- ( prop_predicate_negative_not_counted
- , prop_lazy_partial_force_concurrency
- , prop_partial_order_interleaved_duplicates
- ) where
+ where
import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
import Control.Exception (try, SomeException, evaluate)
import Control.Concurrent.Async (forConcurrently_)
import UnliftIO (withRunInIO)
-import Control.Monad (forM_)
-import Control.Monad.IO.Class (liftIO)
-import Data.List (nub)
import Test.MockCat hiding (any)
-import Test.MockCat (param)
--------------------------------------------------------------------------------
-- 1. Predicate negative: failing inputs raise & are not counted
@@ -26,8 +22,7 @@
prop_predicate_negative_not_counted :: Property
prop_predicate_negative_not_counted = forAll genVals $ \xs -> monadicIO $ do
- m <- run $ createMock (expect even "even" |> True)
- let f = stubFn m
+ f <- run $ mock (expect even "even" ~> True)
outcomes <- run $ mapM (\x -> (try (evaluate (f x)) :: IO (Either SomeException Bool))) xs
let evens = length (filter even xs)
successes = length [ () | (x, Right _) <- zip xs outcomes, even x ]
@@ -40,8 +35,8 @@
assert (failures == odds)
-- Successes count equals even inputs
assert (successes == evens)
- -- Applied count equals successes (only even)
- run $ m `shouldApplyTimesToAnything` evens
+ -- Called count equals successes (only even)
+ run $ f `shouldBeCalled` times evens
assert True
where
genVals = resize 60 $ listOf (arbitrary :: Gen Int)
@@ -54,14 +49,16 @@
class Monad m => ParLazyAction m where
parLazy :: Int -> m Int
-makeMock [t|ParLazyAction|]
+makeAutoLiftMock [t|ParLazyAction|]
prop_lazy_partial_force_concurrency :: Property
prop_lazy_partial_force_concurrency = forAll genPlan $ \(arg, mask) -> monadicIO $ do
let forcedCount = length (filter id mask)
run $ runMockT $ do
-- expectation: arg -> arg; count only forced executions
- _parLazy (param arg |> arg) `applyTimesIs` forcedCount
+ _ <- _parLazy (param arg ~> arg)
+ `expects` do
+ called (times forcedCount)
-- prepare thunks (NOT executed yet)
let thunks = replicate (length mask) (parLazy arg)
withRunInIO $ \runIn -> do
@@ -85,13 +82,12 @@
prop_partial_order_interleaved_duplicates :: Property
prop_partial_order_interleaved_duplicates = forAll genPair $ \(a,b) -> a /= b ==> monadicIO $ do
-- Pattern a a b : [a,b] subsequence succeeds, [b,a] fails.
- m <- run $ createMock $ cases [ param a |> True
- , param a |> True
- , param b |> True ]
- let f = stubFn m
+ f <- run $ mock $ cases [ param a ~> True
+ , param a ~> True
+ , param b ~> True ]
run $ f a `seq` f a `seq` f b `seq` pure ()
- run $ m `shouldApplyInPartialOrder` [param a, param b]
- e <- run $ (try (m `shouldApplyInPartialOrder` [param b, param a]) :: IO (Either SomeException ()))
+ run $ f `shouldBeCalled` inPartialOrderWith [param a, param b]
+ e <- run $ (try (f `shouldBeCalled` inPartialOrderWith [param b, param a]) :: IO (Either SomeException ()))
case e of
Left _ -> assert True
Right _ -> assert False
diff --git a/test/Property/ScriptProps.hs b/test/Property/ScriptProps.hs
--- a/test/Property/ScriptProps.hs
+++ b/test/Property/ScriptProps.hs
@@ -5,14 +5,13 @@
import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
-import Test.MockCat (shouldApplyTimesToAnything, stubFn)
+import Test.MockCat (shouldBeCalled, times)
import Property.Generators
--- | Property: executing a generated script produces exactly that many recorded applications.
+-- | Property: executing a generated script produces exactly that many recorded calls.
prop_script_count_matches :: Property
prop_script_count_matches = forAll scriptGen $ \scr@(Script xs) -> monadicIO $ do
- m <- run $ buildUnaryMock scr
- let f = stubFn m
+ f <- run $ buildUnaryMock scr
run $ runScript f scr
- run $ m `shouldApplyTimesToAnything` length xs
+ run $ f `shouldBeCalled` times (length xs)
assert True
diff --git a/test/ReadmeVerifySpec.hs b/test/ReadmeVerifySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/ReadmeVerifySpec.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+
+module ReadmeVerifySpec where
+
+import Test.Hspec
+import Test.MockCat
+import Prelude hiding (readFile, writeFile, any)
+import Control.Monad (when)
+
+-- -------------------------------------------------------
+-- 2. Typeclass Mocking Definitions
+-- -------------------------------------------------------
+class Monad m => FileSystem m where
+ readFile :: FilePath -> m String
+ writeFile :: FilePath -> String -> m ()
+
+-- [Strict Mode]
+makeMock [t|FileSystem|]
+
+-- Dummy program for Typeclass Mocking
+myProgram :: FileSystem m => FilePath -> m ()
+myProgram path = do
+ content <- readFile path
+ when (content == "debug=true") $ writeFile "log.txt" "start"
+
+
+spec :: Spec
+spec = do
+ describe "Quick Start" do
+ it "Quick Start Demo" do
+ -- 1. Create a mock
+ f <- mock $ "Hello" ~> (42 :: Int)
+
+ -- 2. Use it
+ let result = f "Hello"
+ result `shouldBe` 42
+
+ {-
+ Note: The README includes:
+ -- 3. Verify
+ f `shouldBeCalled` "Hello"
+
+ Without OverloadedStrings, "Hello" is String.
+ f :: String -> Int.
+ shouldBeCalled expects Matcher (String -> Int).
+ "Hello" works as matcher implies `Param String`.
+ -}
+ f `shouldBeCalled` "Hello"
+
+ describe "Function Mocking" do
+ it "Basic" do
+ f <- mock $ "a" ~> "b" ~> True
+ let r = f "a" "b"
+ r `shouldBe` True
+
+ it "Condition" do
+ f <- mock $ expect (> 5) "> 5" ~> True
+ let r = f (6 :: Int)
+ r `shouldBe` True
+
+ it "Any" do
+ f <- mock $ any ~> True
+ let r = f ("something" :: String)
+ r `shouldBe` True
+
+ describe "Typeclass Mocking" do
+ it "filesystem test (Strict)" do
+ result <- runMockT do
+ _readFile $ "config.txt" ~> pure @IO "debug=true"
+ _writeFile $ "log.txt" ~> "start" ~> pure @IO ()
+ myProgram "config.txt"
+ result `shouldBe` ()
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -9,6 +9,19 @@
import Test.MockCat.PartialMockSpec as PartialMock
import Test.MockCat.PartialMockTHSpec as PartialMockTH
import Test.MockCat.ConcurrencySpec as Concurrency
+import Test.MockCat.StubSpec as Stub
+import Test.MockCat.Internal.MockRegistrySpec as Registry
+import Test.MockCat.MockTSpec as MockTSpec
+import Test.MockCat.TH.TypeUtilsSpec as THTypeUtils
+import Test.MockCat.TH.ContextBuilderSpec as THContextBuilder
+import Test.MockCat.TH.ClassAnalysisSpec as THClassAnalysis
+import Test.MockCat.TH.FunctionBuilderSpec as THFunctionBuilder
+import Test.MockCat.ShouldBeCalledSpec as ShouldBeCalled
+import Test.MockCat.ShouldBeCalledMockMSpec as ShouldBeCalledMockM
+import Test.MockCat.WithMockSpec as WithMock
+import Test.MockCat.ErrorDiffSpec as ErrorDiff
+import Test.MockCat.THCompareSpec as THCompare
+import ReadmeVerifySpec as ReadmeVerify
import Test.QuickCheck (property)
import qualified Property.ConcurrentCountProp as ConcurrencyProp
import qualified Property.LazyEvalProp as LazyEvalProp
@@ -32,23 +45,35 @@
PartialMock.spec
PartialMockTH.spec
Concurrency.spec
+ Stub.spec
+ MockTSpec.spec
+ Registry.spec
+ THCompare.spec
+ THTypeUtils.spec
+ THContextBuilder.spec
+ THClassAnalysis.spec
+ THFunctionBuilder.spec
+ ShouldBeCalled.spec
+ ShouldBeCalledMockM.spec
+ WithMock.spec
+ ErrorDiff.spec
+ ReadmeVerify.spec
describe "Property Concurrency" $ do
it "total apply count is preserved across threads" $ property ConcurrencyProp.prop_concurrent_total_apply_count
describe "Property Lazy Evaluation" $ do
it "unforced stub action is not counted" $ property LazyEvalProp.prop_lazy_unforced_not_counted
it "forced stub action is counted" $ property LazyEvalProp.prop_lazy_forced_counted
describe "Property Script Generator" $ do
- it "script count matches recorded applications" $ property ScriptProps.prop_script_count_matches
+ it "script count matches recorded calls" $ property ScriptProps.prop_script_count_matches
describe "Property Order / PartialOrder" $ do
it "in-order script succeeds" $ property OrderProps.prop_inorder_succeeds
it "adjacent swap fails order verification" $ property OrderProps.prop_adjacent_swap_fails
it "subset partial order succeeds" $ property OrderProps.prop_partial_order_subset_succeeds
it "reversed pair fails partial order" $ property OrderProps.prop_partial_order_reversed_pair_fails
- describe "Property Additional (Predicate / Multi-case / Isolation / Unused / Duplicates)" $ do
+ describe "Property Additional (Predicate / Multi-case / Isolation / Duplicates)" $ do
it "predicate param counts match" $ property AdditionalProps.prop_predicate_param_match_counts
it "multi-case progression saturates" $ property AdditionalProps.prop_multicase_progression
it "runMockT isolation of counts" $ property AdditionalProps.prop_runMockT_isolation
- it "neverApply (unused) passes" $ property AdditionalProps.prop_neverApply_unused
it "partial order with duplicates behaves" $ property AdditionalProps.prop_partial_order_duplicates
describe "Property Reinforcement (Negative predicate / Partial force / Interleave)" $ do
it "predicate negative not counted" $ property ReinforcementProps.prop_predicate_negative_not_counted
diff --git a/test/Support/ParamSpec.hs b/test/Support/ParamSpec.hs
--- a/test/Support/ParamSpec.hs
+++ b/test/Support/ParamSpec.hs
@@ -75,5 +75,6 @@
-- * ExpectValue v -> PSExact v
-- * ExpectCondition f l-> PSPredicate f l
fromParam :: Param a -> ParamSpec a
-fromParam (ExpectValue v) = PSExact v
+fromParam (ExpectValue v _) = PSExact v
fromParam (ExpectCondition f l) = PSPredicate f l
+fromParam (ValueWrapper _ _) = PSPredicate (const True) "any"
diff --git a/test/Test/MockCat/ConcurrencySpec.hs b/test/Test/MockCat/ConcurrencySpec.hs
--- a/test/Test/MockCat/ConcurrencySpec.hs
+++ b/test/Test/MockCat/ConcurrencySpec.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Test.MockCat.ConcurrencySpec (spec) where
@@ -19,7 +20,7 @@
class Monad m => ConcurrencyAction m where
action :: Int -> m Int
-makeMock [t|ConcurrencyAction|]
+makeAutoLiftMock [t|ConcurrencyAction|]
-- -------------------------
-- test target functions
@@ -47,11 +48,12 @@
spec :: Spec
spec = do
- describe "Concurrency / applyTimesIs" do
+ describe "Concurrency / expects" do
it "counts calls across parallel async threads" do
result <- runMockT do
- _action (any |> (1 :: Int)) `applyTimesIs` 10
-
+ _ <- _action (any ~> (1 :: Int))
+ `expects` do
+ called (times 10)
parallelActionSum 10
result `shouldBe` 10
@@ -60,22 +62,28 @@
callsPerThread = 20 :: Int
total = threads * callsPerThread :: Int
_ <- (runMockT $ do
- _action (any |> (1 :: Int)) `applyTimesIs` total
+ _ <- _action (any ~> (1 :: Int))
+ `expects` do
+ called (times total)
parallelCallActionWithDelay threads callsPerThread
) :: IO ()
pure ()
it "fails verification when calls are fewer than declared" do
runMockT (do
- _action (any |> (1 :: Int)) `applyTimesIs` 10
+ _ <- _action (any ~> (1 :: Int))
+ `expects` do
+ called (times 10)
parallelCallActionN 9
pure ()
) `shouldThrow` anyErrorCall
- describe "Concurrency / neverApply" do
- it "neverApply passes when stub not used in parallel context" do
+ describe "Concurrency / never expectation" do
+ it "passes when stub not used in parallel context" do
r <- runMockT do
- neverApply $ _action (any |> (99 :: Int))
+ _ <- _action (any ~> (99 :: Int))
+ `expects` do
+ called never
pure (123 :: Int)
r `shouldBe` 123
diff --git a/test/Test/MockCat/Definition.hs b/test/Test/MockCat/Definition.hs
deleted file mode 100644
--- a/test/Test/MockCat/Definition.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# LANGUAGE FunctionalDependencies #-}
-module Test.MockCat.Definition (FileOperation(..), Finder(..), program, findValue) where
-
-import Data.Text
-import Prelude hiding (readFile, writeFile)
-
-class Monad m => FileOperation m where
- readFile :: FilePath -> m Text
- writeFile :: FilePath -> Text -> m ()
-
-program ::
- FileOperation m =>
- FilePath ->
- FilePath ->
- m ()
-program inputPath outputPath = do
- content <- readFile inputPath
- writeFile outputPath content
-
-class Monad m => Finder a b m | a -> b, b -> a where
- findIds :: m [a]
- findById :: a -> m b
-
-findValue :: Finder a b m => m [b]
-findValue = do
- ids <- findIds
- mapM findById ids
diff --git a/test/Test/MockCat/ErrorDiffSpec.hs b/test/Test/MockCat/ErrorDiffSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/ErrorDiffSpec.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+
+module Test.MockCat.ErrorDiffSpec (spec) where
+
+import Test.Hspec (Spec, describe, it, shouldThrow, errorCall)
+import Test.MockCat
+import Control.Exception (evaluate)
+import Prelude hiding (any)
+import GHC.Generics (Generic)
+
+data User = User { name :: String, age :: Int } deriving (Show, Eq, Generic)
+data Config = Config { theme :: String, level :: Int } deriving (Show, Eq, Generic)
+data ComplexUser = ComplexUser { name :: String, config :: Config } deriving (Show, Eq, Generic)
+data DeepNode = Leaf Int | Node { val :: Int, next :: DeepNode } deriving (Show, Eq, Generic)
+-- No longer partial if we use it carefully, but let's just use it.
+-- Actually, to avoid the warning entirely, we could use different field names or separate types,
+-- but for a test it is fine. I will just use anyException for the RED phase.
+data MultiLayer = MultiLayer
+ { layer1 :: String,
+ sub :: SubLayer
+ } deriving (Show, Eq, Generic)
+data SubLayer = SubLayer
+ { layer2 :: String,
+ items :: [DeepNode]
+ } deriving (Show, Eq, Generic)
+
+instance WrapParam User where wrap v = ExpectValue v (show v)
+instance WrapParam Config where wrap v = ExpectValue v (show v)
+instance WrapParam ComplexUser where wrap v = ExpectValue v (show v)
+instance WrapParam DeepNode where wrap v = ExpectValue v (show v)
+instance WrapParam MultiLayer where wrap v = ExpectValue v (show v)
+instance WrapParam SubLayer where wrap v = ExpectValue v (show v)
+
+spec :: Spec
+spec = do
+ describe "Error Message Diff" do
+ it "shows diff for string arguments" do
+ f <- mock $ (any :: Param String) ~> "ok"
+ _ <- evaluate $ f "hello haskell"
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ expected: \"hello world\"\n\
+ \ but got: \"hello haskell\"\n\
+ \ ^^^^^^^^"
+ f `shouldBeCalled` "hello world" `shouldThrow` errorCall expectedError
+
+ it "shows diff for long list" do
+ f <- mock $ (any :: Param [Int]) ~> "ok"
+ _ <- evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ Specific difference in `[5]`:\n\
+ \ expected: 6\n\
+ \ but got: 0\n\
+ \ ^\n\
+ \\n\
+ \Full context:\n\
+ \ expected: [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\
+ \ but got: [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]\n\
+ \ ^^^^^^^^^^^^^^^"
+ f `shouldBeCalled` [1..10] `shouldThrow` errorCall expectedError
+
+ it "shows diff for record" do
+ f <- mock $ (any :: Param User) ~> "ok"
+ _ <- evaluate $ f (User "Fagen" 20)
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ Specific difference in `age`:\n\
+ \ expected: 30\n\
+ \ but got: 20\n\
+ \ ^^\n\
+ \\n\
+ \Full context:\n\
+ \ expected: User {name = \"Fagen\", age = 30}\n\
+ \ but got: User {name = \"Fagen\", age = 20}\n\
+ \ ^^^"
+ f `shouldBeCalled` User "Fagen" 30 `shouldThrow` errorCall expectedError
+
+ it "shows diff for inOrderWith" do
+ f <- mock $ (any :: Param String) ~> "ok"
+ _ <- evaluate $ f "a"
+ _ <- evaluate $ f "b"
+ let expectedError =
+ "function was not called with the expected arguments in the expected order.\n\
+ \ expected 2nd call: \"c\"\n\
+ \ but got 2nd call: \"b\"\n\
+ \ ^^"
+ f `shouldBeCalled` inOrderWith ["a", "c"] `shouldThrow` errorCall expectedError
+
+ it "chooses nearest neighbor in multi-case mock" do
+ f <- mock $ do
+ onCase $ "aaa" ~> (100 :: Int) ~> "ok"
+ onCase $ "bbb" ~> (200 :: Int) ~> "ok"
+
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ expected one of the following:\n\
+ \ \"aaa\", 100\n\
+ \ \"bbb\", 200\n\
+ \ but got:\n\
+ \ \"aaa\", 200\n\
+ \ ^^^"
+ evaluate (f "aaa" 200) `shouldThrow` errorCall expectedError
+
+ it "shows diff for nested record" do
+ f <- mock $ (any :: Param ComplexUser) ~> "ok"
+ _ <- evaluate $ f (ComplexUser "Alice" (Config "Light" 1))
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ Specific difference in `config.theme`:\n\
+ \ expected: \"Dark\"\n\
+ \ but got: \"Light\"\n\
+ \ ^^^^^^\n\
+ \\n\
+ \Full context:\n\
+ \ expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\
+ \ ^^^^^^^^^^^^^^^^^^^"
+ f `shouldBeCalled` ComplexUser "Alice" (Config "Dark" 1) `shouldThrow` errorCall expectedError
+
+ it "shows diff for nested list" do
+ f <- mock $ (any :: Param [[Int]]) ~> "ok"
+ _ <- evaluate $ f [[1, 2], [3, 4]]
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ Specific difference in `[1][1]`:\n\
+ \ expected: 5\n\
+ \ but got: 4\n\
+ \ ^\n\
+ \\n\
+ \Full context:\n\
+ \ expected: [[1,2], [3,5]]\n\
+ \ but got: [[1,2], [3,4]]\n\
+ \ ^^^"
+ f `shouldBeCalled` [[1, 2], [3, 5]] `shouldThrow` errorCall expectedError
+
+ it "shows multiple differences in nested record" do
+ f <- mock $ (any :: Param ComplexUser) ~> "ok"
+ let actual = ComplexUser "Alice" (Config "Light" 2)
+ expected = ComplexUser "Bob" (Config "Dark" 1)
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ Specific differences:\n\
+ \ - `name`:\n\
+ \ expected: \"Bob\"\n\
+ \ but got: \"Alice\"\n\
+ \ - `config.theme`:\n\
+ \ expected: \"Dark\"\n\
+ \ but got: \"Light\"\n\
+ \ - `config.level`:\n\
+ \ expected: 1\n\
+ \ but got: 2\n\
+ \\n\
+ \Full context:\n\
+ \ expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\
+ \ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
+
+ describe "robustness (broken formats)" do
+ it "handles unbalanced braces gracefully (fallback to standard message)" do
+ f <- mock $ (any :: Param String) ~> "ok"
+ let actual = "{ name = \"Alice\""
+ expected = "{ name = \"Bob\" }"
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ expected: \"{ name = \\\"Bob\\\" }\"\n\
+ \ but got: \"{ name = \\\"Alice\\\"\"\n\
+ \ ^^^^^^^^"
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
+
+ it "handles completely broken structure strings" do
+ f <- mock $ (any :: Param String) ~> "ok"
+ let actual = "NotARecord {,,,,,}"
+ expected = "NotARecord { a = 1 }"
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n\
+ \ expected: \"NotARecord { a = 1 }\"\n\
+ \ but got: \"NotARecord {,,,,,}\"\n\
+ \ ^^^^^^^^^"
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
+
+ describe "extreme structural cases" do
+ it "handles extremely deep nesting" do
+ f <- mock $ (any :: Param DeepNode) ~> "ok"
+ -- 5 layers deep
+ let actual = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 0}}}}}
+ expected = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 1}}}}}
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n" <>
+ " Specific difference in `next.next.next.next.next`:\n" <>
+ " expected: Leaf 1\n" <>
+ " but got: Leaf 0\n" <>
+ " " <> replicate 5 ' ' <> "^\n" <>
+ "\n" <>
+ "Full context:\n" <>
+ " expected: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 1}}}}}\n" <>
+ " but got: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}\n" <>
+ " " <> replicate 115 ' ' <> "^^^^^^"
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
+
+ it "shows mismatches across multiple layers" do
+ f <- mock $ (any :: Param MultiLayer) ~> "ok"
+ let actual = MultiLayer {layer1 = "A", sub = SubLayer {layer2 = "B", items = [Node {val = 1, next = Leaf 2}]}}
+ expected = MultiLayer {layer1 = "X", sub = SubLayer {layer2 = "Y", items = [Node {val = 1, next = Leaf 3}]}}
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n" <>
+ " Specific differences:\n" <>
+ " - `layer1`:\n" <>
+ " expected: \"X\"\n" <>
+ " but got: \"A\"\n" <>
+ " - `sub.layer2`:\n" <>
+ " expected: \"Y\"\n" <>
+ " but got: \"B\"\n" <>
+ " - `sub.items[0].next`:\n" <>
+ " expected: Leaf 3\n" <>
+ " but got: Leaf 2\n" <>
+ "\n" <>
+ "Full context:\n" <>
+ " expected: MultiLayer {layer1 = \"X\", sub = SubLayer {layer2 = \"Y\", items = [Node {val = 1, next = Leaf 3}]}}\n" <>
+ " but got: MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}\n" <>
+ " " <> replicate 22 ' ' <> replicate 75 '^'
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
+
+ it "handles cases where almost everything is different" do
+ f <- mock $ (any :: Param Config) ~> "ok"
+ let actual = Config "Light" 1
+ expected = Config "Dark" 99
+ _ <- evaluate $ f actual
+ let expectedError =
+ "function was not called with the expected arguments.\n" <>
+ " Specific differences:\n" <>
+ " - `theme`:\n" <>
+ " expected: \"Dark\"\n" <>
+ " but got: \"Light\"\n" <>
+ " - `level`:\n" <>
+ " expected: 99\n" <>
+ " but got: 1\n" <>
+ "\n" <>
+ "Full context:\n" <>
+ " expected: Config {theme = \"Dark\", level = 99}\n" <>
+ " but got: Config {theme = \"Light\", level = 1}\n" <>
+ " " <> replicate 17 ' ' <> replicate 18 '^'
+ f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
diff --git a/test/Test/MockCat/ExampleSpec.hs b/test/Test/MockCat/ExampleSpec.hs
--- a/test/Test/MockCat/ExampleSpec.hs
+++ b/test/Test/MockCat/ExampleSpec.hs
@@ -1,10 +1,15 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
module Test.MockCat.ExampleSpec (spec) where
@@ -13,12 +18,10 @@
import Prelude hiding (writeFile, readFile, and, any, not, or)
import GHC.IO (evaluate)
import Data.Text hiding (any)
-
-class (Monad m) => FileOperation m where
- writeFile :: FilePath -> Text -> m ()
- readFile :: FilePath -> m Text
+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
+import Test.MockCat.SharedSpecDefs
-makeMock [t|FileOperation|]
+makeAutoLiftMock [t|FileOperation|]
operationProgram ::
FileOperation m =>
@@ -29,25 +32,68 @@
content <- readFile inputPath
writeFile outputPath content
-class Monad m => Teletype m where
- readTTY :: m String
- writeTTY :: String -> m ()
-
-echo :: Teletype m => m ()
-echo = do
+echoProgram :: Teletype m => m ()
+echoProgram = do
i <- readTTY
case i of
"" -> pure ()
- _ -> writeTTY i >> echo
+ _ -> writeTTY i >> echoProgram
-makeMockWithOptions [t|Teletype|] options { implicitMonadicReturn = False }
+makeMock [t|Teletype|]
+
+class Monad m => StrictTest m where
+ strictFunc :: String -> m ()
+
+instance StrictTest IO where
+ strictFunc _ = pure ()
+
+makeMock [t|StrictTest|]
+
spec :: Spec
spec = do
+ it "Default makeMock is strict (requires pure)" do
+ r <- runMockT do
+ _strictFunc $ "arg" ~> pure @IO ()
+ strictFunc "arg"
+ r `shouldBe` ()
+
+ it "function arg" do
+ let
+ f :: String -> String -> String
+ f a b = a <> b
+ -- Example of explicit type application using any @type
+ stub <- mock $ "a" ~> any @(String -> String -> String) ~> True
+ stub "a" f `shouldBe` True
+
+ it "function arg (inferred)" do
+ let
+ f :: String -> String -> String
+ f a b = a <> b
+ -- Example of relying on type inference
+ stub <- mock $ "a" ~> any ~> True
+ stub "a" f `shouldBe` True
+
+ it "function arg2" do
+ let
+ -- Do not allow optimization to remove duplicates.
+ {-# NOINLINE f #-}
+ f :: String -> String -> String
+ f a b = a <> b
+
+ {-# NOINLINE g #-}
+ g :: String -> String -> String
+ g a b = a <> b
+
+ stub <- mock $ "a" ~> f ~> g ~> True
+
+ -- Verify that calling with wrong function order raises an error
+ evaluate (stub "a" g f) `shouldThrow` anyErrorCall
+
it "echo1" do
result <- runMockT do
_readTTY $ pure @IO ""
- echo
+ echoProgram
result `shouldBe` ()
it "echo2" do
@@ -56,118 +102,106 @@
onCase $ pure @IO "a"
onCase $ pure @IO ""
- _writeTTY $ "a" |> pure @IO ()
- echo
+ _writeTTY $ "a" ~> pure @IO ()
+ echoProgram
result `shouldBe` ()
it "echo3" do
result <- runMockT do
_readTTY $ casesIO ["a", ""]
- _writeTTY $ "a" |> pure @IO ()
- echo
+ _writeTTY $ "a" ~> pure @IO ()
+ echoProgram
result `shouldBe` ()
it "echo4" do
result <- runMockT do
_readTTY $ cases [ pure @IO "a", pure @IO "" ]
- _writeTTY $ "a" |> pure @IO ()
- echo
+ _writeTTY $ "a" ~> pure @IO ()
+ echoProgram
result `shouldBe` ()
it "read & write" 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` ()
it "stub" do
-- create a stub function
- stubFn <- createStubFn $ "value" |> True
+ stubFn <- mock $ "value" ~> True
-- assert
stubFn "value" `shouldBe` True
it "stub & verify" do
-- create a mock
- mock <- createMock $ "value" |> True
- -- stub function
- let stubFunction = stubFn mock
+ mockFn <- mock $ "value" ~> True
-- assert
- stubFunction "value" `shouldBe` True
- -- verify
- mock `shouldApplyTo` "value"
+ mockFn "value" `shouldBe` True
it "how to use" do
- f <- createStubFn $ "param1" |> "param2" |> pure @IO ()
+ f <- mock $ "param1" ~> "param2" ~> pure @IO ()
actual <- f "param1" "param2"
actual `shouldBe` ()
it "named stub" do
- f <- createNamedStubFn "named stub" $ "x" |> "y" |> True
+ f <- mock (label "named stub") $ "x" ~> "y" ~> True
f "x" "y" `shouldBe` True
+ it "mock returns monadic stub (IO)" do
+ f <- mock $ "a" ~> (11 :: Int) ~> pure @IO False
+ f "a" (11 :: Int) `shouldReturn` False
+
+ it "mock returns monadic stub (MaybeT)" do
+ mm <- runMaybeT do
+ -- create a mock inside MaybeT
+ mock $ True ~> pure @(MaybeT IO) False
+ case mm of
+ Nothing -> expectationFailure "mock returned Nothing"
+ Just f -> do
+ -- f :: Bool -> MaybeT IO Bool
+ res <- runMaybeT $ f True
+ res `shouldBe` Just False
+
it "named mock" do
- m <- createNamedMock "mock" $ "value" |> "a" |> True
- stubFn m "value" "a" `shouldBe` True
+ f <- mock (label "mock") $ "value" ~> "a" ~> True
+ f "value" "a" `shouldBe` True
it "stub function" do
- f <- createStubFn $ "value" |> True
+ f <- mock $ "value" ~> True
f "value" `shouldBe` True
- it "shouldApplyTimes" do
- m <- createMock $ "value" |> True
- print $ stubFn m "value"
- print $ stubFn m "value"
- m `shouldApplyTimes` (2 :: Int) `to` "value"
-
- it "shouldApplyInOrder" do
- m <- createMock $ any |> True |> ()
- print $ stubFn m "a" True
- print $ stubFn m "b" True
- m
- `shouldApplyInOrder` [ "a" |> True,
- "b" |> True
- ]
-
- 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
- ]
-
it "any" do
- f <- createStubFn $ any |> "return value"
+ f <- mock $ any ~> "return value"
f "something" `shouldBe` "return value"
it "expect" do
- f <- createStubFn $ expect (> (5 :: Int)) "> 5" |> "return value"
+ -- Explicit type annotations like (4 :: Int) are required because the polymorphism
+ -- of numeric literals and operators makes the type of Param ambiguous.
+ f <- mock $ expect (> (5 :: Int)) "> 5" ~> "return value"
f 6 `shouldBe` "return value"
it "expect_" do
- f <- createStubFn $ expect_ (> (5 :: Int)) |> "return value"
+ f <- mock $ expect_ (> (5 :: Int)) ~> "return value"
f 6 `shouldBe` "return value"
it "expectByExpr" do
- f <- createStubFn $ $(expectByExpr [|(> (5 :: Int))|]) |> "return value"
+ f <- mock $ $(expectByExpr [|(> (5 :: Int))|]) ~> "return value"
f 6 `shouldBe` "return value"
it "multi" do
- f <- createStubFn do
- onCase $ "a" |> "return x"
- onCase $ "b" |> "return y"
+ f <- mock do
+ onCase $ "a" ~> "return x"
+ onCase $ "b" ~> "return y"
f "a" `shouldBe` "return x"
f "b" `shouldBe` "return y"
it "Return different values for the same argument" do
- f <- createStubFn $ do
- onCase $ "arg" |> "x"
- onCase $ "arg" |> "y"
+ f <- mock $ do
+ onCase $ "arg" ~> "x"
+ onCase $ "arg" ~> "y"
-- Do not allow optimization to remove duplicates.
v1 <- evaluate $ f "arg"
diff --git a/test/Test/MockCat/Impl.hs b/test/Test/MockCat/Impl.hs
--- a/test/Test/MockCat/Impl.hs
+++ b/test/Test/MockCat/Impl.hs
@@ -4,7 +4,7 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Test.MockCat.Impl (FileOperation, Finder) where
-import Test.MockCat.Definition
+import Test.MockCat.SharedSpecDefs
import Data.Text (pack)
import Prelude hiding (readFile, writeFile)
import Control.Monad.Trans.Maybe
@@ -27,3 +27,8 @@
instance Finder Int String IO where
findIds = pure [1 :: Int, 2 :: Int, 3 :: Int]
findById id = pure $ "{id: " <> show id <> "}"
+
+-- Provide FinderNoImplicit fallback instance for tests that use explicit monadic returns
+instance FinderNoImplicit Int String IO where
+ findIdsNI = pure [1 :: Int, 2 :: Int, 3 :: Int]
+ findByIdNI i = pure $ "{id: " <> show i <> "}"
diff --git a/test/Test/MockCat/Internal/MockRegistrySpec.hs b/test/Test/MockCat/Internal/MockRegistrySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/Internal/MockRegistrySpec.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE BlockArguments #-}
+module Test.MockCat.Internal.MockRegistrySpec (spec) where
+
+import Test.Hspec
+import Test.MockCat.Internal.MockRegistry
+import Control.Concurrent.STM (newTVarIO, readTVarIO)
+import Data.Dynamic (fromDynamic)
+import Test.MockCat.AssociationList (empty)
+import Test.MockCat.Internal.Types (InvocationRecorder(..), FunctionNature(..), InvocationRecord(..))
+
+spec :: Spec
+spec = do
+ describe "MockRegistry" do
+ it "register and lookup" do
+ let f = (+ 1) :: Int -> Int
+ ref <- newTVarIO InvocationRecord { invocations = [] :: [Int], invocationCounts = empty }
+ _ <- attachVerifierToFn f (Just "name", InvocationRecorder ref ParametricFunction)
+ verifier <- lookupVerifierForFn f
+ case verifier of
+ Just (mockName, dyn) -> do
+ mockName `shouldBe` Just "name"
+ case (fromDynamic dyn :: Maybe (InvocationRecorder Int)) of
+ Just (InvocationRecorder vref _) -> do
+ r <- readTVarIO vref
+ r `shouldBe` InvocationRecord { invocations = [] :: [Int], invocationCounts = empty }
+ Nothing -> expectationFailure "payload dynamic mismatch"
+ Nothing -> expectationFailure "lookupStubFn returned Nothing"
+
+
diff --git a/test/Test/MockCat/MockSpec.hs b/test/Test/MockCat/MockSpec.hs
--- a/test/Test/MockCat/MockSpec.hs
+++ b/test/Test/MockCat/MockSpec.hs
@@ -8,816 +8,144 @@
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{- HLINT ignore "Use newtype instead of data" -}
module Test.MockCat.MockSpec (spec) where
import qualified Control.Exception as E
-import Data.Function ((&))
import Test.Hspec
import Test.MockCat
import Prelude hiding (any)
+import Data.List (isInfixOf)
spec :: Spec
spec = do
describe "Test of Mock" do
describe "combination test" do
it "arity = 1" do
- f <- createStubFn $ True |> False
+ f <- mock $ True ~> False
f True `shouldBe` False
it "arity = 2" do
- f <- createStubFn $ True |> False |> True
+ f <- mock $ True ~> False ~> True
f True False `shouldBe` True
it "arity = 3" do
- f <- createStubFn $ True |> "False" |> True |> "False"
+ f <- mock $ True ~> "False" ~> True ~> "False"
f True "False" True `shouldBe` "False"
it "arity = 4" do
- f <- createStubFn $ True |> "False" |> True |> "False" |> True
+ f <- mock $ True ~> "False" ~> True ~> "False" ~> True
f True "False" True "False" `shouldBe` True
- it "Param |> a" do
- f <- createStubFn $ any |> False
+ it "Param ~> a" do
+ f <- mock $ any ~> False
f True `shouldBe` False
- it "Param |> (a |> b)" do
- f <- createStubFn $ any |> False |> True
+ it "Param ~> (a ~> b)" do
+ f <- mock $ any ~> False ~> True
f True False `shouldBe` True
- it "a |> (Param |> b)" do
- f <- createStubFn $ True |> any |> True
+ it "a ~> (Param ~> b)" do
+ f <- mock $ True ~> any ~> True
f True False `shouldBe` True
- it "Param |> (Param |> a)" do
- f <- createStubFn $ any |> any |> True
+ it "Param ~> (Param ~> a)" do
+ f <- mock $ any ~> any ~> True
f True False `shouldBe` True
- it "a |> (Param |> (Param |> a))" do
- f <- createStubFn $ "any" |> any |> any |> True
+ it "a ~> (Param ~> (Param ~> a))" do
+ f <- mock $ "any" ~> any ~> any ~> True
f "any" "any" "any" `shouldBe` True
- it "param |> (Param |> (Param |> a))" do
- f <- createStubFn $ any |> any |> any |> True
+ it "param ~> (Param ~> (Param ~> a))" do
+ f <- mock $ any ~> any ~> any ~> True
f "any" "any" "any" `shouldBe` True
- mockTest
- Fixture
- { name = "arity = 1",
- create = createMock $ "a" |> False,
- apply = (`stubFn` "a"),
- applyFailed = Just (`stubFn` "x"),
- expected = False,
- verifyApply = (`shouldApplyTo` "a"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = (`shouldApplyTo` "2"),
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` "a"
- }
-
- mockTest
- Fixture
- { name = "arity = 2",
- create = createMock $ "a" |> "b" |> True,
- apply = \m -> stubFn m "a" "b",
- applyFailed = Just (\m -> stubFn m "a" "x"),
- expected = True,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "2" |> "b",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b")
- }
-
- mockTest
- Fixture
- { name = "arity = 3",
- create = createMock $ "a" |> "b" |> "c" |> False,
- apply = \m -> stubFn m "a" "b" "c",
- applyFailed = Just (\m -> stubFn m "a" "b" "x"),
- expected = False,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "d",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c")
- }
-
- mockTest
- Fixture
- { name = "arity = 4",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> True,
- apply = \m -> stubFn m "a" "b" "c" "d",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "x"),
- expected = True,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "x",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d")
- }
-
- mockTest
- Fixture
- { name = "arity = 5",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> "e" |> False,
- apply = \m -> stubFn m "a" "b" "c" "d" "e",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "x"),
- expected = False,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "x",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e")
- }
-
- mockTest
- Fixture
- { name = "arity = 6",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> True,
- apply = \m -> stubFn m "a" "b" "c" "d" "e" "f",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "x"),
- expected = True,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "x",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f")
- }
-
- mockTest
- Fixture
- { name = "arity = 7",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> False,
- apply = \m -> stubFn m "a" "b" "c" "d" "e" "f" "g",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "x"),
- expected = False,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "y",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g")
- }
-
- mockTest
- Fixture
- { name = "arity = 8",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> False,
- apply = \m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "h",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "x"),
- expected = False,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "x",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h")
- }
-
- mockTest
- Fixture
- { name = "arity = 9",
- create = createMock $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "i" |> False,
- apply = \m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "h" "i",
- applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "h" "x"),
- expected = False,
- verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "i",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "x",
- verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "i")
- }
-
- describe "Test of Multi Mock" do
- mockTest
- Fixture
- { name = "arity = 1",
- create =
- createMock $ do
- onCase $ "1" |> True
- onCase $ "2" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m -> [stubFn m "1", stubFn m "2"],
- applyFailed = Just \m -> [stubFn m "3"],
- verifyApply = \m -> do
- m `shouldApplyTo` "1"
- m `shouldApplyTo` "2",
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyFailed = (`shouldApplyTo` "3"),
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` "1"
- m `shouldApplyTimes` c `to` "2"
- }
-
- mockTest
- Fixture
- { name = "arity = 2",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> True
- onCase $ "2" |> "3" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2",
- stubFn m "2" "3"
- ],
- applyFailed = Just \m -> [stubFn m "1" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2")
- m `shouldApplyTo` ("2" |> "3"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2")
- m `shouldApplyTimes` c `to` ("2" |> "3"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 3",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> True
- onCase $ "2" |> "3" |> "4" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3",
- stubFn m "2" "3" "4"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3")
- m `shouldApplyTo` ("2" |> "3" |> "4"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 4",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4",
- stubFn m "2" "3" "4" "5"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 5",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> "5" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> "6" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4" "5",
- stubFn m "2" "3" "4" "5" "6"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "4" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 6",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4" "5" "6",
- stubFn m "2" "3" "4" "5" "6" "7"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "4" "5" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 7",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4" "5" "6" "7",
- stubFn m "2" "3" "4" "5" "6" "7" "8"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "4" "5" "6" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 8",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4" "5" "6" "7" "8",
- stubFn m "2" "3" "4" "5" "6" "7" "8" "9"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "4" "5" "6" "7" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "x")
- }
-
- mockTest
- Fixture
- { name = "arity = 9",
- create =
- createMock $ do
- onCase $ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> True
- onCase $ "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "10" |> False
- ,
- expected =
- [ True,
- False
- ],
- apply = \m ->
- [ stubFn m "1" "2" "3" "4" "5" "6" "7" "8" "9",
- stubFn m "2" "3" "4" "5" "6" "7" "8" "9" "10"
- ],
- applyFailed = Just \m -> [stubFn m "1" "2" "3" "4" "5" "6" "7" "8" "x"],
- verifyApply = \m -> do
- m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9")
- m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "10"),
- verifyApplyAny = shouldApplyToAnything,
- verifyApplyCount = \m c -> do
- m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9")
- m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "10"),
- verifyApplyFailed = \m -> m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "x")
- }
-
- describe "Order Verification" do
- describe "exactly sequential order." do
- mockOrderTest
- VerifyOrderFixture
- { name = "arity = 1",
- create = createMock $ any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "b"
- evaluate $ stubFn m "c",
- verifyApply = \m ->
- m
- `shouldApplyInOrder` [ "a",
- "b",
- "c"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInOrder` [ "a",
- "b",
- "b"
- ]
- }
-
- mockOrderTest
- VerifyOrderFixture
- { name = "arity = 9",
- create = createMock $ any |> any |> any |> any |> any |> any |> any |> any |> (),
- apply = \m -> do
- evaluate $ stubFn m "1" "2" "3" "4" "5" "6" "7" "8"
- evaluate $ stubFn m "2" "3" "4" "5" "6" "7" "8" "9"
- evaluate $ stubFn m "3" "4" "5" "6" "7" "8" "9" "0",
- verifyApply = \m ->
- m
- `shouldApplyInOrder` [ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8",
- "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9",
- "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "0"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInOrder` [ "1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "x",
- "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "y",
- "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "z"
- ]
- }
-
- mockOrderTest
- VerifyOrderFixture
- { name = "number of function calls doesn't match the number of params.",
- create = createMock $ any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a"
- pure (),
- verifyApply = \m ->
- m
- `shouldApplyInOrder` [ "a"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInOrder` [ "a",
- "b"
- ]
- }
-
- describe "partially sequential order." do
- mockOrderTest
- VerifyOrderFixture
- { name = "arity = 1",
- create = createMock $ any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "b"
- evaluate $ stubFn m "c"
- pure (),
- verifyApply = \m ->
- m
- `shouldApplyInPartialOrder` [ "a",
- "c"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInPartialOrder` [ "b",
- "a"
- ]
- }
-
- mockOrderTest
- VerifyOrderFixture
- { name = "arity = 9",
- create = createMock $ any |> any |> any |> any |> any |> any |> any |> any |> any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a" "" "" "" "" "" "" "" ""
- evaluate $ stubFn m "b" "" "" "" "" "" "" "" ""
- evaluate $ stubFn m "c" "" "" "" "" "" "" "" ""
- pure (),
- verifyApply = \m ->
- m
- `shouldApplyInPartialOrder` [ "a" |> "" |> "" |> "" |> "" |> "" |> "" |> "" |> "",
- "c" |> "" |> "" |> "" |> "" |> "" |> "" |> "" |> ""
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInPartialOrder` [ "b" |> "" |> "" |> "" |> "" |> "" |> "" |> "" |> "",
- "a" |> "" |> "" |> "" |> "" |> "" |> "" |> "" |> ""
- ]
- }
-
- mockOrderTest
- VerifyOrderFixture
- { name = "Uncalled value specified.",
- create = createMock $ any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "b"
- evaluate $ stubFn m "c"
- pure (),
- verifyApply = \m ->
- m
- `shouldApplyInPartialOrder` [ "b",
- "c"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInPartialOrder` [ "a",
- "d"
- ]
- }
-
- mockOrderTest
- VerifyOrderFixture
- { name = "number of function calls doesn't match the number of params",
- create = createMock $ any |> (),
- apply = \m -> do
- evaluate $ stubFn m "a"
- pure (),
- verifyApply = \m ->
- m
- `shouldApplyInPartialOrder` [ "a"
- ],
- verifyApplyFailed = \m ->
- m
- `shouldApplyInPartialOrder` [ "a",
- "b"
- ]
- }
+ describe "Non-Eq/Show support" do
+ it "can mock function with NoEq argument using any" do
+ f <- mock $ any @NoEq ~> "result"
+ f (NoEq "val") `shouldBe` "result"
+
+ it "can mock function with NoEq argument using expect" do
+ f <- mock $ expect_ (const True) ~> "result"
+ f (NoEq "val") `shouldBe` "result"
- describe "The number of times applied can also be verified by specifying conditions." do
- it "greater than equal" do
- m <- createMock $ "a" |> True
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- m `shouldApplyTimesGreaterThanEqual` 3 `to` "a"
+ it "can stub function with NoEq argument" do
+ let f = stub $ any @NoEq ~> "result"
+ f (NoEq "val") `shouldBe` "result"
- it "less than equal" do
- m <- createMock $ "a" |> False
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- m `shouldApplyTimesLessThanEqual` 3 `to` "a"
+ it "can mock function with NoShow argument using any" do
+ f <- mock $ any @NoShow ~> "result"
+ f (NoShow "val") `shouldBe` "result"
- it "greater than" do
- m <- createMock $ "a" |> True
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- m `shouldApplyTimesGreaterThan` 2 `to` "a"
+ it "can mock function with NoEqNoShow argument using any" do
+ f <- mock $ any @NoEqNoShow ~> "result"
+ f (NoEqNoShow "val") `shouldBe` "result"
+
+ it "can mock function with NoEq argument matching its value" do
+ -- Even without an Eq instance, you can match based on field values using 'expect'.
+ f <- mock $ expect (\(NoEq val) -> val == "target") "NoEq with 'target'" ~> "hit"
+ f (NoEq "target") `shouldBe` "hit"
+ evaluate (f (NoEq "other")) `shouldThrow` anyErrorCall
- it "less than" do
- m <- createMock $ "a" |> False
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- evaluate $ stubFn m "a"
- m `shouldApplyTimesLessThan` 4 `to` "a"
+ it "can mock function taking a function" do
+ f <- mock $ expect_ (\(g :: Int -> Int) -> g (5 :: Int) == (25 :: Int)) ~> "result"
+ let g x = x * x
+ f g `shouldBe` "result"
describe "Monad" do
it "Return IO Monad." do
- m <- createMock $ "Article Id" |> pure @IO "Article Title"
+ f <- mock $ "Article Id" ~> pure @IO "Article Title"
- result <- stubFn m "Article Id"
+ result <- f "Article Id"
result `shouldBe` "Article Title"
- m `shouldApplyTo` "Article Id"
-
describe "Appropriate message when a test fails." do
describe "anonymous mock" do
describe "apply" do
it "simple mock" do
- m <- createMock $ "a" |> pure @IO True
- stubFn m "b"
- `shouldThrow` errorCall
- "function was not applied to the expected arguments.\n\
- \ expected: \"a\"\n\
- \ but got: \"b\""
+ f <- mock $ "a" ~> pure @IO True
+ f "b"
+ `shouldThrow` errorContains "expected: \"a\"\n but got: \"b\"\n ^^"
it "multi mock" do
- m <-
- createMock $ do
- onCase $ "aaa" |> (100 :: Int) |> pure @IO True
- onCase $ "bbb" |> (200 :: Int) |> pure @IO False
-
- stubFn m "aaa" 200
- `shouldThrow` errorCall
- "function was not applied to the expected arguments.\n\
- \ expected one of the following:\n\
- \ \"aaa\",100\n\
- \ \"bbb\",200\n\
- \ but got:\n\
- \ \"aaa\",200"
-
- describe "verify" do
- it "simple mock verify" do
- m <- createMock $ any |> pure @IO True
- evaluate $ stubFn m "A"
- m `shouldApplyTo` "X"
- `shouldThrow` errorCall
- "function was not applied to the expected arguments.\n\
- \ expected: \"X\"\n\
- \ but got: \"A\""
-
- it "It has never been applied." do
- m <- createMock $ "X" |> pure @IO True
- m `shouldApplyTo` "X"
- `shouldThrow` errorCall
- "function was not applied to the expected arguments.\n\
- \ expected: \"X\"\n\
- \ but got: It has never been applied"
-
- it "count" do
- m <- createMock $ any |> pure @IO True
- evaluate $ stubFn m "A"
- let e =
- "function was not applied the expected number of times to the expected arguments.\n\
- \ expected: 2\n\
- \ but got: 1"
- m `shouldApplyTimes` (2 :: Int) `to` "A" `shouldThrow` errorCall e
-
- it "verify sequence" do
- m <- createMock $ any |> pure @IO False
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "C"
- evaluate $ stubFn m "A"
- let e =
- "function was not applied to the expected arguments in the expected order.\n\
- \ expected 1st applied: \"A\"\n\
- \ but got 1st applied: \"B\"\n\
- \ expected 2nd applied: \"B\"\n\
- \ but got 2nd applied: \"C\"\n\
- \ expected 3rd applied: \"C\"\n\
- \ but got 3rd applied: \"A\""
- m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e
-
- it "verify sequence (count mismatch)" do
- m <- createMock $ any |> True
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "C"
- let e =
- "function was not applied to the expected arguments in the expected order (count mismatch).\n\
- \ expected: 3\n\
- \ but got: 2"
- m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e
-
- it "verify partially sequence" do
- m <- createMock $ any |> True
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "A"
- let e =
- "function was not applied to the expected arguments in the expected order.\n\
- \ expected order:\n\
- \ \"A\"\n\
- \ \"C\"\n\
- \ but got:\n\
- \ \"B\"\n\
- \ \"A\""
- m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e
-
- it "verify partially sequence (count mismatch)" do
- m <- createMock $ any |> False
- evaluate $ stubFn m "B"
- let e =
- "function was not applied to the expected arguments in the expected order (count mismatch).\n\
- \ expected: 2\n\
- \ but got: 1"
- m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e
+ f <-
+ mock $ do
+ onCase $ "aaa" ~> (100 :: Int) ~> pure @IO True
+ onCase $ "bbb" ~> (200 :: Int) ~> pure @IO False
- it "verify applied anything" do
- m <- createMock $ "X" |> True
- shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function"
+ f "aaa" 200
+ `shouldThrow` errorContains "expected one of the following:"
describe "named mock" do
describe "aply" do
it "simple mock" do
- m <- createNamedMock "mock function" $ "a" |> pure @IO ()
- let e =
- "function `mock function` was not applied to the expected arguments.\n\
- \ expected: \"a\"\n\
- \ but got: \"b\""
- stubFn m "b" `shouldThrow` errorCall e
+ f <- mock (label "mock function") $ "a" ~> pure @IO ()
+ f "b" `shouldThrow` errorContains "expected: \"a\"\n but got: \"b\"\n ^^"
it "multi mock" do
- m <-
- createNamedMock
- "mock function"
+ f <-
+ mock (label "mock function")
do
- onCase $ "aaa" |> True |> pure @IO True
- onCase $ "bbb" |> False |> pure @IO False
- let e =
- "function `mock function` was not applied to the expected arguments.\n\
- \ expected one of the following:\n\
- \ \"aaa\",True\n\
- \ \"bbb\",False\n\
- \ but got:\n\
- \ \"aaa\",False"
- stubFn m "aaa" False `shouldThrow` errorCall e
-
- describe "verify" do
- it "simple mock verify" do
- m <- createNamedMock "mock function" $ any |> pure @IO ()
- evaluate $ stubFn m "A"
- let e =
- "function `mock function` was not applied to the expected arguments.\n\
- \ expected: \"X\"\n\
- \ but got: \"A\""
- m `shouldApplyTo` "X" `shouldThrow` errorCall e
-
- it "count" do
- m <- createNamedMock "mock function" $ any |> pure @IO ()
- evaluate $ stubFn m "A"
- let e =
- "function `mock function` was not applied the expected number of times to the expected arguments.\n\
- \ expected: 2\n\
- \ but got: 1"
- m `shouldApplyTimes` (2 :: Int) `to` "A" `shouldThrow` errorCall e
-
- it "verify sequence" do
- m <- createNamedMock "mock function" $ any |> pure @IO ()
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "C"
- evaluate $ stubFn m "A"
- let e =
- "function `mock function` was not applied to the expected arguments in the expected order.\n\
- \ expected 1st applied: \"A\"\n\
- \ but got 1st applied: \"B\"\n\
- \ expected 2nd applied: \"B\"\n\
- \ but got 2nd applied: \"C\"\n\
- \ expected 3rd applied: \"C\"\n\
- \ but got 3rd applied: \"A\""
- m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e
-
- it "verify sequence (count mismatch)" do
- m <- createNamedMock "createStubFnc" $ any |> pure @IO ()
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "C"
- let e =
- "function `createStubFnc` was not applied to the expected arguments in the expected order (count mismatch).\n\
- \ expected: 3\n\
- \ but got: 2"
- m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e
-
- it "verify partially sequence" do
- m <- createNamedMock "mock function" $ any |> pure @IO ()
- evaluate $ stubFn m "B"
- evaluate $ stubFn m "A"
- let e =
- "function `mock function` was not applied to the expected arguments in the expected order.\n\
- \ expected order:\n\
- \ \"A\"\n\
- \ \"C\"\n\
- \ but got:\n\
- \ \"B\"\n\
- \ \"A\""
- m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e
-
- it "verify partially sequence (count mismatch)" do
- m <- createNamedMock "createStubFnc" $ any |> pure @IO ()
- evaluate $ stubFn m "B"
- let e =
- "function `createStubFnc` was not applied to the expected arguments in the expected order (count mismatch).\n\
- \ expected: 2\n\
- \ but got: 1"
- m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e
-
- it "verify applied anything" do
- m <- createNamedMock "mock" $ "X" |> True
- shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function `mock`"
+ onCase $ "aaa" ~> True ~> pure @IO True
+ onCase $ "bbb" ~> False ~> pure @IO False
+ evaluate (f "aaa" False) `shouldThrow` errorContains "expected one of the following:"
describe "use expectation" do
it "expectByExpr" do
- f <- createStubFn $ $(expectByExpr [|\x -> x == "y" || x == "z"|]) |> True
+ f <- mock $ $(expectByExpr [|\x -> x == "y" || x == "z"|]) ~> True
f "y" `shouldBe` True
describe "repeatable" do
it "arity = 1" do
- f <- createStubFn $ do
- onCase $ "a" |> True
- onCase $ "b" |> False
- onCase $ "a" |> False
- onCase $ "b" |> True
+ f <- mock $ do
+ onCase $ "a" ~> True
+ onCase $ "b" ~> False
+ onCase $ "a" ~> False
+ onCase $ "b" ~> True
v1 <- evaluate $ f "a"
v2 <- evaluate $ f "a"
@@ -829,11 +157,11 @@
v4 `shouldBe` True
it "arity = 2" do
- f <- createStubFn $ do
- onCase $ "a" |> "b" |> (0 :: Int)
- onCase $ "a" |> "c" |> (1 :: Int)
- onCase $ "a" |> "b" |> (2 :: Int)
- onCase $ "a" |> "c" |> (3 :: Int)
+ f <- mock $ do
+ onCase $ "a" ~> "b" ~> (0 :: Int)
+ onCase $ "a" ~> "c" ~> (1 :: Int)
+ onCase $ "a" ~> "b" ~> (2 :: Int)
+ onCase $ "a" ~> "c" ~> (3 :: Int)
v1 <- evaluate $ f "a" "b"
v2 <- evaluate $ f "a" "b"
@@ -847,61 +175,29 @@
v5 `shouldBe` (2 :: Int)
describe "constant" 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
-
- it "createConstantMock (error message)" do
- m <- createConstantMock "foo"
- shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function"
-
- it "createNamedConstantMock (error message)" do
- m <- createNamedConstantMock "constant" "foo"
- shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function `constant`"
+ it "mock" do
+ f <- mock "foo"
+ f `shouldBe` "foo"
+
+ it "createNamedMockFn" do
+ f <- mock (label "const") "foo"
+ f `shouldBe` "foo"
it "verify constant IO mock" do
- m <- createMock $ pure @IO "foo"
- stubFn m `shouldReturn` "foo"
- stubFn m `shouldReturn` "foo"
- stubFn m `shouldReturn` "foo"
- m `shouldApplyTimesToAnything` 3
+ f <- mock $ pure @IO "foo"
+ f `shouldReturn` "foo"
+ f `shouldReturn` "foo"
+ f `shouldReturn` "foo"
it "verify constant multi IO mock" do
- m <- createMock $ do
+ f <- mock $ do
onCase $ pure @IO "foo"
onCase $ pure @IO "bar"
onCase $ pure @IO "baz"
- stubFn m `shouldReturn` "foo"
- stubFn m `shouldReturn` "bar"
- stubFn m `shouldReturn` "baz"
- m `shouldApplyTimesToAnything` 3
-
-data Fixture mock r = Fixture
- { name :: String,
- create :: IO mock,
- apply :: mock -> r,
- applyFailed :: Maybe (mock -> r),
- expected :: r,
- verifyApply :: mock -> IO (),
- verifyApplyAny :: mock -> IO (),
- verifyApplyFailed :: mock -> IO (),
- verifyApplyCount :: mock -> Int -> IO ()
- }
-
-data VerifyOrderFixture mock r = VerifyOrderFixture
- { name :: String,
- create :: IO mock,
- apply :: mock -> IO r,
- verifyApply :: mock -> IO (),
- verifyApplyFailed :: mock -> IO ()
- }
+ f `shouldReturn` "foo"
+ f `shouldReturn` "bar"
+ f `shouldReturn` "baz"
class Eval a where
evaluate :: a -> IO a
@@ -914,57 +210,9 @@
instance {-# OVERLAPPABLE #-} Eval a where
evaluate = E.evaluate
--- mock test template
-mockTest :: (Eq r, Show r, Eval r) => Fixture mock r -> SpecWith (Arg Expectation)
-mockTest f = describe f.name do
- it "Expected argument is applied, the expected value is returned." do
- m <- f.create
- f.apply m `shouldBe` f.expected
-
- it "Unexpected argument is applied, an exception is thrown." do
- f.applyFailed & maybe mempty \func -> do
- m <- f.create
- evaluate (func m) `shouldThrow` anyErrorCall
-
- it "Expected arguments are applied, the verification succeeds." do
- m <- f.create
- evaluate $ f.apply m
- f.verifyApply m
-
- it "Unexpected arguments are applied, the verification fails." do
- m <- f.create
- evaluate $ f.apply m
- f.verifyApplyFailed m `shouldThrow` anyErrorCall
-
- it "The number of times a function has been applied can be verification (0 times)." do
- m <- f.create
- f.verifyApplyCount m 0
-
- it "The number of times a function has been applied can be verification (3 times)." do
- m <- f.create
- evaluate $ f.apply m
- evaluate $ f.apply m
- evaluate $ f.apply m
- f.verifyApplyCount m 3
-
- it "Fails to verification the number of times it has been applied, an exception is thrown." do
- m <- f.create
- evaluate $ f.apply m
- f.verifyApplyCount m 3 `shouldThrow` anyErrorCall
-
- it "verify any" do
- m <- f.create
- evaluate $ f.apply m
- f.verifyApplyAny m
-
-mockOrderTest :: VerifyOrderFixture mock r -> SpecWith (Arg Expectation)
-mockOrderTest f = describe f.name do
- it "If the functions are applied in the expected order, the verification succeeds." do
- m <- f.create
- f.apply m
- f.verifyApply m
+errorContains :: String -> Selector E.ErrorCall
+errorContains sub (E.ErrorCall msg) = sub `isInfixOf` msg
- it "If the functions are not applied in the expected order, verification fails." do
- m <- f.create
- f.apply m
- f.verifyApplyFailed m `shouldThrow` anyErrorCall
+data NoEq = NoEq String deriving (Show)
+data NoShow = NoShow String deriving (Eq)
+data NoEqNoShow = NoEqNoShow String
diff --git a/test/Test/MockCat/MockTSpec.hs b/test/Test/MockCat/MockTSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/MockTSpec.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+module Test.MockCat.MockTSpec (spec) where
+
+import Control.Monad.IO.Class (liftIO)
+import GHC.IO (evaluate)
+import Test.Hspec
+import Test.MockCat
+import Prelude hiding (any)
+
+spec :: Spec
+spec = describe "MockT + expects integration" do
+ it "allows expects inside runMockT" do
+ runMockT @IO do
+ f <-
+ mock (any @String ~> True)
+ `expects` do
+ called once `with` "foo"
+ _ <- liftIO $ evaluate (f "foo")
+ pure ()
+
diff --git a/test/Test/MockCat/ParamSpec.hs b/test/Test/MockCat/ParamSpec.hs
--- a/test/Test/MockCat/ParamSpec.hs
+++ b/test/Test/MockCat/ParamSpec.hs
@@ -13,23 +13,23 @@
spec :: Spec
spec = do
describe "Param" do
- describe "|>" do
- it "a |> b" do
- True |> False `shouldBe` param True :> param False
- it "Param a |> b" do
- param True |> False `shouldBe` param True :> param False
- it "a |> Param b" do
- True |> param False `shouldBe` param True :> param False
- it "Param a |> Param b" do
- param True |> param False `shouldBe` param True :> param False
- it "a |> b |> c" do
- True |> False |> True `shouldBe` param True :> (param False :> param True)
- it "Param a |> b |> c" do
- param True |> False |> True `shouldBe` param True :> (param False :> param True)
+ describe "~>" do
+ it "a ~> b" do
+ (True ~> False) `shouldBe` param True :> param False
+ it "Param a ~> b" do
+ (param True ~> False) `shouldBe` param True :> param False
+ it "a ~> Param b" do
+ (True ~> param False) `shouldBe` param True :> param False
+ it "Param a ~> Param b" do
+ (param True ~> param False) `shouldBe` param True :> param False
+ it "a ~> b ~> c" do
+ (True ~> False ~> True) `shouldBe` param True :> (param False :> param True)
+ it "Param a ~> b ~> c" do
+ (param True ~> False ~> True) `shouldBe` param True :> (param False :> param True)
describe "Show" do
it "String" do
- show (param "X") `shouldBe` "X"
+ show (param "X") `shouldBe` "\"X\""
it "Integer" do
show (param 100) `shouldBe` "100"
it "Bool" do
@@ -40,6 +40,10 @@
param 10 == param 10 `shouldBe` True
it "param (not eq)" do
param 10 == param 11 `shouldBe` False
+ it "any (non-Eq type)" do
+ (P.any :: Param NoEq) == (P.any :: Param NoEq) `shouldBe` True
+ it "ValueWrapper (non-Eq type) - always False" do
+ wrap NoEq == wrap NoEq `shouldBe` False
describe "Returns True if the expected value condition is met." do
it "any" do
@@ -49,28 +53,32 @@
it "any" do
show (P.any :: Param Int) `shouldBe` "any"
+ -- Type inference works for numeric literals and operators without explicit annotations.
it "expect" do
show (expect (> 4) "> 4") `shouldBe` "> 4"
it "expect_" do
show (expect_ (> 4)) `shouldBe` "[some condition]"
-
+
+ it "param 10" do
+ show (param 10) `shouldBe` "10"
+
describe "show expectation by Exp" do
it "(> 3)" do
- show $(expectByExpr [|(> 3)|]) `shouldBe` "(> 3)"
+ show $(expectByExpr [|(> (3 :: Int))|]) `shouldBe` "(> 3)"
it "lambda" do
- show $(expectByExpr [|\x -> x == 3 || x == 5|]) `shouldBe` "(\\x -> ((x == 3) || (x == 5)))"
-
+ show $(expectByExpr [|\x -> x == (3 :: Int) || x == 5|]) `shouldBe` "(\\x -> ((x == 3) || (x == 5)))"
+
it "use data" do
show $(expectByExpr [|\x -> x == Foo "foo"|]) `shouldBe` "(\\x -> (x == (Foo \"foo\")))"
-
+
describe "ProjectionArgs" do
it "Param a :> Param r" do
projArgs (param 10 :> param "foo") `shouldBe` param 10
it "Param a :> rest" do
projArgs (param 10 :> param "foo" :> param True) `shouldBe` (param 10 :> param "foo")
-
+
describe "ProjectionReturn" do
it "Param a :> Param r" do
projReturn (param 10 :> param "foo") `shouldBe` param "foo"
@@ -78,3 +86,5 @@
projReturn (param 10 :> param "foo" :> param True) `shouldBe` param True
data TestData = Foo String | Bar deriving (Eq, Show)
+
+data NoEq = NoEq deriving (Show)
diff --git a/test/Test/MockCat/PartialMockCommonSpec.hs b/test/Test/MockCat/PartialMockCommonSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/PartialMockCommonSpec.hs
@@ -0,0 +1,302 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Test.MockCat.PartialMockCommonSpec
+ ( spec
+ , PartialMockDeps(..)
+ ) where
+
+import Prelude hiding (readFile, writeFile)
+import Test.Hspec (Spec, it, shouldBe, describe, shouldThrow, Selector)
+import Test.MockCat
+import Test.MockCat.SharedSpecDefs
+import qualified Test.MockCat.Verify as Verify
+import Test.MockCat.Impl ()
+import Control.Monad.IO.Class (MonadIO)
+import Data.Typeable (Typeable)
+import Data.Text (Text, pack)
+import Control.Exception (ErrorCall(..), displayException)
+import Data.List (isInfixOf, find)
+import Control.Monad.Trans.Maybe (MaybeT (..))
+import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.IO.Unlift (withRunInIO)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad (forM)
+import Control.Concurrent.Async (async, wait)
+import Data.Proxy (Proxy(..))
+import GHC.TypeLits (symbolVal, KnownSymbol)
+import Unsafe.Coerce (unsafeCoerce)
+
+
+-- Dependency record to group builders
+data PartialMockDeps = PartialMockDeps
+ { _getInput :: forall r m. (Verify.ResolvableParamsOf r ~ (), MonadIO m, Typeable r, Show r, Eq r) => r -> MockT m r
+ , _getBy :: forall params. ( MockBuilder params (String -> IO Int) (Param String)
+ , Typeable (String -> IO Int)
+ , Verify.ResolvableParamsOf (String -> IO Int) ~ Param String
+ ) => params -> MockT IO (String -> IO Int)
+ , _echo :: forall params. ( MockBuilder params (String -> IO ()) (Param String)
+ , Typeable (String -> IO ())
+ , Verify.ResolvableParamsOf (String -> IO ()) ~ Param String
+ ) => params -> MockT IO (String -> IO ())
+ , _writeFile :: forall params m. ( MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text)
+ , MonadIO m
+ , Typeable (FilePath -> Text -> ())
+ , Verify.ResolvableParamsOf (FilePath -> Text -> ()) ~ (Param FilePath :> Param Text)
+ ) => params -> MockT m (FilePath -> Text -> ())
+ , _findIds :: forall r m. (Verify.ResolvableParamsOf r ~ (), MonadIO m, Typeable r, Show r, Eq r) => r -> MockT m r
+ , _findById :: forall params m. ( MockBuilder params (Int -> String) (Param Int)
+ , MonadIO m
+ , Typeable (Int -> String)
+ , Verify.ResolvableParamsOf (Int -> String) ~ Param Int
+ ) => params -> MockT m (Int -> String)
+ , _findByIdNI :: forall params. ( MockBuilder params (Int -> IO String) (Param Int)
+ , Typeable (Int -> IO String)
+ , Verify.ResolvableParamsOf (Int -> IO String) ~ Param Int
+ ) => params -> MockT IO (Int -> IO String)
+ }
+
+-- Main Entry Point
+spec ::
+ ( UserInputGetter (MockT IO)
+ , ExplicitlyReturnMonadicValuesPartialTest (MockT IO)
+ , Finder Int String (MockT IO)
+ , Verify.ResolvableParamsOf (Int -> String) ~ Param Int
+ ) =>
+ PartialMockDeps ->
+ MockT IO () ->
+ Spec
+spec deps programAction = do
+ specBasicPartialMocking deps programAction
+ specExplicitMonadicReturns deps
+ specFinderBehavior deps
+ specVerificationFailures deps
+
+-- Group: Basic Partial Mocking (UserInput, FileOperation)
+specBasicPartialMocking ::
+ ( UserInputGetter (MockT IO)
+ ) =>
+ PartialMockDeps ->
+ MockT IO () ->
+ Spec
+specBasicPartialMocking (PartialMockDeps { _getInput, _writeFile }) programAction = describe "Basic Partial Mocking" do
+ describe "UserInputGetter" do
+ it "Get user input (has input)" do
+ result <- runMockT do
+ _ <- _getInput ("value" :: String)
+ i <- getInput
+ toUserInput i
+ result `shouldBe` Just (UserInput "value")
+
+ it "Get user input (no input)" do
+ result <- runMockT do
+ _ <- _getInput ("" :: String)
+ i <- getInput
+ toUserInput i
+ result `shouldBe` Nothing
+
+ describe "FileOperation" do
+ it "IO" do
+ result <- runMockT do
+ _ <- _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ())
+ pure ()
+ result `shouldBe` ()
+
+ it "MaybeT" do
+ result <- runMaybeT do
+ runMockT do
+ _ <- _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ())
+ pure ()
+ result `shouldBe` Just ()
+
+ it "ReaderT" do
+ result <- flip runReaderT "foo" do
+ runMockT do
+ _ <- _writeFile (("output.text" :: FilePath) ~> pack ("ReaderT content foo" :: String) ~> ())
+ pure ()
+ result `shouldBe` ()
+
+ describe "Handwritten Partial Mock Test" do
+ it "IO" do
+ result <- runMockT do
+ _ <- _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ())
+ programAction
+ result `shouldBe` ()
+
+ it "MaybeT" do
+ result <- runMaybeT do
+ runMockT do
+ _ <- _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ())
+ pure ()
+ result `shouldBe` Just ()
+
+
+-- Group: Explicit Monadic Returns
+specExplicitMonadicReturns ::
+ ( ExplicitlyReturnMonadicValuesPartialTest (MockT IO)
+ ) =>
+ PartialMockDeps ->
+ Spec
+specExplicitMonadicReturns (PartialMockDeps { _echo, _getBy }) = describe "Explicit Monadic Returns" do
+ it "Return monadic value test" do
+ result <- runMockT $ do
+ _ <- _echo $ ("3" :: String) ~> pure @IO ()
+ v <- getByExplicitPartial "abc"
+ echoExplicitPartial (show v)
+ result `shouldBe` ()
+
+ it "Override getBy via stub" do
+ result <- runMockT do
+ _ <- _getBy $ ("abc" :: String) ~> pure @IO (123 :: Int)
+ getByExplicitPartial "abc"
+ result `shouldBe` 123
+
+
+-- Group: Finder Behavior (Multi-param type class)
+specFinderBehavior ::
+ ( Finder Int String (MockT IO)
+ , Verify.ResolvableParamsOf (Int -> String) ~ Param Int
+ ) =>
+ PartialMockDeps ->
+ Spec
+specFinderBehavior (PartialMockDeps { _findIds, _findById, _findByIdNI }) = describe "Finder Behavior (MultiParamTypeClass)" do
+ it "all real function" do
+ values <- runMockT findValue
+ values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]
+
+ it "partial findIds" do
+ values <- runMockT $ do
+ _ <- _findIds ([1 :: Int, 2] :: [Int])
+ findValue @Int @String
+ values `shouldBe` ["{id: 1}", "{id: 2}"]
+
+ it "partial findById" do
+ values <- runMockT $ do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "id1"
+ onCase $ (2 :: Int) ~> "id2"
+ onCase $ (3 :: Int) ~> "id3"
+ findValue @Int @String
+ values `shouldBe` ["id1", "id2", "id3"]
+
+ it "Concurrent execution correctly calls and collects results from mocks (async)" do
+ result <- runMockT do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "id1"
+ onCase $ (2 :: Int) ~> "id2"
+ withRunInIO $ \runInIO -> do
+ a1 <- async $ runInIO (findById 1)
+ a2 <- async $ runInIO (findById 2)
+ r1 <- wait a1
+ r2 <- wait a2
+ pure [r1, r2]
+ result `shouldBe` ["id1", "id2"]
+
+ describe "Edge cases" do
+ it "partial mock that doesn't cover all ids causes argument error" do
+ let argError :: Selector ErrorCall
+ argError err = "was not called with the expected arguments" `isInfixOf` displayException (err :: ErrorCall)
+ (runMockT @IO do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "id1"
+ -- calling findValue will hit findById for id 2 which is not covered by mock
+ findValue @Int @String) `shouldThrow` argError
+
+ it "duplicate cases prefer first" do
+ result <- runMockT $ do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "first"
+ onCase $ (1 :: Int) ~> "second"
+ findById 1
+ result `shouldBe` "first"
+
+ it "findValue returns empty when findIds returns empty list" do
+ result <- runMockT $ do
+ _ <- _findIds ([] :: [Int])
+ findValue @Int @String
+ result `shouldBe` []
+
+ describe "Named error messages" do
+ it "error message contains mock name when unexpected arg is used" do
+ let nameMsg = "function `_findById` was not called with the expected arguments"
+ (runMockT @IO do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "id1"
+ -- call with unexpected arg to trigger message
+ findById (2 :: Int)) `shouldThrow` (\(err :: ErrorCall) -> nameMsg `isInfixOf` displayException err)
+
+ describe "Mixed fallback" do
+ it "when a per-id mock exists, unexpected args produce an argument error (no fallback)" do
+ let argError :: Selector ErrorCall
+ argError err = "was not called with the expected arguments" `isInfixOf` displayException (err :: ErrorCall)
+ (runMockT @IO do
+ _ <- _findById $ do
+ onCase $ (1 :: Int) ~> "id1"
+ -- calling findValue will hit findById for id 2 which is not covered by mock,
+ -- and because a mock function exists for _findById, it will error rather than fallback.
+ findValue @Int @String) `shouldThrow` argError
+
+ describe "Implicit monadic return options" do
+ it "partial findById with explicit monadic returns (implicitMonadicReturn=False)" do
+ result <- runMockT $ do
+ _ <- _findByIdNI $ do
+ onCase $ (1 :: Int) ~> pure @IO "id1"
+ onCase $ (2 :: Int) ~> pure @IO "id2"
+ onCase $ (3 :: Int) ~> pure @IO "id3"
+ -- manually call the NI variant (avoid needing FinderNoImplicit MockT instance)
+ defs <- getDefinitions
+ case findParam (Proxy :: Proxy "_findByIdNI") defs of
+ Just mockFn -> do
+ ids <- lift (findIds :: IO [Int])
+ forM ids (lift . mockFn)
+ Nothing -> do
+ ids <- lift (findIds :: IO [Int])
+ forM ids (lift . findById)
+ result `shouldBe` ["id1", "id2", "id3"]
+
+
+-- Group: Verification Failures
+specVerificationFailures ::
+ PartialMockDeps ->
+ Spec
+specVerificationFailures (PartialMockDeps { _findIds, _findById }) = describe "Verification Failures" do
+ let missingCall name err =
+ let needle = "function `" <> name <> "` was not called the expected number of times."
+ in needle `isInfixOf` displayException (err :: ErrorCall)
+
+ it "fails when _findIds is defined but findIds is never called" do
+ (runMockT @IO do
+ _ <- _findIds ([1 :: Int, 2] :: [Int])
+ `expects` do
+ called once
+ -- findIds is never called
+ pure ()) `shouldThrow` missingCall "_findIds"
+
+ it "fails when _findById is defined but findById is never called" do
+ (runMockT @IO do
+ let casesDef = do
+ onCase $ (1 :: Int) ~> "id1"
+ onCase $ (2 :: Int) ~> "id2"
+ onCase $ (3 :: Int) ~> "id3"
+ _ <- _findById casesDef `expects` do
+ called once
+ -- findById is never called
+ pure ()) `shouldThrow` missingCall "_findById"
+
+
+-- Helper to find a definition by symbol and coerce the function
+findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a
+findParam pa definitions = do
+ let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions
+ fmap (\(Definition _ mockFunction _) -> unsafeCoerce mockFunction) definition
diff --git a/test/Test/MockCat/PartialMockSpec.hs b/test/Test/MockCat/PartialMockSpec.hs
--- a/test/Test/MockCat/PartialMockSpec.hs
+++ b/test/Test/MockCat/PartialMockSpec.hs
@@ -4,119 +4,274 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
module Test.MockCat.PartialMockSpec (spec) where
-import Data.Text (Text, pack)
-import Test.Hspec (Spec, it, shouldBe, describe)
+import Data.Text (Text)
+import Test.Hspec (Spec)
+import Data.List (find)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Class (lift)
import Test.MockCat
-import Test.MockCat.Definition
+import Test.MockCat.SharedSpecDefs
+import qualified Test.MockCat.PartialMockCommonSpec as PartialMockCommonSpec
import Test.MockCat.Impl ()
import Prelude hiding (readFile, writeFile)
import Data.Data
-import Data.List (find)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Unsafe.Coerce (unsafeCoerce)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Maybe (MaybeT (..))
-import Control.Monad.Trans.Reader hiding (ask)
+import qualified Test.MockCat.Verify as Verify
+
+ensureVerifiable ::
+ ( MonadIO m
+ , Verify.ResolvableMock target
+ ) =>
+ target ->
+ m ()
+ensureVerifiable target =
+ liftIO $
+ Verify.resolveForVerification target >>= \case
+ Just _ -> pure ()
+ Nothing -> Verify.verificationFailure
+
+
+instance UserInputGetter IO where
+ getInput = getLine
+ toUserInput "" = pure Nothing
+ toUserInput a = pure . Just . UserInput $ a
+
+instance ExplicitlyReturnMonadicValuesPartialTest IO where
+ echoExplicitPartial _ = pure ()
+ getByExplicitPartial s = pure (length s)
+
+
instance (MonadIO m, FileOperation m) => FileOperation (MockT m) where
readFile path = MockT do
defs <- getDefinitions
case findParam (Proxy :: Proxy "readFile") defs of
- Just mock -> do
- let !result = stubFn mock path
+ Just mockFn -> do
+ let !result = mockFn path
pure result
Nothing -> lift $ readFile path
writeFile path content = MockT do
defs <- getDefinitions
case findParam (Proxy :: Proxy "writeFile") defs of
- Just mock -> do
- let !result = stubFn mock path content
+ Just mockFn -> do
+ let !result = mockFn path content
pure result
Nothing -> lift $ writeFile path content
-_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), MonadIO m) => params -> MockT m ()
+instance (MonadIO m, UserInputGetter m) => UserInputGetter (MockT m) where
+ getInput = MockT do
+ defs <- getDefinitions
+ case findParam (Proxy :: Proxy "getInput") defs of
+ Just mockFn -> do
+ let !result = mockFn
+ pure result
+ Nothing -> lift getInput
+
+ toUserInput str = MockT do
+ defs <- getDefinitions
+ case findParam (Proxy :: Proxy "toUserInput") defs of
+ Just mockFn -> do
+ let !result = mockFn str
+ lift result
+ Nothing -> lift $ toUserInput str
+
+instance
+ ( MonadIO m
+ , ExplicitlyReturnMonadicValuesPartialTest m
+ ) =>
+ ExplicitlyReturnMonadicValuesPartialTest (MockT m) where
+ getByExplicitPartial label = MockT do
+ defs <- getDefinitions
+ case findParam (Proxy :: Proxy "getBy") defs of
+ Just mockFn -> do
+ let !result = mockFn label
+ lift result
+ Nothing -> lift $ getByExplicitPartial label
+
+ echoExplicitPartial label = MockT do
+ defs <- getDefinitions
+ case findParam (Proxy :: Proxy "echo") defs of
+ Just mockFn -> do
+ let !result = mockFn label
+ lift result
+ Nothing -> lift $ echoExplicitPartial label
+
+_readFile ::
+ ( MockBuilder params (FilePath -> Text) (Param FilePath)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (FilePath -> Text)
_readFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "readFile" p
- addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "readFile" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance NoVerification)
+ pure mockInstance
-_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), MonadIO m) => params -> MockT m ()
+_writeFile ::
+ ( MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (FilePath -> Text -> ())
_writeFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "writeFile" p
- addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "writeFile" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification)
+ pure mockInstance
+_getInput ::
+ ( Verify.ResolvableParamsOf r ~ ()
+ , MonadIO m
+ , Typeable r
+ , Show r
+ , Eq r
+ ) =>
+ r ->
+ MockT m r
+_getInput value = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "getInput" (Head :> param value)
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "getInput") mockInstance NoVerification)
+ pure mockInstance
+
+_toUserInput ::
+ ( MockBuilder params (String -> m (Maybe UserInput)) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m (Maybe UserInput)) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m (Maybe UserInput))
+_toUserInput p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "toUserInput" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "toUserInput") mockInstance NoVerification)
+ pure mockInstance
+
+_getByPartial ::
+ ( MockBuilder params (String -> IO Int) (Param String)
+ ) =>
+ params ->
+ MockT IO (String -> IO Int)
+_getByPartial p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "getBy" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "getBy") mockInstance NoVerification)
+ pure mockInstance
+
+_echoPartial ::
+ ( MockBuilder params (String -> IO ()) (Param String)
+ ) =>
+ params ->
+ MockT IO (String -> IO ())
+_echoPartial p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "echo" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "echo") mockInstance NoVerification)
+ pure mockInstance
+
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
+ fmap (\(Definition _ mockFunction _) -> unsafeCoerce mockFunction) definition
instance (MonadIO m, Finder a b m) => Finder a b (MockT m) where
- findIds :: (Finder a b m) => MockT m [a]
+
findIds = MockT do
defs <- getDefinitions
case findParam (Proxy :: Proxy "_findIds") defs of
- Just mock -> do
- let !result = stubFn mock
+ Just mockFn -> do
+ let !result = mockFn
pure result
Nothing -> lift findIds
- findById :: (Finder a b m) => a -> MockT m b
+
findById id = MockT do
defs <- getDefinitions
case findParam (Proxy :: Proxy "_findById") defs of
- Just mock -> do
- let !result = stubFn mock id
+ Just mockFn -> do
+ let !result = mockFn id
pure result
Nothing -> lift $ findById id
-_findIds :: MonadIO m => r -> MockT m ()
-_findIds p = MockT $ do
- mockInstance <- liftIO $ createNamedConstantMock "_findIds" p
- addDefinition (Definition (Proxy :: Proxy "_findIds") mockInstance shouldApplyToAnything)
-spec :: Spec
-spec = do
- describe "Partial Mock Test" do
- it "MaybeT" do
- result <- runMaybeT do
- runMockT do
- _writeFile $ "output.text" |> pack "MaybeT content" |> ()
- program "input.txt" "output.text"
- result `shouldBe` Just ()
-
- it "IO" do
- result <- runMockT do
- _writeFile $ "output.text" |> pack "IO content" |> ()
- program "input.txt" "output.text"
-
- result `shouldBe` ()
+_findIds ::
+ ( Verify.ResolvableParamsOf r ~ ()
+ , MonadIO m
+ , Typeable r
+ , Show r
+ , Eq r
+ ) =>
+ r ->
+ MockT m r
+_findIds p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_findIds" (Head :> param p)
+ ensureVerifiable mockInstance
+ addDefinition
+ ( Definition
+ (Proxy :: Proxy "_findIds")
+ mockInstance
+ NoVerification
+ )
+ pure mockInstance
- it "ReaderT" do
- result <- flip runReaderT "foo" do
- runMockT do
- _writeFile $ "output.text" |> pack "ReaderT content foo" |> ()
- program "input.txt" "output.text"
+_findById ::
+ ( MockBuilder params (Int -> String) (Param Int)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (Int -> String)
+_findById p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_findById" p
+ ensureVerifiable mockInstance
+ addDefinition
+ ( Definition
+ (Proxy :: Proxy "_findById")
+ mockInstance
+ NoVerification
+ )
+ pure mockInstance
- result `shouldBe` ()
-
- describe "MultiParamType" do
- it "all real function" do
- values <- runMockT findValue
- values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]
+_findByIdNI ::
+ ( MockBuilder params (Int -> IO String) (Param Int)
+ ) =>
+ params ->
+ MockT IO (Int -> IO String)
+_findByIdNI p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_findByIdNI" p
+ ensureVerifiable mockInstance
+ addDefinition
+ ( Definition
+ (Proxy :: Proxy "_findByIdNI")
+ mockInstance
+ NoVerification
+ )
+ pure mockInstance
- it "partial 1" do
- values <- runMockT do
- _findIds [1 :: Int, 2]
- findValue
- values `shouldBe` ["{id: 1}", "{id: 2}"]
+spec :: Spec
+spec = PartialMockCommonSpec.spec deps (program "input.txt" "output.text")
+ where
+ deps = PartialMockCommonSpec.PartialMockDeps
+ { PartialMockCommonSpec._getInput = _getInput
+ , PartialMockCommonSpec._getBy = _getByPartial
+ , PartialMockCommonSpec._echo = _echoPartial
+ , PartialMockCommonSpec._writeFile = _writeFile
+ , PartialMockCommonSpec._findIds = _findIds
+ , PartialMockCommonSpec._findById = _findById
+ , PartialMockCommonSpec._findByIdNI = _findByIdNI
+ }
diff --git a/test/Test/MockCat/PartialMockTHSpec.hs b/test/Test/MockCat/PartialMockTHSpec.hs
--- a/test/Test/MockCat/PartialMockTHSpec.hs
+++ b/test/Test/MockCat/PartialMockTHSpec.hs
@@ -1,124 +1,54 @@
{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
module Test.MockCat.PartialMockTHSpec (spec) where
-import Data.Text (pack)
-import Test.Hspec (Spec, it, shouldBe, describe)
import Test.MockCat
-
-import Test.MockCat.Definition
+import qualified Test.MockCat.PartialMockCommonSpec as PartialMockCommonSpec
+import Test.MockCat.SharedSpecDefs
import Test.MockCat.Impl ()
import Prelude hiding (readFile, writeFile)
-import Control.Monad.Trans.Maybe (MaybeT (..))
-import Control.Monad.Reader (ReaderT(..))
-
-newtype 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
+import Test.Hspec (Spec)
instance UserInputGetter IO where
getInput = getLine
toUserInput "" = pure Nothing
toUserInput a = (pure . Just . UserInput) a
-class Monad m => ExplicitlyReturnMonadicValuesPartialTest m where
- echo :: String -> m ()
- getBy :: String -> m Int
-
instance ExplicitlyReturnMonadicValuesPartialTest IO where
- echo _ = pure ()
- getBy s = pure $ length s
-
-echoProgram :: ExplicitlyReturnMonadicValuesPartialTest m => String -> m ()
-echoProgram s = do
- v <- getBy s
- echo $ show v
+ echoExplicitPartial _ = pure ()
+ getByExplicitPartial s = pure $ length s
-makePartialMock [t|UserInputGetter|]
-makePartialMock [t|Finder|]
-makePartialMock [t|FileOperation|]
-makePartialMockWithOptions [t|ExplicitlyReturnMonadicValuesPartialTest|] options { implicitMonadicReturn = False }
-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
-
- describe "Partial Mock Test (TH)" do
- it "MaybeT" do
- result <- runMaybeT do
- runMockT do
- _writeFile $ "output.text" |> pack "MaybeT content" |> ()
- program "input.txt" "output.text"
-
- result `shouldBe` Just ()
-
- it "IO" do
- result <- runMockT do
- _writeFile $ "output.text" |> pack "IO content" |> ()
- program "input.txt" "output.text"
-
- result `shouldBe` ()
-
- it "ReaderT" do
- result <- flip runReaderT "foo" do
- runMockT do
- _writeFile $ "output.text" |> pack "ReaderT content foo" |> ()
- program "input.txt" "output.text"
-
- result `shouldBe` ()
-
- describe "MultiParamType" do
- it "all real function" do
- values <- runMockT findValue
- values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]
-
- it "partial findIds" do
- values <- runMockT do
- _findIds [1 :: Int, 2]
- findValue
- values `shouldBe` ["{id: 1}", "{id: 2}"]
-
- it "partial findById" do
- values <- runMockT do
- _findById $ do
- onCase $ (1 :: Int) |> "id1"
- onCase $ (2 :: Int) |> "id2"
- onCase $ (3 :: Int) |> "id3"
- findValue
- values `shouldBe` ["id1", "id2", "id3"]
-
- it "Return monadic value test" do
- result <- runMockT do
- _echo $ "3" |> pure @IO ()
- echoProgram "abc"
+makeAutoLiftPartialMock [t|UserInputGetter|]
+makeAutoLiftPartialMock [t|Finder|]
+makeAutoLiftPartialMock [t|FileOperation|]
+makePartialMock [t|ExplicitlyReturnMonadicValuesPartialTest|]
+makePartialMock [t|FinderNoImplicit|]
- result `shouldBe` ()
+spec :: Spec
+spec = PartialMockCommonSpec.spec deps (program "input.txt" "output.text")
+ where
+ deps = PartialMockCommonSpec.PartialMockDeps
+ { PartialMockCommonSpec._getInput = Test.MockCat.PartialMockTHSpec._getInput
+ , PartialMockCommonSpec._getBy = _getByExplicitPartial
+ , PartialMockCommonSpec._echo = _echoExplicitPartial
+ , PartialMockCommonSpec._writeFile = Test.MockCat.PartialMockTHSpec._writeFile
+ , PartialMockCommonSpec._findIds = Test.MockCat.PartialMockTHSpec._findIds
+ , PartialMockCommonSpec._findById = Test.MockCat.PartialMockTHSpec._findById
+ , PartialMockCommonSpec._findByIdNI = Test.MockCat.PartialMockTHSpec._findByIdNI
+ }
diff --git a/test/Test/MockCat/SharedSpecDefs.hs b/test/Test/MockCat/SharedSpecDefs.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/SharedSpecDefs.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.MockCat.SharedSpecDefs
+ ( FileOperation(..),
+ program,
+ Finder(..),
+ findValue,
+ FinderNoImplicit(..),
+ findValueNI,
+ ApiOperation(..),
+ MonadStateSub(..),
+ MonadStateSub2(..),
+ MonadVar2_1,
+ MonadVar2_1Sub(..),
+ MonadVar2_2,
+ MonadVar2_2Sub(..),
+ MonadVar3_1,
+ MonadVar3_1Sub(..),
+ MonadVar3_2,
+ MonadVar3_2Sub(..),
+ MonadVar3_3,
+ MonadVar3_3Sub(..),
+ MultiApplyTest(..),
+ getValues,
+ ExplicitlyReturnMonadicValuesTest(..),
+ ExplicitlyReturnMonadicValuesPartialTest(..),
+ AssocTypeTest(..),
+ DefaultMethodTest(..),
+ ParamThreeMonad(..),
+ MonadAsync(..),
+ TestClass(..),
+ Teletype(..),
+ UserInput(..),
+ UserInputGetter(..)
+ )
+where
+
+import Prelude hiding (readFile, writeFile)
+import Data.Text (Text)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.State (MonadState)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Data.Kind (Type)
+
+
+class Monad m => FileOperation m where
+ readFile :: FilePath -> m Text
+ writeFile :: FilePath -> Text -> m ()
+
+program ::
+ FileOperation m =>
+ FilePath ->
+ FilePath ->
+ m ()
+program inputPath outputPath = do
+ content <- readFile inputPath
+ writeFile outputPath content
+
+class Monad m => Finder a b m | a -> b, b -> a where
+ findIds :: m [a]
+ findById :: a -> m b
+
+findValue :: Finder a b m => m [b]
+findValue = do
+ ids <- findIds
+ mapM findById ids
+
+class Monad m => ApiOperation m where
+ post :: Text -> m ()
+
+class (Eq s, Show s, MonadState s m) => MonadStateSub s m where
+ fnState :: Maybe s -> m s
+
+class (MonadState String m) => MonadStateSub2 s m where
+ fnState2 :: String -> m ()
+
+class Monad m => MonadVar2_1 m a where
+class MonadVar2_1 m a => MonadVar2_1Sub m a where
+ fn2_1Sub :: String -> m ()
+
+class Monad m => MonadVar2_2 a m where
+class MonadVar2_2 a m => MonadVar2_2Sub a m where
+ fn2_2Sub :: String -> m ()
+
+class MonadIO m => MonadVar3_1 m a b where
+class MonadVar3_1 m a b => MonadVar3_1Sub m a b where
+ fn3_1Sub :: String -> m ()
+
+class MonadIO m => MonadVar3_2 a m b where
+class MonadVar3_2 a m b => MonadVar3_2Sub a m b where
+ fn3_2Sub :: String -> m ()
+
+class MonadIO m => MonadVar3_3 a b m where
+class MonadVar3_3 a b m => MonadVar3_3Sub a b m where
+ fn3_3Sub :: String -> m ()
+
+class Monad m => MultiApplyTest m where
+ getValueBy :: String -> m String
+
+getValues :: MultiApplyTest m => [String] -> m [String]
+getValues = mapM getValueBy
+
+class Monad m => ExplicitlyReturnMonadicValuesTest m where
+ echoExplicit :: String -> m ()
+ getByExplicit :: String -> m Int
+
+class Monad m => ExplicitlyReturnMonadicValuesPartialTest m where
+ echoExplicitPartial :: String -> m ()
+ getByExplicitPartial :: String -> m Int
+
+class Monad m => AssocTypeTest m where
+ type ResultType m :: Type
+ produce :: m (ResultType m)
+
+class Monad m => DefaultMethodTest m where
+ defaultAction :: m Int
+ defaultAction = pure 0
+
+class Monad m => ParamThreeMonad a b m | m -> a, m -> b where
+ fnParam3_1 :: a -> b -> m String
+ fnParam3_2 :: m a
+ fnParam3_3 :: m b
+
+class MonadUnliftIO m => MonadAsync m where
+ mapConcurrently :: Traversable t => (a -> m b) -> t a -> m (t b)
+
+class Monad m => TestClass m where
+ echo :: String -> m ()
+ getBy :: String -> m Int
+
+class Monad m => Teletype m where
+ readTTY :: m String
+ writeTTY :: String -> m ()
+
+newtype UserInput = UserInput String deriving (Show, Eq)
+
+class Monad m => UserInputGetter m where
+ getInput :: m String
+ toUserInput :: String -> m (Maybe UserInput)
+
+-- Duplicate Finder variant without implicit monadic return (for TH tests)
+class Monad m => FinderNoImplicit a b m | a -> b, b -> a where
+ findIdsNI :: m [a]
+ findByIdNI :: a -> m b
+
+findValueNI :: FinderNoImplicit a b m => m [b]
+findValueNI = do
+ ids <- findIdsNI
+ mapM findByIdNI ids
diff --git a/test/Test/MockCat/ShouldBeCalledMockMSpec.hs b/test/Test/MockCat/ShouldBeCalledMockMSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/ShouldBeCalledMockMSpec.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+module Test.MockCat.ShouldBeCalledMockMSpec (spec) where
+
+import Control.Exception (ErrorCall(..), try)
+import Control.Monad (replicateM_, void)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Reader (runReaderT)
+import Test.Hspec
+import Test.MockCat
+import Prelude hiding (any)
+
+spec :: Spec
+spec = describe "shouldBeCalled API (mockM)" $ do
+ describe "Simple verification" do
+ it "records arguments and results" do
+ f <- mockM $ "a" ~> True
+ result <- f "a"
+ result `shouldBe` True
+ f `shouldBeCalled` "a"
+
+ it "fails when called with unexpected argument" do
+ f <- mockM $ "a" ~> True
+ void $ f "a"
+ f `shouldBeCalled` "b" `shouldThrow` anyErrorCall
+
+ it "anything expectation succeeds" do
+ f <- mockM $ any @String ~> True
+ void $ f "x"
+ f `shouldBeCalled` anything
+
+ it "anything expectation fails when never called" do
+ f <- mockM $ any @String ~> True
+ f `shouldBeCalled` anything `shouldThrow` anyErrorCall
+
+ it "never expectation" do
+ f <- mockM $ any @String ~> True
+ f `shouldBeCalled` (never `withArgs` "z")
+ void $ f "a"
+ f `shouldBeCalled` (never `withArgs` "a") `shouldThrow` anyErrorCall
+
+ describe "Count verification" do
+ it "times succeeds" do
+ f <- mockM $ "a" ~> True
+ replicateM_ 3 (void $ f "a")
+ f `shouldBeCalled` (times 3 `withArgs` "a")
+
+ it "times fails" do
+ f <- mockM $ "a" ~> True
+ replicateM_ 2 (void $ f "a")
+ f `shouldBeCalled` (times 3 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "atLeast / atMost" do
+ f <- mockM $ "a" ~> True
+ replicateM_ 3 (void $ f "a")
+ f `shouldBeCalled` (atLeast 2 `withArgs` "a")
+ f `shouldBeCalled` (atMost 3 `withArgs` "a")
+ f `shouldBeCalled` (atMost 2 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "greaterThan / lessThan" do
+ f <- mockM $ "a" ~> True
+ replicateM_ 3 (void $ f "a")
+ f `shouldBeCalled` (greaterThan 2 `withArgs` "a")
+ f `shouldBeCalled` (lessThan 4 `withArgs` "a")
+ f `shouldBeCalled` (lessThan 3 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ describe "Multiple arguments" do
+ it "works with Param combinators" do
+ f <- mockM $ any @String ~> any @String ~> True
+ void $ f "x" "y"
+ f `shouldBeCalled` (any @String ~> any @String)
+
+ it "supports explicit Param values" do
+ f <- mockM $ param "x" ~> param "y" ~> True
+ void $ f "x" "y"
+ f `shouldBeCalled` ("x" ~> "y")
+ f `shouldBeCalled` ("y" ~> "x") `shouldThrow` anyErrorCall
+
+ it "accepts cases blocks" do
+ f <- mockM $ cases
+ [ "hello" ~> True
+ , "world" ~> False
+ ]
+ void $ f "hello"
+ result <- f "world"
+ result `shouldBe` False
+ f `shouldBeCalled` ("hello" :: String)
+ f `shouldBeCalled` ("world" :: String)
+
+ describe "Order verification" do
+ it "validates inOrderWith" do
+ f <- mockM $ any @String ~> ()
+ void $ f "first"
+ void $ f "second"
+ f `shouldBeCalled` inOrderWith ["first", "second"]
+ f `shouldBeCalled` inOrderWith ["second", "first"] `shouldThrow` anyErrorCall
+
+ it "validates inPartialOrderWith" do
+ f <- mockM $ any @String ~> ()
+ void $ f "alpha"
+ void $ f "beta"
+ void $ f "gamma"
+ f `shouldBeCalled` inPartialOrderWith ["alpha", "gamma"]
+ f `shouldBeCalled` inPartialOrderWith ["gamma", "alpha"] `shouldThrow` anyErrorCall
+
+ describe "named mocks and errors" do
+ it "reports names in error messages" do
+ f <- mockM (label "named" :: Label) $ "a" ~> True
+ result <- f "a"
+ result `shouldBe` True
+ e <- try (f `shouldBeCalled` "b") :: IO (Either ErrorCall ())
+ case e of
+ Left (ErrorCall msg) -> msg `shouldContain` "named"
+ Right _ -> expectationFailure "expected an error"
+
+ describe "integration with transformer stacks" do
+ it "works inside ReaderT IO" do
+ runReaderT @() @IO
+ (do
+ f <- mockM $ any @String ~> True
+ void $ f "lifted"
+ void $ f "lifted"
+ liftIO $ f `shouldBeCalled` (times 2 `withArgs` "lifted"))
+ ()
+
diff --git a/test/Test/MockCat/ShouldBeCalledSpec.hs b/test/Test/MockCat/ShouldBeCalledSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/ShouldBeCalledSpec.hs
@@ -0,0 +1,755 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+{- HLINT ignore "Use newtype instead of data" -}
+
+module Test.MockCat.ShouldBeCalledSpec (spec) where
+
+import Control.Exception (ErrorCall(..), evaluate)
+import Data.List (isInfixOf)
+import Test.Hspec
+import Test.MockCat
+import Test.MockCat.Verify (verificationFailureMessage)
+import Prelude hiding (any)
+
+spec :: Spec
+spec = do
+ describe "shouldBeCalled API" do
+ describe "Simple verification (arguments only, at least once)" do
+ it "single argument" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` "a"
+
+ it "multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` ("a" ~> "b")
+
+ it "failure case" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` "b" `shouldThrow` anyErrorCall
+
+ it "single argument with param" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` param "a"
+
+ it "single argument with any" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` any
+
+ it "single argument with expect" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` expect (const True) "always true"
+
+ describe "Simple verification without arguments (anything)" do
+ it "success" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` anything
+
+ it "failure (never called)" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` anything `shouldThrow` anyErrorCall
+
+ describe "Count verification with arguments" do
+ it "times - exact count" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (times 3 `withArgs` "a")
+
+ it "times - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (times 3 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "atLeast - success" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 3 `withArgs` "a")
+
+ it "atLeast - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 3 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "atMost - success" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atMost 3 `withArgs` "a")
+
+ it "atMost - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atMost 2 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "greaterThan - success" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (greaterThan 2 `withArgs` "a")
+
+ it "greaterThan - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (greaterThan 2 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "lessThan - success" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (lessThan 4 `withArgs` "a")
+
+ it "lessThan - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (lessThan 3 `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "once - success" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` (once `withArgs` "a")
+
+ it "once - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (once `withArgs` "a") `shouldThrow` anyErrorCall
+
+ it "never - success" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` (never `withArgs` "a")
+
+ it "never - failure" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ f `shouldBeCalled` (never `withArgs` "a") `shouldThrow` anyErrorCall
+
+ describe "Count verification with Param arguments" do
+ it "times with param" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (times 3 `withArgs` param "a")
+
+ it "times with any" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` (times 3 `withArgs` any)
+
+ it "times with expect" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` (times 3 `withArgs` expect (const True) "always true")
+
+ describe "Count verification without arguments (times only)" do
+ it "times - success" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` times 3
+
+ it "times - failure" do
+ f <- mock $ any ~> True
+ evaluate $ f "a"
+ evaluate $ f "b"
+ f `shouldBeCalled` times 3 `shouldThrow` anyErrorCall
+
+ describe "Order verification" do
+ it "inOrderWith - success" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` inOrderWith ["a", "b", "c"]
+
+ it "inOrderWith - failure" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` inOrderWith ["a", "b", "b"] `shouldThrow` anyErrorCall
+
+ it "inPartialOrderWith - success" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ evaluate $ f "b"
+ evaluate $ f "c"
+ f `shouldBeCalled` inPartialOrderWith ["a", "c"]
+
+ it "inPartialOrderWith - failure" do
+ f <- mock $ any ~> ()
+ evaluate $ f "b"
+ evaluate $ f "a"
+ f `shouldBeCalled` inPartialOrderWith ["a", "b"] `shouldThrow` anyErrorCall
+
+ describe "Monadic mocks" do
+ it "shouldBeCalled with IO mock" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` ("a" ~> (1 :: Int))
+
+ it "shouldBeCalled times with IO mock" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled inOrderWith with IO mock" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "b" (2 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)]
+
+ it "shouldBeCalled inPartialOrderWith with IO mock" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "b" (2 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` inPartialOrderWith ["a" ~> (1 :: Int), "c" ~> (3 :: Int)]
+
+ it "shouldBeCalled anything with IO mock" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` anything
+
+ it "shouldBeCalled times without args with IO mock" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "b" (2 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` times 3
+
+ describe "Named mocks (error messages)" do
+ it "shouldBeCalled with name in error message" do
+ f <- mock (label "named mock") $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` ("b" ~> (1 :: Int)) `shouldThrow` anyErrorCall
+
+ it "shouldBeCalled times with name in error message" do
+ f <- mock (label "named mock") $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ let e =
+ "function `named mock` was not called the expected number of times with the expected arguments.\n\
+ \ expected: 3\n\
+ \ but got: 2"
+ f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int))) `shouldThrow` errorCall e
+
+ it "shouldBeCalled inOrderWith with name in error message" do
+ f <- mock (label "named mock") $ any ~> any ~> pure @IO True
+ _ <- f "b" (2 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)] `shouldThrow` errorContains "expected 1st call:"
+
+ it "shouldBeCalled inPartialOrderWith with name in error message" do
+ f <- mock (label "named mock") $ any ~> any ~> pure @IO True
+ _ <- f "b" (2 :: Int)
+ _ <- f "a" (1 :: Int)
+ let e =
+ "function `named mock` was not called with the expected arguments in the expected order.\n\
+ \ expected order:\n\
+ \ \"a\",1\n\
+ \ \"c\",3\n\
+ \ but got:\n\
+ \ \"b\",2\n\
+ \ \"a\",1"
+ f `shouldBeCalled` inPartialOrderWith ["a" ~> (1 :: Int), "c" ~> (3 :: Int)] `shouldThrow` errorCall e
+
+ it "shouldBeCalled anything with name in error message" do
+ f <- mock (label "named mock") $ "a" ~> (1 :: Int) ~> pure @IO True
+ f `shouldBeCalled` anything `shouldThrow` errorCall "Function `named mock` was never called"
+
+ describe "Non-Eq/Show support" do
+ it "can verify calls with NoEq argument using anything" do
+ f <- mock $ any @NoEq ~> "result"
+ f (NoEq "val") `shouldBe` "result"
+ f `shouldBeCalled` anything
+
+ describe "Error messages" do
+ it "shouldBeCalled failure with detailed error message" do
+ f <- mock $ any ~> True
+ evaluate $ f "A"
+ -- The error message format uses showForMessage which may quote the value
+ f `shouldBeCalled` "X" `shouldThrow` anyErrorCall
+
+ it "shouldBeCalled times failure with detailed error message" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ let e =
+ "function was not called the expected number of times with the expected arguments.\n\
+ \ expected: 3\n\
+ \ but got: 2"
+ f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int))) `shouldThrow` errorCall e
+
+ it "shouldBeCalled with non-mock function shows guidance message" do
+ let f :: Int -> Int
+ f x = x
+ (f `shouldBeCalled` times 1) `shouldThrow` errorCall verificationFailureMessage
+
+ describe "Multiple arguments with typed values" do
+ it "shouldBeCalled with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` ("a" ~> (1 :: Int))
+
+ it "shouldBeCalled times with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled atLeast with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (atLeast 3 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled atMost with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (atMost 3 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled greaterThan with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (greaterThan 2 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled lessThan with multiple typed arguments" do
+ f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ _ <- f "a" (1 :: Int)
+ f `shouldBeCalled` (lessThan 4 `withArgs` ("a" ~> (1 :: Int)))
+
+ it "shouldBeCalled inOrderWith with multiple typed arguments" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "b" (2 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)]
+
+ it "shouldBeCalled inPartialOrderWith with multiple typed arguments" do
+ f <- mock $ any ~> any ~> pure @IO True
+ _ <- f "a" (1 :: Int)
+ _ <- f "b" (2 :: Int)
+ _ <- f "c" (3 :: Int)
+ f `shouldBeCalled` inPartialOrderWith ["a" ~> (1 :: Int), "c" ~> (3 :: Int)]
+
+ describe "High arity mocks" do
+ it "shouldBeCalled with arity 2" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` ("a" ~> "b")
+
+ it "shouldBeCalled with arity 3" do
+ f <- mock $ "a" ~> "b" ~> "c" ~> False
+ evaluate $ f "a" "b" "c"
+ f `shouldBeCalled` ("a" ~> "b" ~> "c")
+
+ it "shouldBeCalled times with arity 2" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (times 3 `withArgs` ("a" ~> "b"))
+
+ it "shouldBeCalled times with arity 3" do
+ f <- mock $ "a" ~> "b" ~> "c" ~> False
+ evaluate $ f "a" "b" "c"
+ evaluate $ f "a" "b" "c"
+ f `shouldBeCalled` (times 2 `withArgs` ("a" ~> "b" ~> "c"))
+
+ it "shouldBeCalled inOrderWith with arity 2" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` inOrderWith ["a" ~> "b", "c" ~> "d"]
+
+ describe "Multi-case mocks" do
+ it "shouldBeCalled with multiple cases (arity 1)" do
+ f <- mock $ do
+ onCase $ "1" ~> True
+ onCase $ "2" ~> False
+ evaluate $ f "1"
+ evaluate $ f "2"
+ f `shouldBeCalled` "1"
+ f `shouldBeCalled` "2"
+
+
+ it "shouldBeCalled with multiple cases (arity 2)" do
+ f <- mock $ do
+ onCase $ "1" ~> "2" ~> True
+ onCase $ "2" ~> "3" ~> False
+ evaluate $ f "1" "2"
+ evaluate $ f "2" "3"
+ f `shouldBeCalled` ("1" ~> "2")
+ f `shouldBeCalled` ("2" ~> "3")
+
+ it "shouldBeCalled times with multiple cases (arity 2)" do
+ f <- mock $ do
+ onCase $ "1" ~> "2" ~> True
+ onCase $ "2" ~> "3" ~> False
+ evaluate $ f "1" "2"
+ evaluate $ f "1" "2"
+ evaluate $ f "2" "3"
+ evaluate $ f "2" "3"
+ f `shouldBeCalled` (times 2 `withArgs` ("1" ~> "2"))
+ f `shouldBeCalled` (times 2 `withArgs` ("2" ~> "3"))
+
+ describe "Edge cases and boundary conditions" do
+ it "times 0 (never called)" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` (times 0 `withArgs` "a")
+
+ it "atLeast 0 (always succeeds)" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` (atLeast 0 `withArgs` "a")
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 0 `withArgs` "a")
+
+ it "atLeast boundary (exact count)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 3 `withArgs` "a")
+
+ it "atMost boundary (exact count)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atMost 3 `withArgs` "a")
+
+ it "greaterThan boundary (one more)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (greaterThan 2 `withArgs` "a")
+
+ it "lessThan boundary (one less)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (lessThan 3 `withArgs` "a")
+
+ describe "Multiple arguments with Param combinators" do
+ it "shouldBeCalled with multiple arguments using any" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (any ~> any)
+
+ it "shouldBeCalled times with multiple arguments using any" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ evaluate $ f "e" "f"
+ f `shouldBeCalled` (times 3 `withArgs` (any ~> any))
+
+ it "shouldBeCalled with multiple arguments using expect" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (expect (const True) "always true" ~> expect (const True) "always true")
+
+ it "shouldBeCalled times with multiple arguments using expect" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` (times 2 `withArgs` (expect (const True) "always true" ~> expect (const True) "always true"))
+
+ it "shouldBeCalled anything with multiple arguments" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` anything
+
+ describe "High arity mocks (continued)" do
+ it "shouldBeCalled with arity 9" do
+ f <- mock $ any ~> any ~> any ~> any ~> any ~> any ~> any ~> any ~> ()
+ evaluate $ f "1" "2" "3" "4" "5" "6" "7" "8"
+ f `shouldBeCalled` ("1" ~> "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8")
+
+ it "shouldBeCalled inOrderWith with arity 9" do
+ f <- mock $ any ~> any ~> any ~> any ~> any ~> any ~> any ~> any ~> ()
+ evaluate $ f "1" "2" "3" "4" "5" "6" "7" "8"
+ evaluate $ f "2" "3" "4" "5" "6" "7" "8" "9"
+ evaluate $ f "3" "4" "5" "6" "7" "8" "9" "0"
+ f `shouldBeCalled` inOrderWith
+ [ "1" ~> "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8",
+ "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8" ~> "9",
+ "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8" ~> "9" ~> "0"
+ ]
+
+ describe "Order verification edge cases" do
+ it "inOrderWith with single element" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ f `shouldBeCalled` inOrderWith ["a"]
+
+ it "inPartialOrderWith with single element" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ f `shouldBeCalled` inPartialOrderWith ["a"]
+
+ it "inOrderWith with multiple arguments (failure case)" do
+ f <- mock $ any ~> any ~> ()
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` inOrderWith ["a" ~> "b", "d" ~> "c"] `shouldThrow` anyErrorCall
+
+ it "inPartialOrderWith with multiple arguments (failure case)" do
+ f <- mock $ any ~> any ~> ()
+ evaluate $ f "b" "a"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` inPartialOrderWith ["a" ~> "b", "c" ~> "d"] `shouldThrow` anyErrorCall
+
+ describe "Count verification with multiple arguments" do
+ it "once with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (once `withArgs` ("a" ~> "b"))
+
+ it "once with multiple arguments (failure)" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (once `withArgs` ("a" ~> "b")) `shouldThrow` anyErrorCall
+
+ it "never with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ f `shouldBeCalled` (never `withArgs` ("a" ~> "b"))
+
+ it "never with multiple arguments (failure)" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (never `withArgs` ("a" ~> "b")) `shouldThrow` anyErrorCall
+
+ it "atLeast with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (atLeast 2 `withArgs` ("a" ~> "b"))
+
+ it "atMost with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (atMost 2 `withArgs` ("a" ~> "b"))
+
+ it "greaterThan with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (greaterThan 1 `withArgs` ("a" ~> "b"))
+
+ it "lessThan with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (lessThan 3 `withArgs` ("a" ~> "b"))
+
+ describe "mockM" do
+ it "records calls for monadic mocks" do
+ f <- mockM $ "a" ~> True
+ result <- f "a"
+ result `shouldBe` True
+ f `shouldBeCalled` "a"
+
+ describe "Edge cases and boundary conditions" do
+ it "times 0 (never called)" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` (times 0 `withArgs` "a")
+
+ it "atLeast 0 (always succeeds)" do
+ f <- mock $ "a" ~> True
+ f `shouldBeCalled` (atLeast 0 `withArgs` "a")
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 0 `withArgs` "a")
+
+ it "atLeast boundary (exact count)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atLeast 3 `withArgs` "a")
+
+ it "atMost boundary (exact count)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (atMost 3 `withArgs` "a")
+
+ it "greaterThan boundary (one more)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (greaterThan 2 `withArgs` "a")
+
+ it "lessThan boundary (one less)" do
+ f <- mock $ "a" ~> True
+ evaluate $ f "a"
+ evaluate $ f "a"
+ f `shouldBeCalled` (lessThan 3 `withArgs` "a")
+
+ describe "Multiple arguments with Param combinators" do
+ it "shouldBeCalled with multiple arguments using any" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (any ~> any)
+
+ it "shouldBeCalled times with multiple arguments using any" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ evaluate $ f "e" "f"
+ f `shouldBeCalled` (times 3 `withArgs` (any ~> any))
+
+ it "shouldBeCalled with multiple arguments using expect" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (expect (const True) "always true" ~> expect (const True) "always true")
+
+ it "shouldBeCalled times with multiple arguments using expect" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` (times 2 `withArgs` (expect (const True) "always true" ~> expect (const True) "always true"))
+
+ it "shouldBeCalled anything with multiple arguments" do
+ f <- mock $ any ~> any ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` anything
+
+ describe "High arity mocks (continued)" do
+ it "shouldBeCalled with arity 9" do
+ f <- mock $ any ~> any ~> any ~> any ~> any ~> any ~> any ~> any ~> ()
+ evaluate $ f "1" "2" "3" "4" "5" "6" "7" "8"
+ f `shouldBeCalled` inOrderWith ["1" ~> "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8"]
+
+ it "shouldBeCalled inOrderWith with arity 9" do
+ f <- mock $ any ~> any ~> any ~> any ~> any ~> any ~> any ~> any ~> ()
+ evaluate $ f "1" "2" "3" "4" "5" "6" "7" "8"
+ evaluate $ f "2" "3" "4" "5" "6" "7" "8" "9"
+ evaluate $ f "3" "4" "5" "6" "7" "8" "9" "0"
+ f `shouldBeCalled` inOrderWith
+ [ "1" ~> "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8",
+ "2" ~> "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8" ~> "9",
+ "3" ~> "4" ~> "5" ~> "6" ~> "7" ~> "8" ~> "9" ~> "0"
+ ]
+
+ describe "Order verification edge cases" do
+ it "inOrderWith with single element" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ f `shouldBeCalled` inOrderWith ["a"]
+
+ it "inPartialOrderWith with single element" do
+ f <- mock $ any ~> ()
+ evaluate $ f "a"
+ f `shouldBeCalled` inPartialOrderWith ["a"]
+
+ it "inOrderWith with multiple arguments (failure case)" do
+ f <- mock $ any ~> any ~> ()
+ evaluate $ f "a" "b"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` inOrderWith ["a" ~> "b", "d" ~> "c"] `shouldThrow` anyErrorCall
+
+ it "inPartialOrderWith with multiple arguments (failure case)" do
+ f <- mock $ any ~> any ~> ()
+ evaluate $ f "b" "a"
+ evaluate $ f "c" "d"
+ f `shouldBeCalled` inPartialOrderWith ["a" ~> "b", "c" ~> "d"] `shouldThrow` anyErrorCall
+
+ describe "Count verification with multiple arguments" do
+ it "once with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (once `withArgs` ("a" ~> "b"))
+
+ it "once with multiple arguments (failure)" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (once `withArgs` ("a" ~> "b")) `shouldThrow` anyErrorCall
+
+ it "never with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ f `shouldBeCalled` (never `withArgs` ("a" ~> "b"))
+
+ it "never with multiple arguments (failure)" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (never `withArgs` ("a" ~> "b")) `shouldThrow` anyErrorCall
+
+ it "atLeast with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (atLeast 2 `withArgs` ("a" ~> "b"))
+
+ it "atMost with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (atMost 2 `withArgs` ("a" ~> "b"))
+
+ it "greaterThan with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (greaterThan 1 `withArgs` ("a" ~> "b"))
+
+ it "lessThan with multiple arguments" do
+ f <- mock $ "a" ~> "b" ~> True
+ evaluate $ f "a" "b"
+ evaluate $ f "a" "b"
+ f `shouldBeCalled` (lessThan 3 `withArgs` ("a" ~> "b"))
+
+errorContains :: String -> Selector ErrorCall
+errorContains sub (ErrorCall msg) = sub `isInfixOf` msg
+
+data NoEq = NoEq String deriving (Show)
+
diff --git a/test/Test/MockCat/StubSpec.hs b/test/Test/MockCat/StubSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/StubSpec.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+module Test.MockCat.StubSpec where
+
+import Test.Hspec
+import Test.MockCat
+import Control.Exception (evaluate, ErrorCall(..))
+import Data.List (isInfixOf)
+
+spec :: Spec
+spec = do
+ it "stub" do
+ let f = stub $ "value" ~> True
+ f "value" `shouldBe` True
+
+ it "stub with multiple arguments" do
+ let f = stub $ "value1" ~> "value2" ~> True
+ f "value1" "value2" `shouldBe` True
+
+ it "stub with multiple arguments and return value" do
+ let f = stub $ "value1" ~> "value2" ~> "value3" ~> True
+ f "value1" "value2" "value3" `shouldBe` True
+
+ it "stub with multiple arguments and return value" do
+ let f = stub $ "value1" ~> "value2" ~> "value3" ~> "value4" ~> True
+ f "value1" "value2" "value3" "value4" `shouldBe` True
+
+ it "stub with multiple arguments and return value" do
+ let
+ f = stub do
+ onCase $ "value1" ~> "value2" ~> True
+ onCase $ "value2" ~> "value3" ~> False
+
+ f "value1" "value2" `shouldBe` True
+ f "value2" "value3" `shouldBe` False
+
+ it "throws on unexpected argument" do
+ let f = stub $ "a" ~> True
+ evaluate (f "b") `shouldThrow` errorContains "expected: \"a\"\n but got: \"b\"\n ^^"
+
+ describe "named stub" do
+ it "stub with label" do
+ let f = stub (label "stub function") $ "value" ~> True
+ f "value" `shouldBe` True
+
+ it "stub with label and multiple arguments" do
+ let f = stub (label "stub function") $ "value1" ~> "value2" ~> True
+ f "value1" "value2" `shouldBe` True
+
+ it "stub with label throws on unexpected argument with name in error message" do
+ let f = stub (label "stub function") $ "a" ~> True
+ evaluate (f "b") `shouldThrow` errorContains "expected: \"a\"\n but got: \"b\"\n ^^"
+
+ it "stub with label and cases" do
+ let f = stub (label "stub function") $ do
+ onCase $ "value1" ~> "value2" ~> True
+ onCase $ "value2" ~> "value3" ~> False
+ f "value1" "value2" `shouldBe` True
+ f "value2" "value3" `shouldBe` False
+
+errorContains :: String -> Selector ErrorCall
+errorContains sub (ErrorCall msg) = sub `isInfixOf` msg
diff --git a/test/Test/MockCat/TH/ClassAnalysisSpec.hs b/test/Test/MockCat/TH/ClassAnalysisSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/TH/ClassAnalysisSpec.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Test.MockCat.TH.ClassAnalysisSpec (spec) where
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Reader.Class (MonadReader)
+import Language.Haskell.TH
+import Test.Hspec
+import Test.MockCat.TH.ClassAnalysis
+import Test.MockCat.MockT (MockT)
+
+spec :: Spec
+spec = describe "ClassAnalysis helpers" $ do
+ describe "toClassInfo" $ do
+ it "collects variable names from single-argument class constraints" $ do
+ let a = mkName "a"
+ predicate = AppT (ConT ''Monad) (VarT a)
+ ClassName2VarNames name vars = toClassInfo predicate
+ name `shouldBe` ''Monad
+ vars `shouldBe` [a]
+
+ it "collects variables in order even from nested constraints" $ do
+ let env = mkName "env"
+ m = mkName "m"
+ predicate = AppT (AppT (ConT ''MonadReader) (VarT env)) (VarT m)
+ ClassName2VarNames name vars = toClassInfo predicate
+ name `shouldBe` ''MonadReader
+ vars `shouldBe` [env, m]
+
+ describe "filterClassInfo" $ do
+ it "keeps only classes that contain the target type variable" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ infos =
+ [ ClassName2VarNames ''Monad [a]
+ , ClassName2VarNames ''Applicative [b]
+ ]
+ fmap (\(ClassName2VarNames name vars) -> (name, vars)) (filterClassInfo a infos)
+ `shouldBe` [(''Monad, [a])]
+
+ describe "filterMonadicVarInfos" $ do
+ it "keeps only variables with Monad constraints" $ do
+ let vars =
+ [ VarName2ClassNames (mkName "m") [''Monad, ''MonadIO]
+ , VarName2ClassNames (mkName "x") [''Applicative]
+ ]
+ fmap (\(VarName2ClassNames name classes) -> (name, classes)) (filterMonadicVarInfos vars)
+ `shouldBe` [(mkName "m", [''Monad, ''MonadIO])]
+
+ describe "getClassName / getClassNames" $ do
+ it "gets the top-level class name" $ do
+ getClassName (AppT (ConT ''MonadReader) (VarT (mkName "env"))) `shouldBe` ''MonadReader
+
+ it "gets all names from nested class applications" $ do
+ let a = mkName "a"
+ ty = AppT (AppT (ConT ''Either) (ConT ''String)) (VarT a)
+ getClassNames ty `shouldBe` [''Either, ''String]
+
+ describe "VarCalled helpers" $ do
+ it "applyVarAppliedTypes replaces type variables with class names" $ do
+ let m = mkName "m"
+ a = mkName "a"
+ mapping =
+ [ VarAppliedType m (Just ''Maybe)
+ , VarAppliedType a Nothing
+ ]
+ ty = AppT (AppT ArrowT (VarT m)) (VarT a)
+ expected = AppT (AppT ArrowT (ConT ''Maybe)) (VarT a)
+ applyVarAppliedTypes mapping ty `shouldBe` expected
+
+ it "updateType replaces VarT combinations with class names" $ do
+ let m = mkName "m"
+ a = mkName "a"
+ mapping =
+ [ VarAppliedType m (Just ''MockT)
+ , VarAppliedType a (Just ''Int)
+ ]
+ ty = AppT (VarT m) (VarT a)
+ expected = AppT (ConT ''MockT) (ConT ''Int)
+ updateType ty mapping `shouldBe` expected
+
+
diff --git a/test/Test/MockCat/TH/ContextBuilderSpec.hs b/test/Test/MockCat/TH/ContextBuilderSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/TH/ContextBuilderSpec.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Test.MockCat.TH.ContextBuilderSpec (spec) where
+
+import Language.Haskell.TH
+import Test.Hspec
+import Control.Monad.IO.Class (MonadIO)
+import Test.MockCat.MockT (MockT)
+import Test.MockCat.TH.ContextBuilder
+
+spec :: Spec
+spec = describe "ContextBuilder helpers" $ do
+ describe "liftConstraint" $ do
+ it "preserves Monad constraints" $ do
+ let m = mkName "m"
+ constraint = AppT (ConT ''Monad) (VarT m)
+ liftConstraint m constraint `shouldBe` constraint
+
+ it "injects MockT into the monad type variable" $ do
+ let m = mkName "m"
+ constraint = AppT (ConT ''MonadIO) (VarT m)
+ expected = AppT (ConT ''MonadIO) (AppT (ConT ''MockT) (VarT m))
+ liftConstraint m constraint `shouldBe` expected
+
+ describe "mockTType / tyVarBndrToType / applyFamilyArg" $ do
+ it "mockTType constructs MockT" $ do
+ let m = mkName "m"
+ mockTType m `shouldBe` AppT (ConT ''MockT) (VarT m)
+
+ it "tyVarBndrToType converts a PlainTV matching the monad variable to MockT" $ do
+ let m = mkName "m"
+ binder = PlainTV m SpecifiedSpec
+ tyVarBndrToType m binder `shouldBe` AppT (ConT ''MockT) (VarT m)
+
+ it "applyFamilyArg works with KindedTV" $ do
+ let m = mkName "m"
+ binder = KindedTV m SpecifiedSpec StarT
+ applyFamilyArg m binder `shouldBe` AppT (ConT ''MockT) (VarT m)
+
+ describe "buildContext" $ do
+ it "removes Monad constraints and adds MonadIO in Total mocks" $ do
+ let m = mkName "m"
+ constraint = AppT (ConT ''Monad) (VarT m)
+ buildContext [constraint] Total (mkName "Cls") m [] []
+ `shouldBe` [AppT (ConT ''MonadIO) (VarT m)]
+
+ it "adds the class itself as a constraint in Partial mocks" $ do
+ let m = mkName "m"
+ a = mkName "a"
+ cls = mkName "Cls"
+ tyVars =
+ [ PlainTV m SpecifiedSpec
+ , PlainTV a SpecifiedSpec
+ ]
+ expectedClassConstraint =
+ AppT (AppT (ConT cls) (VarT m)) (VarT a)
+ buildContext [] Partial cls m tyVars []
+ `shouldBe`
+ [ AppT (ConT ''MonadIO) (VarT m)
+ , expectedClassConstraint
+ ]
+
+
diff --git a/test/Test/MockCat/TH/FunctionBuilderSpec.hs b/test/Test/MockCat/TH/FunctionBuilderSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/TH/FunctionBuilderSpec.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Test.MockCat.TH.FunctionBuilderSpec (spec) where
+
+import qualified Data.Text as T
+import Language.Haskell.TH
+import Test.Hspec
+import Test.MockCat.Cons ((:>))
+import Test.MockCat.Param (Param)
+import Test.MockCat.TH.FunctionBuilder
+import Test.MockCat.SharedSpecDefs (UserInput(..))
+
+spec :: Spec
+spec = do
+ describe "createMockBuilderVerifyParams" $ do
+ it "returns a single Param for a function with a single argument" $ do
+ let m = mkName "m"
+ funType = AppT (AppT ArrowT (ConT ''String)) (AppT (VarT m) (TupleT 0))
+ createMockBuilderVerifyParams funType
+ `shouldBe` AppT (ConT ''Param) (ConT ''String)
+
+ it "connects Params with :> for functions with multiple arguments" $ do
+ let m = mkName "m"
+ rest = AppT (AppT ArrowT (ConT ''Int)) (AppT (VarT m) (TupleT 0))
+ funType = AppT (AppT ArrowT (ConT ''String)) rest
+ expected =
+ AppT
+ (AppT (ConT ''(:>)) (AppT (ConT ''Param) (ConT ''String)))
+ (AppT (ConT ''Param) (ConT ''Int))
+ createMockBuilderVerifyParams funType `shouldBe` expected
+
+ it "returns () when there are no arguments" $ do
+ let m = mkName "m"
+ createMockBuilderVerifyParams (AppT (VarT m) (TupleT 0))
+ `shouldBe` TupleT 0
+
+ describe "createMockBuilderFnType" $ do
+ it "removes monad arguments to make a pure function type" $ do
+ let m = mkName "m"
+ funType = AppT (AppT ArrowT (ConT ''String)) (AppT (VarT m) (ConT ''Int))
+ expected = AppT (AppT ArrowT (ConT ''String)) (ConT ''Int)
+ createMockBuilderFnType m funType `shouldBe` expected
+
+ it "does not change return values other than the monad variable" $ do
+ let m = mkName "m"
+ funType = AppT (AppT ArrowT (ConT ''String)) (AppT (ConT ''IO) (ConT ''Int))
+ createMockBuilderFnType m funType `shouldBe` funType
+
+ it "removes the monad variable even in types containing forall" $ do
+ let m = mkName "m"
+ a = mkName "a"
+ body = AppT (VarT m) (VarT a)
+ funType = ForallT [PlainTV a SpecifiedSpec] [] body
+ createMockBuilderFnType m funType `shouldBe` VarT a
+
+ describe "partialAdditionalPredicates (migrated from THMockFnContextSpec)" $ do
+ it "adds Typeable and equality constraints for verification parameters in polymorphic functions" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ funType = AppT (AppT ArrowT (VarT a)) (VarT b)
+ verifyParams = AppT (ConT ''Param) (VarT a)
+ preds = partialAdditionalPredicates funType verifyParams
+ normalize preds `shouldMatchList`
+ [ "ResolvableParamsOf (a -> b) ~ Param a"
+ ]
+
+ it "does not add Typeable for verification parameters when type variables only appear in the return value" $ do
+ let a = mkName "a"
+ funType = AppT (AppT ArrowT (ConT ''String)) (VarT a)
+ verifyParams = AppT (ConT ''Param) (ConT ''String)
+ preds = partialAdditionalPredicates funType verifyParams
+ normalize preds `shouldMatchList`
+ [ "ResolvableParamsOf (String -> a) ~ Param String"
+ ]
+
+ it "does not duplicate Typeable even if the same type variable appears multiple times" $ do
+ let a = mkName "a"
+ funType = AppT (AppT ArrowT (VarT a)) (VarT a)
+ verifyParams = AppT (ConT ''Param) (VarT a)
+ preds = partialAdditionalPredicates funType verifyParams
+ normalize preds `shouldMatchList`
+ [ "ResolvableParamsOf (a -> a) ~ Param a"
+ ]
+
+ it "does not add redundant constraints for functions with concrete types" $ do
+ let funType =
+ AppT
+ (AppT ArrowT (ConT ''String))
+ (AppT (ConT ''Maybe) (ConT ''UserInput))
+ verifyParams = AppT (ConT ''Param) (ConT ''String)
+ preds = partialAdditionalPredicates funType verifyParams
+ normalize preds `shouldBe` []
+
+ describe "createTypeablePreds" $ do
+ it "decomposes and extracts types containing type variables and removes duplicates" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ funType = AppT (AppT ArrowT (VarT a)) (VarT b)
+ verifyParams = AppT (ConT ''Param) (VarT a)
+ preds = createTypeablePreds [funType, verifyParams]
+ normalize preds `shouldMatchList`
+ [ "Typeable a"
+ , "Typeable b"
+ ]
+
+ it "extracts type families without decomposing them" $ do
+ let m = mkName "m"
+ assoc = AppT (ConT (mkName "ResultType")) (VarT m)
+ preds = createTypeablePreds [assoc]
+ normalize preds `shouldMatchList`
+ [ "Typeable (ResultType m)"
+ ]
+
+ it "generates nothing for concrete types only" $ do
+ let ty = AppT (ConT ''Maybe) (ConT ''Int)
+ preds = createTypeablePreds [ty]
+ normalize preds `shouldBe` []
+
+normalize :: [Pred] -> [String]
+normalize = fmap (cleanup . pprint)
+ where
+ cleanup =
+ T.unpack
+ . T.unwords
+ . T.words
+ . T.replace (T.pack "\n") (T.pack " ")
+ . T.replace (T.pack "Data.Typeable.Internal.") (T.pack "")
+ . T.replace (T.pack "GHC.Internal.") (T.pack "")
+ . T.replace (T.pack "Base.") (T.pack "")
+ . T.replace (T.pack "GHC.Base.") (T.pack "")
+ . T.replace (T.pack "GHC.Types.") (T.pack "")
+ . T.replace (T.pack "Test.MockCat.Param.") (T.pack "")
+ . T.replace (T.pack "Test.MockCat.Verify.") (T.pack "")
+ . T.pack
diff --git a/test/Test/MockCat/TH/TypeUtilsSpec.hs b/test/Test/MockCat/TH/TypeUtilsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/TH/TypeUtilsSpec.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Test.MockCat.TH.TypeUtilsSpec (spec) where
+
+import qualified Data.Map.Strict as Map
+import Language.Haskell.TH
+import Test.Hspec
+import Test.MockCat.TH.TypeUtils
+
+spec :: Spec
+spec = do
+ describe "splitApps" $ do
+ it "expands function type arguments in order" $ do
+ let a = mkName "a"
+ ty = AppT (AppT ArrowT (ConT ''Int)) (VarT a)
+ splitApps ty `shouldBe` (ArrowT, [ConT ''Int, VarT a])
+
+ it "decomposes nested type applications into top-level and argument list" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ ty =
+ AppT
+ (ConT ''Maybe)
+ (AppT (AppT (ConT ''Either) (VarT a)) (VarT b))
+ splitApps ty
+ `shouldBe` ( ConT ''Maybe
+ , [AppT (AppT (ConT ''Either) (VarT a)) (VarT b)]
+ )
+
+ it "returns types without application as they are" $ do
+ splitApps (ConT ''Bool) `shouldBe` (ConT ''Bool, [])
+
+ describe "substituteType" $ do
+ it "replaces VarT with types from the map" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ ty = AppT (VarT a) (VarT b)
+ subMap =
+ Map.fromList
+ [ (a, ConT ''Int)
+ , (b, ConT ''Bool)
+ ]
+ substituteType subMap ty `shouldBe` AppT (ConT ''Int) (ConT ''Bool)
+
+ it "recursively applies to constraints and body within ForallT" $ do
+ let a = mkName "a"
+ b = mkName "b"
+ ty =
+ ForallT
+ [PlainTV a SpecifiedSpec]
+ [AppT (ConT ''Eq) (VarT a)]
+ (AppT (VarT b) (VarT a))
+ subMap =
+ Map.fromList
+ [ (a, ConT ''Char)
+ , (b, ConT ''Maybe)
+ ]
+ expected =
+ ForallT
+ [PlainTV a SpecifiedSpec]
+ [AppT (ConT ''Eq) (ConT ''Char)]
+ (AppT (ConT ''Maybe) (ConT ''Char))
+ substituteType subMap ty `shouldBe` expected
+
+ it "leaves type variables not in the map as they are" $ do
+ let a = mkName "a"
+ ty = VarT a
+ substituteType Map.empty ty `shouldBe` VarT a
+
+ describe "isNotConstantFunctionType" $ do
+ it "is True for types containing arrows" $ do
+ let ty = AppT (AppT ArrowT (ConT ''Int)) (ConT ''Bool)
+ isNotConstantFunctionType ty `shouldBe` True
+
+ it "is False for tuples" $ do
+ isNotConstantFunctionType (TupleT 0) `shouldBe` False
+
+ it "can judge even when wrapped in forall" $ do
+ let a = mkName "a"
+ body = AppT (AppT ArrowT (VarT a)) (ConT ''Int)
+ ty = ForallT [PlainTV a SpecifiedSpec] [] body
+ isNotConstantFunctionType ty `shouldBe` True
+
+
diff --git a/test/Test/MockCat/THCompareSpec.hs b/test/Test/MockCat/THCompareSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/THCompareSpec.hs
@@ -0,0 +1,499 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{- HLINT ignore "Use fewer imports" -}
+
+module Test.MockCat.THCompareSpec (spec) where
+
+import Test.Hspec
+import Language.Haskell.TH (pprint, Dec(..), Type(..), litE, stringL, listE, tupE)
+import Language.Haskell.TH.Syntax (nameBase)
+import Data.Char (isDigit, isLower)
+import Data.List (foldl', sort, nub)
+import Data.Maybe (mapMaybe)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import qualified System.IO as SIO
+import Test.MockCat.SharedSpecDefs
+import Test.MockCat.TH (makeMock, makeAutoLiftMock, makePartialMock, makeAutoLiftPartialMock)
+import Language.Haskell.TH (lookupTypeName, conT)
+import Control.Monad (forM_, when)
+
+normalize :: String -> String
+normalize =
+ T.unpack
+ . squeezePunctuation
+ . T.unwords
+ . map stripVarSuffix
+ . T.words
+ . stripQualifiers
+ . T.pack
+
+stripQualifiers :: T.Text -> T.Text
+stripQualifiers =
+ stripPrefixes
+ (map
+ T.pack
+ [ "Test.MockCat.SharedSpecDefs."
+ , "Test.MockCat.MockT."
+ , "Test.MockCat.Internal.Builder."
+ , "Test.MockCat.Cons."
+ , "Test.MockCat.Param."
+ , "Control.Monad.IO.Class."
+ , "GHC.Types."
+ , "Data.Typeable.Internal."
+ , "GHC.Internal."
+ , "Base."
+ , "Test.MockCat.Verify."
+ , "Verify."
+ , "GHC.Show."
+ , "GHC.Classes."
+ , "Show."
+ , "Classes."
+ , "Internal."
+ ])
+ where
+ stripPrefixes [] t = t
+ stripPrefixes (p : ps) t = stripPrefixes ps (T.replace p T.empty t)
+
+stripVarSuffix :: T.Text -> T.Text
+stripVarSuffix = T.pack . go Nothing . T.unpack
+ where
+ go _ [] = []
+ go prev (c : cs)
+ | c == '_' && maybe False isLower prev =
+ go prev (dropWhile isDigit cs)
+ | otherwise = c : go (Just c) cs
+
+squeezePunctuation :: T.Text -> T.Text
+squeezePunctuation =
+ applyReplacements
+ [ ("( ", "(")
+ , (" )", ")")
+ , (" ,", ",")
+ , ("[ ", "[")
+ , (" ]", "]")
+ , (" <" , "<")
+ , ("> ", ">")
+ , ("((:>) ", "(")
+ , ("((:>)", "(")
+ , ("(:>) ", "")
+ , ("(:>)", "")
+ ]
+ . T.replace (T.pack "Head (Param") (T.pack "Head :>Param")
+ . T.replace (T.pack "Head :> Param") (T.pack "Head :>Param")
+ -- Fix: MockBuilder (Head :>Param r) r () should not become MockBuilder (Head :>Param r r ()
+ -- First fix the case where " r r ()" appears (missing closing paren)
+ . T.replace (T.pack ":>Param r r ()") (T.pack ":>Param r) r ()")
+ . T.replace (T.pack "Head :>Param r r ()") (T.pack "Head :>Param r) r ()")
+ . T.replace (T.pack "Param r r ()") (T.pack "Param r) r ()")
+ -- Then handle the general case of ") r ()" -> " r ()" but only if not already fixed
+ . T.replace (T.pack ") r ()") (T.pack " r ()")
+ where
+ applyReplacements reps txt =
+ foldl'
+ (\acc (from, to) -> T.replace (T.pack from) (T.pack to) acc)
+ txt
+ reps
+
+-- generate at compile time to avoid running restricted TH actions in IO
+-- store pretty-printed generated declarations as strings
+generatedFinderStr :: String
+generatedFinderStr = $(do decs <- makeAutoLiftPartialMock [t|Finder|]; litE (stringL (concatMap pprint decs)))
+
+generatedFinderSigPairs :: [(String, String)]
+generatedFinderSigPairs =
+ $(
+ do
+ decs <- makeAutoLiftPartialMock [t|Finder|]
+ let sigPairs =
+ [ (nameBase name, pprint ty)
+ | SigD name ty <- decs
+ ]
+ listE
+ [ tupE [litE (stringL fn), litE (stringL sig)]
+ | (fn, sig) <- sigPairs
+ ]
+ )
+
+generatedFinderSigMap :: Map.Map String String
+generatedFinderSigMap = Map.fromList generatedFinderSigPairs
+
+generatedUserInputSigPairs :: [(String, String)]
+generatedUserInputSigPairs =
+ $(
+ do
+ decs <- makeAutoLiftPartialMock [t|UserInputGetter|]
+ let sigPairs =
+ [ (nameBase name, pprint ty)
+ | SigD name ty <- decs
+ ]
+ listE
+ [ tupE [litE (stringL fn), litE (stringL sig)]
+ | (fn, sig) <- sigPairs
+ ]
+ )
+
+generatedUserInputSigMap :: Map.Map String String
+generatedUserInputSigMap = Map.fromList generatedUserInputSigPairs
+
+generatedFileOpStr :: String
+generatedFileOpStr = $(do decs <- makeAutoLiftPartialMock [t|FileOperation|]; litE (stringL (concatMap pprint decs)))
+
+generatedTestClassStr :: String
+generatedTestClassStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.TestClass"
+ case m of
+ Nothing -> fail "TestClass not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedMultiApplyStr :: String
+generatedMultiApplyStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MultiApplyTest"
+ case m of
+ Nothing -> fail "MultiApplyTest not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedExplicitStr :: String
+generatedExplicitStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.ExplicitlyReturnMonadicValuesTest"
+ case m of
+ Nothing -> fail "ExplicitlyReturnMonadicValuesTest not found"
+ Just n -> do decs <- makeMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedDefaultMethodStr :: String
+generatedDefaultMethodStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.DefaultMethodTest"
+ case m of
+ Nothing -> fail "DefaultMethodTest not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedAssocTypeStr :: String
+generatedAssocTypeStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.AssocTypeTest"
+ case m of
+ Nothing -> fail "AssocTypeTest not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedAssocSigPairs :: [(String, String)]
+generatedAssocSigPairs =
+ $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.AssocTypeTest"
+ case m of
+ Nothing -> fail "AssocTypeTest not found"
+ Just n -> do
+ decs <- makeAutoLiftMock (conT n)
+ let sigPairs =
+ [ (nameBase name, pprint ty)
+ | SigD name ty <- decs
+ ]
+ listE
+ [ tupE [litE (stringL fn), litE (stringL sig)]
+ | (fn, sig) <- sigPairs
+ ]
+ )
+
+generatedAssocSigMap :: Map.Map String String
+generatedAssocSigMap = Map.fromList generatedAssocSigPairs
+
+generatedParamThreeStr :: String
+generatedParamThreeStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.ParamThreeMonad"
+ case m of
+ Nothing -> fail "ParamThreeMonad not found"
+ Just n -> do
+ let targetType =
+ AppT
+ (AppT (ConT n) (ConT ''Int))
+ (ConT ''Bool)
+ decs <- makeAutoLiftMock (pure targetType)
+ litE (stringL (concatMap pprint decs))
+ )
+
+generatedUserInputStr :: String
+generatedUserInputStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.UserInputGetter"
+ case m of
+ Nothing -> fail "UserInputGetter not found"
+ Just n -> do decs <- makeAutoLiftPartialMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedExplicitPartialStr :: String
+generatedExplicitPartialStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.ExplicitlyReturnMonadicValuesPartialTest"
+ case m of
+ Nothing -> fail "ExplicitlyReturnMonadicValuesPartialTest not found"
+ Just n -> do decs <- makePartialMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+-- additional generated declarations for classes produced in `TypeClassTHSpec.hs`
+
+
+generatedVar2_1SubStr :: String
+generatedVar2_1SubStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MonadVar2_1Sub"
+ case m of
+ Nothing -> fail "MonadVar2_1Sub not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedVar2_2SubStr :: String
+generatedVar2_2SubStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MonadVar2_2Sub"
+ case m of
+ Nothing -> fail "MonadVar2_2Sub not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedVar3_1SubStr :: String
+generatedVar3_1SubStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MonadVar3_1Sub"
+ case m of
+ Nothing -> fail "MonadVar3_1Sub not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedVar3_2SubStr :: String
+generatedVar3_2SubStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MonadVar3_2Sub"
+ case m of
+ Nothing -> fail "MonadVar3_2Sub not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+generatedVar3_3SubStr :: String
+generatedVar3_3SubStr = $(
+ do
+ m <- lookupTypeName "Test.MockCat.SharedSpecDefs.MonadVar3_3Sub"
+ case m of
+ Nothing -> fail "MonadVar3_3Sub not found"
+ Just n -> do decs <- makeAutoLiftMock (conT n); litE (stringL (concatMap pprint decs))
+ )
+
+partialMockSpecPath :: FilePath
+partialMockSpecPath = "test/Test/MockCat/PartialMockSpec.hs"
+
+typeClassSpecPath :: FilePath
+typeClassSpecPath = "test/Test/MockCat/TypeClassSpec.hs"
+
+-- extract textual instance context for handwritten module
+extractHandwrittenInstanceCxts :: FilePath -> String -> IO [String]
+extractHandwrittenInstanceCxts fp className = do
+ src <- SIO.readFile fp
+ pure $ extractInstanceHeaders src className
+
+spec :: Spec
+spec = describe "TH generated vs handwritten instances" do
+ let cases =
+ [ ("Finder partial mock instance matches handwritten", partialMockSpecPath, "Finder", generatedFinderStr)
+ , ("FileOperation mock instance matches handwritten", partialMockSpecPath, "FileOperation", generatedFileOpStr)
+ , ("UserInputGetter partial mock instance matches handwritten", partialMockSpecPath, "UserInputGetter", generatedUserInputStr)
+ , ("ExplicitlyReturnMonadicValuesPartialTest instance matches handwritten", partialMockSpecPath, "ExplicitlyReturnMonadicValuesPartialTest", generatedExplicitPartialStr)
+ , ("TypeClass: TestClass instance matches handwritten", typeClassSpecPath, "TestClass", generatedTestClassStr)
+ , ("TypeClass: MultiApplyTest instance matches handwritten", typeClassSpecPath, "MultiApplyTest", generatedMultiApplyStr)
+ , ("TypeClass: ExplicitlyReturnMonadicValuesTest instance matches handwritten", typeClassSpecPath, "ExplicitlyReturnMonadicValuesTest", generatedExplicitStr)
+ , ("TypeClass: DefaultMethodTest instance matches handwritten", typeClassSpecPath, "DefaultMethodTest", generatedDefaultMethodStr)
+ , ("TypeClass: AssocTypeTest instance matches handwritten", typeClassSpecPath, "AssocTypeTest", generatedAssocTypeStr)
+ , ("TypeClass: ParamThreeMonad instance matches handwritten", typeClassSpecPath, "ParamThreeMonad", generatedParamThreeStr)
+
+ , ("MonadVar2_1Sub instance matches handwritten", typeClassSpecPath, "MonadVar2_1Sub", generatedVar2_1SubStr)
+ , ("MonadVar2_2Sub instance matches handwritten", typeClassSpecPath, "MonadVar2_2Sub", generatedVar2_2SubStr)
+ , ("MonadVar3_1Sub instance matches handwritten", typeClassSpecPath, "MonadVar3_1Sub", generatedVar3_1SubStr)
+ , ("MonadVar3_2Sub instance matches handwritten", typeClassSpecPath, "MonadVar3_2Sub", generatedVar3_2SubStr)
+ , ("MonadVar3_3Sub instance matches handwritten", typeClassSpecPath, "MonadVar3_3Sub", generatedVar3_3SubStr)
+ ]
+ forM_ cases \(desc, manualPath, className, generatedStr) ->
+ it desc $
+ assertInstancesEquivalent manualPath className generatedStr
+
+ it "generated helper signatures do not contain duplicated Typeable constraints" do
+ let allSigMaps =
+ [ generatedFinderSigMap,
+ generatedUserInputSigMap
+ ]
+ extractTypeableTargets :: String -> [String]
+ extractTypeableTargets s =
+ let go acc txt =
+ let (_, rest) = T.breakOn (T.pack "Typeable") txt
+ in if T.null rest
+ then acc
+ else
+ let afterTypeable = T.drop (T.length (T.pack "Typeable")) rest
+ afterTrim = T.stripStart afterTypeable
+ tok = T.strip $ T.takeWhile (\c -> c /= ',' && c /= ')' && c /= '=') afterTrim
+ rest' = afterTypeable
+ in go (acc ++ [T.unpack tok]) rest'
+ in go [] (T.pack s)
+ checkMap m =
+ forM_ (Map.toList m) \(_fn, sig) -> do
+ let nsig = normalizeSignature sig
+ targets = extractTypeableTargets nsig
+ length targets `shouldBe` length (nub targets)
+ mapM_ checkMap allSigMaps
+
+ describe "Partial mock helper signatures match handwritten" do
+ it "_findIds signature matches handwritten" $
+ assertHelperSigMatches partialMockSpecPath generatedFinderSigMap "_findIds"
+
+ it "_toUserInput signature omits redundant ResolvableParamsOf constraint" do
+ let genSig =
+ Map.lookup "_toUserInput" generatedUserInputSigMap
+ case genSig of
+ Nothing ->
+ expectationFailure "TH generated signature not found: _toUserInput"
+ Just sig ->
+ normalizeSignature sig
+ `shouldSatisfy` not . T.isInfixOf (T.pack "ResolvableParamsOf") . T.pack
+
+ it "_produce signature matches handwritten" $
+ assertHelperSigMatches typeClassSpecPath generatedAssocSigMap "_produce"
+
+-- helper to extract generated instance headers from a pre-pprinted string
+extractGeneratedInstanceCxtsFromStr :: String -> String -> [String]
+extractGeneratedInstanceCxtsFromStr = extractInstanceHeaders
+
+extractInstanceHeaders :: String -> String -> [String]
+extractInstanceHeaders input className =
+ let txt = T.pack input
+ classTxt = T.pack className
+ insts = drop 1 $ T.splitOn (T.pack "instance") txt
+ mkHeader body =
+ let (beforeWhere, _) = T.breakOn (T.pack "where") body
+ (beforeBrace, _) = T.breakOn (T.pack "{") beforeWhere
+ header = T.strip beforeBrace
+ headerWithoutQualifiers = stripQualifiers header
+ headPart =
+ let (_ctxPart, rest) = T.breakOn (T.pack "=>") headerWithoutQualifiers
+ in if T.null rest
+ then headerWithoutQualifiers
+ else T.strip $ T.drop 2 rest
+ actualClassName =
+ case T.words headPart of
+ [] -> Nothing
+ (tok : _) ->
+ let cleaned = T.dropAround (`elem` "()") tok
+ in if T.null cleaned then Nothing else Just cleaned
+ containsMockT = T.pack "MockT" `T.isInfixOf` headerWithoutQualifiers
+ in case actualClassName of
+ Just cls
+ | cls == classTxt && containsMockT ->
+ Just $ normalize $ "instance " ++ T.unpack headerWithoutQualifiers
+ _ -> Nothing
+ in mapMaybe mkHeader insts
+
+assertInstancesEquivalent :: FilePath -> String -> String -> Expectation
+assertInstancesEquivalent manualPath className generatedStr = do
+ hand <- extractHandwrittenInstanceCxts manualPath className
+ let gen = extractGeneratedInstanceCxtsFromStr generatedStr className
+ sortedHand = sort hand
+ sortedGen = sort gen
+ when (null hand) $ expectationFailure $
+ "Handwritten instance not found: " ++ className ++ " in " ++ manualPath
+ when (null gen) $ expectationFailure $
+ "TH generated instance not found: " ++ className
+ ++ "\nGenerated result (prefix only):\n"
+ ++ take 1000 generatedStr
+ sortedGen `shouldBe` sortedHand
+
+extractHandwrittenFunctionSig :: FilePath -> String -> IO (Maybe String)
+extractHandwrittenFunctionSig fp funName = do
+ src <- SIO.readFile fp
+ let linesText = T.lines (T.pack src)
+ isSignatureLine line =
+ let trimmed = T.stripStart line
+ in (T.pack funName <> T.pack " ::") `T.isPrefixOf` trimmed
+ continuation line =
+ case T.uncons line of
+ Just (c, _) -> c == ' ' || c == '\t'
+ Nothing -> False
+ collect [] = Nothing
+ collect (line:rest)
+ | isSignatureLine line =
+ let cont = takeWhile continuation rest
+ in Just $ T.unpack $ T.unlines (line : cont)
+ | otherwise = collect rest
+ pure $ collect linesText
+
+stripForallClause :: String -> String
+stripForallClause sig =
+ let txt = T.pack sig
+ (preForall, rest) = T.breakOn (T.pack "forall") txt
+ in
+ if T.null rest
+ then sig
+ else
+ let afterForall = T.drop 1 $ T.dropWhile (/= '.') rest
+ in T.unpack (preForall <> afterForall)
+
+normalizeSignature :: String -> String
+normalizeSignature =
+ T.unpack
+ . T.strip
+ . T.pack
+ . dropFunctionName
+ . stripForallClause
+ . replaceDoubleParens
+ . normalize
+
+-- collapse duplicated closing parens introduced by normalization quirks
+replaceDoubleParens :: String -> String
+replaceDoubleParens = T.unpack . T.replace (T.pack "))") (T.pack ")") . T.pack
+
+dropFunctionName :: String -> String
+dropFunctionName sig =
+ let txt = T.pack sig
+ (_, rest) = T.breakOn (T.pack "::") txt
+ in
+ if T.null rest
+ then sig
+ else T.unpack $ T.drop 2 rest
+
+assertHelperSigMatches ::
+ FilePath ->
+ Map.Map String String ->
+ String ->
+ Expectation
+assertHelperSigMatches manualPath generatedSigMap funName = do
+ manualSigM <- extractHandwrittenFunctionSig manualPath funName
+ manualSig <-
+ case manualSigM of
+ Nothing -> do
+ expectationFailure $
+ "Handwritten signature not found: "
+ ++ funName
+ ++ " in "
+ ++ manualPath
+ pure ""
+ Just sig -> pure sig
+ generatedSig <-
+ case Map.lookup funName generatedSigMap of
+ Nothing -> do
+ expectationFailure $
+ "TH generated signature not found: "
+ ++ funName
+ pure ""
+ Just sig -> pure sig
+ normalizeSignature generatedSig `shouldBe` normalizeSignature manualSig
+
+
diff --git a/test/Test/MockCat/TypeClassCommonSpec.hs b/test/Test/MockCat/TypeClassCommonSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/TypeClassCommonSpec.hs
@@ -0,0 +1,831 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{- HLINT ignore "Use newtype instead of data" -}
+
+module Test.MockCat.TypeClassCommonSpec where
+
+import Prelude hiding (readFile, writeFile, any)
+import Test.Hspec
+import Test.MockCat
+import Data.Kind (Type)
+import Data.Text (Text, pack, isInfixOf)
+import Control.Exception (ErrorCall(..), displayException)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.State (MonadState(..), StateT, evalStateT)
+import Control.Monad.Trans.Class (lift)
+import Test.MockCat.SharedSpecDefs
+import qualified Data.List as List
+import Control.Concurrent.Async (async, wait)
+import Control.Monad.IO.Unlift (withRunInIO)
+import Control.Monad (unless)
+
+-- Helpers
+
+missingCall :: String -> Selector ErrorCall
+missingCall name err =
+ let needle1 = "function `" <> name <> "` was not called the expected number of times."
+ needle2 = "function `_" <> name <> "` was not called the expected number of times."
+ in (needle1 `List.isInfixOf` displayException err) || (needle2 `List.isInfixOf` displayException err)
+
+-- Orphan Instances needed for testing
+
+instance MonadState s m => MonadState s (MockT m) where
+ get = lift get
+ put = lift . put
+ state f = lift (state f)
+
+-- Programs under test
+
+data Environment = Environment { inputPath :: String, outputPath :: String }
+ deriving (Show, Eq)
+
+apiFileOperationProgram ::
+ (MonadReader Environment m, FileOperation m, ApiOperation m) =>
+ (Text -> Text) ->
+ m ()
+apiFileOperationProgram modifyText = do
+ e <- ask
+ content <- readFile (inputPath e)
+ let modifiedContent = modifyText content
+ writeFile (outputPath e) modifiedContent
+ post $ modifiedContent <> pack ("+" <> show e)
+
+operationProgram ::
+ (FileOperation m) =>
+ FilePath ->
+ FilePath ->
+ m ()
+operationProgram inputPath outputPath = do
+ content <- readFile inputPath
+ unless (pack "ngWord" `isInfixOf` content) $
+ writeFile outputPath content
+
+operationProgram2 ::
+ (FileOperation m, ApiOperation m) =>
+ FilePath ->
+ FilePath ->
+ (Text -> Text) ->
+ m ()
+operationProgram2 inputPath outputPath modifyText = do
+ content <- readFile inputPath
+ let modifiedContent = modifyText content
+ writeFile outputPath modifiedContent
+ post modifiedContent
+
+operationProgram3 ::
+ MonadReader Environment m =>
+ FileOperation m =>
+ m ()
+operationProgram3 = do
+ (Environment inputPath outputPath) <- ask
+ content <- readFile inputPath
+ writeFile outputPath content
+
+echoProgram :: (MonadIO m, TestClass m) => String -> m ()
+echoProgram s = do
+ v <- getBy s
+ liftIO $ print v
+ echo $ show v
+
+echoProgramExplicit :: ExplicitlyReturnMonadicValuesTest m => String -> m ()
+echoProgramExplicit s = do
+ v <- getByExplicit s
+ echoExplicit $ show v
+
+processFiles :: (MonadAsync m, FileOperation m) => [FilePath] -> m [Text]
+processFiles = mapConcurrently readFile
+
+echo2 :: Teletype m => m ()
+echo2 = do
+ i <- readTTY
+ case i of
+ "" -> pure ()
+ _ -> writeTTY i >> echo2
+
+-- Specs
+-- Type-level utilities to derive MockBuilder arg-lists from function types
+type family PrependParam (p :: Type) (rest :: Type) :: Type where
+ PrependParam p () = p
+ PrependParam p rest = p :> rest
+
+type family ArgsOfF (f :: Type) :: Type where
+ ArgsOfF (a -> b) = PrependParam (Param a) (ArgsOfF b)
+ ArgsOfF r = ()
+
+-- Generic Mock alias for a function type f
+type MockFor f = forall params. (MockBuilder params f (ArgsOfF f)) => params -> MockT IO f
+-- Generic Mock alias for an arbitrary base monad m
+type MockForM m f = forall params. (MockBuilder params f (ArgsOfF f)) => params -> MockT m f
+
+-- Per-spec dependency records to group required builders/mocks
+data BasicDeps = BasicDeps
+ { _readFile :: MockFor (FilePath -> Text)
+ , _writeFile :: MockFor (FilePath -> Text -> ())
+ }
+
+data MixedDeps = MixedDeps
+ { _readFile :: MockFor (FilePath -> Text)
+ , _writeFile :: MockFor (FilePath -> Text -> ())
+ , _post :: MockFor (Text -> ())
+ }
+
+data MultipleDeps = MultipleDeps
+ { _ask :: Environment -> MockT IO Environment
+ , _readFile :: MockFor (FilePath -> Text)
+ , _writeFile:: MockFor (FilePath -> Text -> ())
+ , _post :: MockFor (Text -> ())
+ }
+
+
+
+data ReaderContextDeps = ReaderContextDeps
+ { _ask :: Environment -> MockT IO Environment
+ , _readFile :: MockFor (FilePath -> Text)
+ , _writeFile:: MockFor (FilePath -> Text -> ())
+ }
+
+data SequentialIODeps = SequentialIODeps
+ { _readTTY :: MockFor (IO String)
+ , _writeTTY :: MockFor (String -> IO ())
+ }
+
+data ImplicitMonadicReturnDeps = ImplicitMonadicReturnDeps
+ { _getBy :: MockFor (String -> IO Int)
+ , _echo :: MockFor (String -> IO ())
+ }
+
+data ArgumentPatternMatchingDeps = ArgumentPatternMatchingDeps
+ { _getValueBy :: MockFor (String -> IO String)
+ }
+
+data MonadStateTransformerDeps = MonadStateTransformerDeps
+ { _fnState :: MockForM (StateT String IO) (Maybe String -> StateT String IO String)
+ , _fnState2 :: MockForM (StateT String IO) (String -> StateT String IO ())
+ }
+
+data MultiParamTypeClassArityDeps = MultiParamTypeClassArityDeps
+ { _fn2_1Sub :: MockFor (String -> IO ())
+ , _fn2_2Sub :: MockFor (String -> IO ())
+ , _fn3_1Sub :: MockFor (String -> IO ())
+ , _fn3_2Sub :: MockFor (String -> IO ())
+ , _fn3_3Sub :: MockFor (String -> IO ())
+ }
+
+data FunctionalDependenciesDeps = FunctionalDependenciesDeps
+ { _fnParam3_1 :: MockFor (Int -> Bool -> IO String)
+ , _fnParam3_2 :: MockFor (IO Int)
+ , _fnParam3_3 :: MockFor (IO Bool)
+ }
+
+data ExplicitMonadicReturnDeps = ExplicitMonadicReturnDeps
+ { _getByExplicit :: MockFor (String -> IO Int)
+ , _echoExplicit :: MockFor (String -> IO ())
+ }
+
+data DefaultMethodDeps = DefaultMethodDeps
+ { _defaultAction :: Int -> MockT IO Int
+ }
+
+data AssociatedTypeFamiliesDeps = AssociatedTypeFamiliesDeps
+ { _produce :: Int -> MockT IO Int
+ }
+
+data ConcurrencyAndUnliftIODeps = ConcurrencyAndUnliftIODeps
+ { _readFile :: MockFor (FilePath -> Text)
+ }
+
+-- backward-compatible constructor pattern synonyms (preserve old names used by test modules)
+pattern TtyDeps :: MockFor (IO String) -> MockFor (String -> IO ()) -> SequentialIODeps
+pattern TtyDeps r w <- SequentialIODeps { _readTTY = r, _writeTTY = w }
+ where TtyDeps r w = SequentialIODeps { _readTTY = r, _writeTTY = w }
+
+pattern TestClassDeps :: MockFor (String -> IO Int) -> MockFor (String -> IO ()) -> ImplicitMonadicReturnDeps
+pattern TestClassDeps g e <- ImplicitMonadicReturnDeps { _getBy = g, _echo = e }
+ where TestClassDeps g e = ImplicitMonadicReturnDeps { _getBy = g, _echo = e }
+
+pattern MultiApplyDeps :: MockFor (String -> IO String) -> ArgumentPatternMatchingDeps
+pattern MultiApplyDeps f <- ArgumentPatternMatchingDeps { _getValueBy = f }
+ where MultiApplyDeps f = ArgumentPatternMatchingDeps { _getValueBy = f }
+
+pattern StateDeps :: MockForM (StateT String IO) (Maybe String -> StateT String IO String) -> MockForM (StateT String IO) (String -> StateT String IO ()) -> MonadStateTransformerDeps
+pattern StateDeps s s2 <- MonadStateTransformerDeps { _fnState = s, _fnState2 = s2 }
+ where StateDeps s s2 = MonadStateTransformerDeps { _fnState = s, _fnState2 = s2 }
+
+pattern MultiParamDeps :: MockFor (String -> IO ()) -> MockFor (String -> IO ()) -> MockFor (String -> IO ()) -> MockFor (String -> IO ()) -> MockFor (String -> IO ()) -> MultiParamTypeClassArityDeps
+pattern MultiParamDeps a b c d e <- MultiParamTypeClassArityDeps { _fn2_1Sub = a, _fn2_2Sub = b, _fn3_1Sub = c, _fn3_2Sub = d, _fn3_3Sub = e }
+ where MultiParamDeps a b c d e = MultiParamTypeClassArityDeps { _fn2_1Sub = a, _fn2_2Sub = b, _fn3_1Sub = c, _fn3_2Sub = d, _fn3_3Sub = e }
+
+pattern FunDeps :: MockFor (Int -> Bool -> IO String) -> MockFor (IO Int) -> MockFor (IO Bool) -> FunctionalDependenciesDeps
+pattern FunDeps a b c <- FunctionalDependenciesDeps { _fnParam3_1 = a, _fnParam3_2 = b, _fnParam3_3 = c }
+ where FunDeps a b c = FunctionalDependenciesDeps { _fnParam3_1 = a, _fnParam3_2 = b, _fnParam3_3 = c }
+
+pattern ExplicitReturnDeps :: MockFor (String -> IO Int) -> MockFor (String -> IO ()) -> ExplicitMonadicReturnDeps
+pattern ExplicitReturnDeps a b <- ExplicitMonadicReturnDeps { _getByExplicit = a, _echoExplicit = b }
+ where ExplicitReturnDeps a b = ExplicitMonadicReturnDeps { _getByExplicit = a, _echoExplicit = b }
+
+pattern AssocTypeDeps :: (Int -> MockT IO Int) -> AssociatedTypeFamiliesDeps
+pattern AssocTypeDeps f <- AssociatedTypeFamiliesDeps { _produce = f }
+ where AssocTypeDeps f = AssociatedTypeFamiliesDeps { _produce = f }
+
+pattern ConcurrencyDeps :: MockFor (FilePath -> Text) -> ConcurrencyAndUnliftIODeps
+pattern ConcurrencyDeps r <- ConcurrencyAndUnliftIODeps { _readFile = r }
+ where ConcurrencyDeps r = ConcurrencyAndUnliftIODeps { _readFile = r }
+
+-- Aggregate all per-spec dependency groups + standalone mocks into one record
+data SpecDeps = SpecDeps
+ { basicDeps :: BasicDeps
+ , mixedDeps :: MixedDeps
+ , multipleDeps :: MultipleDeps
+
+ , readerContextDeps :: ReaderContextDeps
+ , sequentialIODeps :: SequentialIODeps
+ , ttyDeps :: SequentialIODeps
+ , implicitMonadicReturnDeps :: ImplicitMonadicReturnDeps
+ , testClassDeps :: ImplicitMonadicReturnDeps
+ , argumentPatternMatchingDeps :: ArgumentPatternMatchingDeps
+ , multiApplyDeps :: ArgumentPatternMatchingDeps
+ , monadStateTransformerDeps :: MonadStateTransformerDeps
+ , stateDeps :: MonadStateTransformerDeps
+ , multiParamTypeClassArityDeps :: MultiParamTypeClassArityDeps
+ , multiParamDeps :: MultiParamTypeClassArityDeps
+ , functionalDependenciesDeps :: FunctionalDependenciesDeps
+ , funDeps :: FunctionalDependenciesDeps
+ , explicitMonadicReturnDeps :: ExplicitMonadicReturnDeps
+ , explicitReturnDeps :: ExplicitMonadicReturnDeps
+ , defaultMethodDeps :: DefaultMethodDeps
+ , assocTypeDeps :: AssociatedTypeFamiliesDeps
+ , associatedTypeFamiliesDeps :: AssociatedTypeFamiliesDeps
+ , concurrencyAndUnliftIODeps :: ConcurrencyAndUnliftIODeps
+ , concurrencyDeps :: ConcurrencyAndUnliftIODeps
+ }
+
+-- SpecDeps is defined above; test modules construct a `SpecDeps` and call the individual specs
+-- Aggregated entry point: call all specs from a single SpecDeps
+spec ::
+ ( Teletype (MockT IO)
+ , FileOperation (MockT IO)
+ , ApiOperation (MockT IO)
+ , MonadReader Environment (MockT IO)
+ , TestClass (MockT IO)
+ , MultiApplyTest (MockT IO)
+ , MonadVar2_1Sub (MockT IO) String
+ , MonadVar2_2Sub String (MockT IO)
+ , MonadVar3_1Sub (MockT IO) String String
+ , MonadVar3_2Sub String (MockT IO) String
+ , MonadVar3_3Sub String String (MockT IO)
+ , MonadStateSub String (MockT (StateT String IO))
+ , MonadStateSub2 String (MockT (StateT String IO))
+ , ParamThreeMonad Int Bool (MockT IO)
+ , ExplicitlyReturnMonadicValuesTest (MockT IO)
+ , DefaultMethodTest (MockT IO)
+ , AssocTypeTest (MockT IO)
+ , ResultType (MockT IO) ~ Int
+ , MonadAsync (MockT IO)
+ ) =>
+ SpecDeps ->
+ Spec
+spec deps = do
+ specSequentialIOStubbing deps.sequentialIODeps
+ specBasicStubbingAndVerification deps.basicDeps
+ specMixedMockingStrategies deps.mixedDeps
+ specMultipleTypeclassConstraints deps.multipleDeps
+
+ specImplicitMonadicReturnValues deps.implicitMonadicReturnDeps
+ specArgumentPatternMatching deps.argumentPatternMatchingDeps
+ specMultiParamTypeClassArity deps.multiParamTypeClassArityDeps
+ specMonadStateTransformerSupport deps.monadStateTransformerDeps
+ specFunctionalDependenciesSupport deps.functionalDependenciesDeps
+ specExplicitMonadicReturnValues deps.explicitMonadicReturnDeps
+ specDefaultMethodMocking deps.defaultMethodDeps
+ specAssociatedTypeFamiliesSupport deps.associatedTypeFamiliesDeps
+ specConcurrencyAndUnliftIO deps.concurrencyAndUnliftIODeps
+ specMonadReaderContextMocking deps.readerContextDeps
+
+ -- Verification failures
+ specBasicVerificationFailureDetection deps.basicDeps
+
+ specMonadReaderVerificationFailureDetection deps.readerContextDeps
+ specImplicitReturnVerificationFailureDetection deps.implicitMonadicReturnDeps
+ specMultiParamVerificationFailureDetection deps.multiParamTypeClassArityDeps
+ specArgumentMatchingVerificationFailureDetection deps.argumentPatternMatchingDeps
+ specFunDepsVerificationFailureDetection deps.functionalDependenciesDeps
+ specExplicitReturnVerificationFailureDetection deps.explicitMonadicReturnDeps
+ specAdvancedTypesVerificationFailureDetection deps.defaultMethodDeps deps.associatedTypeFamiliesDeps
+ specSequentialStubbingVerificationFailureDetection deps.sequentialIODeps
+
+specBasicStubbingAndVerification ::
+ ( FileOperation (MockT IO)
+ ) =>
+ BasicDeps ->
+ Spec
+specBasicStubbingAndVerification (BasicDeps { _readFile, _writeFile }) = do
+ it "Program reads content and writes it to output path" do
+ result <- runMockT do
+ _ <- _readFile $ "input.txt" ~> pack "content"
+ _ <- _writeFile $ "output.txt" ~> pack "content" ~> ()
+ operationProgram "input.txt" "output.txt"
+
+ result `shouldBe` ()
+
+ it "Program skips file write when input content contains 'ngWord'" do
+ result <- runMockT do
+ _ <- _readFile ("input.txt" ~> pack "contains ngWord")
+ _ <- _writeFile ("output.txt" ~> any ~> ())
+ `expects` do
+ called never
+ operationProgram "input.txt" "output.txt"
+
+ result `shouldBe` ()
+
+specMixedMockingStrategies ::
+ ( FileOperation (MockT IO)
+ , ApiOperation (MockT IO)
+ ) =>
+ MixedDeps ->
+ Spec
+specMixedMockingStrategies (MixedDeps { _readFile, _writeFile, _post }) = do
+ it "Program reads, modifies content via stub, writes, and posts result" do
+ modifyContentStub <- mock $ pack "content" ~> pack "modifiedContent"
+
+ result <- runMockT do
+ _ <- _readFile $ "input.txt" ~> pack "content"
+ _ <- _writeFile ("output.text" ~> pack "modifiedContent" ~> ())
+ _ <- _post (pack "modifiedContent" ~> ())
+ operationProgram2 "input.txt" "output.text" modifyContentStub
+
+ result `shouldBe` ()
+
+specMultipleTypeclassConstraints ::
+ ( FileOperation (MockT IO)
+ , ApiOperation (MockT IO)
+ , MonadReader Environment (MockT IO)
+ ) =>
+ MultipleDeps ->
+ Spec
+specMultipleTypeclassConstraints (MultipleDeps { _ask, _readFile, _writeFile, _post }) = do
+ it "Composed program successfully reads environment, processes file, and posts combined result" do
+ modifyContentStub <- mock $ pack "content" ~> pack "modifiedContent"
+ let env = Environment "input.txt" "output.text"
+
+ result <- runMockT do
+ _ <- _ask env
+ _ <- _readFile ("input.txt" ~> pack "content")
+ _ <- _writeFile ("output.text" ~> pack "modifiedContent" ~> ())
+ _ <- _post ((pack "modifiedContent" <> pack ("+" <> show env)) ~> ())
+ apiFileOperationProgram modifyContentStub
+
+ result `shouldBe` ()
+
+
+
+specMonadReaderContextMocking ::
+ ( MonadReader Environment (MockT IO)
+ , FileOperation (MockT IO)
+ ) =>
+ ReaderContextDeps ->
+ Spec
+specMonadReaderContextMocking (ReaderContextDeps { _ask, _readFile, _writeFile }) = do
+ it "Program successfully uses MonadReader to find paths and executes FileOperation" do
+ r <- runMockT do
+ _ <- _ask (Environment "input.txt" "output.txt")
+ _ <- _readFile ("input.txt" ~> pack "content")
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
+ operationProgram3
+ r `shouldBe` ()
+
+specSequentialIOStubbing ::
+ ( Teletype (MockT IO)
+ ) =>
+ SequentialIODeps ->
+ Spec
+specSequentialIOStubbing (SequentialIODeps { _readTTY, _writeTTY }) = do
+ it "Recursive program echo2 reads sequential input and writes output until empty string" do
+ result <- runMockT do
+ _ <- _readTTY $ casesIO ["a", ""]
+ _ <- _writeTTY $ "a" ~> pure @IO ()
+ echo2
+ result `shouldBe` ()
+
+specImplicitMonadicReturnValues ::
+ ( TestClass (MockT IO)
+ ) =>
+ ImplicitMonadicReturnDeps ->
+ Spec
+specImplicitMonadicReturnValues (ImplicitMonadicReturnDeps { _getBy, _echo }) = do
+ it "Program correctly uses and echoes the implicitly stubbed monadic return value" do
+ result <- runMockT do
+ _ <- _getBy $ "s" ~> pure @IO (10 :: Int)
+ _ <- _echo $ "10" ~> pure @IO ()
+ echoProgram "s"
+
+ result `shouldBe` ()
+
+specArgumentPatternMatching ::
+ ( MultiApplyTest (MockT IO)
+ ) =>
+ ArgumentPatternMatchingDeps ->
+ Spec
+specArgumentPatternMatching (ArgumentPatternMatchingDeps { _getValueBy }) = do
+ it "Multi-case stubbing correctly dispatches and collects results for distinct arguments" do
+ result <- runMockT do
+ _ <- _getValueBy $ do
+ onCase $ "a" ~> pure @IO "ax"
+ onCase $ "b" ~> pure @IO "bx"
+ onCase $ "c" ~> pure @IO "cx"
+ getValues ["a", "b", "c"]
+ result `shouldBe` ["ax", "bx", "cx"]
+
+specMonadStateTransformerSupport ::
+ ( MonadStateSub String (MockT (StateT String IO))
+ , MonadStateSub2 String (MockT (StateT String IO))
+ ) =>
+ MonadStateTransformerDeps ->
+ Spec
+specMonadStateTransformerSupport (MonadStateTransformerDeps { _fnState, _fnState2 }) = do
+ it "Mock with StateT correctly consumes input and returns next value" do
+ let action = runMockT $ do
+ _ <- _fnState $ do
+ onCase $ Just "current" ~> pure @(StateT String IO) "next"
+ onCase $ Nothing ~> pure @(StateT String IO) "default"
+ fnState (Just "current")
+ result <- evalStateT action "seed"
+ result `shouldBe` "next"
+
+ it "Mock in StateT correctly executes and leaves the state unchanged (unit return)" do
+ let action = runMockT $ do
+ _ <- _fnState2 $ "label" ~> pure @(StateT String IO) ()
+ fnState2 @String "label"
+ result <- evalStateT action "initial"
+ result `shouldBe` ()
+
+specMultiParamTypeClassArity ::
+ ( MonadVar2_1Sub (MockT IO) String
+ , MonadVar2_2Sub String (MockT IO)
+ , MonadVar3_1Sub (MockT IO) String String
+ , MonadVar3_2Sub String (MockT IO) String
+ , MonadVar3_3Sub String String (MockT IO)
+ ) =>
+ MultiParamTypeClassArityDeps ->
+ Spec
+specMultiParamTypeClassArity (MultiParamTypeClassArityDeps { _fn2_1Sub, _fn2_2Sub, _fn3_1Sub, _fn3_2Sub, _fn3_3Sub }) = do
+ it "Type variable MonadVar2_1Sub is correctly resolved and mocked" do
+ result <- runMockT do
+ _ <- _fn2_1Sub $ "alpha" ~> pure @IO ()
+ fn2_1Sub @(MockT IO) @String "alpha"
+ result `shouldBe` ()
+
+ it "Type variable MonadVar2_2Sub is correctly resolved and mocked" do
+ result <- runMockT do
+ _ <- _fn2_2Sub $ "beta" ~> pure @IO ()
+ fn2_2Sub @String @(MockT IO) "beta"
+ result `shouldBe` ()
+
+ it "Type variable MonadVar3_1Sub is correctly resolved and mocked" do
+ result <- runMockT do
+ _ <- _fn3_1Sub $ "gamma" ~> pure @IO ()
+ fn3_1Sub @(MockT IO) @String @String "gamma"
+ result `shouldBe` ()
+
+ it "Type variable MonadVar3_2Sub is correctly resolved and mocked" do
+ result <- runMockT do
+ _ <- _fn3_2Sub $ "delta" ~> pure @IO ()
+ fn3_2Sub @String @(MockT IO) @String "delta"
+ result `shouldBe` ()
+
+ it "Type variable MonadVar3_3Sub is correctly resolved and mocked" do
+ result <- runMockT do
+ _ <- _fn3_3Sub $ "epsilon" ~> pure @IO ()
+ fn3_3Sub @String @String @(MockT IO) "epsilon"
+ result `shouldBe` ()
+
+specFunctionalDependenciesSupport ::
+ ( ParamThreeMonad Int Bool (MockT IO)
+ ) =>
+ FunctionalDependenciesDeps ->
+ Spec
+specFunctionalDependenciesSupport (FunctionalDependenciesDeps { _fnParam3_1, _fnParam3_2, _fnParam3_3 }) = do
+ it "FunDeps are correctly resolved allowing multiple actions to return values" do
+ result <- runMockT $ do
+ _ <- _fnParam3_1 $ do
+ onCase $ (1 :: Int) ~> True ~> pure @IO "combined"
+ _ <- _fnParam3_2 $ casesIO [1 :: Int]
+ _ <- _fnParam3_3 $ casesIO [True]
+ r1 <- fnParam3_1 (1 :: Int) True
+ r2 <- fnParam3_2
+ r3 <- fnParam3_3
+ pure (r1, r2, r3)
+ result `shouldBe` ("combined", 1, True)
+
+specExplicitMonadicReturnValues ::
+ ( ExplicitlyReturnMonadicValuesTest (MockT IO)
+ ) =>
+ ExplicitMonadicReturnDeps ->
+ Spec
+specExplicitMonadicReturnValues (ExplicitMonadicReturnDeps { _getByExplicit, _echoExplicit }) = do
+ it "Explicitly stubbed function returns value and subsequent action is verified" do
+ result <- runMockT do
+ _ <- _getByExplicit $ "key" ~> pure @IO (42 :: Int)
+ _ <- _echoExplicit $ "value" ~> pure @IO ()
+ v <- getByExplicit "key"
+ echoExplicit "value"
+ pure v
+ result `shouldBe` 42
+
+ it "Helper program correctly uses and echoes the explicitly stubbed monadic return value" do
+ result <- runMockT do
+ _ <- _getByExplicit $ "s" ~> pure @IO (10 :: Int)
+ _ <- _echoExplicit $ "10" ~> pure @IO ()
+ echoProgramExplicit "s"
+ result `shouldBe` ()
+
+specDefaultMethodMocking ::
+ ( DefaultMethodTest (MockT IO)
+ ) =>
+ DefaultMethodDeps ->
+ Spec
+specDefaultMethodMocking (DefaultMethodDeps { _defaultAction }) = do
+ it "Default method is successfully overridden and stubbed value is returned" do
+ result <- runMockT do
+ _ <- _defaultAction (99 :: Int)
+ defaultAction
+ result `shouldBe` 99
+
+specAssociatedTypeFamiliesSupport ::
+ ( AssocTypeTest (MockT IO)
+ , ResultType (MockT IO) ~ Int
+ ) =>
+ AssociatedTypeFamiliesDeps ->
+ Spec
+specAssociatedTypeFamiliesSupport (AssociatedTypeFamiliesDeps { _produce }) = do
+ it "Associated Type family is correctly resolved and mocked stub value is returned" do
+ v <- runMockT do
+ _ <- _produce (321 :: Int)
+ produce
+ v `shouldBe` 321
+
+specConcurrencyAndUnliftIO ::
+ ( MonadAsync (MockT IO)
+ , FileOperation (MockT IO)
+ ) =>
+ ConcurrencyAndUnliftIODeps ->
+ Spec
+specConcurrencyAndUnliftIO (ConcurrencyAndUnliftIODeps { _readFile }) = do
+ it "Concurrent execution (mapConcurrently) correctly calls and collects results from mocks" do
+ result <- runMockT do
+ _ <- _readFile $ do
+ onCase $ "file1.txt" ~> pack "content1"
+ onCase $ "file2.txt" ~> pack "content2"
+ processFiles ["file1.txt", "file2.txt"]
+ result `shouldBe` [pack "content1", pack "content2"]
+
+ it "MonadUnliftIO correctly handles internal async operation and verification" do
+ result <- runMockT do
+ _ <- _readFile $ do
+ onCase $ "test.txt" ~> pack "content"
+
+ content <- withRunInIO $ \runInIO -> do
+ asyncAction <- async $ runInIO (readFile "test.txt")
+ wait asyncAction
+
+ liftIO $ content `shouldBe` pack "content"
+ pure content
+
+ result `shouldBe` pack "content"
+
+ it "MonadUnliftIO basic runInIO functionality is verified correctly" do
+ result <- runMockT do
+ _ <- _readFile $ do
+ onCase $ "test.txt" ~> pack "test content"
+
+ content <- withRunInIO $ \runInIO -> do
+ runInIO (readFile "test.txt")
+
+ liftIO $ content `shouldBe` pack "test content"
+ pure content
+
+ result `shouldBe` pack "test content"
+
+-- Verification Failure Tests
+
+specBasicVerificationFailureDetection ::
+ ( FileOperation (MockT IO)
+ ) =>
+ BasicDeps ->
+ Spec
+specBasicVerificationFailureDetection (BasicDeps { _readFile, _writeFile }) = describe "verification failures (FileOperation)" do
+ it "Error when read stub is defined but target function readFile is never called" do
+ (runMockT @IO do
+ _ <- _readFile ("input.txt" ~> pack "content")
+ `expects` do
+ called once
+ -- readFile is never called
+ pure ()) `shouldThrow` missingCall "readFile"
+
+ it "Error when write stub is defined but target function writeFile is never called" do
+ (runMockT @IO do
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
+ `expects` do
+ called once
+ -- writeFile is never called
+ pure ()) `shouldThrow` missingCall "writeFile"
+
+ it "Error when read stub expects call but only writeFile is executed" do
+ (runMockT @IO do
+ _ <- _readFile ("input.txt" ~> pack "content")
+ `expects` do
+ called once
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
+ -- readFile is never called, only writeFile is called
+ do
+ writeFile "output.txt" (pack "content")
+ pure ()) `shouldThrow` missingCall "readFile"
+
+ it "Error when write stub expects call but only readFile is executed" do
+ (runMockT @IO do
+ _ <- _readFile ("input.txt" ~> pack "content")
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
+ `expects` do
+ called once
+ -- writeFile is never called, only readFile is called
+ do
+ readFile "input.txt") `shouldThrow` missingCall "writeFile"
+
+
+
+specMonadReaderVerificationFailureDetection ::
+ ReaderContextDeps ->
+ Spec
+specMonadReaderVerificationFailureDetection (ReaderContextDeps { _ask }) = describe "verification failures (Reader Environment)" do
+ it "Error when MonadReader stub _ask is defined but target function ask is never called" do
+ (runMockT @IO do
+ _ <- _ask (Environment "input.txt" "output.txt")
+ `expects` do
+ called once
+ -- ask is never called
+ pure ()) `shouldThrow` missingCall "ask"
+
+specImplicitReturnVerificationFailureDetection ::
+ ImplicitMonadicReturnDeps ->
+ Spec
+specImplicitReturnVerificationFailureDetection (ImplicitMonadicReturnDeps { _getBy, _echo }) = describe "verification failures (TestClass)" do
+ it "Error when _getBy stub expects call but getBy is never executed" do
+ (runMockT @IO do
+ _ <- _getBy ("s" ~> pure @IO (10 :: Int))
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_getBy"
+
+ it "Error when _echo stub expects call but echo is never executed" do
+ (runMockT @IO do
+ _ <- _echo ("10" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_echo"
+
+specMultiParamVerificationFailureDetection ::
+ MultiParamTypeClassArityDeps ->
+ Spec
+specMultiParamVerificationFailureDetection (MultiParamTypeClassArityDeps { _fn2_1Sub, _fn2_2Sub, _fn3_1Sub, _fn3_2Sub, _fn3_3Sub }) = describe "verification failures (SubVars)" do
+ it "Error when _fn2_1Sub stub expects call but fn2_1Sub is never executed" do
+ (runMockT @IO do
+ _ <- _fn2_1Sub ("alpha" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fn2_1Sub"
+
+ it "Error when _fn2_2Sub stub expects call but fn2_2Sub is never executed" do
+ (runMockT @IO do
+ _ <- _fn2_2Sub ("beta" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fn2_2Sub"
+
+ it "Error when _fn3_1Sub stub expects call but fn3_1Sub is never executed" do
+ (runMockT @IO do
+ _ <- _fn3_1Sub ("gamma" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fn3_1Sub"
+
+ it "Error when _fn3_2Sub stub expects call but fn3_2Sub is never executed" do
+ (runMockT @IO do
+ _ <- _fn3_2Sub ("delta" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fn3_2Sub"
+
+ it "Error when _fn3_3Sub stub expects call but fn3_3Sub is never executed" do
+ (runMockT @IO do
+ _ <- _fn3_3Sub ("epsilon" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fn3_3Sub"
+
+specArgumentMatchingVerificationFailureDetection ::
+ ArgumentPatternMatchingDeps ->
+ Spec
+specArgumentMatchingVerificationFailureDetection (ArgumentPatternMatchingDeps { _getValueBy }) = describe "verification failures (MultiApply)" do
+ it "Error when multi-case stub _getValueBy expects call but getValueBy is never executed" do
+ (runMockT @IO do
+ _ <- _getValueBy (do onCase $ "a" ~> pure @IO "ax")
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_getValueBy"
+
+specFunDepsVerificationFailureDetection ::
+ FunctionalDependenciesDeps ->
+ Spec
+specFunDepsVerificationFailureDetection (FunctionalDependenciesDeps { _fnParam3_1, _fnParam3_2, _fnParam3_3 }) = describe "verification failures (ParamThreeMonad)" do
+ it "Error when FunDep stub _fnParam3_1 expects call but fnParam3_1 is never executed" do
+ (runMockT @IO do
+ _ <- _fnParam3_1 (do
+ onCase $ (1 :: Int) ~> True ~> pure @IO "combined")
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fnParam3_1"
+
+ it "Error when FunDep stub _fnParam3_2 expects call but fnParam3_2 is never executed" do
+ (runMockT @IO do
+ _ <- _fnParam3_2 (casesIO [1 :: Int])
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fnParam3_2"
+
+ it "Error when FunDep stub _fnParam3_3 expects call but fnParam3_3 is never executed" do
+ (runMockT @IO do
+ _ <- _fnParam3_3 (casesIO [True])
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_fnParam3_3"
+
+specExplicitReturnVerificationFailureDetection ::
+ ExplicitMonadicReturnDeps ->
+ Spec
+specExplicitReturnVerificationFailureDetection (ExplicitMonadicReturnDeps { _getByExplicit, _echoExplicit }) = describe "verification failures (ExplicitReturn)" do
+ it "Error when explicit stub _getByExplicit expects call but getByExplicit is never executed" do
+ (runMockT @IO do
+ _ <- _getByExplicit ("key" ~> pure @IO (42 :: Int))
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_getByExplicit"
+
+ it "Error when explicit stub _echoExplicit expects call but echoExplicit is never executed" do
+ (runMockT @IO do
+ _ <- _echoExplicit ("value" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_echoExplicit"
+
+specAdvancedTypesVerificationFailureDetection ::
+ DefaultMethodDeps ->
+ AssociatedTypeFamiliesDeps ->
+ Spec
+specAdvancedTypesVerificationFailureDetection (DefaultMethodDeps { _defaultAction }) (AssociatedTypeFamiliesDeps { _produce }) = describe "verification failures (Default/Assoc)" do
+ it "Error when default method stub _defaultAction expects call but defaultAction is never executed" do
+ (runMockT @IO do
+ _ <- _defaultAction (99 :: Int)
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_defaultAction"
+
+ it "Error when associated type stub _produce expects call but produce is never executed" do
+ (runMockT @IO do
+ _ <- _produce (321 :: Int)
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_produce"
+
+specSequentialStubbingVerificationFailureDetection ::
+ SequentialIODeps ->
+ Spec
+specSequentialStubbingVerificationFailureDetection (SequentialIODeps { _readTTY, _writeTTY }) = describe "verification failures (TTY)" do
+ it "Error when sequential stub _readTTY expects call but readTTY is never executed" do
+ (runMockT @IO do
+ _ <- _readTTY (casesIO ["a", ""])
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_readTTY"
+
+ it "Error when sequential stub _writeTTY expects call but writeTTY is never executed" do
+ (runMockT @IO do
+ _ <- _writeTTY ("a" ~> pure @IO ())
+ `expects` do
+ called once
+ pure ()) `shouldThrow` missingCall "_writeTTY"
diff --git a/test/Test/MockCat/TypeClassSpec.hs b/test/Test/MockCat/TypeClassSpec.hs
--- a/test/Test/MockCat/TypeClassSpec.hs
+++ b/test/Test/MockCat/TypeClassSpec.hs
@@ -3,16 +3,22 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DuplicateRecordFields #-}
module Test.MockCat.TypeClassSpec (spec) where
-import Data.Text (Text, pack)
-import Test.Hspec (Spec, it, shouldBe)
+import Data.Text (Text)
+import Test.Hspec (Spec)
import Test.MockCat
import Prelude hiding (readFile, writeFile)
import Data.Data
@@ -24,184 +30,583 @@
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader.Class (ask, MonadReader (local))
import Control.Monad.Trans.Class (lift)
-
-class Monad m => FileOperation m where
- readFile :: FilePath -> m Text
- writeFile :: FilePath -> Text -> m ()
-
-class Monad m => ApiOperation m where
- post :: Text -> m ()
+import Control.Monad.State (MonadState (..))
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import qualified Test.MockCat.Verify as Verify
+import Test.MockCat.SharedSpecDefs
+import qualified Test.MockCat.TypeClassCommonSpec as SpecCommon
+import Test.MockCat.Internal.Types (BuiltMock(..))
+import qualified Test.MockCat.Internal.MockRegistry as Registry (register)
-program ::
- (MonadReader String m, FileOperation m, ApiOperation m) =>
- FilePath ->
- FilePath ->
- (Text -> Text) ->
+ensureVerifiable ::
+ ( MonadIO m
+ , Verify.ResolvableMock target
+ ) =>
+ target ->
m ()
-program inputPath outputPath modifyText = do
- e <- ask
- content <- readFile inputPath
- let modifiedContent = modifyText content
- writeFile outputPath modifiedContent
- post $ modifiedContent <> pack ("+" <> e)
+ensureVerifiable target =
+ liftIO $ do
+ m <- Verify.resolveForVerification target
+ case m of { Just _ -> pure (); Nothing -> Verify.verificationFailure }
+
instance MonadIO m => FileOperation (MockT m) where
readFile path = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `readFile`.") $ findParam (Proxy :: Proxy "readFile") defs
- !result = stubFn mock path
+ mockFn = fromMaybe (error "no answer found stub function `readFile`.") $ findParam (Proxy :: Proxy "readFile") defs
+ !result = mockFn path
pure result
writeFile path content = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `writeFile`.") $ findParam (Proxy :: Proxy "writeFile") defs
- !result = stubFn mock path content
+ mockFn = fromMaybe (error "no answer found stub function `writeFile`.") $ findParam (Proxy :: Proxy "writeFile") defs
+ !result = mockFn path content
pure result
instance MonadIO m => ApiOperation (MockT m) where
post content = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `post`.") $ findParam (Proxy :: Proxy "post") defs
- !result = stubFn mock content
+ mockFn = fromMaybe (error "no answer found stub function `post`.") $ findParam (Proxy :: Proxy "post") defs
+ !result = mockFn content
pure result
-instance MonadIO m => MonadReader String (MockT m) where
+instance MonadIO m => MonadReader SpecCommon.Environment (MockT m) where
ask = MockT do
defs <- getDefinitions
let
mock = fromMaybe (error "no answer found stub function `ask`.") $ findParam (Proxy :: Proxy "ask") defs
- !result = stubFn mock
+ !result = mock
pure result
local = undefined
-_ask :: MonadIO m => params -> MockT m ()
+-- instance MonadState s m => MonadState s (MockT m) where
+-- get = lift get
+-- put = lift . put
+-- state f = lift (state f)
+
+_ask ::
+ ( Verify.ResolvableParamsOf env ~ ()
+ , MonadIO m
+ , Typeable env
+ , Show env
+ , Eq env
+ ) =>
+ env ->
+ MockT m env
_ask p = MockT $ do
- mockInstance <- liftIO $ createNamedConstantMock "ask" p
- addDefinition (Definition (Proxy :: Proxy "ask") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "ask" (Head :> param p)
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "ask") mockInstance NoVerification)
+ pure mockInstance
-_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), MonadIO m) => params -> MockT m ()
+_readFile ::
+ ( MockBuilder params (FilePath -> Text) (Param FilePath)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (FilePath -> Text)
_readFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "readFile" p
- addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "readFile" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance NoVerification)
+ pure mockInstance
-_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), MonadIO m) => params -> MockT m ()
+_writeFile ::
+ ( MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (FilePath -> Text -> ())
_writeFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "writeFile" p
- addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "writeFile" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification)
+ pure mockInstance
-_post :: (MockBuilder params (Text -> ()) (Param Text), MonadIO m) => params -> MockT m ()
+_post ::
+ ( MockBuilder params (Text -> ()) (Param Text)
+ , MonadIO m
+ ) =>
+ params ->
+ MockT m (Text -> ())
_post p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "post" p
- addDefinition (Definition (Proxy :: Proxy "post") mockInstance shouldApplyToAnything)
+ mockFn <- liftIO $ createNamedMockFnWithParams "post" p
+ ensureVerifiable mockFn
+ addDefinition (Definition (Proxy :: Proxy "post") mockFn NoVerification)
+ pure mockFn
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
-
-class Monad m => TestClass m where
- echo :: String -> m ()
- getBy :: String -> m Int
+ fmap (\(Definition _ f _) -> unsafeCoerce f) definition
-echoProgram :: MonadIO m => TestClass m => String -> m ()
-echoProgram s = do
- v <- getBy s
- liftIO $ print v
- echo $ show v
+instance AssocTypeTest IO where
+ type ResultType IO = Int
+ produce = pure 0
instance MonadIO m => TestClass (MockT m) where
getBy a = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `_getBy`.") $ findParam (Proxy :: Proxy "_getBy") defs
- !result = stubFn mock a
+ mockFn = fromMaybe (error "no answer found stub function `_getBy`.") $ findParam (Proxy :: Proxy "_getBy") defs
+ !result = mockFn a
lift result
echo a = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `_echo`.") $ findParam (Proxy :: Proxy "_echo") defs
- !result = stubFn mock a
+ mockFn = fromMaybe (error "no answer found stub function `_echo`.") $ findParam (Proxy :: Proxy "_echo") defs
+ !result = mockFn a
lift result
-_getBy :: (MockBuilder params (String -> m Int) (Param String), MonadIO m) => params -> MockT m ()
+instance
+ ( Eq s
+ , Show s
+ , MonadState s m
+ , MonadIO m
+ ) =>
+ MonadStateSub s (MockT m)
+ where
+ fnState maybeValue = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fnState`.") $ findParam (Proxy :: Proxy "_fnState") defs
+ !result = mockFn maybeValue
+ lift result
+
+instance
+ ( MonadState String m
+ , MonadIO m
+ ) =>
+ MonadStateSub2 s (MockT m)
+ where
+ fnState2 label = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fnState2`.") $ findParam (Proxy :: Proxy "_fnState2") defs
+ !result = mockFn label
+ lift result
+
+instance Monad m => MonadVar2_1 (MockT m) a
+instance MonadIO m => MonadVar2_1Sub (MockT m) a where
+ fn2_1Sub tag = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fn2_1Sub`.") $ findParam (Proxy :: Proxy "_fn2_1Sub") defs
+ !result = mockFn tag
+ lift result
+
+instance MonadIO m => MonadVar3_1 (MockT m) a b
+instance MonadIO m => MonadVar3_1Sub (MockT m) a b where
+ fn3_1Sub tag = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fn3_1Sub`.") $ findParam (Proxy :: Proxy "_fn3_1Sub") defs
+ !result = mockFn tag
+ lift result
+
+instance MonadIO m => MonadVar3_2 a (MockT m) b
+instance MonadIO m => MonadVar3_2Sub a (MockT m) b where
+ fn3_2Sub tag = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fn3_2Sub`.") $ findParam (Proxy :: Proxy "_fn3_2Sub") defs
+ !result = mockFn tag
+ lift result
+
+instance Monad m => MonadVar2_2 a (MockT m)
+instance MonadIO m => MonadVar2_2Sub a (MockT m) where
+ fn2_2Sub tag = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fn2_2Sub`.") $ findParam (Proxy :: Proxy "_fn2_2Sub") defs
+ !result = mockFn tag
+ lift result
+
+instance MonadIO m => MonadVar3_3 a b (MockT m)
+instance MonadIO m => MonadVar3_3Sub a b (MockT m) where
+ fn3_3Sub tag = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fn3_3Sub`.") $ findParam (Proxy :: Proxy "_fn3_3Sub") defs
+ !result = mockFn tag
+ lift result
+
+instance MonadIO m => MultiApplyTest (MockT m) where
+ getValueBy key = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_getValueBy`.") $ findParam (Proxy :: Proxy "_getValueBy") defs
+ !result = mockFn key
+ lift result
+
+instance MonadIO m => ExplicitlyReturnMonadicValuesTest (MockT m) where
+ getByExplicit label = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_getByExplicit`.") $ findParam (Proxy :: Proxy "_getByExplicit") defs
+ !result = mockFn label
+ lift result
+ echoExplicit label = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_echoExplicit`.") $ findParam (Proxy :: Proxy "_echoExplicit") defs
+ !result = mockFn label
+ lift result
+
+instance MonadIO m => DefaultMethodTest (MockT m) where
+ defaultAction = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_defaultAction`.") $ findParam (Proxy :: Proxy "_defaultAction") defs
+ !result = mockFn
+ pure result
+
+instance MonadIO m => AssocTypeTest (MockT m) where
+ type ResultType (MockT m) = ResultType m
+ produce = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_produce`.") $ findParam (Proxy :: Proxy "_produce") defs
+ !result = mockFn
+ pure result
+
+instance MonadIO m => ParamThreeMonad Int Bool (MockT m) where
+ fnParam3_1 a b = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fnParam3_1`.") $ findParam (Proxy :: Proxy "_fnParam3_1") defs
+ !result = mockFn a b
+ lift result
+ fnParam3_2 = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fnParam3_2`.") $ findParam (Proxy :: Proxy "_fnParam3_2") defs
+ !result = mockFn
+ lift result
+ fnParam3_3 = MockT do
+ defs <- getDefinitions
+ let
+ mockFn = fromMaybe (error "no answer found stub function `_fnParam3_3`.") $ findParam (Proxy :: Proxy "_fnParam3_3") defs
+ !result = mockFn
+ lift result
+
+instance (MonadUnliftIO m) => MonadAsync (MockT m) where
+ mapConcurrently = traverse
+
+_getBy ::
+ ( MockBuilder params (String -> m Int) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m Int) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m Int)
_getBy p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "_getBy" p
- addDefinition (Definition (Proxy :: Proxy "_getBy") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_getBy" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_getBy") mockInstance NoVerification)
+ pure mockInstance
-_echo :: (MockBuilder params (String -> m ()) (Param String), MonadIO m) => params -> MockT m ()
+_echo ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
_echo p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "_echo" p
- addDefinition (Definition (Proxy :: Proxy "_echo") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_echo" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_echo") mockInstance NoVerification)
+ pure mockInstance
+_fn2_1Sub ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fn2_1Sub p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fn2_1Sub" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fn2_1Sub") mockInstance NoVerification)
+ pure mockInstance
-class Monad m => Teletype m where
- readTTY :: m String
- writeTTY :: String -> m ()
+_fn2_2Sub ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fn2_2Sub p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fn2_2Sub" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fn2_2Sub") mockInstance NoVerification)
+ pure mockInstance
-echo2 :: Teletype m => m ()
-echo2 = do
- i <- readTTY
- case i of
- "" -> pure ()
- _ -> writeTTY i >> echo2
+_fn3_1Sub ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fn3_1Sub p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_1Sub" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fn3_1Sub") mockInstance NoVerification)
+ pure mockInstance
+_fn3_2Sub ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fn3_2Sub p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_2Sub" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fn3_2Sub") mockInstance NoVerification)
+ pure mockInstance
+
+_fn3_3Sub ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fn3_3Sub p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_3Sub" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fn3_3Sub") mockInstance NoVerification)
+ pure mockInstance
+
+_getValueBy ::
+ ( MockBuilder params (String -> m String) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m String) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m String)
+_getValueBy p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_getValueBy" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_getValueBy") mockInstance NoVerification)
+ pure mockInstance
+
+_fnState ::
+ ( MockBuilder params (Maybe s -> m s) (Param (Maybe s))
+ , MonadIO m
+ , Typeable m
+ , Typeable s
+ , Verify.ResolvableParamsOf (Maybe s -> m s) ~ Param (Maybe s)
+ ) =>
+ params ->
+ MockT m (Maybe s -> m s)
+_fnState p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fnState" p
+ addDefinition (Definition (Proxy :: Proxy "_fnState") mockInstance NoVerification)
+ pure mockInstance
+
+_fnState2 ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_fnState2 p = MockT $ do
+ BuiltMock { builtMockFn = mockInstance, builtMockRecorder = verifier } <- liftIO $ buildMock (Just "_fnState2") p
+ registeredFn <- liftIO $ Registry.register (Just "_fnState2") verifier mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fnState2") registeredFn NoVerification)
+ pure mockInstance
+
+_fnParam3_1 ::
+ ( MockBuilder params (Int -> Bool -> m String) (Param Int :> Param Bool)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (Int -> Bool -> m String) ~ (Param Int :> Param Bool)
+ ) =>
+ params ->
+ MockT m (Int -> Bool -> m String)
+_fnParam3_1 p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_1" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fnParam3_1") mockInstance NoVerification)
+ pure mockInstance
+
+_fnParam3_2 ::
+ ( MockBuilder params (m Int) ()
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (m Int) ~ ()
+ ) =>
+ params ->
+ MockT m (m Int)
+_fnParam3_2 p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_2" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fnParam3_2") mockInstance NoVerification)
+ pure mockInstance
+
+_fnParam3_3 ::
+ ( MockBuilder params (m Bool) ()
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (m Bool) ~ ()
+ ) =>
+ params ->
+ MockT m (m Bool)
+_fnParam3_3 p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_3" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_fnParam3_3") mockInstance NoVerification)
+ pure mockInstance
+
+_getByExplicit ::
+ ( MockBuilder params (String -> m Int) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m Int) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m Int)
+_getByExplicit p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_getByExplicit" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_getByExplicit") mockInstance NoVerification)
+ pure mockInstance
+
+_echoExplicit ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
+_echoExplicit p = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_echoExplicit" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_echoExplicit") mockInstance NoVerification)
+ pure mockInstance
+
+_defaultAction ::
+ ( MonadIO m
+ , Verify.ResolvableParamsOf a ~ ()
+ , Typeable a
+ , Show a
+ , Eq a
+ ) =>
+ a ->
+ MockT m a
+_defaultAction value = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_defaultAction" (Head :> param value)
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_defaultAction") mockInstance NoVerification)
+ pure mockInstance
+
+_produce ::
+ ( MonadIO m
+ , Verify.ResolvableParamsOf a ~ ()
+ , Typeable a
+ , Show a
+ , Eq a
+ ) =>
+ a ->
+ MockT m a
+_produce value = MockT $ do
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_produce" (Head :> param value)
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_produce") mockInstance NoVerification)
+ pure mockInstance
+
instance MonadIO m => Teletype (MockT m) where
readTTY = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `_readTTY`.") $ findParam (Proxy :: Proxy "_readTTY") defs
- !result = stubFn mock
+ mockFn = fromMaybe (error "no answer found stub function `_readTTY`.") $ findParam (Proxy :: Proxy "_readTTY") defs
+ !result = mockFn
lift result
writeTTY a = MockT do
defs <- getDefinitions
let
- mock = fromMaybe (error "no answer found stub function `_writeTTY`.") $ findParam (Proxy :: Proxy "_writeTTY") defs
- !result = stubFn mock a
+ mockFn = fromMaybe (error "no answer found stub function `_writeTTY`.") $ findParam (Proxy :: Proxy "_writeTTY") defs
+ !result = mockFn a
lift result
-_readTTY :: (MockBuilder params (m String) (), MonadIO m) => params -> MockT m ()
+_readTTY ::
+ ( MockBuilder params (m String) ()
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (m String) ~ ()
+ ) =>
+ params ->
+ MockT m (m String)
_readTTY p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "_readTTY" p
- addDefinition (Definition (Proxy :: Proxy "_readTTY") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_readTTY" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_readTTY") mockInstance NoVerification)
+ pure mockInstance
-_writeTTY :: (MockBuilder params (String -> m ()) (Param String), MonadIO m) => params -> MockT m ()
+_writeTTY ::
+ ( MockBuilder params (String -> m ()) (Param String)
+ , MonadIO m
+ , Typeable m
+ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String
+ ) =>
+ params ->
+ MockT m (String -> m ())
_writeTTY p = MockT $ do
- mockInstance <- liftIO $ createNamedMock "_writeTTY" p
- addDefinition (Definition (Proxy :: Proxy "_writeTTY") mockInstance shouldApplyToAnything)
+ mockInstance <- liftIO $ createNamedMockFnWithParams "_writeTTY" p
+ ensureVerifiable mockInstance
+ addDefinition (Definition (Proxy :: Proxy "_writeTTY") mockInstance NoVerification)
+ pure mockInstance
spec :: Spec
spec = do
- it "echo" do
- result <- runMockT do
- _readTTY $ casesIO [
- "a",
- ""
- ]
- _writeTTY $ "a" |> pure @IO ()
- echo2
- result `shouldBe` ()
-
- it "Read, edit, and output files" do
- modifyContentStub <- createStubFn $ pack "content" |> pack "modifiedContent"
-
- result <- runMockT do
- _ask "environment"
- _readFile ("input.txt" |> pack "content")
- _writeFile $ "output.text" |> pack "modifiedContent" |> ()
- _post $ pack "modifiedContent+environment" |> ()
- program "input.txt" "output.text" modifyContentStub
-
- result `shouldBe` ()
-
- it "return monadic value test" do
- result <- runMockT do
- _getBy $ "s" |> pure @IO (10 :: Int)
- _echo $ "10" |> pure @IO ()
- echoProgram "s"
+ -- build SpecDeps and call aggregated spec entrypoint
+ let deps = SpecCommon.SpecDeps
+ { SpecCommon.basicDeps = SpecCommon.BasicDeps _readFile _writeFile
+ , SpecCommon.mixedDeps = SpecCommon.MixedDeps _readFile _writeFile _post
+ , SpecCommon.multipleDeps = SpecCommon.MultipleDeps _ask _readFile _writeFile _post
- result `shouldBe` ()
+ , SpecCommon.readerContextDeps = SpecCommon.ReaderContextDeps _ask _readFile _writeFile
+ , SpecCommon.sequentialIODeps = SpecCommon.SequentialIODeps _readTTY _writeTTY
+ , SpecCommon.ttyDeps = SpecCommon.TtyDeps _readTTY _writeTTY
+ , SpecCommon.implicitMonadicReturnDeps = SpecCommon.ImplicitMonadicReturnDeps _getBy _echo
+ , SpecCommon.testClassDeps = SpecCommon.TestClassDeps _getBy _echo
+ , SpecCommon.argumentPatternMatchingDeps = SpecCommon.ArgumentPatternMatchingDeps _getValueBy
+ , SpecCommon.multiApplyDeps = SpecCommon.MultiApplyDeps _getValueBy
+ , SpecCommon.monadStateTransformerDeps = SpecCommon.MonadStateTransformerDeps _fnState _fnState2
+ , SpecCommon.stateDeps = SpecCommon.StateDeps _fnState _fnState2
+ , SpecCommon.multiParamTypeClassArityDeps = SpecCommon.MultiParamTypeClassArityDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub
+ , SpecCommon.multiParamDeps = SpecCommon.MultiParamDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub
+ , SpecCommon.functionalDependenciesDeps = SpecCommon.FunctionalDependenciesDeps _fnParam3_1 _fnParam3_2 _fnParam3_3
+ , SpecCommon.funDeps = SpecCommon.FunDeps _fnParam3_1 _fnParam3_2 _fnParam3_3
+ , SpecCommon.explicitMonadicReturnDeps = SpecCommon.ExplicitMonadicReturnDeps _getByExplicit _echoExplicit
+ , SpecCommon.explicitReturnDeps = SpecCommon.ExplicitReturnDeps _getByExplicit _echoExplicit
+ , SpecCommon.defaultMethodDeps = SpecCommon.DefaultMethodDeps _defaultAction
+ , SpecCommon.associatedTypeFamiliesDeps = SpecCommon.AssociatedTypeFamiliesDeps _produce
+ , SpecCommon.assocTypeDeps = SpecCommon.AssocTypeDeps _produce
+ , SpecCommon.concurrencyAndUnliftIODeps = SpecCommon.ConcurrencyAndUnliftIODeps _readFile
+ , SpecCommon.concurrencyDeps = SpecCommon.ConcurrencyDeps _readFile
+ }
+ SpecCommon.spec deps
diff --git a/test/Test/MockCat/TypeClassTHSpec.hs b/test/Test/MockCat/TypeClassTHSpec.hs
--- a/test/Test/MockCat/TypeClassTHSpec.hs
+++ b/test/Test/MockCat/TypeClassTHSpec.hs
@@ -6,230 +6,75 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
module Test.MockCat.TypeClassTHSpec (spec) where
import Prelude hiding (readFile, writeFile, any)
-import Data.Text (Text, pack, isInfixOf)
import Test.Hspec
import Test.MockCat
-import Control.Monad.State
-import Control.Monad.Reader (MonadReader, ask)
-import Control.Monad (unless)
-import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO)
-import Control.Concurrent.Async (async, wait)
-
-class Monad m => FileOperation m where
- writeFile :: FilePath -> Text -> m ()
- readFile :: FilePath -> m Text
-
-class Monad m => ApiOperation m where
- post :: Text -> m ()
-
-operationProgram ::
- FileOperation m =>
- FilePath ->
- FilePath ->
- m ()
-operationProgram inputPath outputPath = do
- content <- readFile inputPath
- unless (pack "ngWord" `isInfixOf` content) $
- writeFile outputPath content
-
-operationProgram2 ::
- (FileOperation m, ApiOperation m) =>
- FilePath ->
- FilePath ->
- (Text -> Text) ->
- m ()
-operationProgram2 inputPath outputPath modifyText = do
- content <- readFile inputPath
- let modifiedContent = modifyText content
- writeFile outputPath modifiedContent
- post modifiedContent
-
-data Environment = Environment { inputPath :: String, outputPath :: String }
-
-operationProgram3 ::
- MonadReader Environment m =>
- FileOperation m =>
- m ()
-operationProgram3 = do
- (Environment inputPath outputPath) <- ask
- content <- readFile inputPath
- writeFile outputPath content
-
-class (Eq s, Show s, MonadState s m) => MonadStateSub s m where
- fn_state :: Maybe s -> m s
-
-class (MonadState String m) => MonadStateSub2 s m where
- fn_state2 :: String -> m ()
-
-class Monad m => MonadVar2_1 m a where
-class MonadVar2_1 m a => MonadVar2_1Sub m a where
- fn2_1Sub :: String -> m ()
-
-class Monad m => MonadVar2_2 a m where
-class MonadVar2_2 a m => MonadVar2_2Sub a m where
- fn2_2Sub :: String -> m ()
-
-class MonadIO m => MonadVar3_1 m a b where
-class MonadVar3_1 m a b => MonadVar3_1Sub m a b where
- fn3_1Sub :: String -> m ()
-
-class MonadIO m => MonadVar3_2 a m b where
-class MonadVar3_2 a m b => MonadVar3_2Sub a m b where
- fn3_2Sub :: String -> m ()
-
-class MonadIO m => MonadVar3_3 a b m where
-class MonadVar3_3 a b m => MonadVar3_3Sub a b m where
- fn3_3Sub :: String -> m ()
+import Control.Monad.Reader (MonadReader)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Test.MockCat.SharedSpecDefs
+import qualified Test.MockCat.TypeClassCommonSpec as SpecCommon
---makeMock [t|MonadReader Bool|]
-makeMock [t|MonadReader Environment|]
+--makeAutoLiftMock [t|MonadReader Bool|]
+makeAutoLiftMock [t|MonadReader SpecCommon.Environment|]
makeMock [t|MonadVar2_1Sub|]
makeMock [t|MonadVar2_2Sub|]
makeMock [t|MonadVar3_1Sub|]
makeMock [t|MonadVar3_2Sub|]
makeMock [t|MonadVar3_3Sub|]
-makeMock [t|FileOperation|]
-makeMockWithOptions [t|ApiOperation|] options { prefix = "stub_", suffix = "_fn" }
-
-class Monad m => ParamThreeMonad a b m | m -> a, m -> b where
- fnParam3_1 :: a -> b -> m String
- fnParam3_2 :: m a
- fnParam3_3 :: m b
-
-
-
-class Monad m => MultiApplyTest m where
- getValueBy :: String -> m String
-
-getValues :: MultiApplyTest m => [String] -> m [String]
-getValues = mapM getValueBy
-
+makeAutoLiftMock [t|FileOperation|]
+makeAutoLiftMock [t|ApiOperation|]
makeMock [t|MultiApplyTest|]
-
-class Monad m => ExplicitlyReturnMonadicValuesTest m where
- echo :: String -> m ()
- getBy :: String -> m Int
-
-echoProgram :: ExplicitlyReturnMonadicValuesTest m => String -> m ()
-echoProgram s = do
- v <- getBy s
- echo $ show v
-
-makeMockWithOptions [t|ExplicitlyReturnMonadicValuesTest|] options { implicitMonadicReturn = False }
-
-class MonadUnliftIO m => MonadAsync m where
- mapConcurrently :: Traversable t => (a -> m b) -> t a -> m (t b)
+makeMock [t|ParamThreeMonad Int Bool|]
+makeMock [t|MonadStateSub|]
+makeMock [t|MonadStateSub2|]
+makeMock [t|Teletype|]
+makeMock [t|ExplicitlyReturnMonadicValuesTest|]
+makeAutoLiftMock [t|DefaultMethodTest|]
+makeAutoLiftMock [t|AssocTypeTest|]
+makeMock [t|TestClass|]
instance (MonadUnliftIO m) => MonadAsync (MockT m) where
mapConcurrently = traverse
-processFiles :: MonadAsync m => FileOperation m => [FilePath] -> m [Text]
-processFiles = mapConcurrently readFile
+instance AssocTypeTest IO where
+ type ResultType IO = Int
+ produce = pure 0
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` ()
-
- it "Read, and output files (contain ng word)" do
- result <- runMockT do
- _readFile ("input.txt" |> pack "contains ngWord")
- _writeFile ("output.txt" |> any |> ()) `applyTimesIs` 0
- operationProgram "input.txt" "output.txt"
-
- result `shouldBe` ()
-
- it "Read, and output files (contain ng word)2" do
- result <- runMockT do
- _readFile ("input.txt" |> pack "contains ngWord")
- neverApply $ _writeFile ("output.txt" |> any |> ())
- operationProgram "input.txt" "output.txt"
-
- result `shouldBe` ()
-
- 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" |> ())
- operationProgram3
- r `shouldBe` ()
-
-
- it "Read, edit, and output files2" do
- modifyContentStub <- createStubFn $ pack "content" |> pack "modifiedContent"
-
- result <- runMockT do
- _readFile $ "input.txt" |> pack "content"
- _writeFile ("output.text" |> pack "modifiedContent" |> ())
- stub_post_fn (pack "modifiedContent" |> ())
- operationProgram2 "input.txt" "output.text" modifyContentStub
-
- result `shouldBe` ()
-
-
- it "Multi apply" do
- result <- runMockT do
- _getValueBy $ do
- onCase $ "a" |> "ax"
- onCase $ "b" |> "bx"
- onCase $ "c" |> "cx"
- getValues ["a", "b", "c"]
- result `shouldBe` ["ax", "bx", "cx"]
-
- it "Return monadic value test" do
- result <- runMockT do
- _getBy $ "s" |> pure @IO (10 :: Int)
- _echo $ "10" |> pure @IO ()
- echoProgram "s"
-
- result `shouldBe` ()
-
- it "MonadUnliftIO instance works correctly" do
- result <- runMockT do
- _readFile ("test.txt" |> pack "content")
-
- content <- withRunInIO $ \runInIO -> do
- asyncAction <- async $ runInIO (readFile "test.txt")
- wait asyncAction
-
- liftIO $ content `shouldBe` pack "content"
- pure content
-
- result `shouldBe` pack "content"
-
- it "MonadUnliftIO basic functionality" do
- result <- runMockT do
- _readFile ("test.txt" |> pack "test content")
-
- content <- withRunInIO $ \runInIO -> do
- runInIO (readFile "test.txt")
-
- liftIO $ content `shouldBe` pack "test content"
- pure content
-
- result `shouldBe` pack "test content"
-
- it "MonadAsync type class can be instantiated for MockT" do
- result <- runMockT do
- _readFile $ do
- onCase $ "file1.txt" |> pack "content1"
- onCase $ "file2.txt" |> pack "content2"
-
- processFiles ["file1.txt", "file2.txt"]
- result `shouldBe` [pack "content1", pack "content2"]
+ -- build SpecDeps and call aggregated spec entrypoint
+ let deps = SpecCommon.SpecDeps
+ { SpecCommon.basicDeps = SpecCommon.BasicDeps _readFile _writeFile
+ , SpecCommon.mixedDeps = SpecCommon.MixedDeps _readFile _writeFile _post
+ , SpecCommon.multipleDeps = SpecCommon.MultipleDeps _ask _readFile _writeFile _post
+ , SpecCommon.readerContextDeps = SpecCommon.ReaderContextDeps _ask _readFile _writeFile
+ , SpecCommon.sequentialIODeps = SpecCommon.SequentialIODeps _readTTY _writeTTY
+ , SpecCommon.ttyDeps = SpecCommon.TtyDeps _readTTY _writeTTY
+ , SpecCommon.implicitMonadicReturnDeps = SpecCommon.ImplicitMonadicReturnDeps _getBy _echo
+ , SpecCommon.testClassDeps = SpecCommon.TestClassDeps _getBy _echo
+ , SpecCommon.argumentPatternMatchingDeps = SpecCommon.ArgumentPatternMatchingDeps _getValueBy
+ , SpecCommon.multiApplyDeps = SpecCommon.MultiApplyDeps _getValueBy
+ , SpecCommon.monadStateTransformerDeps = SpecCommon.MonadStateTransformerDeps _fnState _fnState2
+ , SpecCommon.stateDeps = SpecCommon.StateDeps _fnState _fnState2
+ , SpecCommon.multiParamTypeClassArityDeps = SpecCommon.MultiParamTypeClassArityDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub
+ , SpecCommon.multiParamDeps = SpecCommon.MultiParamDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub
+ , SpecCommon.functionalDependenciesDeps = SpecCommon.FunctionalDependenciesDeps _fnParam3_1 _fnParam3_2 _fnParam3_3
+ , SpecCommon.funDeps = SpecCommon.FunDeps _fnParam3_1 _fnParam3_2 _fnParam3_3
+ , SpecCommon.explicitMonadicReturnDeps = SpecCommon.ExplicitMonadicReturnDeps _getByExplicit _echoExplicit
+ , SpecCommon.explicitReturnDeps = SpecCommon.ExplicitReturnDeps _getByExplicit _echoExplicit
+ , SpecCommon.defaultMethodDeps = SpecCommon.DefaultMethodDeps _defaultAction
+ , SpecCommon.associatedTypeFamiliesDeps = SpecCommon.AssociatedTypeFamiliesDeps _produce
+ , SpecCommon.assocTypeDeps = SpecCommon.AssocTypeDeps _produce
+ , SpecCommon.concurrencyAndUnliftIODeps = SpecCommon.ConcurrencyAndUnliftIODeps _readFile
+ , SpecCommon.concurrencyDeps = SpecCommon.ConcurrencyDeps _readFile
+ }
+ SpecCommon.spec deps
diff --git a/test/Test/MockCat/UnsafeCheck.hs b/test/Test/MockCat/UnsafeCheck.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/UnsafeCheck.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+module Test.MockCat.UnsafeCheck where
+
+import GHC.IO (unsafePerformIO)
+import Test.Inspection (inspect, doesNotUse)
+import Test.MockCat
+
+simpleStubExample :: String -> Bool
+simpleStubExample = stub $ "value" ~> True
+
+monadicMockExample :: IO (String -> IO Bool)
+monadicMockExample = mockM $ "value" ~> True
+
+pureMockExample :: IO (String -> Bool)
+pureMockExample = mock $ "value" ~> True
+
+inspect $ 'simpleStubExample `doesNotUse` 'unsafePerformIO
+inspect $ 'monadicMockExample `doesNotUse` 'unsafePerformIO
+inspect $ 'pureMockExample `doesNotUse` 'unsafePerformIO
+
+{-
+-- The following check demonstrates that calling the inspection to a pure
+-- binding built via `mock` indeed fails (because `mock` relies on
+-- unsafePerformIO internally). We keep it commented out so the suite passes.
+{-# NOINLINE pureMockPure #-}
+pureMockPure :: String -> Bool
+pureMockPure = unsafePerformIO $ do
+ f <- mock $ "value" ~> True
+ pure f
+
+inspect $ 'pureMockPure `doesNotUse` 'unsafePerformIO
+-}
+
diff --git a/test/Test/MockCat/WithMockSpec.hs b/test/Test/MockCat/WithMockSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/WithMockSpec.hs
@@ -0,0 +1,461 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.MockCat.WithMockSpec (spec) where
+
+import Prelude hiding (readFile, writeFile, any)
+import Data.Text (pack)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow, anyErrorCall)
+import Test.MockCat
+import Test.MockCat.SharedSpecDefs
+import GHC.IO (evaluate)
+import Control.Concurrent.Async (async, wait)
+import Control.Concurrent (threadDelay)
+import Control.Monad (void, forM, forM_)
+import Control.Monad.IO.Unlift (withRunInIO)
+import Control.Monad.IO.Class (liftIO)
+import Control.Exception (try, ErrorCall(..))
+
+-- Generate mocks for FileOperation
+makeAutoLiftMock [t|FileOperation|]
+
+perCall :: Int -> a -> a
+perCall _ x = x
+
+operationProgram ::
+ FileOperation m =>
+ FilePath ->
+ FilePath ->
+ m ()
+operationProgram inputPath outputPath = do
+ content <- readFile inputPath
+ writeFile outputPath content
+
+spec :: Spec
+spec = do
+ describe "withMock basic functionality" $ do
+ it "simple mock with expects" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` (called once `with` "a")
+ liftIO $ mockFn "a" `shouldBe` True
+
+ it "simple mock with expects using param" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` (called once `with` param "a")
+ liftIO $ mockFn "a" `shouldBe` True
+
+ it "fails when not called" $ do
+ withMock (do
+ _ <- mock (any ~> True)
+ `expects` (called once `with` "a")
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "error message when not called" $ do
+ result <- try $ withMock $ do
+ _ <- mock (any ~> True)
+ `expects` (called once `with` "a")
+ pure ()
+ case result of
+ Left (ErrorCall msg) -> do
+ let expected =
+ "function was not called the expected number of times with the expected arguments.\n" <>
+ " expected: 1\n" <>
+ " but got: 0"
+ msg `shouldBe` expected
+ _ -> fail "Expected ErrorCall"
+
+ it "atLeast expectation" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` (called (atLeast 2) `with` "a")
+
+ void $ liftIO $ evaluate $ mockFn "a"
+ void $ liftIO $ evaluate $ mockFn "a"
+ void $ liftIO $ evaluate $ mockFn "a"
+
+ it "anything expectation" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` called once
+
+ void $ liftIO $ evaluate $ mockFn "a"
+
+ it "anything expectation fails when not called" $ do
+ withMock (do
+ _ <- mock (any @String ~> True)
+ `expects` called once
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "anything expectation error message when not called" $ do
+ result <- try $ withMock $ do
+ _ <- mock (any @String ~> True)
+ `expects` called once
+ pure ()
+ case result of
+ Left (ErrorCall msg) -> do
+ let expected =
+ "function was not called the expected number of times.\n" <>
+ " expected: 1\n" <>
+ " but got: 0"
+ msg `shouldBe` expected
+ _ -> fail "Expected ErrorCall"
+
+ it "never expectation without args succeeds when not called" $ do
+ withMock $ do
+ _ <- mock (any @String ~> True)
+ `expects` called never
+ pure ()
+
+ it "never expectation without args fails when called" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` called never
+ liftIO $ mockFn "a" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "never expectation with args succeeds when not called with that arg" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` (called never `with` "z")
+ liftIO $ mockFn "a" `shouldBe` True
+ pure ()
+
+ it "never expectation with args fails when called with that arg" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` (called never `with` "z")
+ liftIO $ mockFn "z" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "multiple expectations in do block" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 2) `with` "a"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ pure ()
+
+ it "multiple expectations in do block fails when not all satisfied" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 2) `with` "a"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ -- missing: mockFn "b"
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "multiple expectations in do block with never" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called once `with` "a"
+ called never `with` "z"
+ liftIO $ mockFn "a" `shouldBe` True
+ pure ()
+
+ it "multiple expectations in do block with never fails when violated" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called once `with` "a"
+ called never `with` "z"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "z" `shouldBe` True -- This should fail
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "multiple expectations with different counts" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 3) `with` "a"
+ called (atLeast 2) `with` "b"
+ called once `with` "c"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ liftIO $ mockFn "c" `shouldBe` True
+ pure ()
+
+ it "multiple expectations fails when count is insufficient" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 3) `with` "a"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ -- missing one more "a" call
+ liftIO $ mockFn "b" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "multiple expectations fails when atLeast is not satisfied" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (atLeast 2) `with` "a"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ -- missing one more "a" call (need at least 2)
+ liftIO $ mockFn "b" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "multiple expectations with mixed never and count" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 2) `with` "a"
+ called never `with` "z"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ pure ()
+
+ it "multiple expectations with never fails when never is violated" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ called (times 2) `with` "a"
+ called never `with` "z"
+ called once `with` "b"
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "z" `shouldBe` True -- This should fail
+ pure ()) `shouldThrow` anyErrorCall
+
+
+ describe "withMock verification failures" $ do
+ it "fails when called fewer times than expected" $ do
+ withMock (do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called (times 3) `with` "a"
+
+ liftIO $ evaluate $ mockFn "a"
+ liftIO $ evaluate $ mockFn "a"
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "fails when called with unexpected arguments" $ do
+ withMock (do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called once `with` "a"
+
+ liftIO $ evaluate $ mockFn "b"
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "fails when called but never expected" $ do
+ withMock (do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called never `with` "z"
+
+ liftIO $ evaluate $ mockFn "z"
+ pure ()) `shouldThrow` anyErrorCall
+
+ describe "withMock with runMockT" $ do
+ it "can use runMockT inside withMock" $ do
+ withMock $ do
+ result <- runMockT do
+ _readFile $ "input.txt" ~> pack "content"
+ _writeFile $ "output.txt" ~> pack "content" ~> ()
+ operationProgram "input.txt" "output.txt"
+
+ liftIO $ result `shouldBe` ()
+
+ describe "order verification" $ do
+ it "calledInOrder succeeds when called in correct order" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInOrder ["a", "b", "c"]
+
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ liftIO $ mockFn "c" `shouldBe` True
+ pure ()
+
+ it "calledInOrder fails when called in wrong order" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInOrder ["a", "b", "c"]
+
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "c" `shouldBe` True -- Wrong order: should be "b"
+ liftIO $ mockFn "b" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "calledInOrder fails when not all calls are made" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInOrder ["a", "b", "c"]
+
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True
+ -- missing: mockFn "c"
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "calledInSequence succeeds when sequence is followed" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInSequence ["a", "c"]
+
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "b" `shouldBe` True -- This is ignored
+ liftIO $ mockFn "c" `shouldBe` True
+ pure ()
+
+ it "calledInSequence fails when sequence is violated" $ do
+ withMock (do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInSequence ["a", "c"]
+
+ liftIO $ mockFn "c" `shouldBe` True -- Wrong: "a" should come first
+ liftIO $ mockFn "a" `shouldBe` True
+ pure ()) `shouldThrow` anyErrorCall
+
+ it "calledInSequence succeeds with extra calls in between" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInSequence ["a", "c"]
+
+ liftIO $ mockFn "a" `shouldBe` True
+ liftIO $ mockFn "x" `shouldBe` True
+ liftIO $ mockFn "y" `shouldBe` True
+ liftIO $ mockFn "c" `shouldBe` True
+ pure ()
+
+ describe "multiple mocks" $ do
+ it "can define multiple mocks in withMock" $ do
+ withMock $ do
+ fn1 <- mock (any @String ~> True)
+ `expects` do
+ called once `with` "a"
+
+ fn2 <- mock (any @String ~> any @String ~> False)
+ `expects` do
+ called once `with` ("x" ~> "y")
+
+ liftIO $ fn1 "a" `shouldBe` True
+ liftIO $ fn2 "x" "y" `shouldBe` False
+ pure ()
+
+ describe "withMock scope isolation" $ do
+ it "mocks from different withMock blocks do not interfere" $ do
+ -- First withMock block: expect one call
+ withMock $ do
+ fn1 <- mock (any ~> True)
+ `expects` do
+ called once `with` "a"
+ liftIO $ evaluate $ fn1 "a"
+
+ -- Second withMock block: expect zero (if leaked, would see 1 and fail)
+ withMock $ do
+ _ <- mock (any ~> True)
+ `expects` do
+ called never `with` "a"
+ pure ()
+
+ it "multiple sequential withMock blocks are independent" $ do
+ -- Block 1: call with "x"
+ withMock $ do
+ fn1 <- mock (any ~> True)
+ `expects` do
+ called once `with` "x"
+ liftIO $ evaluate $ fn1 "x"
+
+ -- Block 2: call with "y"
+ withMock $ do
+ fn2 <- mock (any ~> True)
+ `expects` do
+ called once `with` "y"
+ liftIO $ evaluate $ fn2 "y"
+
+ -- Block 3: no calls
+ withMock $ do
+ _ <- mock (any ~> True)
+ `expects` do
+ called never `with` "z"
+ pure ()
+
+ describe "withMock concurrency" $ do
+ it "counts calls across parallel threads" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called (times 10)
+
+ withRunInIO $ \runInIO -> do
+ as <- forM [1 .. 10] $ \i ->
+ async $ runInIO $ do
+ liftIO $ evaluate $ perCall i (mockFn "a")
+ pure ()
+ mapM_ wait as
+
+ it "handles concurrent calls with different arguments" $ do
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called (times 5) `with` "a"
+ called (times 5) `with` "b"
+
+ withRunInIO $ \runInIO -> do
+ as1 <- forM [1 .. 5] $ \i ->
+ async $ runInIO $ liftIO $ evaluate $ perCall i (mockFn "a")
+ as2 <- forM [1 .. 5] $ \i ->
+ async $ runInIO $ liftIO $ evaluate $ perCall (100 + i) (mockFn "b")
+ mapM_ wait (as1 ++ as2)
+
+ it "stress test: many threads with many calls" $ do
+ let threads = 20 :: Int
+ callsPerThread = 10 :: Int
+ total = threads * callsPerThread :: Int
+
+ withMock $ do
+ mockFn <- mock (any ~> True)
+ `expects` do
+ called (times total)
+
+ withRunInIO $ \runInIO -> do
+ as <- forM [1 .. threads] $ \threadIx ->
+ async $ runInIO $ do
+ forM_ [1 .. callsPerThread] $ \callIx -> do
+ let tag = threadIx * 1000 + callIx
+ liftIO $ evaluate $ perCall tag (mockFn "stress")
+ liftIO $ threadDelay 1
+ mapM_ wait as
+
+ it "concurrent calls preserve order expectations" $ do
+ withMock $ do
+ mockFn <- mock (any @String ~> True)
+ `expects` do
+ calledInOrder ["first", "second", "third"]
+
+ withRunInIO $ \runInIO -> do
+ -- Sequential calls to preserve order
+ runInIO $ void $ liftIO $ evaluate $ mockFn "first"
+ runInIO $ void $ liftIO $ evaluate $ mockFn "second"
+ runInIO $ void $ liftIO $ evaluate $ mockFn "third"
+