mockcat 0.5.5.0 → 0.6.0.0

raw patch · 22 files changed

+1307/−361 lines, 22 filesdep +QuickCheckdep +hashabledep +unordered-containersdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, hashable, unordered-containers

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README-ja.md +56/−1
• README.md +68/−0
• mockcat.cabal +18/−4
• src/Test/MockCat.hs +1/−2
• src/Test/MockCat/Mock.hs +192/−286
• src/Test/MockCat/Param.hs +46/−2
• src/Test/MockCat/ParamDivider.hs +0/−63
• test/Property/AdditionalProps.hs +166/−0
• test/Property/ConcurrentCountProp.hs +43/−0
• test/Property/Generators.hs +29/−0
• test/Property/LazyEvalProp.hs +41/−0
• test/Property/OrderProps.hs +79/−0
• test/Property/ParamSpecMergeProp.hs +36/−0
• test/Property/ParamSpecNormalizeProp.hs +87/−0
• test/Property/ParamSpecRangeMergeRandomProp.hs +34/−0
• test/Property/ReinforcementProps.hs +103/−0
• test/Property/ScriptProps.hs +18/−0
• test/Spec.hs +37/−3
• test/Support/ParamSpec.hs +79/−0
• test/Support/ParamSpecNormalize.hs +158/−0
• test/Test/MockCat/ParamSpec.hs +12/−0

@@ -6,6 +6,10 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 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.+ ## 0.5.5.0 ### Added - Aliases `expectApplyTimes` and `expectNever` (preferred names) for pre-run expectation declarations.

@@ -11,17 +11,72 @@ mockcat は Haskell 向けの小さなモック / スタブ DSL です。   `arg |> arg |> 戻り値` というシンプルな書き方で「こう呼ばれたらこう返す」を並べ、関数ならそのまま使い、型クラスなら Template Haskell (`makeMock`, `makePartialMock`) で生成したスタブ関数を `runMockT` の中で走らせると自動で検証まで行われます。 +### 使うべきタイミング / 使わない方が良いタイミング++#### 使うべきタイミング+| 状況 | 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 環境 |++#### 設計ポリシー+* DSL の中核は極小 (`|>` + 期待マッチャ)。周辺は拡張層（ParamSpec, シナリオ DSL）は後置。 +* 「明示性 > 自動化」: 暗黙のグローバル検証なし。`runMockT` 境界で完了。 +* 並行安全性とメッセージ明快さを優先、過剰な内部最適化は後回し。 +* 侵襲的なアーキテクチャ変更を要求しない。既存テストへ差し込める。++#### 導入 (手書きスタブから段階的移行) 手順例+1. 既存の手書きスタブを `createMock` + `stubFn` に置換 (同じ型シグネチャ温存)。+2. 必要なテストだけ `shouldApplyTo` / `shouldApplyTimes` を追加 (全部に付けない)。+3. 重複呼び出し判定や順序がテスト意図なら `shouldApplyInOrder` を追加。+4. 将来さらに fuzz / property を盛りたい場合は PoC モジュール (ParamSpec/Scenario) を検討。++#### FAQ 抜粋+**Q. 未評価のまま終わるとカウントされますか?**  +されません。返り値評価時点で 1 カウント。 ++**Q. 同じ引数ケースを複数 onCase 登録した場合の選択順は?**  +左から順に消費し、末尾に到達後は末尾を繰り返します。 ++**Q. 並列呼び出しは安全?**  +`atomicModifyIORef'` による単一レコード更新でロス/二重記録防止。Property で検証。 ++**Q. DSL をこれ以上膨らませる予定は?**  +コアは安定志向。高度な生成は別モジュール or オプションパッケージ。 ++**Q. 失敗時デバッグは?**  +期待 vs 実際（順序ミスマッチの場合は位置付き）＋ラベル表示。`expect (>x) "label"` で補助。 ++---+ ### 特徴 * シンプル: `arg |> ... |> 戻り値` でスタブ関数をすぐ作れる。 * 柔軟な戻り値: 同じ引数でも呼び出しごとで値を変えたり、引数別に振り分けたりできる。 * 型クラスのモックを生成: Template Haskell によりボイラープレートを削減。 * 型クラスの部分モック: 必要な関数だけ差し替え、残りは本物で動かすことができる。 * 並列処理への対応: スタブ関数を並列に呼び出しても、正確な呼び出し回数の検証が行える。+* (PoC) QuickCheck / シナリオ DSL との統合実験進行中。  <details> <summary>更新履歴</summary> -- **0.6.0**: 並列処理に対応+- **0.6.0.0**: スタブ関数作成時の可変引数の上限を撤廃。 - **0.5.3.0**: MockT が MonadUnliftIO のインスタンスになった - **0.5.0**: `IO a`型のスタブ関数が、適用される度に異なる値を返すことができるようになった - **0.4.0**: 型クラスの部分的なモックを作れるようになった

@@ -45,6 +45,73 @@  Designed to be something you can pick up to stub one or two spots and then forget again – more a handy extension of regular Haskell testing than a new framework. +### When should you use mockcat?+Use it when the following resonate:++| Situation | Why mockcat helps |+|-----------|-------------------|+| You only need 1–3 small mocks and don’t want a heavy framework | Single expression `a |> b |> r` expectations stay lightweight |+| You want argument + occurrence sensitive returns | Multiple `onCase` (including duplicate args) choose per call deterministically |+| Verifying exact / partial order matters | Built‑in `shouldApplyInOrder` / `shouldApplyInPartialOrder` without extra harness |+| Need to assert precise call counts (including zero) | `expectApplyTimes`, `expectNever`, plus granular `shouldApplyTimes*` APIs |+| Concurrency: parallel tasks must not lose counts | Atomic recording + per‑call evaluation semantics tested with property tests |+| You prefer explicit, non‑magical DSL | Only `|>` and a few combinators (`any`, `expect`, `expect_`, TH expectByExpr) |+| You mix real + mocked methods in a typeclass | `makePartialMock` keeps untouched members real |+| Occasional tests, not an application‑wide inversion setup | Zero global registry; opt‑in per test |+| Need monadic variation for `IO` results | Repeated cases + monadic explicit returns under `implicitMonadicReturn` |++### When should you NOT use mockcat?+Consider alternatives if:++| Case | Probably better with |+|------|---------------------|+| Large system with dozens of interacting behaviors and deep expectations | A fuller test double / simulation layer or effect system (e.g. Polysemy / fused‑effects) |+| You want automatic generation of all mocks and default fallbacks | Dedicated auto‑deriving mock frameworks |+| Property‑based orchestration of complex multi‑step protocols with shrinking | Use Hedgehog directly (future integration planned) |+| You require record‑style structured matchers (e.g. JSON diff, partial AST pattern) | Custom predicate functions or a richer matcher library layered on top |+| You need time‑travel / virtual clock / deterministic scheduling | A purpose built simulation or effect runtime |+| Performance micro‑bench harness of millions of calls | Hand coded stub (mockcat overhead is small but non‑zero) |+| Cross‑module pervasive dependency injection | Typeclass instances / reader environment without mocks |++### Design philosophy & trade‑offs+* Favors readability of individual expectations over bulk generation.+* Explicit over implicit: no hidden global state; verification is opt‑in or at `runMockT` boundary.+* Encourages shrinking scope: mocks local to the test file; does not push architectural rewrites.+* Leaves advanced generation (scenarios, property fuzz) as optional layering – PoCs exist, but core stays minimal.+* Concurrency correctness prioritized above micro‑optimizing hot paths.++### Migrating from handwritten stubs+If you already write tiny handmade stubs:+1. Replace the stub body with `createMock` + `stubFn`.+2. Inline expectation in the test (keep original type signature).+3. Add verification only where it increases confidence (don’t verify everything by habit).++### Interoperability notes+| Layer | Status | Notes |+|-------|--------|-------|+| QuickCheck integration | PoC | ParamSpec → Gen, scenario DSL prototypes |+| Hedgehog integration | Planned | Will focus on shrinking ordered call sequences |+| Effect systems (Polysemy / fused‑effects) | Manual | Wrap `MockT` inside effect stack or lift via newtype derivation |+| Benchmarking | Planned | Criterion harness template (compare hand stub vs mockcat) |++### FAQ (selected)+**Q. Does mockcat force results strictly?**  +No. A call is recorded when the return value is evaluated; unevaluated results don’t count.++**Q. How are duplicate argument cases resolved?**  +Left‑to‑right; once the last variant is reached it repeats (sticky tail).++**Q. Thread safety?**  +All state mutations use a single `IORef` with atomic modification; properties cover contention scenarios.++**Q. Will the DSL expand a lot?**  +Core is intentionally stable; higher level generators / scenario DSL live in optional modules.++**Q. How to debug a mismatch?**  +Failure message lists expected vs actual (or sequence diff). Add labels via `expect (>x) "label"` for clarity.++---+ ### Quick Start  Function mock:@@ -121,6 +188,7 @@ <details> <summary><strong>Update History</strong></summary> +* **0.6.0.0**: Removed the upper limit on variable arguments when creating stub functions. * **0.5.3.0**: `MockT` now implements `MonadUnliftIO`; concurrency safety clarified; removal of `unsafePerformIO`. * **0.5.0**: `IO a` stubs can return different values on successive applications. * **0.4.0**: Partial mocks for typeclasses.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mockcat-version:        0.5.5.0+version:        0.6.0.0 synopsis:       Mock library for test in Haskell. description:    mockcat is a small mocking / stubbing DSL for Haskell tests.                 .@@ -53,7 +53,6 @@       Test.MockCat.Mock       Test.MockCat.MockT       Test.MockCat.Param-      Test.MockCat.ParamDivider       Test.MockCat.TH   other-modules:       Paths_mockcat@@ -74,6 +73,18 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Property.AdditionalProps+      Property.ConcurrentCountProp+      Property.Generators+      Property.LazyEvalProp+      Property.OrderProps+      Property.ParamSpecMergeProp+      Property.ParamSpecNormalizeProp+      Property.ParamSpecRangeMergeRandomProp+      Property.ReinforcementProps+      Property.ScriptProps+      Support.ParamSpec+      Support.ParamSpecNormalize       Test.MockCat.AssociationListSpec       Test.MockCat.ConcurrencySpec       Test.MockCat.ConsSpec@@ -91,9 +102,11 @@       test   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 -threaded -rtsopts -with-rtsopts=-N   build-depends:-      async >=2.2.4 && <2.3+      QuickCheck >=2.14 && <2.17+    , async >=2.2.4 && <2.3     , base >=4.7 && <5-    , hspec ==2.11.*+    , hashable >=1.4 && <1.6+    , hspec >=2.11 && <2.13     , mockcat     , mtl >=2.3.1 && <2.4     , template-haskell >=2.18 && <2.24@@ -101,4 +114,5 @@     , transformers >=0.5.6 && <0.7     , unliftio >=0.2.25.0 && <0.2.26     , unliftio-core >=0.2.1.0 && <0.2.2+    , unordered-containers >=0.2.19 && <0.3   default-language: Haskell2010

@@ -1,6 +1,5 @@ module Test.MockCat-  ( -    module Test.MockCat.Mock,+  ( module Test.MockCat.Mock,     module Test.MockCat.Cons,     module Test.MockCat.Param,     module Test.MockCat.MockT,

@@ -2,10 +2,13 @@ {-# 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. @@ -45,6 +48,7 @@  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@@ -52,14 +56,13 @@ import GHC.IO (unsafePerformIO) import Test.MockCat.Cons import Test.MockCat.Param-import Test.MockCat.ParamDivider 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 fun params = Mock (Maybe MockName) fun (Verifier params)+data Mock fn params = Mock (Maybe MockName) fn (Verifier params)  type MockName = String @@ -87,10 +90,9 @@  -} createMock ::-  MockBuilder params fun verifyParams =>-  MonadIO m =>+  (MonadIO m, MockBuilder params fn verifyParams) =>   params ->-  m (Mock fun verifyParams)+  m (Mock fn verifyParams) createMock params = liftIO $ build Nothing params  {- | Create a constant mock.@@ -121,19 +123,18 @@   @ -} createNamedMock ::-  MockBuilder params fun verifyParams =>-  MonadIO m =>+  (MonadIO m, MockBuilder params fn verifyParams) =>   MockName ->   params ->-  m (Mock fun verifyParams)+  m (Mock fn verifyParams) createNamedMock name params = liftIO $ build (Just name) params  -- | Create a named constant mock.-createNamedConstantMock :: MonadIO m => MockName -> fun -> m (Mock fun ())+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 fun v -> fun+stubFn :: Mock fn v -> fn stubFn (Mock _ f _) = f  {- | Create a stub function.@@ -147,142 +148,52 @@   @ -} createStubFn ::-  MockBuilder params fun verifyParams =>-  MonadIO m =>+  (MonadIO m, MockBuilder params fn verifyParams) =>   params ->-  m fun+  m fn createStubFn params = stubFn <$> createMock params  -- | Create a named stub function. createNamedStubFn ::-  MockBuilder params fun verifyParams =>-  MonadIO m =>+  (MonadIO m, MockBuilder params fn verifyParams) =>   String ->   params ->-  m fun+  m fn createNamedStubFn name params = stubFn <$> createNamedMock name params --- | Class for creating a mock corresponding to the parameter.-class MockBuilder params fun verifyParams | params -> fun, params -> verifyParams where-  -- build a mock-  build :: MonadIO m => Maybe MockName -> params -> m (Mock fun verifyParams)---- instances-instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g, Show h, Eq h, Show i, Eq i) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i :> Param r)-    (a -> b -> c -> d -> e -> f -> g -> h -> i -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock-      name-      s-      ( \a2 b2 c2 d2 e2 f2 g2 h2 i2 ->-          unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2 :> p h2 :> p i2) s-      )--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g, Show h, Eq h) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param r)-    (a -> b -> c -> d -> e -> f -> g -> h -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock-      name-      s-      ( \a2 b2 c2 d2 e2 f2 g2 h2 ->-          unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2 :> p h2) s-      )--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param r)-    (a -> b -> c -> d -> e -> f -> g -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock-      name-      s-      ( \a2 b2 c2 d2 e2 f2 g2 ->-          unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2) s-      )--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param r)-    (a -> b -> c -> d -> e -> f -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 f2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param r)-    (a -> b -> c -> d -> e -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d) =>-  MockBuilder-    (Param a :> Param b :> Param c :> Param d :> Param r)-    (a -> b -> c -> d -> r)-    (Param a :> Param b :> Param c :> Param d)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2 :> p d2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c) =>-  MockBuilder (Param a :> Param b :> Param c :> Param r) (a -> b -> c -> r) (Param a :> Param b :> Param c)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2 :> p c2) s)+-- | 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 -instance-  (Show a, Eq a, Show b, Eq b) =>-  MockBuilder (Param a :> Param b :> Param r) (a -> b -> r) (Param a :> Param b)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2 :> p b2) s)+-- | 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) -instance-  (Show a, Eq a) =>-  MockBuilder (Param a :> Param r) (a -> r) (Param a)-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2) s)+-- | 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)) -instance-  MockBuilder (Param r) r ()-  where-  build name params = do-    s <- liftIO $ newIORef appliedRecord-    let v = value params-    makeMock name s $ unsafePerformIO (do-      liftIO $ appendAppliedParams s ()-      pure v)+-- | 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@@ -292,111 +203,19 @@       liftIO $ appendAppliedParams s ()       a) -instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g, Show h, Eq h, Show i, Eq i) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i :> Param r) ())-    (a -> b -> c -> d -> e -> f -> g -> h -> i -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 f2 g2 h2 i2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2 :> p h2 :> p i2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g, Show h, Eq h) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param r) ())-    (a -> b -> c -> d -> e -> f -> g -> h -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 f2 g2 h2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2 :> p h2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param r) ())-    (a -> b -> c -> d -> e -> f -> g -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 f2 g2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2 :> p g2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param r) ())-    (a -> b -> c -> d -> e -> f -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e :> Param f)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 f2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2 :> p f2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param e :> Param r) ())-    (a -> b -> c -> d -> e -> r)-    (Param a :> Param b :> Param c :> Param d :> Param e)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 e2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2 :> p e2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param d :> Param r) ())-    (a -> b -> c -> d -> r)-    (Param a :> Param b :> Param c :> Param d)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 d2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2 :> p d2) s)--instance-  (Show a, Eq a, Show b, Eq b, Show c, Eq c) =>-  MockBuilder-    (Cases (Param a :> Param b :> Param c :> Param r) ())-    (a -> b -> c -> r)-    (Param a :> Param b :> Param c)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 c2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2 :> p c2) s)--instance-  (Show a, Eq a, Show b, Eq b) =>-  MockBuilder (Cases (Param a :> Param b :> Param r) ()) (a -> b -> r) (Param a :> Param b)-  where-  build name cases = do-    let params = runCase cases-    s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 b2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2 :> p b2) s)-+-- | Instance for building a mock for a function with a single parameter. instance-  (Show a, Eq a) =>-  MockBuilder (Cases (Param a :> Param r) ()) (a -> r) (Param a)+  MockBuilder (Param r) r ()   where-  build name cases = do-    let params = runCase cases+  build name params = do     s <- liftIO $ newIORef appliedRecord-    makeMock name s (\a2 -> unsafePerformIO $ findReturnValueWithStore name params (p a2) s)+    let v = value params+    makeMock name s $ perform (do+      liftIO $ appendAppliedParams s ()+      pure v) -instance-  MockBuilder (Cases (IO a) ()) (IO a) ()-  where+-- | 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@@ -407,31 +226,70 @@       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) -> fun -> m (Mock fun params)+makeMock :: MonadIO m => Maybe MockName -> IORef (AppliedRecord params) -> fn -> m (Mock fn params) makeMock name l fn = pure $ Mock name fn (Verifier l)  extractReturnValueWithValidate ::-  ParamDivider params args (Param r) =>-  Eq args =>-  Show args =>+  ( 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 (args params) inputParams+  validateWithStoreParams name s (projArgs params) inputParams   pure $ returnValue params  findReturnValueWithStore ::-  Eq args =>-  Show args =>-  ParamDivider params args (Param r) =>+  ( ProjectionArgs params+  , ProjectionReturn params+  , ArgsOf params ~ args+  , ReturnOf params ~ Param r+  , Eq args+  , Show args+  ) =>   Maybe MockName ->   AppliedParamsList params ->   args ->@@ -439,7 +297,7 @@   IO r findReturnValueWithStore name paramsList inputParams ref = do   appendAppliedParams ref inputParams-  let expectedArgs = args <$> paramsList+  let expectedArgs = projArgs <$>paramsList   r <- findReturnValue paramsList inputParams ref   maybe     (errorWithoutStackTrace $ messageForMultiMock name expectedArgs inputParams)@@ -447,14 +305,18 @@     r  findReturnValue ::-  Eq args =>-  ParamDivider params args (Param r) =>+  ( 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 -> args params == inputParams) paramsList+  let matchedParams = filter (\params -> projArgs params == inputParams) paramsList   case matchedParams of     [] -> pure Nothing     _ -> do@@ -474,25 +336,50 @@     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: " <> show expected,-      "   but got: " <> show actual+      "  expected: " <> showForMessage (show expected),+      "   but got: " <> showForMessage (show actual)     ]  messageForMultiMock :: Show a => Maybe MockName -> [a] -> a -> String messageForMultiMock name expecteds actual =-  intercalate-    "\n"-    [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",-      "  expected one of the following:",-      intercalate "\n" $ ("    " <>) . show <$> expecteds,-      "  but got:",-      ("    " <>) . show $ 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 "`"@@ -506,7 +393,7 @@ -- | Class for verifying mock function. class Verify params input where   -- | Verifies that the function has been applied to the expected arguments.-  shouldApplyTo :: HasCallStack => Mock fun params -> input -> IO ()+  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))@@ -514,7 +401,7 @@ instance (Eq a, Show a) => Verify a a where   shouldApplyTo v a = verify v (MatchAny a) -verify :: (Eq params, Show params) => Mock fun params -> VerifyMatchType params -> IO ()+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@@ -538,15 +425,36 @@     intercalate       "\n"       [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",-        "  expected: " <> show expected,+        "  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-  | length appliedParams == 0 = "It has never been applied"-  | length appliedParams == 1 = init . drop 1 . show $ appliedParams-  | otherwise = show 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))@@ -565,7 +473,7 @@   --   m \`shouldApplyTimes\` (2 :: Int) \`to\` "value"    -- @   ---  shouldApplyTimes :: HasCallStack => Eq params => Mock fun params -> countType -> a -> IO ()+  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@@ -600,7 +508,7 @@ compareCount (GreaterThanEqual e) a = a >= e compareCount (GreaterThan e) a = a > e -verifyCount :: Eq params => Mock fun params -> params -> CountVerifyMethod -> IO ()+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)@@ -632,14 +540,14 @@   --   print $ stubFn m "b" True   --   m \`shouldApplyInOrder\` ["a" |\> True, "b" |\> True]   -- @-  shouldApplyInOrder :: HasCallStack => Mock fun params -> [input] -> IO ()+  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 fun params -> [input] -> IO ()+  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@@ -654,10 +562,9 @@   | PartiallySequence  verifyOrder ::-  Eq params =>-  Show params =>+  (Eq params, Show params) =>   VerifyOrderMethod ->-  Mock fun params ->+  Mock fn params ->   [params] ->   IO () verifyOrder method (Mock name _ (Verifier ref)) matchers = do@@ -666,8 +573,7 @@   result & maybe (pure ()) (\(VerifyFailed msg) -> errorWithoutStackTrace msg)  doVerifyOrder ::-  Eq a =>-  Show a =>+  (Eq a, Show a) =>   VerifyOrderMethod ->   Maybe MockName ->   AppliedParamsList a ->@@ -766,9 +672,8 @@  -- | 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 fun params ->+  (VerifyCount CountVerifyMethod params a, Eq params) =>+  Mock fn params ->   Int ->   a ->   IO ()@@ -776,9 +681,8 @@  -- | 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 fun params ->+  (VerifyCount CountVerifyMethod params a, Eq params) =>+  Mock fn params ->   Int ->   a ->   IO ()@@ -786,9 +690,8 @@  -- | 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 fun params ->+  (VerifyCount CountVerifyMethod params a, Eq params) =>+  Mock fn params ->   Int ->   a ->   IO ()@@ -796,9 +699,8 @@  -- | 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 fun params ->+  (VerifyCount CountVerifyMethod params a, Eq params) =>+  Mock fn params ->   Int ->   a ->   IO ()@@ -858,13 +760,13 @@   | otherwise = listToMaybe (drop n xs)  -- | Verify that it was apply to anything.-shouldApplyToAnything :: HasCallStack => Mock fun params -> IO ()+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 fun params -> Int -> IO ()+shouldApplyTimesToAnything :: Mock fn params -> Int -> IO () shouldApplyTimesToAnything (Mock name _ (Verifier ref)) count = do   appliedParamsList <- readAppliedParamsList ref   let appliedCount = length appliedParamsList@@ -937,3 +839,7 @@ -} casesIO :: [a] -> Cases (IO a) () casesIO = Cases . (put . map pure)++{-# NOINLINE perform #-}+perform :: IO a -> a+perform = unsafePerformIO

@@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -20,7 +19,14 @@     (|>),     expect,     expect_,-    any+    any,+    ArgsOf,+    ProjectionArgs,+    projArgs,+    ReturnOf,+    ProjectionReturn,+    projReturn,+    returnValue   ) where @@ -102,3 +108,41 @@ -} 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 (Param a :> Param r) = Param a+  ArgsOf (Param a :> rest) = Param a :> ArgsOf rest++-- | Class for projecting the arguments of the parameter.+class ProjectionArgs params where+  projArgs :: params -> ArgsOf params++instance {-# OVERLAPPING #-} ProjectionArgs (Param a :> Param r) where+  projArgs (a :> _) = a++instance+  {-# OVERLAPPABLE #-}+  (ProjectionArgs rest, ArgsOf (Param a :> rest) ~ (Param a :> ArgsOf rest)) =>+  ProjectionArgs (Param a :> rest) where+  projArgs (a :> rest) = a :> projArgs rest++-- | The type of the return parameter of the parameters.+type family ReturnOf params where+  ReturnOf (Param a :> Param r) = Param r+  ReturnOf (Param a :> rest) = ReturnOf rest++class ProjectionReturn param where+  projReturn :: param -> ReturnOf param++instance {-# OVERLAPPING #-} ProjectionReturn (Param a :> Param r) where+  projReturn (_ :> r) = r++instance+  {-# OVERLAPPABLE #-}+  (ProjectionReturn rest, ReturnOf (Param a :> rest) ~ ReturnOf rest) =>+  ProjectionReturn (Param a :> rest) where+  projReturn (_ :> rest) = projReturn rest++returnValue :: (ProjectionReturn params, ReturnOf params ~ Param r) => params -> r+returnValue = value . projReturn

@@ -1,63 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}--module Test.MockCat.ParamDivider (ParamDivider, args, return, returnValue) where--import Test.MockCat.Cons-import Test.MockCat.Param-import Prelude hiding (return)--class ParamDivider params args return | params -> args, params -> return where-  args :: params -> args-  return :: params -> return--instance ParamDivider -  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i :> Param r)-  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i) (Param r) where-  args (a :> b :> c :> d :> e :> f :> g :> h :> i :> _) = a :> b :> c :> d :> e :> f :> g :> h :> i-  return (_ :> _ :> _ :> _ :> _ :> _ :> _ :> _ :> _ :> r) = r--instance ParamDivider -  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param r)-  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h) (Param r) where-  args (a :> b :> c :> d :> e :> f :> g :> h :> _) = a :> b :> c :> d :> e :> f :> g :> h-  return (_ :> _ :> _ :> _ :> _ :> _ :> _ :> _ :> r) = r--instance ParamDivider -  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param r)-  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g) (Param r) where-  args (a :> b :> c :> d :> e :> f :> g :> _) = a :> b :> c :> d :> e :> f :> g-  return (_ :> _ :> _ :> _ :> _ :> _ :> _ :> r) = r--instance ParamDivider -  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param r)-  (Param a :> Param b :> Param c :> Param d :> Param e :> Param f) (Param r) where-  args (a :> b :> c :> d :> e :> f :> _) = a :> b :> c :> d :> e :> f-  return (_ :> _ :> _ :> _ :> _ :> _ :> r) = r--instance ParamDivider -  (Param a :> Param b :> Param c :> Param d :> Param e :> Param r)-  (Param a :> Param b :> Param c :> Param d :> Param e) (Param r) where-  args (a :> b :> c :> d :> e :> _) = a :> b :> c :> d :> e-  return (_ :> _ :> _ :> _ :> _ :> r) = r--instance ParamDivider (Param a :> Param b :> Param c :> Param d :> Param r) (Param a :> Param b :> Param c :> Param d) (Param r) where-  args (a :> b :> c :> d :> _) = a :> b :> c :> d-  return (_ :> _ :> _ :> _ :> r) = r--instance ParamDivider (Param a :> Param b :> Param c :> Param r) (Param a :> Param b :> Param c) (Param r) where-  args (a :> b :> c :> _) = a :> b :> c-  return (_ :> _ :> _ :> r) = r--instance ParamDivider (Param a :> Param b :> Param r) (Param a :> Param b) (Param r) where-  args (a :> b :> _) = a :> b-  return (_ :> _ :> r) = r--instance ParamDivider (Param a :> Param r) (Param a) (Param r) where-  args (a :> _) = a-  return (_ :> r) = r--returnValue :: ParamDivider params args (Param r) => params -> r-returnValue = value . return

@@ -0,0 +1,166 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O0 #-}+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 Data.List (nub)+import Data.Proxy (Proxy(..))+import Test.MockCat+import Control.Monad.IO.Class (liftIO)+import Test.MockCat.MockT (MockT(..), Definition(..), runMockT, MonadMockDefs(..))++--------------------------------------------------------------------------------+-- 21. PredicateParam property+--------------------------------------------------------------------------------++-- | Property: A predicate Param (expect even) accepts only matching values and+-- the total recorded applications 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+  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+  assert (successes == expected)+  where+    genVals = resize 40 $ listOf (arbitrary :: Gen Int)++--------------------------------------------------------------------------------+-- 22. Multi-case progression property+--------------------------------------------------------------------------------++-- | For identical argument, successive cases yield successive results then+-- 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+  -- 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+  -- 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 })+  let (prefix, suffix) = splitAt (length rs) vals+  assert (prefix == rs)+  assert (all (== last rs) suffix)+  run $ m `shouldApplyTimesToAnything` totalCalls+  where+    genSeq = do+      arg <- arbitrary :: Gen Int+      Positive len <- arbitrary :: Gen (Positive Int)+      let capped = 1 + (len `mod` 5) -- keep small (1..5)+      rs <- vectorOf capped (arbitrary :: Gen Int)+      extra <- chooseInt (0,3)+      pure (arg, rs, extra)++--------------------------------------------------------------------------------+-- 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.+prop_runMockT_isolation :: Property+prop_runMockT_isolation = monadicIO $ do+  -- Run 1: expect one application+  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+    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 }+    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+--------------------------------------------------------------------------------++-- | For a sequence with duplicates, the partial order check succeeds with the+-- list of first occurrences; reversing that list (when length >=2) fails.+prop_partial_order_duplicates :: Property+prop_partial_order_duplicates = forAll genDupScript $ \xs -> length xs >= 2 ==> monadicIO $ do+  -- 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 ]+  let uniques = nub xs+  -- success case+  run $ m `shouldApplyInPartialOrder` (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 ()))+      case e of+        Left _ -> assert True+        Right _ -> assert False+    _ -> assert True+  where+    genDupScript = do+      Positive len <- arbitrary :: Gen (Positive Int)+      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+    ensureDup ys = if length (nub ys) == length ys && not (null ys) then head ys : ys else ys+    -- Check that for each earlier unique value all its indices precede all indices of later unique values.+    isClusterOrdered us seqVals = all pairOrdered pairs+      where+        idxs v = [ i | (i,a) <- zip [0..] seqVals, a == v ]+        pairs = [ (u1,u2) | (i,u1) <- zip [0..] us, u2 <- drop (i+1) us ]+        pairOrdered (u1,u2) = case (idxs u1, idxs u2) of+          ([],_) -> True+          (_,[]) -> True+          (is1,is2) -> maximum is1 < minimum is2

@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+module Property.ConcurrentCountProp+  ( prop_concurrent_total_apply_count+  ) where++import Test.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Control.Concurrent.Async (async, wait)+import Control.Monad (replicateM_, replicateM)+import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO)+import Test.MockCat hiding (any)+import qualified Test.MockCat as MC (any)++-- ローカル並行アクション用クラス (既存 ConcurrencySpec を再利用せず独立定義)+class Monad m => PropConcurrencyAction m where+  propAction :: Int -> m Int++makeMock [t|PropConcurrencyAction|]++-- | 並行に複数スレッドから同じモック関数を呼び出しても、合計呼び出し回数が失われずに記録されることを検証する property。+--   引数: 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 により期待回数を事前宣言し、並行呼び出し後に自動検証させる+        run $ runMockT $ do+          _propAction (MC.any |> (1 :: Int)) `applyTimesIs` totalCalls+          parallelInvoke threads callsPerThread+          pure ()+        assert True++-- 並行に propAction を呼び出す+parallelInvoke :: (PropConcurrencyAction m, MonadUnliftIO m) => Int -> Int -> m ()+parallelInvoke threads callsPerThread = withRunInIO $ \runInIO -> do+  as <- replicateM threads (async $ runInIO $ replicateM_ callsPerThread (propAction 42 >> pure ()))+  mapM_ wait as

@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Property.Generators+  ( Script(..)+  , scriptGen+  , buildUnaryMock+  , runScript+  ) where++import Test.QuickCheck+import Test.MockCat++-- | A simple script: sequence of argument values for a unary function.+newtype Script a = Script { unScript :: [a] } deriving (Show, Eq)++-- | Generator for a script of Ints (length 0..9 to respect current arity limits if later extended to multi-arg).+scriptGen :: Gen (Script Int)+scriptGen = do+  n <- chooseInt (0,9)+  xs <- vectorOf n arbitrary+  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 ]++-- | Execute the script against the provided stub function, forcing each Bool.+runScript :: (Int -> Bool) -> Script Int -> IO ()+runScript f (Script xs) = mapM_ (\a -> f a `seq` pure ()) xs

@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Property.LazyEvalProp+  ( prop_lazy_unforced_not_counted+  , prop_lazy_forced_counted+  ) where++import Test.QuickCheck+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.+class Monad m => LazyUnaryAction m where+  lazyUnaryAction :: Int -> m Int++makeMock [t|LazyUnaryAction|]++-- | Property: if we declare an expectation but never force (execute) the action,+--   the recorded application 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+    -- Do NOT force the call; only build a thunk.+    let _thunk :: MockT IO Int+        _thunk = lazyUnaryAction 10+    pure ()+  assert True++-- | Property: once we actually execute (force) the action, it is counted exactly once.+prop_lazy_forced_counted :: Property+prop_lazy_forced_counted = monadicIO $ do+  run $ runMockT $ do+    _lazyUnaryAction (param (10 :: Int) |> (7 :: Int)) `applyTimesIs` 1+    v <- lazyUnaryAction 10   -- forcing the monadic action executes the mock+    v `seq` pure ()           -- ensure result is evaluated (WHNF for Int)+  assert True

@@ -0,0 +1,79 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Property.OrderProps+  ( prop_inorder_succeeds+  , prop_adjacent_swap_fails+  , prop_partial_order_subset_succeeds+  , prop_partial_order_reversed_pair_fails+  ) where++import Test.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Control.Exception (try, SomeException, evaluate)+import Data.Maybe (listToMaybe)+import Data.List (nub)+import Test.MockCat (shouldApplyInOrder, shouldApplyInPartialOrder, stubFn)+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+  run $ runScript f scr+  run $ m `shouldApplyInOrder` (param <$> xs)+  assert True++-- | Property: a single adjacent swap causes order verification failure.+prop_adjacent_swap_fails :: Property+prop_adjacent_swap_fails = forAll scriptGen $ \(Script xs) -> length xs >= 2 ==> monadicIO $ do+  let distinct = nub xs+  if length distinct /= length xs+    then assert True  -- discard scripts with duplicates; they can mask order errors+    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+      run $ runScript f (Script xs)+      e <- run $ (try (m `shouldApplyInOrder` (param <$> swapped)) :: IO (Either SomeException ()))+      case e of+        Left _ -> assert True+        Right _ -> assert False++-- | Helper: produce a non-empty in-order subsequence.+chooseSubsequence :: [a] -> Gen [a]+chooseSubsequence [] = pure []+chooseSubsequence xs = do+  bools <- vectorOf (length xs) arbitrary+  let picked = [ x | (x,b) <- zip xs bools, b ]+  if null picked then chooseSubsequence xs else pure picked++-- | Property: any non-empty subsequence (order-preserving) passes partial order check.+prop_partial_order_subset_succeeds :: Property+prop_partial_order_subset_succeeds = forAll scriptGen $ \scr@(Script xs) -> not (null xs) ==> monadicIO $ do+  subset <- run $ generate $ chooseSubsequence xs+  m <- run $ buildUnaryMock scr+  let f = stubFn m+  run $ runScript f scr+  run $ m `shouldApplyInPartialOrder` (param <$> subset)+  assert True++-- | Property: selecting two distinct values and reversing them causes partial order failure.+prop_partial_order_reversed_pair_fails :: Property+prop_partial_order_reversed_pair_fails = forAll scriptGen $ \scr@(Script xs) -> length xs >= 2 ==> monadicIO $ do+  if length (nub xs) /= length xs+    then assert True -- discard non-unique scripts to avoid accidental subsequences+    else do+      let pairs = [ (i,j) | i <- [0..length xs -2], j <- [i+1..length xs -1] ]+      case listToMaybe pairs of+        Nothing -> assert True+        Just (i,j) -> do+          m <- run $ buildUnaryMock scr+          let f = stubFn m+          run $ runScript f scr+          let reversed = [xs!!j, xs!!i]+          e <- run $ (try (m `shouldApplyInPartialOrder` (param <$> reversed)) :: IO (Either SomeException ()))+          case e of+            Left _ -> assert True+            Right _ -> assert False

@@ -0,0 +1,36 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonoLocalBinds #-}+module Property.ParamSpecMergeProp (spec) where++import Test.Hspec+import Test.QuickCheck+import Support.ParamSpec (ParamSpec(..))+import Support.ParamSpecNormalize++spec :: Spec+spec = describe "ParamSpec Int merge (normaliseManyInt)" $ do+  it "overlapping ranges merge" $ property prop_overlap_merge+  it "adjacent ranges merge" $ property prop_adjacent_merge+  it "separate ranges stay separate" $ property prop_separate_no_merge++prop_overlap_merge :: Property+prop_overlap_merge =+  let r = normaliseManyInt [PSRangeInt 1 5, PSRangeInt 3 10]+  in case r of+       NRangeInt 1 10 -> property True+       _              -> counterexample (show r) False++prop_adjacent_merge :: Property+prop_adjacent_merge =+  let r = normaliseManyInt [PSRangeInt 1 5, PSRangeInt 6 8]+  in case r of+       NRangeInt 1 8 -> property True+       _             -> counterexample (show r) False++prop_separate_no_merge :: Property+prop_separate_no_merge =+  let r = normaliseManyInt [PSRangeInt 1 3, PSRangeInt 5 7]+  in case r of+       NUnion [NRangeInt 1 3, NRangeInt 5 7] -> property True+       _ -> counterexample (show r) False

@@ -0,0 +1,87 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonoLocalBinds #-}+module Property.ParamSpecNormalizeProp (spec, prop_enum_duplicate_equivalence) where++import Test.Hspec+import Test.QuickCheck+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.+genParamSpecInt :: Gen (ParamSpec Int)+genParamSpecInt = frequency+  [ (3, PSExact <$> smallInt)+  , (3, sizedEnum)+  , (2, rangeSpec)+  , (1, pure PSAny)+  , (1, pure (PSPredicate even "even"))+  ]+  where+    smallInt = choose (-5, 5)+    sizedEnum = do+      n <- choose (1,5)+      xs <- vectorOf n smallInt+      pure (PSEnum xs)+    rangeSpec = do+      a <- smallInt; b <- smallInt+      pure (PSRangeInt a b)++pretty :: ParamSpec Int -> String+pretty ps = case ps of+  PSExact a -> "Exact " ++ show a+  PSEnum xs -> "Enum " ++ show xs+  PSRangeInt l h -> "Range " ++ show (l,h)+  PSAny -> "Any"+  PSPredicate _ l -> "Pred " ++ l++-- Property: normalise . toParamSpec . normalise ≡ normalise (idempotence via roundtrip)+prop_normalise_idempotent :: Property+prop_normalise_idempotent = forAll (Blind <$> genParamSpecInt) $ \(Blind ps) ->+  let n1 = normalise ps+      n2 = normalise (toParamSpec n1)+  in counterexample ("ps=" ++ pretty ps) (n1 == n2)++-- Property: acceptance equivalence on a finite sample domain+prop_acceptance_equivalence :: Property+prop_acceptance_equivalence = forAll (Blind <$> genParamSpecInt) $ \(Blind ps) ->+  forAll sampleDomain $ \xs ->+    let n = normalise ps+        ok = all (\x -> acceptsParamSpec ps x == acceptsNormal n x) xs+    in counterexample ("ps=" ++ pretty ps ++ "; xs sample mismatch") ok+  where+    sampleDomain = vectorOf 20 (choose (-7,7))++spec :: Spec+spec = do+  describe "ParamSpec Normalisation" $ do+    it "idempotent (roundtrip)" $ prop_normalise_idempotent+    it "acceptance equivalence on sample domain" $ prop_acceptance_equivalence+    it "enum duplicate equivalence" $ prop_enum_duplicate_equivalence++-- Property A: Enum に重複があっても正規化後の形が期待通り (単一点→NExact / 複数→NEnum uniq)+prop_enum_duplicate_equivalence :: Property+prop_enum_duplicate_equivalence = forAll genDupEnum $ \(xs :: [Int]) ->+  let n = normalise (PSEnum xs)+      uniq = nub xs+  in case uniq of+       []    -> counterexample "unexpected empty after nub" False+       [x]   -> case n of+                  NExact y -> counterexample (show n) (y == x)+                  _        -> counterexample (show n) False+       _     -> case n of+                  NEnum ys -> counterexample (show n) (ys == uniq)+                  _        -> counterexample (show n ++ " expected NEnum") False+  where+    genDupEnum :: Gen [Int]+    genDupEnum = do+      baseLen <- choose (1,5)+      base <- vectorOf baseLen (choose (-5,5))+      dupFactor <- choose (0,3)+      extras <- concat <$> mapM (\v -> vectorOf dupFactor (pure v)) base+      shuffle (base ++ extras)

@@ -0,0 +1,34 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonoLocalBinds #-}+module Property.ParamSpecRangeMergeRandomProp (spec) where++import Test.Hspec+import Test.QuickCheck+import Support.ParamSpec (ParamSpec(..))+import Support.ParamSpecNormalize++-- ランダムに Range / Exact を生成し normaliseManyInt の受理集合と元集合の OR が一致するか検証+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] }+instance Show PSList where show _ = "<ParamSpec Int list>"++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 ]+  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))+      , (1, PSExact <$> small)+      ]+    small = choose (-20,20)+    sampleDomain = vectorOf 25 (choose (-25,25))

@@ -0,0 +1,103 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Property.ReinforcementProps+  ( prop_predicate_negative_not_counted+  , prop_lazy_partial_force_concurrency+  , prop_partial_order_interleaved_duplicates+  ) 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+--------------------------------------------------------------------------------++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+  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 ]+      oddSuccesses = [ x | (x, Right _) <- zip xs outcomes, odd x ]+      failures = length [ () | (_, Left _) <- zip xs outcomes ]+      odds = length (filter odd xs)+  -- No odd value should succeed+  assert (null oddSuccesses)+  -- Failures count equals number of odd inputs+  assert (failures == odds)+  -- Successes count equals even inputs+  assert (successes == evens)+  -- Applied count equals successes (only even)+  run $ m `shouldApplyTimesToAnything` evens+  assert True+  where+    genVals = resize 60 $ listOf (arbitrary :: Gen Int)++--------------------------------------------------------------------------------+-- 2. Lazy partial force with concurrency+--------------------------------------------------------------------------------++-- We reuse a unary typeclass mock to get laziness semantics (same pattern as LazyEvalProp).+class Monad m => ParLazyAction m where+  parLazy :: Int -> m Int++makeMock [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+    -- prepare thunks (NOT executed yet)+    let thunks = replicate (length mask) (parLazy arg)+    withRunInIO $ \runIn -> do+      forConcurrently_ (zip mask thunks) $ \(forceIt, action) ->+        if forceIt then do+          v <- runIn action+          v `seq` pure ()+        else pure () -- skip executing -> not counted+  assert True+  where+    genPlan = do+      size <- chooseInt (1,40)+      arg <- arbitrary :: Gen Int+      mask <- vectorOf size arbitrary+      pure (arg, mask)++--------------------------------------------------------------------------------+-- 3. Interleaved duplicate partial-order spec (A B A pattern)+--------------------------------------------------------------------------------++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+  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 ()))+  case e of+    Left _  -> assert True+    Right _ -> assert False+  assert True+  where+    genPair = do+      a <- arbitrary :: Gen Int+      b <- arbitrary :: Gen Int+      pure (a,b)

@@ -0,0 +1,18 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Property.ScriptProps+  ( prop_script_count_matches+  ) where++import Test.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.MockCat (shouldApplyTimesToAnything, stubFn)+import Property.Generators++-- | Property: executing a generated script produces exactly that many recorded applications.+prop_script_count_matches :: Property+prop_script_count_matches = forAll scriptGen $ \scr@(Script xs) -> monadicIO $ do+  m <- run $ buildUnaryMock scr+  let f = stubFn m+  run $ runScript f scr+  run $ m `shouldApplyTimesToAnything` length xs+  assert True

@@ -1,4 +1,4 @@-import Test.Hspec (hspec)+import Test.Hspec (hspec, describe, it) import Test.MockCat.MockSpec as Mock import Test.MockCat.ConsSpec as Cons import Test.MockCat.ParamSpec as Param@@ -9,10 +9,19 @@ import Test.MockCat.PartialMockSpec as PartialMock import Test.MockCat.PartialMockTHSpec as PartialMockTH import Test.MockCat.ConcurrencySpec as Concurrency+import Test.QuickCheck (property)+import qualified Property.ConcurrentCountProp as ConcurrencyProp+import qualified Property.LazyEvalProp as LazyEvalProp+import qualified Property.ScriptProps as ScriptProps+import qualified Property.OrderProps as OrderProps+import qualified Property.AdditionalProps as AdditionalProps+import qualified Property.ReinforcementProps as ReinforcementProps+import qualified Property.ParamSpecNormalizeProp as ParamSpecNormalizeProp+import qualified Property.ParamSpecMergeProp as ParamSpecMergeProp+import qualified Property.ParamSpecRangeMergeRandomProp as ParamSpecRangeMergeRandomProp  main :: IO ()-main = do-  hspec $ do+main = hspec $ do     Cons.spec     Param.spec     Mock.spec@@ -23,3 +32,28 @@     PartialMock.spec     PartialMockTH.spec     Concurrency.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+    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+      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+      it "lazy partial force in concurrency counts only forced" $ property ReinforcementProps.prop_lazy_partial_force_concurrency+      it "interleaved duplicate partial order semantics" $ property ReinforcementProps.prop_partial_order_interleaved_duplicates+    ParamSpecNormalizeProp.spec+    ParamSpecMergeProp.spec+    ParamSpecRangeMergeRandomProp.spec

@@ -0,0 +1,79 @@+{-# LANGUAGE GADTs #-}+-- |+-- = ParamSpec (Experimental)+--+-- Minimal reversible specification for parameters.+--+-- This module is /experimental/ and its data constructors or semantics may+-- change between minor releases until the Scenario / Hedgehog integration is+-- stabilized.  It intentionally stays tiny and dependency–free; integration+-- layers (QuickCheck / Hedgehog) live outside the core library for now.+--+-- Stability: experimental+--+-- Design notes:+-- * `PSPredicate` keeps the original predicate for fallback generation /+--   validation. We do not attempt predicate decomposition.+-- * `PSRangeInt` focuses on a common ergonomic win first; more numeric ranges+--   can be added when needed.+-- * Future additions may introduce pretty-printing or normalisation helpers+--   (e.g. enum duplicate collapse) without breaking existing pattern matches.+--+-- When in doubt prefer using smart constructors (`exact`, `enum`, ...) instead+-- of pattern matching directly so future internal tweaks are easier.+module Support.ParamSpec+  (+    ParamSpec(..)+  , fromParam+  , exact+  , enum+  , rangeInt+  , anySpec+  , predicate+  ) where++import Test.MockCat.Param (Param(..))++-- | A small, closed specification set.+--   NOTE: 'PSPredicate' keeps the original predicate for fallback generation / validation.+--   For now we do not attempt to decompose arbitrary predicates.+--   'PSRangeInt' is specialised so we can show a concrete ergonomic win early.+--   Future: add textual pretty printer / merging / normalisation if needed.+data ParamSpec a where+  -- | Exact value expectation.+  PSExact     :: a -> ParamSpec a+  -- | Enumeration of acceptable values (duplicates preserved for now).+  PSEnum      :: [a] -> ParamSpec a            -- ^ Non-empty expected; empty is treated as unsatisfiable elsewhere.+  -- | Inclusive integer range (caller responsible for low <= high; library may normalise in future).+  PSRangeInt  :: Int -> Int -> ParamSpec Int+  -- | Arbitrary predicate with a human readable label.+  PSPredicate :: (a -> Bool) -> String -> ParamSpec a+  -- | Wildcard (accept any value of the domain).+  PSAny       :: ParamSpec a++-- | Construct exact.+exact :: a -> ParamSpec a+exact = PSExact++-- | Construct enumeration (duplicates allowed; kept verbatim so that later we could weight frequency if we wished).+enum :: [a] -> ParamSpec a+enum = PSEnum++-- | Inclusive integer range.+rangeInt :: Int -> Int -> ParamSpec Int+rangeInt = PSRangeInt++-- | Wildcard (accept any value of the domain).+anySpec :: ParamSpec a+anySpec = PSAny++-- | Explicit predicate (kept for validation / fallback generation filtering).+predicate :: (a -> Bool) -> String -> ParamSpec a+predicate = PSPredicate++-- | Derive a coarse specification from an existing 'Param'.+--   * ExpectValue v      -> PSExact v+--   * ExpectCondition f l-> PSPredicate f l+fromParam :: Param a -> ParamSpec a+fromParam (ExpectValue v)      = PSExact v+fromParam (ExpectCondition f l) = PSPredicate f l

@@ -0,0 +1,158 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PackageImports #-}+-- | Test-only normalization utilities migrated from former+-- Test.MockCat.Internal.ParamSpec.Normalize. These are not part of the+-- public API and may change freely. Copied here because only the+-- property tests rely on the canonical form & merging behaviour.+module Support.ParamSpecNormalize+  ( NormalParamSpec(..)+  , normalise+  , normaliseMany+  , normaliseManyInt+  , combine+  , toParamSpec+  , acceptsParamSpec+  , acceptsNormal+  ) where++import qualified Data.HashSet as HS+import Data.Hashable (Hashable)+import Support.ParamSpec+import Data.List (sortOn)++-- | Canonical internal form (test-only).+data NormalParamSpec a where+  NExact      :: a -> NormalParamSpec a+  NEnum       :: [a] -> NormalParamSpec a+  NRangeInt   :: Int -> Int -> NormalParamSpec Int+  NUnion      :: [NormalParamSpec a] -> NormalParamSpec a+  NAny        :: NormalParamSpec a+  NOpaquePred :: (a -> Bool) -> String -> NormalParamSpec a++instance Show a => Show (NormalParamSpec a) where+  show (NExact a) = "NExact " ++ show a+  show (NEnum xs) = "NEnum " ++ show xs+  show (NRangeInt l h) = "NRangeInt " ++ show (l,h)+  show (NUnion xs) = "NUnion " ++ show (map show xs)+  show NAny = "NAny"+  show (NOpaquePred _ l) = "NOpaquePred <fn> " ++ show l++instance Eq a => Eq (NormalParamSpec a) where+  NExact a == NExact b = a == b+  NEnum xs == NEnum ys = xs == ys+  NRangeInt a b == NRangeInt c d = a == c && b == d+  NUnion xs == NUnion ys = xs == ys+  NAny == NAny = True+  NOpaquePred _ la == NOpaquePred _ lb = la == lb+  _ == _ = False++normalise :: Hashable a => ParamSpec a -> NormalParamSpec a+normalise ps = case ps of+  PSExact a      -> NExact a+  PSAny          -> NAny+  PSRangeInt l h -> range l h+  PSPredicate f l -> NOpaquePred f l+  PSEnum xs      -> enumNorm xs+ where+  range l h+    | l == h    = NExact l+    | l < h     = NRangeInt l h+    | otherwise = NRangeInt h l+  enumNorm [] = NEnum []+  enumNorm xs =+    let uniq = dedupStable xs+    in case uniq of+         []       -> NEnum []+         [x]      -> NExact x+         (x:y:rs) -> NEnum (x:y:rs)++normaliseMany :: Hashable a => [ParamSpec a] -> NormalParamSpec a+normaliseMany [] = NEnum []+normaliseMany [p] = normalise p+normaliseMany ps = combine (map normalise ps)++combine :: [NormalParamSpec a] -> NormalParamSpec a+combine specs+  | any isAny specs = NAny+  | otherwise = case flatten specs of+      []  -> NEnum []+      [x] -> x+      xs  -> NUnion xs+  where+    isAny NAny = True; isAny _ = False+    flatten [] = []+    flatten (NUnion xs:ys) = flatten xs ++ flatten ys+    flatten (x:xs) = x : flatten xs++normaliseManyInt :: [ParamSpec Int] -> NormalParamSpec Int+normaliseManyInt ps = finalize merged others+  where+    ns = map normalise ps+    flat = flatten ns+    (ranges, others) = partitionInt flat+    merged = mergeRanges ranges++    flatten [] = []+    flatten (NUnion xs:ys) = flatten xs ++ flatten ys+    flatten (x:xs) = x:flatten xs++    partitionInt [] = ([],[])+    partitionInt (n:ns') = case n of+      NRangeInt l h -> let (rs,os) = partitionInt ns' in ( (l,h):rs, os)+      NExact v      -> let (rs,os) = partitionInt ns' in ( (v,v):rs, os)+      _             -> let (rs,os) = partitionInt ns' in ( rs, n:os)++    mergeRanges [] = []+    mergeRanges rs = go (sortOn fst (map norm rs))+      where+        norm (l,h) = if l<=h then (l,h) else (h,l)+        go [] = []+        go [x] = [x]+        go ((l1,h1):(l2,h2):rest)+          | h1 + 1 < l2 = (l1,h1) : go ((l2,h2):rest)+          | otherwise   = go ((l1, max h1 h2):rest)++    finalize [] [] = NEnum []+    finalize [(l,h)] [] | l==h = NExact l+    finalize [(l,h)] []        = NRangeInt l h+    finalize rs os =+      let rangeNodes = map (\(l,h) -> if l==h then NExact l else NRangeInt l h) rs+          parts = rangeNodes ++ os+      in case parts of+           []  -> NEnum []+           [x] -> x+           xs  -> NUnion xs++toParamSpec :: NormalParamSpec a -> ParamSpec a+toParamSpec n = case n of+  NExact a        -> PSExact a+  NEnum xs        -> PSEnum xs+  NUnion _        -> PSAny+  NAny            -> PSAny+  NOpaquePred f l -> PSPredicate f l+  NRangeInt l h   -> PSRangeInt l h++acceptsParamSpec :: Eq a => ParamSpec a -> a -> Bool+acceptsParamSpec ps x = case ps of+  PSExact a        -> x == a+  PSEnum as        -> any (== x) as+  PSRangeInt l h   -> let (lo,hi) = if l <= h then (l,h) else (h,l) in lo <= x && x <= hi+  PSAny            -> True+  PSPredicate f _  -> f x++acceptsNormal :: Eq a => NormalParamSpec a -> a -> Bool+acceptsNormal n x = case n of+  NExact a        -> x == a+  NEnum as        -> any (== x) as+  NUnion as       -> any (\s -> acceptsNormal s x) as+  NAny            -> True+  NOpaquePred f _ -> f x+  NRangeInt l h   -> l <= x && x <= h++dedupStable :: Hashable a => [a] -> [a]+dedupStable = go HS.empty+  where+    go _ [] = []+    go seen (z:zs)+      | HS.member z seen = go seen zs+      | otherwise        = z : go (HS.insert z seen) zs

@@ -64,5 +64,17 @@              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"+      it "Param a :> rest" do+        projReturn (param 10 :> param "foo" :> param True) `shouldBe` param True  data TestData = Foo String | Bar deriving (Eq, Show)