diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,15 @@
and this project adheres to the
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+## [1.2.0.0] - 2025-12-31
+### Changed
+- **Breaking Change**: Changed the fixity of `expects` operator to `infixl 0` to resolve precedence issues with `$`.
+ - **Impact**: Code using `mock $ ... expects ...` will now fail to compile.
+ - **Migration**: Wrap the mock definition in parentheses: `mock (... ~> ...) expects ...`.
+- **Breaking Change**: `expects` now strictly enforces that it can only be applied to a mock creation action (`m fn`).
+ - Attempting to apply `expects` directly to a `MockSpec` (e.g. `(any ~> 1) expects ...`) or an already instantiated function will result in a compile-time `TypeError`.
+- Removed redundant `Typeable` constraints from `expects`, enabling cleaner builds on GHC 9.8+.
+
## [1.1.0.0] - 2025-12-29
### Added
- **HPC Coverage Support**: Verification logic now robustly handles unstable `StableNames` caused by HPC instrumentation (`stack test --coverage`).
diff --git a/README-ja.md b/README-ja.md
--- a/README-ja.md
+++ b/README-ja.md
@@ -18,7 +18,7 @@
```haskell
-- 定義 (Define)
-f <- mock $ "input" ~> "output"
+f <- mock ("input" ~> "output")
-- 検証 (Verify)
f `shouldBeCalled` "input"
@@ -60,8 +60,8 @@
| | **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"
_記録は自動。
「何を検証するか」という本質に集中できます。_ |
+| **定義 (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"
_記録は自動。
「何を検証するか」という本質に集中できます。_ |
### 主な特徴
@@ -70,10 +70,16 @@
* **値ではなく「条件」で検証**: 引数が `Eq` インスタンスを持っていなくても問題ありません。値の一致だけでなく、「どのような性質を満たすべきか」という条件 (Predicate) で検証できます。
* **圧倒的に親切なエラー**: テスト失敗時、どこが違うのかを「構造差分」で表示します。
```text
- Expected arguments were not called.
- expected: [Record { name = "Alice", age = 20 }]
- but got: [Record { name = "Alice", age = 21 }]
- ^^
+ function was not called with the expected arguments.
+
+ Closest match:
+ expected: Record { name = "Alice", age = 20 }
+ but got: Record { name = "Alice", age = 21 }
+ ^^^
+ Specific difference in `age`:
+ expected: 20
+ but got: 21
+ ^^
```
* **意図を導く型設計**: 型はあなたの記述を縛るものではなく、テストの意図（何を期待しているか）を自然に表現させるために存在します。
@@ -113,7 +119,7 @@
spec = do
it "Quick Start Demo" do
-- 1. モックを作成 ("Hello" を受け取ったら 42 を返す)
- f <- mock $ "Hello" ~> (42 :: Int)
+ f <- mock ("Hello" ~> (42 :: Int))
-- 2. 関数として使う
let result = f "Hello"
@@ -128,9 +134,9 @@
### 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` |
+| **`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"]`` |
@@ -151,7 +157,7 @@
```haskell
-- "a" -> "b" -> True を返す関数
-f <- mock $ "a" ~> "b" ~> True
+f <- mock ("a" ~> "b" ~> True)
```
**柔軟なマッチング**:
@@ -159,10 +165,10 @@
```haskell
-- 任意の文字列 (param any)
-f <- mock $ any ~> True
+f <- mock (any ~> True)
-- 条件式 (expect)
-f <- mock $ expect (> 5) "> 5" ~> True
+f <- mock (expect (> 5) "> 5" ~> True)
```
### 2. 型クラスのモック (`makeMock`)
@@ -228,6 +234,13 @@
f "arg"
```
+> [!IMPORTANT]
+> `expects`（宣言的検証）を使用する場合、モック定義部分は必ず **括弧 `(...)`** で囲んでください。
+> 以前のバージョンで使用できた `$` 演算子 (`mock $ ... expected ...`) は、優先順位の関係でコンパイルエラーになります。
+>
+> ❌ `mock $ any ~> True expects ...`
+> ✅ `mock (any ~> True) expects ...`
+
> [!NOTE]
> `runMockT` ブロックの中でも、同様に `expects` を使った宣言的検証が可能です。
> つまり、「モック生成」と「期待値宣言」が１つのブロック内で完結する統一された体験を提供します。
@@ -241,7 +254,7 @@
```haskell
-- どんな引数で呼ばれても True を返す
-f <- mock $ any ~> True
+f <- mock (any ~> True)
-- 何でもいいから呼ばれたことを検証
f `shouldBeCalled` any
@@ -254,7 +267,7 @@
```haskell
-- 引数が "error" で始まる場合のみ False を返す
-f <- mock $ do
+f <- mock do
onCase $ expect (\s -> "error" `isPrefixOf` s) "start with error" ~> False
onCase $ any ~> True
```
@@ -299,7 +312,7 @@
`IO` を返す関数で、呼び出しごとに副作用（結果）を変えたい場合に使います。
```haskell
-f <- mock $ do
+f <- mock do
onCase $ "get" ~> pure @IO 1 -- 1回目
onCase $ "get" ~> pure @IO 2 -- 2回目
```
@@ -309,7 +322,7 @@
エラーメッセージに関数名を表示させたい場合は、ラベルを付けられます。
```haskell
-f <- mock (label "myAPI") $ "arg" ~> True
+f <- mock (label "myAPI") ("arg" ~> True)
```
---
@@ -399,7 +412,7 @@
その場合は明示的に型注釈を付けてください。
```haskell
-mock $ ("value" :: String) ~> True
+mock (("value" :: String) ~> True)
```
---
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -18,7 +18,7 @@
```haskell
-- Define
-f <- mock $ "input" ~> "output"
+f <- mock ("input" ~> "output")
-- Verify
f `shouldBeCalled` "input"
@@ -60,8 +60,8 @@
| | **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"._ |
+| **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
@@ -70,10 +70,16 @@
* **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 }]
- ^^
+ function was not called with the expected arguments.
+
+ Closest match:
+ expected: Record { name = "Alice", age = 20 }
+ but got: Record { name = "Alice", age = 21 }
+ ^^^
+ Specific difference in `age`:
+ expected: 20
+ but got: 21
+ ^^
```
* **Intent-Driven Types**: Types exist not to restrict you, but to naturally guide you in expressing your testing intent.
@@ -113,7 +119,7 @@
spec = do
it "Quick Start Demo" do
-- 1. Create a mock (Return 42 when receiving "Hello")
- f <- mock $ "Hello" ~> (42 :: Int)
+ f <- mock ("Hello" ~> (42 :: Int))
-- 2. Use it as a function
let result = f "Hello"
@@ -128,9 +134,9 @@
### 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` |
+| **`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"]`` |
@@ -153,7 +159,7 @@
```haskell
-- Function that returns True for "a" -> "b"
-f <- mock $ "a" ~> "b" ~> True
+f <- mock ("a" ~> "b" ~> True)
```
**Flexible Matching**:
@@ -161,10 +167,10 @@
```haskell
-- Arbitrary string (param any)
-f <- mock $ any ~> True
+f <- mock (any ~> True)
-- Condition (expect)
-f <- mock $ expect (> 5) "> 5" ~> True
+f <- mock (expect (> 5) "> 5" ~> True)
```
### 2. Typeclass Mocking (`makeMock`)
@@ -230,6 +236,13 @@
f "arg"
```
+> [!IMPORTANT]
+> When using `expects` (declarative verification), you MUST wrap the mock definition in **parentheses `(...)`**.
+> The `$` operator pattern used in previous versions (`mock $ ... expected ...`) will cause compilation errors due to precedence changes.
+>
+> ❌ `mock $ any ~> True expects ...`
+> ✅ `mock (any ~> True) expects ...`
+
> [!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.
@@ -243,7 +256,7 @@
```haskell
-- Return True regardless of the argument
-f <- mock $ any ~> True
+f <- mock (any ~> True)
-- Verify that it was called (arguments don't matter)
f `shouldBeCalled` any
@@ -256,7 +269,7 @@
```haskell
-- Return False only if the argument starts with "error"
-f <- mock $ do
+f <- mock do
onCase $ expect (\s -> "error" `isPrefixOf` s) "start with error" ~> False
onCase $ any ~> True
```
@@ -301,7 +314,7 @@
Used when you want a function returning `IO` to have different side effects (results) for each call.
```haskell
-f <- mock $ do
+f <- mock do
onCase $ "get" ~> pure @IO 1 -- 1st call
onCase $ "get" ~> pure @IO 2 -- 2nd call
```
@@ -311,7 +324,7 @@
You can attach labels to display function names in error messages.
```haskell
-f <- mock (label "myAPI") $ "arg" ~> True
+f <- mock (label "myAPI") ("arg" ~> True)
```
---
@@ -401,7 +414,7 @@
Add explicit type annotations to resolve this.
```haskell
-mock $ ("value" :: String) ~> True
+mock (("value" :: String) ~> True)
```
---
diff --git a/mockcat.cabal b/mockcat.cabal
--- a/mockcat.cabal
+++ b/mockcat.cabal
@@ -5,7 +5,7 @@
-- see: https://github.com/sol/hpack
name: mockcat
-version: 1.1.0.0
+version: 1.2.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.
@@ -46,6 +46,7 @@
Test.MockCat.Internal.MockRegistry
Test.MockCat.Internal.Registry.Core
Test.MockCat.Internal.Types
+ Test.MockCat.Internal.Verify
Test.MockCat.Mock
Test.MockCat.MockT
Test.MockCat.Param
@@ -94,6 +95,7 @@
Test.MockCat.AssociationListSpec
Test.MockCat.ConcurrencySpec
Test.MockCat.ConsSpec
+ Test.MockCat.DeferredTypeErrorsSpec
Test.MockCat.ExampleSpec
Test.MockCat.HPCFallbackSpec
Test.MockCat.HPCNestSpec
@@ -101,6 +103,7 @@
Test.MockCat.Internal.MockRegistrySpec
Test.MockCat.MockSpec
Test.MockCat.MockTSpec
+ Test.MockCat.MultipleMocksSpec
Test.MockCat.ParamSpec
Test.MockCat.PartialMockCommonSpec
Test.MockCat.PartialMockSpec
diff --git a/src/Test/MockCat/Internal/Builder.hs b/src/Test/MockCat/Internal/Builder.hs
--- a/src/Test/MockCat/Internal/Builder.hs
+++ b/src/Test/MockCat/Internal/Builder.hs
@@ -35,6 +35,7 @@
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`)
@@ -150,6 +151,8 @@
recorder = InvocationRecorder ref PureConstant
pure (BuiltMock fn recorder)
+
+
-- | Instance for building a stub for a value (backward compatibility).
instance
MockBuilder (Param r) r ()
@@ -219,6 +222,8 @@
) => MockIOBuilder (Param a :> rest) fn args where
buildIO name params =
buildWithRecorderIO (\ref inputParams -> executeInvocation ref (singleInvocationStep name params inputParams))
+
+
buildWithRecorder ::
diff --git a/src/Test/MockCat/Internal/Message.hs b/src/Test/MockCat/Internal/Message.hs
--- a/src/Test/MockCat/Internal/Message.hs
+++ b/src/Test/MockCat/Internal/Message.hs
@@ -92,28 +92,7 @@
" expected: " <> expectedStr,
" but the function was never called"
]
- _ ->
- let actualStr = formatInvocationList invocationList
- diffLine = " " <> diffPointer expectedStr actualStr
- in case structuralDiff expectedStr actualStr of
- [] ->
- intercalate "\n"
- [ mainMessage,
- " expected: " <> expectedStr,
- " but got: " <> actualStr,
- diffLine
- ]
- ds ->
- let diffMessages = formatDifferences ds
- in intercalate "\n"
- [ mainMessage,
- diffMessages,
- "",
- "Full context:",
- " expected: " <> expectedStr,
- " but got: " <> actualStr,
- diffLine
- ]
+ _ -> countWithArgsMismatchMessageWithDiff name expected invocationList
data Difference = Difference
{ diffPath :: String,
@@ -231,6 +210,74 @@
let commonPrefixLen s1 s2 = length $ takeWhile id $ zipWith (==) s1 s2
scores = map (\e -> (commonPrefixLen actual e, e)) expectations
in snd $ maximumBy (comparing fst) scores
+
+countWithArgsMismatchMessageWithDiff :: Show a => Maybe MockName -> a -> [a] -> String
+countWithArgsMismatchMessageWithDiff mockName expected actuals =
+ let expectedStr = formatStr (show expected)
+ actualStrs = map (formatStr . show) actuals
+ (nearest, nearestIdx) = chooseNearestWithIndex expectedStr actualStrs
+ diffLine = " " <> diffPointer expectedStr nearest
+
+ header = "function" <> mockNameLabel mockName <> " was not called with the expected arguments."
+
+ closestMatchSection =
+ intercalate "\n"
+ [ " Closest match:"
+ , " expected: " <> expectedStr
+ , " but got: " <> nearest
+ , diffLine
+ ]
+
+ diffs = case structuralDiff expectedStr nearest of
+ [] -> ""
+ ds -> formatDifferences ds
+
+ historySection = formatCallHistory actualStrs nearestIdx
+ in intercalate "\n" $
+ [ header
+ , ""
+ , closestMatchSection
+ ]
+ ++ (if null diffs then [] else [diffs])
+ ++
+ [ ""
+ , historySection
+ ]
+
+chooseNearestWithIndex :: String -> [String] -> (String, Int)
+chooseNearestWithIndex _ [] = ("", -1)
+chooseNearestWithIndex pivot candidates =
+ let commonPrefixLen s1 s2 = length $ takeWhile id $ zipWith (==) s1 s2
+ scores = zipWith (\idx c -> (commonPrefixLen pivot c, c, idx)) [0..] candidates
+ (_, bestStr, bestIdx) = maximumBy (comparing (\(score, _, _) -> score)) scores
+ in (bestStr, bestIdx)
+
+formatCallHistory :: [String] -> Int -> String
+formatCallHistory actuals nearestIdx =
+ let count = length actuals
+ limit = 5
+ (shown, hidden) = splitAt limit actuals
+
+ formatItem idx s =
+ let num = idx + 1
+ prefix = if idx == nearestIdx then " [Closest] " else " "
+ -- number alignment: "1. " vs "10. "
+ numStr = show num <> "."
+ paddedNum = if num < 10 then numStr <> " " else numStr
+ in prefix <> paddedNum <> s
+
+ items = zipWith formatItem [0..] shown
+
+ moreMessage =
+ if null hidden
+ then []
+ else [" ... (" <> show (length hidden) <> " more calls)"]
+
+ in intercalate "\n"
+ ( [ " Call history (" <> show count <> " calls):" ]
+ ++ items
+ ++ moreMessage
+ )
isRecord :: String -> Bool
diff --git a/src/Test/MockCat/Internal/Types.hs b/src/Test/MockCat/Internal/Types.hs
--- a/src/Test/MockCat/Internal/Types.hs
+++ b/src/Test/MockCat/Internal/Types.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use null" #-}
@@ -11,12 +13,15 @@
import Control.Monad (ap)
import Control.Concurrent.STM (TVar)
-import Data.Maybe
+import Data.Maybe (listToMaybe)
import GHC.IO (unsafePerformIO)
import Test.MockCat.AssociationList (AssociationList)
import Prelude hiding (lookup)
-import Control.Monad.State ( State )
+import Control.Monad.State ( State, MonadState, execState, modify )
+import Control.Monad.Reader (MonadReader, ask)
+type MockName = String
+
data InvocationRecorder params = InvocationRecorder
{ invocationRef :: TVar (InvocationRecord params)
, functionNature :: FunctionNature
@@ -28,6 +33,11 @@
, builtMockRecorder :: InvocationRecorder params
}
+data ResolvedMock params = ResolvedMock {
+ resolvedMockName :: Maybe MockName,
+ resolvedMockRecorder :: InvocationRecorder params
+}
+
data FunctionNature
= PureConstant
| IOConstant
@@ -49,6 +59,7 @@
| GreaterThanEqual Int
| LessThan Int
| GreaterThan Int
+ deriving (Eq)
instance Show CountVerifyMethod where
show (Equal e) = show e
@@ -77,6 +88,7 @@
data VerifyOrderMethod
= ExactlySequence
| PartiallySequence
+ deriving (Show, Eq)
data VerifyOrderResult a = VerifyOrderResult
{ index :: Int,
@@ -88,8 +100,6 @@
data VerifyMatchType a = MatchAny a | MatchAll a
-type MockName = String
-
safeIndex :: [a] -> Int -> Maybe a
safeIndex xs n
| n < 0 = Nothing
@@ -98,3 +108,40 @@
{-# NOINLINE perform #-}
perform :: IO a -> a
perform = unsafePerformIO
+
+-- | Mock expectation context holds verification actions to run at the end
+-- of the `withMock` block. Storing `IO ()` avoids forcing concrete param
+-- types at registration time.
+newtype WithMockContext = WithMockContext (TVar [IO ()])
+
+class MonadWithMockContext m where
+ askWithMockContext :: m WithMockContext
+
+instance {-# OVERLAPPABLE #-} (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
+ deriving (Show, Eq)
+
+-- | Expectations builder (Monad instance for do syntax)
+newtype Expectations params a = Expectations (State [Expectation params] a)
+ deriving (Functor, Applicative, Monad, MonadState [Expectation params])
+
+-- | Run the Expectations monad to get a list of Expectation
+runExpectations :: Expectations params () -> [Expectation params]
+runExpectations (Expectations s) = execState s []
+
+-- | Add an expectation to the list
+addExpectation :: Expectation params -> Expectations params ()
+addExpectation e = modify (++ [e])
diff --git a/src/Test/MockCat/Internal/Verify.hs b/src/Test/MockCat/Internal/Verify.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/MockCat/Internal/Verify.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+
+module Test.MockCat.Internal.Verify where
+
+import Control.Concurrent.STM (readTVarIO, TVar)
+import Control.Monad (guard, when)
+import Data.List (intercalate, elemIndex)
+import Data.Maybe (catMaybes, isNothing)
+import Test.MockCat.Internal.Types
+import Test.MockCat.Internal.Message
+
+import Prelude hiding (lookup)
+
+-- | Verify an expectation directly against a resolved mock.
+-- This is used by 'mock' when expectations are provided.
+verifyExpectationDirect :: (Eq params, Show params) => ResolvedMock params -> Expectation params -> IO ()
+verifyExpectationDirect resolved (CountExpectation method args) =
+ verifyResolvedCount resolved args method
+verifyExpectationDirect resolved (CountAnyExpectation method) =
+ verifyResolvedCallCount resolved method
+verifyExpectationDirect resolved (OrderExpectation method matchers) =
+ verifyResolvedOrder method resolved matchers
+verifyExpectationDirect resolved (SimpleExpectation args) =
+ verifyResolvedMatch resolved (MatchAny args)
+verifyExpectationDirect resolved AnyExpectation =
+ verifyResolvedAny resolved
+
+-- | Verify that a resolved mock function was called at least once.
+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"
+ ]
+
+-- | Verify that mock was called with specific arguments using resolved mock directly.
+verifyResolvedMatch :: (Eq params, Show params) => ResolvedMock params -> VerifyMatchType params -> IO ()
+verifyResolvedMatch (ResolvedMock mockName recorder) matchType = do
+ invocationList <- readInvocationList (invocationRef recorder)
+ case doVerify mockName invocationList matchType of
+ Nothing -> pure ()
+ Just (VerifyFailed msg) ->
+ errorWithoutStackTrace msg `seq` pure ()
+
+-- | Verify call count with specific arguments using resolved mock directly.
+verifyResolvedCount :: (Eq params, Show params) => ResolvedMock params -> params -> CountVerifyMethod -> IO ()
+verifyResolvedCount (ResolvedMock mockName recorder) v method = do
+ invocationList <- readInvocationList (invocationRef recorder)
+ let callCount = length (filter (v ==) invocationList)
+ if compareCount method callCount
+ then pure ()
+ else
+ errorWithoutStackTrace $
+ -- If we expected some calls (e.g. atLeast 1) but got 0, and there were OTHER calls,
+ -- show the closest match diff to help debugging.
+ if callCount == 0 && not (null invocationList)
+ && expectsPositive method
+ then countWithArgsMismatchMessageWithDiff mockName v invocationList
+ else countWithArgsMismatchMessage mockName method callCount
+
+expectsPositive :: CountVerifyMethod -> Bool
+expectsPositive (Equal n) = n > 0
+expectsPositive (GreaterThanEqual n) = n > 0
+expectsPositive (GreaterThan _) = True
+expectsPositive (LessThan _) = False -- usually "less than 2" allows 0, so 0 is valid.
+expectsPositive (LessThanEqual _) = False -- "at most N" allows 0.
+
+-- | Verify overall call count (ignoring arguments)
+verifyResolvedCallCount :: ResolvedMock params -> CountVerifyMethod -> IO ()
+verifyResolvedCallCount (ResolvedMock mockName recorder) method =
+ verifyCallCount mockName recorder method
+
+-- | Verify call order using resolved mock directly.
+verifyResolvedOrder :: (Eq params, Show params) => VerifyOrderMethod -> ResolvedMock params -> [params] -> IO ()
+verifyResolvedOrder method (ResolvedMock mockName recorder) matchers = do
+ invocationList <- readInvocationList (invocationRef recorder)
+ case doVerifyOrder method mockName invocationList matchers of
+ Nothing -> pure ()
+ Just (VerifyFailed msg) ->
+ errorWithoutStackTrace msg `seq` pure ()
+
+-- | Internal helper to read invocation list
+readInvocationList :: TVar (InvocationRecord params) -> IO (InvocationList params)
+readInvocationList ref = do
+ record <- readTVarIO ref
+ pure $ invocations record
+
+-- | Helper to verify call count (low level)
+verifyCallCount ::
+ Maybe MockName ->
+ InvocationRecorder params ->
+ CountVerifyMethod ->
+ IO ()
+verifyCallCount maybeName recorder method = do
+ result <- tryVerifyCallCount maybeName recorder method
+ case result of
+ Nothing -> pure ()
+ Just msg -> errorWithoutStackTrace msg
+
+tryVerifyCallCount ::
+ Maybe MockName ->
+ InvocationRecorder params ->
+ CountVerifyMethod ->
+ IO (Maybe String)
+tryVerifyCallCount maybeName recorder method = do
+ invocationList <- readInvocationList (invocationRef recorder)
+ let callCount = length invocationList
+ if compareCount method callCount
+ then pure Nothing
+ else pure $ Just $ countMismatchMessage maybeName method callCount
+
+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
+
+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
+ ]
+
+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
+
+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
+
+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]
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,4 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
@@ -23,6 +26,7 @@
, mock
, mockM
, createNamedMockFnWithParams
+ , CreateMockFn(..)
, stub
, shouldBeCalled
, times
@@ -44,21 +48,26 @@
, casesIO
, label
, Label
+ , MockDispatch(..)
+ , IsMockSpec
) where
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State (get, put)
+import Control.Concurrent.STM (atomically, modifyTVar')
import Data.Kind (Type)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
import Prelude hiding (lookup)
import Test.MockCat.Internal.Builder
+import Test.MockCat.Internal.Verify (verifyExpectationDirect)
import qualified Test.MockCat.Internal.MockRegistry as MockRegistry ( register )
import Test.MockCat.Internal.Types
import Test.MockCat.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.
@@ -125,13 +134,64 @@
class CreateStubFn a where
stubImpl :: a
+-- | Type family to distinguish MockSpec from other parameters.
+type family IsMockSpec p :: Bool where
+ IsMockSpec (MockSpec p e) = 'True
+ IsMockSpec other = 'False
+
+-- | Internal class for dispatching named mocks based on parameter type.
+-- This resolves overlapping instances between generic params and MockSpec.
+-- The 'flag' parameter avoids instance overlap.
+class MockDispatch (flag :: Bool) p m fn where
+ mockDispatchImpl :: Label -> p -> m fn
+
+-- Generic instance for named mocks (flag ~ 'False)
+instance
+ ( MonadIO m
+ , CreateMock p
+ , MockBuilder (ToMockParams p) fn verifyParams
+ , Typeable verifyParams
+ , Typeable fn
+ , IsMockSpec p ~ 'False
+ ) =>
+ MockDispatch 'False p m fn
+ where
+ mockDispatchImpl (Label name) p = do
+ let params = toParams p
+ BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) params
+ liftIO $ MockRegistry.register (Just name) recorder fn
+
+-- Specific instance for MockSpec (flag ~ 'True)
+instance
+ ( MonadIO m
+ , MonadWithMockContext m
+ , CreateMock params
+ , MockBuilder (ToMockParams params) fn verifyParams
+ , Show verifyParams
+ , Eq verifyParams
+ , Typeable verifyParams
+ , Typeable fn
+ ) =>
+ MockDispatch 'True (MockSpec params [Expectation verifyParams]) m fn
+ where
+ mockDispatchImpl (Label name) (MockSpec params exps) = do
+ BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) (toParams params)
+ _ <- liftIO $ MockRegistry.register (Just name) recorder fn
+
+ WithMockContext ctxRef <- askWithMockContext
+ let resolved = ResolvedMock (Just name) recorder
+ let verifyAction = mapM_ (verifyExpectationDirect resolved) exps
+ liftIO $ atomically $ modifyTVar' ctxRef (++ [verifyAction])
+
+ pure fn
+
-- | 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
+instance {-# OVERLAPPABLE #-}
( MonadIO m
, CreateMock p
, MockBuilder (ToMockParams p) fn verifyParams
@@ -145,23 +205,45 @@
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.
+-- | Create a mock function from MockSpec.
+-- MockSpec can optionally contain expectations.
+-- If expectations are present, they are automatically registered.
--
--- > f <- mock (label "MyAPI") $ "a" ~> "b"
+-- > f <- mock $ any ~> True
+-- > f <- mock $ any ~> True `expects` do called once
instance {-# OVERLAPPING #-}
( MonadIO m
- , CreateMock p
- , MockBuilder (ToMockParams p) fn verifyParams
+ , MonadWithMockContext m
+ , CreateMock params
+ , MockBuilder (ToMockParams params) fn verifyParams
+ , Show verifyParams
+ , Eq verifyParams
, Typeable verifyParams
, Typeable fn
) =>
+ CreateMockFn (MockSpec params [Expectation verifyParams] -> m fn)
+ where
+ mockImpl (MockSpec params exps) = do
+ BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing (toParams params)
+ _ <- liftIO $ MockRegistry.register Nothing recorder fn
+
+ WithMockContext ctxRef <- askWithMockContext
+ let resolved = ResolvedMock Nothing recorder
+ let verifyAction = mapM_ (verifyExpectationDirect resolved) exps
+ liftIO $ atomically $ modifyTVar' ctxRef (++ [verifyAction])
+
+ pure 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 #-} forall p m fn.
+ ( MockDispatch (IsMockSpec p) p m 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
+ mockImpl = mockDispatchImpl @(IsMockSpec p)
-- | Create a mock function with verification hooks attached.
--
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
@@ -29,9 +29,8 @@
import Data.IORef (newIORef, IORef)
import Data.Dynamic (Dynamic)
import UnliftIO (MonadUnliftIO(..))
-import Test.MockCat.Internal.Types (InvocationRecorder)
+import Test.MockCat.Internal.Types (InvocationRecorder, WithMockContext(..), MonadWithMockContext(..))
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
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
@@ -19,6 +19,7 @@
value,
param,
ConsGen(..),
+ MockSpec(..),
expect,
expect_,
any,
@@ -35,14 +36,25 @@
where
import Test.MockCat.Cons ((:>) (..), Head(..))
+import Test.MockCat.Internal.Types (Cases)
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)
-infixr 0 ~>
+infixr 1 ~>
+-- | MockSpec wraps stub parameters with optional expectations.
+-- The 'exps' type parameter is () when no expectations are set,
+-- or a list of expectations when 'expects' has been applied.
+-- This design ensures 'expects' can only be applied to MockSpec,
+-- not to the result of 'mock'.
+data MockSpec params exps = MockSpec
+ { specParams :: params
+ , specExpectations :: exps
+ } deriving (Show, Eq)
+
data Param v where
-- | A parameter that expects a specific value.
ExpectValue :: (Show v, Eq v) => v -> String -> Param v
@@ -119,6 +131,7 @@
-- | Type family to untie the knot for ConsGen instances
type family Normalize a where
Normalize (a :> b) = a :> b
+ Normalize Head = Head
Normalize (Param a) = Param a
Normalize a = Param a
@@ -134,6 +147,9 @@
instance {-# OVERLAPPABLE #-} (Normalize a ~ Param a, WrapParam a) => ToParamArg a where
toParamArg = wrap
+instance {-# OVERLAPPING #-} ToParamArg Head where
+ toParamArg = id
+
class ToParamResult b where
toParamResult :: b -> Normalize b
@@ -149,6 +165,7 @@
class ConsGen a b where
(~>) :: a -> b -> Normalize a :> Normalize b
+-- | Instance for chaining parameters
instance (ToParamArg a, ToParamResult b) => ConsGen a b where
(~>) a b = (:>) (toParamArg a) (toParamResult b)
@@ -179,8 +196,11 @@
-- | The type of the argument parameters of the parameters.
type family ArgsOf params where
ArgsOf (Head :> Param r) = () -- Constant value has no arguments
+ ArgsOf (IO a) = ()
ArgsOf (Param a :> Param r) = Param a
ArgsOf (Param a :> rest) = Param a :> ArgsOf rest
+ ArgsOf (Cases a b) = ArgsOf a
+ ArgsOf a = ()
-- | Class for projecting the arguments of the parameter.
class ProjectionArgs params where
diff --git a/src/Test/MockCat/TH/FunctionBuilder.hs b/src/Test/MockCat/TH/FunctionBuilder.hs
--- a/src/Test/MockCat/TH/FunctionBuilder.hs
+++ b/src/Test/MockCat/TH/FunctionBuilder.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
@@ -32,7 +33,7 @@
)
where
-import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Language.Haskell.TH
( Dec (..),
@@ -51,11 +52,9 @@
)
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.Mock (IsMockSpec, MockDispatch(..), label)
+import Test.MockCat.Internal.Types (InvocationRecorder)
+import Test.MockCat.Cons ((:>)(..))
import Test.MockCat.MockT
( MockT (..),
Definition (..),
@@ -66,7 +65,9 @@
( isNotConstantFunctionType,
needsTypeable,
collectTypeVars,
- collectTypeableTargets
+ collectTypeableTargets,
+ splitApps,
+ isTypeFamily
)
import Test.MockCat.TH.ContextBuilder
( MockType (..)
@@ -78,14 +79,14 @@
import Test.MockCat.Verify (ResolvableParamsOf)
import Data.Dynamic (Dynamic, toDyn)
import Data.Proxy (Proxy(..))
-import Data.List (find, nubBy)
+import Data.List (find, nubBy, nub)
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.Param (Param)
import Test.MockCat.TH.Types (MockOptions(..))
createMockBuilderVerifyParams :: Type -> Type
@@ -121,12 +122,14 @@
]
-- 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
- ]
+createTypeablePreds :: [Type] -> Q [Pred]
+createTypeablePreds targets = do
+ allTargets <- concat <$> mapM collectTypeableTargets targets
+ pure
+ [ AppT (ConT ''Typeable) t
+ | t <- nubBy (\a b -> pprint a == pprint b) allTargets
+ , needsTypeable t
+ ]
data MockFnContext = MockFnContext
@@ -191,159 +194,199 @@
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))
+isAtomicNonFunction :: Type -> Q Bool
+isAtomicNonFunction (AppT t _) = isAtomicNonFunction t
+isAtomicNonFunction ListT = pure True
+isAtomicNonFunction (TupleT _) = pure True
+isAtomicNonFunction (ConT n)
+ | n == ''(->) = pure False
+ | otherwise = not <$> isTypeFamily (ConT n)
+isAtomicNonFunction _ = pure False
+
+doCreateMockFnDecs :: MockType -> String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
+doCreateMockFnDecs mockType funNameStr mockFunName params funTypeInput monadVarName _ = do
+ let funType = sanitizeType [monadVarName] funTypeInput
+ let resultType =
+ AppT
+ (AppT ArrowT (VarT params))
+ (AppT (AppT (ConT ''MockT) (VarT monadVarName)) funType)
+
+ mockTType = AppT (ConT ''MockT) (VarT monadVarName)
+ flag = AppT (ConT ''IsMockSpec) (VarT params)
+ createMockFnPred =
+ AppT (AppT (AppT (AppT (ConT ''MockDispatch) flag) (VarT params)) mockTType) funType
+
+ recType = AppT (ConT ''InvocationRecorder) (AppT (ConT ''ResolvableParamsOf) funType)
+ recConstraint = AppT (ConT ''Typeable) recType
+
+ paramsType = AppT (ConT ''ResolvableParamsOf) funType
+ paramsConstraint = AppT (ConT ''Typeable) paramsType
+
+
+ typeablePreds <- createTypeablePreds [funType]
+
+ let baseCtx =
+ [ createMockFnPred
+ , AppT (ConT ''MonadIO) (VarT monadVarName)
+ , recConstraint
+ , paramsConstraint
]
- 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))
+ ++ typeablePreds
+
+ ctx = case mockType of
+ Partial -> baseCtx
+ Total -> baseCtx
+
+ let vars = collectFreeVars funType ++ [params, monadVarName]
+ let tvs = map (\n -> PlainTV n SpecifiedSpec) (nub vars)
+ let finalCtx = filter (not . isRedundantTypeable monadVarName) ctx
+ newFunSig <- sigD mockFunName (pure (ForallT tvs finalCtx resultType))
- mockBody <- createMockBody funNameStr [|p|] funType
+ mockBody <- createMockBody funNameStr [|p|] (VarT params)
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"
+doCreateConstantMockFnDecs :: MockType -> String -> Name -> Type -> Name -> Q [Dec]
+doCreateConstantMockFnDecs Partial funNameStr mockFunName ty monadVarName = do
+ let stubVar = mkName "p"
+ let tySanitized = sanitizeType [monadVarName] ty
+ let resultType =
+ AppT
+ (AppT ArrowT (VarT stubVar))
+ (AppT (AppT (ConT ''MockT) (VarT monadVarName)) tySanitized)
+
+ let mockTType = AppT (ConT ''MockT) (VarT monadVarName)
+ let flag = AppT (ConT ''IsMockSpec) (VarT stubVar)
+ let createMockFnPred =
+ AppT (AppT (AppT (AppT (ConT ''MockDispatch) flag) (VarT stubVar)) mockTType) tySanitized
+
+ let recType = AppT (ConT ''InvocationRecorder) (AppT (ConT ''ResolvableParamsOf) tySanitized)
+ let recConstraint = AppT (ConT ''Typeable) recType
+
+ let paramsType = AppT (ConT ''ResolvableParamsOf) tySanitized
+ let paramsConstraint = AppT (ConT ''Typeable) paramsType
+
+ typeablePreds <- createTypeablePreds [tySanitized]
+ isAtomic <- isAtomicNonFunction tySanitized
+ let constraints = if isAtomic then [] else [recConstraint, paramsConstraint]
+
let ctx =
- [ AppT
- (AppT EqualityT (AppT (ConT ''ResolvableParamsOf) (VarT stubVar)))
- (TupleT 0)
+ [ createMockFnPred
, 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))
+ ++ constraints
+ ++ typeablePreds
+ let finalCtx = filter (not . isRedundantTypeable monadVarName) ctx
+ let vars = collectFreeVars tySanitized ++ [stubVar, monadVarName]
+ let tvs = map (\n -> PlainTV n SpecifiedSpec) (nub vars)
newFunSig <-
sigD
mockFunName
( pure
(ForallT
- [ PlainTV stubVar SpecifiedSpec
- , PlainTV monadVarName SpecifiedSpec
- ]
- ctx
+ tvs
+ finalCtx
resultType
)
)
- headParam <- [|Head :> param p|]
- mockBody <- createMockBody funNameStr (pure headParam) (VarT stubVar)
+ mockBody <- createMockBody funNameStr [|p|] (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)
+ case ty of
+ -- Case 3: Generic (Polymorphic p)
_ -> 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 =
+ let params = mkName "p"
+ let tySanitized = sanitizeType [monadVarName] ty
+ let 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]
+ (AppT ArrowT (VarT params))
+ (AppT (AppT (ConT ''MockT) (VarT monadVarName)) tySanitized)
+
+ mockTType = AppT (ConT ''MockT) (VarT monadVarName)
+ flag = AppT (ConT ''IsMockSpec) (VarT params)
+ createMockFnPred =
+ AppT (AppT (AppT (AppT (ConT ''MockDispatch) flag) (VarT params)) mockTType) tySanitized
-doCreateEmptyVerifyParamMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
-doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funType monadVarName updatedType = do
+ let recType = AppT (ConT ''InvocationRecorder) (AppT (ConT ''ResolvableParamsOf) tySanitized)
+ let recConstraint = AppT (ConT ''Typeable) recType
+
+ let paramsType = AppT (ConT ''ResolvableParamsOf) tySanitized
+ let paramsConstraint = AppT (ConT ''Typeable) paramsType
+
+ typeablePreds <- createTypeablePreds [tySanitized]
+ isAtomic <- isAtomicNonFunction tySanitized
+ let constraints = if isAtomic then [] else [recConstraint, paramsConstraint]
+
+ let ctx =
+ [ createMockFnPred
+ , AppT (ConT ''MonadIO) (VarT monadVarName)
+ ]
+ ++ constraints
+ ++ typeablePreds
+
+ let tvs = map (\n -> PlainTV n SpecifiedSpec) (nub (collectFreeVars tySanitized ++ [params, monadVarName]))
+ let finalCtx = filter (not . isRedundantTypeable monadVarName) ctx
+ newFunSig <- sigD mockFunName (pure (ForallT tvs finalCtx resultType))
+
+ mockBody <- createMockBody funNameStr [|p|] (VarT params)
+ newFun <- funD mockFunName [clause [varP params] (normalB (pure mockBody)) []]
+ pure [newFunSig, newFun]
+
+doCreateEmptyVerifyParamMockFnDecs :: String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
+doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funTypeInput monadVarName updatedType = do
+ let funType = sanitizeType [monadVarName] funTypeInput
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))
+
+ mockTType = AppT (ConT ''MockT) (VarT monadVarName)
+ flag = AppT (ConT ''IsMockSpec) (VarT params)
+ createMockFnPred =
+ AppT (AppT (AppT (AppT (ConT ''MockDispatch) flag) (VarT params)) mockTType) funType
- mockBody <- createMockBody funNameStr [|p|] funType
+ recType = AppT (ConT ''InvocationRecorder) (AppT (ConT ''ResolvableParamsOf) funType)
+ recConstraint = AppT (ConT ''Typeable) recType
+
+ paramsType = AppT (ConT ''ResolvableParamsOf) funType
+ paramsConstraint = AppT (ConT ''Typeable) paramsType
+
+ typeablePreds <- createTypeablePreds [funType, verifyParams]
+ let ctx =
+ [createMockFnPred]
+ ++ [AppT (ConT ''MonadIO) (VarT monadVarName)]
+ ++ [recConstraint, paramsConstraint]
+ ++ typeablePreds
+
+ let finalCtx = filter (not . isRedundantTypeable monadVarName) ctx
+
+ let vars = collectFreeVars funType ++ [params, monadVarName]
+ let tvs = map (\n -> PlainTV n SpecifiedSpec) (nub vars)
+ sigD mockFunName (pure (ForallT tvs finalCtx resultType))
+
+ mockBody <- createMockBody funNameStr [|p|] (VarT params)
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
+createMockBody funNameStr paramsExp paramsType = do
params <- paramsExp
+ let flag = AppT (ConT ''IsMockSpec) paramsType
[|
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
+ mockInstance <- unMockT $ $(appTypeE (varE 'mockDispatchImpl) (pure flag)) (label $(litE (stringL funNameStr))) $(pure params)
addDefinition
( Definition
(Proxy :: Proxy $(litT (strTyLit funNameStr)))
- canonicalInstance
+ mockInstance
NoVerification
)
- pure canonicalInstance
+ pure mockInstance
|]
createFnName :: Name -> MockOptions -> String
@@ -355,11 +398,40 @@
let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions
fmap (\(Definition _ mockFunction _) -> toDyn mockFunction) definition
+collectFreeVars :: Type -> [Name]
+collectFreeVars (ForallT bndrs _ t) =
+ let boundNames = map getTVName bndrs
+ in filter (`notElem` boundNames) (collectFreeVars t)
+collectFreeVars (AppT t1 t2) = collectFreeVars t1 ++ collectFreeVars t2
+collectFreeVars (SigT t _) = collectFreeVars t
+collectFreeVars (VarT n) = [n]
+collectFreeVars _ = []
+
+getTVName :: TyVarBndr flag -> Name
+getTVName (PlainTV n _) = n
+getTVName (KindedTV n _ _) = n
+
typeToNames :: Type -> [Q Name]
typeToNames (AppT (AppT ArrowT _) t2) = newName "a" : typeToNames t2
typeToNames (ForallT _ _ ty) = typeToNames ty
typeToNames _ = []
+sanitizeType :: [Name] -> Type -> Type
+sanitizeType kept (AppT t1 t2) = AppT (sanitizeType kept t1) (sanitizeType kept t2)
+sanitizeType kept (SigT t k) = SigT (sanitizeType kept t) (sanitizeType kept k)
+sanitizeType kept (VarT n)
+ | n `elem` kept = VarT n
+ | otherwise = VarT (mkName (nameBase n))
+sanitizeType kept (ForallT bndrs ctx t) =
+ let sanitizeBndr (PlainTV n flag)
+ | n `elem` kept = PlainTV n flag
+ | otherwise = PlainTV (mkName (nameBase n)) flag
+ sanitizeBndr (KindedTV n flag k)
+ | n `elem` kept = KindedTV n flag (sanitizeType kept k)
+ | otherwise = KindedTV (mkName (nameBase n)) flag (sanitizeType kept k)
+ in ForallT (map sanitizeBndr bndrs) (map (sanitizeType kept) ctx) (sanitizeType kept t)
+sanitizeType _ t = t
+
safeIndex :: [a] -> Int -> Maybe a
safeIndex [] _ = Nothing
safeIndex (x : _) 0 = Just x
@@ -380,8 +452,8 @@
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|])
+ let mockFn = unsafeCoerce mf
+ let $(bangP $ varP r) = $(generateStubFn args [|mockFn|])
$(pure returnExp)
Nothing -> error $ "no answer found stub function `" ++ fnNameStr ++ "`."
|]
@@ -397,14 +469,43 @@
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|])
+ let mockFn = unsafeCoerce mf
+ let $(bangP $ varP r) = $(generateStubFn args [|mockFn|])
$(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
+generateStubFn [] mockFn = mockFn
+generateStubFn args mockFn = foldl appE mockFn args
+
+
+isRedundantTypeable :: Name -> Pred -> Bool
+isRedundantTypeable monadName (AppT (ConT n) t)
+ | n == ''Typeable =
+ if null (collectFreeVars t)
+ then True
+ else case t of
+ VarT vn | nameBase vn == nameBase monadName -> False
+ _ -> if any (\v -> nameBase v == nameBase monadName) (collectFreeVars t)
+ then not (isProtectedType t)
+ else False
+ where
+ isProtectedType ty =
+ let (headTy, _) = splitApps ty
+ in case headTy of
+ ConT hn -> nameBase hn `elem` protectedTypes
+ _ -> False
+
+ protectedTypes =
+ [ "ResolvableParamsOf"
+ , "ResultType"
+ , "InvocationRecorder"
+ , "PrependParam"
+ , "FunctionParams"
+ ]
+isRedundantTypeable _ _ = False
+
+
diff --git a/src/Test/MockCat/TH/TypeUtils.hs b/src/Test/MockCat/TH/TypeUtils.hs
--- a/src/Test/MockCat/TH/TypeUtils.hs
+++ b/src/Test/MockCat/TH/TypeUtils.hs
@@ -6,12 +6,14 @@
collectTypeVars,
needsTypeable,
collectTypeableTargets,
- isStandardTypeCon
+ isStandardTypeCon,
+ isTypeFamily
+
)
where
import qualified Data.Map.Strict as Map
-import Language.Haskell.TH (Name, Type (..))
+import Language.Haskell.TH (Name, Type (..), Q, reify, Info(FamilyI), recover)
import Test.MockCat.Param (Param)
import Test.MockCat.Cons ((:>))
@@ -63,22 +65,46 @@
collectTypeVars (ForallT _ _ t) = collectTypeVars t
collectTypeVars (ImplicitParamT _ t) = collectTypeVars t
collectTypeVars _ = []
+
+peel :: Type -> Type
+peel (SigT t _) = peel t
+peel (ParensT t) = peel t
+peel t = t
-collectTypeableTargets :: Type -> [Type]
+collectTypeableTargets :: Type -> Q [Type]
collectTypeableTargets ty =
case ty of
- VarT _ -> [ty]
+ VarT _ -> pure [ty]
AppT _ _ ->
- let (f, args) = splitApps ty
- in if isStandardTypeCon f
- then concatMap collectTypeableTargets args
- else [ty]
+ let (headTy, args) = splitApps ty
+ in do
+ isTF <- isTypeFamily headTy
+ if isTF
+ then pure [ty]
+ else case peel headTy of
+ ConT _ -> concat <$> mapM collectTypeableTargets args
+ ListT -> pure [ty]
+ TupleT _ -> concat <$> mapM collectTypeableTargets args
+ VarT _ -> do
+ headResult <- pure (peel headTy)
+ argsResult <- concat <$> mapM collectTypeableTargets args
+ pure (headResult : argsResult)
+ ArrowT -> concat <$> mapM collectTypeableTargets args
+ _ -> concat <$> mapM collectTypeableTargets args
SigT t _ -> collectTypeableTargets t
ParensT t -> collectTypeableTargets t
- InfixT t1 _ t2 -> collectTypeableTargets t1 ++ collectTypeableTargets t2
- UInfixT t1 _ t2 -> collectTypeableTargets t1 ++ collectTypeableTargets t2
+ InfixT t1 _ t2 -> (++) <$> collectTypeableTargets t1 <*> collectTypeableTargets t2
+ UInfixT t1 _ t2 -> (++) <$> collectTypeableTargets t1 <*> collectTypeableTargets t2
ForallT _ _ t -> collectTypeableTargets t
- _ -> []
+ _ -> pure []
+
+isTypeFamily :: Type -> Q Bool
+isTypeFamily (ConT name) = recover (pure False) $ do
+ info <- reify name
+ case info of
+ FamilyI _ _ -> pure True
+ _ -> pure False
+isTypeFamily _ = pure False
isStandardTypeCon :: Type -> Bool
isStandardTypeCon ArrowT = True
diff --git a/src/Test/MockCat/Verify.hs b/src/Test/MockCat/Verify.hs
--- a/src/Test/MockCat/Verify.hs
+++ b/src/Test/MockCat/Verify.hs
@@ -18,10 +18,20 @@
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Test.MockCat.Verify where
-import Control.Concurrent.STM (TVar, readTVarIO)
+
+import Test.MockCat.Internal.Verify
+ ( tryVerifyCallCount
+ , compareCount
+ , countWithArgsMismatchMessage
+ , doVerify
+ , doVerifyOrder
+ , readInvocationList
+ )
import Test.MockCat.Internal.Types
-import Control.Monad (guard, when)
-import Data.List (elemIndex, intercalate)
+
+
+import Control.Monad ()
+import Data.List (intercalate)
import Data.Maybe
import Test.MockCat.Param
import Prelude hiding (lookup)
@@ -56,195 +66,8 @@
Nothing -> pure Nothing
Just (VerifyFailed msg) -> pure (Just msg)
-doVerify :: (Eq a, Show a) => Maybe MockName -> InvocationList a -> VerifyMatchType a -> Maybe VerifyFailed
-doVerify name list (MatchAny a) = do
- 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"
- ]
-
--- | Verify that mock was called with specific arguments using resolved mock directly.
--- This avoids StableName lookup and is HPC-safe.
-verifyResolvedMatch :: (Eq params, Show params) => ResolvedMock params -> VerifyMatchType params -> IO ()
-verifyResolvedMatch (ResolvedMock mockName recorder) matchType = do
- invocationList <- readInvocationList (invocationRef recorder)
- case doVerify mockName invocationList matchType of
- Nothing -> pure ()
- Just (VerifyFailed msg) ->
- errorWithoutStackTrace msg `seq` pure ()
-
--- | Verify call count with specific arguments using resolved mock directly.
--- This avoids StableName lookup and is HPC-safe.
-verifyResolvedCount :: Eq params => ResolvedMock params -> params -> CountVerifyMethod -> IO ()
-verifyResolvedCount (ResolvedMock mockName recorder) v method = do
- invocationList <- readInvocationList (invocationRef recorder)
- let callCount = length (filter (v ==) invocationList)
- if compareCount method callCount
- then pure ()
- else
- errorWithoutStackTrace $
- countWithArgsMismatchMessage mockName method callCount
-
--- | Verify call order using resolved mock directly.
--- This avoids StableName lookup and is HPC-safe.
-verifyResolvedOrder :: (Eq params, Show params) => VerifyOrderMethod -> ResolvedMock params -> [params] -> IO ()
-verifyResolvedOrder method (ResolvedMock mockName recorder) matchers = do
- invocationList <- readInvocationList (invocationRef recorder)
- case doVerifyOrder method mockName invocationList matchers of
- Nothing -> pure ()
- Just (VerifyFailed msg) ->
- errorWithoutStackTrace msg `seq` pure ()
-
-compareCount :: CountVerifyMethod -> Int -> Bool
-compareCount (Equal e) a = a == e
-compareCount (LessThanEqual e) a = a <= e
-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
- candidates <- requireResolved m
- checkCandidates candidates $ \(ResolvedMock mockName recorder) -> do
- invocationList <- readInvocationList (invocationRef recorder)
- let callCount = length (filter (v ==) invocationList)
- if compareCount method callCount
- then pure Nothing
- else
- pure $ Just $ countWithArgsMismatchMessage mockName method callCount
-
--- | Generate error message for count mismatch with arguments
-countWithArgsMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String
-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
- candidates <- requireResolved m
- checkCandidates candidates $ \(ResolvedMock mockName recorder) -> do
- invocationList <- readInvocationList (invocationRef recorder)
- case doVerifyOrder method mockName invocationList matchers of
- Nothing -> pure Nothing
- Just (VerifyFailed msg) -> pure (Just msg)
-
-doVerifyOrder ::
- (Eq a, Show a) =>
- 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
@@ -298,6 +121,31 @@
-- | Constraint alias for resolvable mock types with specific params.
type ResolvableMockWithParams m params = (ResolvableParamsOf m ~ params, ResolvableMock m)
+
+
+
+
+
+verificationFailure :: IO a
+verificationFailure =
+ errorWithoutStackTrace verificationFailureMessage
+
+
+
+requireResolved ::
+ forall target params.
+ ( params ~ ResolvableParamsOf target
+ , Typeable params
+ , Typeable (InvocationRecorder params)
+ ) =>
+ target ->
+ IO [ResolvedMock params]
+requireResolved target = do
+ candidates <- resolveForVerification target
+ case candidates of
+ [] -> verificationFailure
+ _ -> pure $ map (\(name, recorder) -> ResolvedMock name recorder) candidates
+
resolveForVerification ::
forall target params.
( params ~ ResolvableParamsOf target
@@ -324,74 +172,6 @@
pure $ (name, verifier) : matchRest
Nothing -> findCompatible rest
-
--- | Verify that the mock was called the expected number of times
--- Returns Nothing on success, or Just errorMessage on failure.
-tryVerifyCallCount ::
- Maybe MockName ->
- InvocationRecorder params ->
- CountVerifyMethod ->
- IO (Maybe String)
-tryVerifyCallCount maybeName recorder method = do
- invocationList <- readInvocationList (invocationRef recorder)
- let callCount = length invocationList
- if compareCount method callCount
- then pure Nothing
- else pure $ Just $ countMismatchMessage maybeName method callCount
-
--- | Verify that a function was called the expected number of times
--- Throw error if verification fails.
-verifyCallCount ::
- Maybe MockName ->
- InvocationRecorder params ->
- CountVerifyMethod ->
- IO ()
-verifyCallCount maybeName recorder method = do
- result <- tryVerifyCallCount maybeName recorder method
- case result of
- Nothing -> pure ()
- Just msg -> errorWithoutStackTrace msg
-
-
--- | Generate error message for count mismatch
-countMismatchMessage :: Maybe MockName -> CountVerifyMethod -> Int -> String
-countMismatchMessage maybeName method callCount =
- 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
- candidates <- resolveForVerification target
- case candidates of
- [] -> verificationFailure
- _ -> pure $ map (\(name, recorder) -> ResolvedMock name recorder) candidates
-
verificationFailureMessage :: String
verificationFailureMessage =
intercalate
@@ -634,7 +414,6 @@
Just (VerifyFailed msg) -> pure $ Just msg
AnyVerification -> do
- -- Logic for AnyVerification (called at least once)
if null invocationList
then pure $ Just $ intercalate "\n" ["Function" <> mockNameLabel mockName <> " was never called"]
else pure Nothing
diff --git a/src/Test/MockCat/WithMock.hs b/src/Test/MockCat/WithMock.hs
--- a/src/Test/MockCat/WithMock.hs
+++ b/src/Test/MockCat/WithMock.hs
@@ -9,25 +9,10 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# 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
@@ -40,83 +25,44 @@
, once
, never
, atLeast
+ , atMost
+ , greaterThan
+ , lessThan
, anything
, WithMockContext(..)
, MonadWithMockContext(..)
, Expectation(..)
, Expectations(..)
+ , verifyExpectationDirect
) 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
-
- , verifyResolvedAny
- , verifyCallCount
- , verifyResolvedMatch
- , verifyResolvedCount
- , verifyResolvedOrder
- , ResolvedMock(..)
- , VerificationSpec(..)
- , TimesSpec(..)
- , times
- , once
- , never
- , atLeast
- , anything
-
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Reader (ReaderT(..), runReaderT)
+import Control.Concurrent.STM (newTVarIO, readTVarIO, atomically, modifyTVar')
+import Control.Monad.State (get, put, modify)
+import Test.MockCat.Verify (TimesSpec(..), times, once, never, atLeast, atMost, greaterThan, lessThan, anything, ResolvableMock, ResolvableParamsOf)
+import Test.MockCat.Internal.Verify
+ ( verifyExpectationDirect
)
import Test.MockCat.Internal.Types
- ( CountVerifyMethod(..)
- , VerifyOrderMethod(..)
- , VerifyMatchType(..)
+ ( VerifyOrderMethod(..)
+ , WithMockContext(..)
+ , MonadWithMockContext(..)
+ , Expectation(..)
+ , Expectations(..)
+ , runExpectations
+ , addExpectation
, InvocationRecorder(..)
+ , ResolvedMock(..)
)
import qualified Test.MockCat.Internal.MockRegistry as MockRegistry
+
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 MonadWithMockContext m where
- askWithMockContext :: m WithMockContext
-instance {-# OVERLAPPABLE #-} (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
@@ -128,30 +74,6 @@
sequence_ actions
pure result
--- | Verify a single expectation using already-resolved mock.
--- This avoids StableName lookup and is HPC-safe.
-verifyExpectationDirect ::
- ( Show params
- , Eq params
- ) =>
- ResolvedMock params ->
- Expectation params ->
- IO ()
-verifyExpectationDirect resolved expectation = do
- case expectation of
- CountExpectation (Equal 1) args ->
- verifyResolvedMatch resolved (MatchAny args)
- CountExpectation method args ->
- verifyResolvedCount resolved args method
- CountAnyExpectation count ->
- verifyCallCount (resolvedMockName resolved) (resolvedMockRecorder resolved) count
- OrderExpectation method argsList ->
- verifyResolvedOrder method resolved argsList
- SimpleExpectation args ->
- verifyResolvedMatch resolved (MatchAny args)
- AnyExpectation ->
- verifyResolvedAny resolved
-
-- | Attach expectations to a mock function
-- Supports both single expectation and multiple expectations in a do block
infixl 0 `expects`
@@ -165,10 +87,6 @@
type ExpParams (Expectations params ()) = params
extractParams _ = Proxy
-instance ExtractParams (VerificationSpec params) where
- type ExpParams (VerificationSpec params) = params
- extractParams _ = Proxy
-
instance ExtractParams (fn -> Expectations params ()) where
type ExpParams (fn -> Expectations params ()) = params
extractParams _ = Proxy
@@ -184,15 +102,6 @@
instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (Expectations params ()) where
buildExpectations _ = runExpectations
-instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (VerificationSpec params) where
- buildExpectations _ spec =
- case spec of
- CountVerification method args -> [CountExpectation method args]
- CountAnyVerification method -> [CountAnyExpectation method]
- OrderVerification method argsList -> [OrderExpectation method argsList]
- SimpleVerification args -> [SimpleExpectation args]
- AnyVerification -> [AnyExpectation]
-
-- | Instance for function form (fn -> Expectations params ())
-- This allows passing a function that receives the mock function
instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (fn -> Expectations params ()) where
@@ -308,4 +217,3 @@
where
calledInSequence args =
addExpectation (OrderExpectation PartiallySequence (map param args))
-
diff --git a/test/Property/ConcurrentCountProp.hs b/test/Property/ConcurrentCountProp.hs
--- a/test/Property/ConcurrentCountProp.hs
+++ b/test/Property/ConcurrentCountProp.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
@@ -32,7 +33,7 @@
let totalCalls = threads * callsPerThread
-- Pre-declare expected count with `expects` inside `runMockT`, and have it automatically verified after concurrent calls.
run $ runMockT $ do
- _ <- _propAction (MC.any ~> (1 :: Int))
+ _ <- _propAction ((MC.any ~> (1 :: Int)))
`expects` do
called (times totalCalls)
parallelInvoke threads callsPerThread
diff --git a/test/Property/LazyEvalProp.hs b/test/Property/LazyEvalProp.hs
--- a/test/Property/LazyEvalProp.hs
+++ b/test/Property/LazyEvalProp.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +25,7 @@
prop_lazy_unforced_not_counted :: Property
prop_lazy_unforced_not_counted = monadicIO $ do
run $ runMockT $ do
- _ <- _lazyUnaryAction (param (10 :: Int) ~> (42 :: Int))
+ _ <- _lazyUnaryAction ((param (10 :: Int) ~> (42 :: Int)))
`expects` do
called never
-- Do NOT force the call; only build a thunk.
@@ -37,7 +38,7 @@
prop_lazy_forced_counted :: Property
prop_lazy_forced_counted = monadicIO $ do
run $ runMockT $ do
- _ <- _lazyUnaryAction (param (10 :: Int) ~> (7 :: Int))
+ _ <- _lazyUnaryAction ((param (10 :: Int) ~> (7 :: Int)))
`expects` do
called once
v <- lazyUnaryAction 10 -- forcing the monadic action executes the mock
diff --git a/test/Property/ReinforcementProps.hs b/test/Property/ReinforcementProps.hs
--- a/test/Property/ReinforcementProps.hs
+++ b/test/Property/ReinforcementProps.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -60,7 +61,7 @@
let forcedCount = length (filter id mask)
run $ runMockT $ do
-- expectation: arg -> arg; count only forced executions
- _ <- _parLazy (param arg ~> arg)
+ _ <- _parLazy ((param arg ~> arg))
`expects` do
called (times forcedCount)
-- prepare thunks (NOT executed yet)
diff --git a/test/ReadmeVerifySpec.hs b/test/ReadmeVerifySpec.hs
--- a/test/ReadmeVerifySpec.hs
+++ b/test/ReadmeVerifySpec.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
@@ -16,6 +17,7 @@
import Test.MockCat
import Prelude hiding (readFile, writeFile, any)
import Control.Monad (when)
+
-- -------------------------------------------------------
-- 2. Typeclass Mocking Definitions
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -24,6 +24,8 @@
import Test.MockCat.THCompareSpec as THCompare
import ReadmeVerifySpec as ReadmeVerify
import qualified Test.MockCat.HPCFallbackSpec as HPCFallback
+import qualified Test.MockCat.DeferredTypeErrorsSpec as DeferredTypeErrors
+import qualified Test.MockCat.MultipleMocksSpec as MultipleMocks
import Test.MockCat.UnsafeCheck ()
import Test.QuickCheck (property)
import qualified Property.ConcurrentCountProp as ConcurrencyProp
@@ -63,6 +65,8 @@
WithMockErrorDiff.spec
ReadmeVerify.spec
HPCFallback.spec
+ DeferredTypeErrors.spec
+ MultipleMocks.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
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
@@ -1,5 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
@@ -51,7 +52,7 @@
describe "Concurrency / expects" do
it "counts calls across parallel async threads" do
result <- runMockT do
- _ <- _action (any ~> (1 :: Int))
+ _ <- _action ((any ~> (1 :: Int)))
`expects` do
called (times 10)
parallelActionSum 10
@@ -62,7 +63,7 @@
callsPerThread = 20 :: Int
total = threads * callsPerThread :: Int
_ <- (runMockT $ do
- _ <- _action (any ~> (1 :: Int))
+ _ <- _action ((any ~> (1 :: Int)))
`expects` do
called (times total)
parallelCallActionWithDelay threads callsPerThread
@@ -71,7 +72,7 @@
it "fails verification when calls are fewer than declared" do
runMockT (do
- _ <- _action (any ~> (1 :: Int))
+ _ <- _action ((any ~> (1 :: Int)))
`expects` do
called (times 10)
parallelCallActionN 9
@@ -81,7 +82,7 @@
describe "Concurrency / never expectation" do
it "passes when stub not used in parallel context" do
r <- runMockT do
- _ <- _action (any ~> (99 :: Int))
+ _ <- _action ((any ~> (99 :: Int)))
`expects` do
called never
diff --git a/test/Test/MockCat/DeferredTypeErrorsSpec.hs b/test/Test/MockCat/DeferredTypeErrorsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/DeferredTypeErrorsSpec.hs
@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+
+module Test.MockCat.DeferredTypeErrorsSpec (spec) where
+
+import Test.Hspec
+import Test.MockCat
+import Control.Exception (evaluate)
+import Control.Monad.IO.Class (liftIO)
+import Prelude hiding (any)
+
+spec :: Spec
+spec = describe "Compile-time restrictions (Deferred Type Errors)" do
+ it "expects throws type error when applied directly to MockSpec instead of mock result" do
+ -- This expression should fail to typecheck because `expects` requires `m fn` (monadic action),
+ -- but here it is applied to `MockSpec` (pure value).
+ -- With -fdefer-type-errors, this becomes a runtime error.
+ let expression = (any ~> True) `expects` do
+ called once
+
+ evaluate expression `shouldThrow` anyException
+
+ it "expects throws type error when applied to instantiated mock function (f)" do
+ -- f <- mock ... returns a function `f`.
+ -- expects expects `m fn`, not `fn`.
+ -- This verifies that we cannot "attach" expectations to an existing function variable.
+ -- We type-annotate the block to ensure 'mock' has a concreter context (MockT IO),
+ -- so that the error is specifically about 'f' not matching 'm fn'.
+ let expression :: MockT IO ()
+ expression = do
+ f <- mock (any ~> (1 :: Int))
+ let val = f `expects` do
+ called once
+ _ <- liftIO $ evaluate val
+ pure ()
+
+ -- Since the type error is deferred inside the IO action logic, we must run it to trigger the exception.
+ runMockT expression `shouldThrow` anyException
+
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,4 +1,5 @@
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
@@ -42,6 +43,7 @@
makeMock [t|Teletype|]
+
class Monad m => StrictTest m where
strictFunc :: String -> m ()
@@ -49,6 +51,8 @@
strictFunc _ = pure ()
makeMock [t|StrictTest|]
+
+
spec :: Spec
spec = do
diff --git a/test/Test/MockCat/HPCFallbackSpec.hs b/test/Test/MockCat/HPCFallbackSpec.hs
--- a/test/Test/MockCat/HPCFallbackSpec.hs
+++ b/test/Test/MockCat/HPCFallbackSpec.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.MockCat.HPCFallbackSpec (spec) where
@@ -16,7 +15,7 @@
it "distinguishes mocks of different types" do
-- Case 1: Different types should be distinguishable by type check in fallback
f <- mock $ "a" ~> (1 :: Int)
- g <- mock $ (1 :: Int) ~> "b"
+ g <- mock ((1 :: Int) ~> "b")
-- Verify f (String -> Int)
f "a" `shouldBe` 1
diff --git a/test/Test/MockCat/MockTSpec.hs b/test/Test/MockCat/MockTSpec.hs
--- a/test/Test/MockCat/MockTSpec.hs
+++ b/test/Test/MockCat/MockTSpec.hs
@@ -19,4 +19,3 @@
called once `with` "foo"
_ <- liftIO $ evaluate (f "foo")
pure ()
-
diff --git a/test/Test/MockCat/MultipleMocksSpec.hs b/test/Test/MockCat/MultipleMocksSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/MockCat/MultipleMocksSpec.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.MockCat.MultipleMocksSpec (spec) where
+
+import Test.Hspec
+import Test.MockCat
+import Control.Exception (evaluate, try, SomeException)
+import Control.Monad.IO.Class (liftIO)
+import Data.Either (isLeft)
+import Prelude hiding (any)
+
+spec :: Spec
+spec = describe "Multiple Mocks Isolation" do
+ it "expects attaches only to the target mock, not others of the same type" do
+ -- This test ensures that `expects` is tightly bound to the specific mock instance
+ -- it is chained from, even when multiple mocks share the same type signature.
+ withMock do
+ -- Define two mocks of the same type (String -> Int)
+ -- f expects "A" once
+ -- f expects matchers to be satisfied once
+ f <- mock ("A" ~> (1 :: Int)) `expects` do
+ called once
+
+ -- g expects matchers to be satisfied once
+ g <- mock ("B" ~> (2 :: Int)) `expects` do
+ called once
+
+ -- Call them to satisfy expectations
+ _ <- liftIO $ evaluate $ f "A"
+ _ <- liftIO $ evaluate $ g "B"
+
+ pure ()
+
+ it "fails when calls are crossed between identical mocks (expects isolation)" do
+ -- Verify that calling f with "B" (g's expectation) does not count for g,
+ -- and violates f's expectation (if strictly checked).
+ -- Here we verify that f is NOT g.
+ result :: Either SomeException () <- try $ withMock do
+ f <- mock ("A" ~> (1 :: Int)) `expects` do
+ called once
+
+ _ <- mock ("B" ~> (2 :: Int)) `expects` do
+ called once
+
+ -- We call f with "B".
+ -- f expects "A", so f should fail (unexpected arg).
+ -- g expects "B", but g was not called, so g should fail (count mismatch).
+ _ <- liftIO $ evaluate $ f "B"
+ pure ()
+
+ -- We expect failure because expectations were not met.
+ result `shouldSatisfy` isLeft
+
+
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
@@ -1,7 +1,6 @@
{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
module Test.MockCat.ParamSpec (spec) where
import Prelude hiding (and, or)
diff --git a/test/Test/MockCat/PartialMockCommonSpec.hs b/test/Test/MockCat/PartialMockCommonSpec.hs
--- a/test/Test/MockCat/PartialMockCommonSpec.hs
+++ b/test/Test/MockCat/PartialMockCommonSpec.hs
@@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -17,6 +16,9 @@
, PartialMockDeps(..)
) where
+
+
+import Test.MockCat.Internal.Types (InvocationRecorder)
import Prelude hiding (readFile, writeFile)
import Test.Hspec (Spec, it, shouldBe, describe, shouldThrow, Selector)
import Test.MockCat
@@ -41,30 +43,13 @@
-- 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)
+ { _getInput :: forall params m. (MockDispatch (IsMockSpec params) params (MockT m) String, MonadIO m, Typeable (Verify.ResolvableParamsOf String), Typeable params, Show params, Eq params) => params -> MockT m String
+ , _getBy :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO Int)) => params -> MockT IO (String -> IO Int)
+ , _echo :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO ())) => params -> MockT IO (String -> IO ())
+ , _writeFile :: forall params m. (MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text -> ()), MonadIO m) => params -> MockT m (FilePath -> Text -> ())
+ , _findIds :: forall p a m. (MockDispatch (IsMockSpec p) p (MockT m) [a], MonadIO m, Typeable p, Show p, Eq p, Typeable (InvocationRecorder (Verify.ResolvableParamsOf [a])), Typeable (Verify.ResolvableParamsOf [a]), Typeable [a], Typeable a) => p -> MockT m [a]
+ , _findById :: forall params m. (MockDispatch (IsMockSpec params) params (MockT m) (Int -> String), MonadIO m) => params -> MockT m (Int -> String)
+ , _findByIdNI :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (Int -> IO String)) => params -> MockT IO (Int -> IO String)
}
-- Main Entry Point
@@ -275,7 +260,7 @@
it "fails when _findIds is defined but findIds is never called" do
(runMockT @IO do
- _ <- _findIds ([1 :: Int, 2] :: [Int])
+ _ <- _findIds (Head :> param ([1 :: Int, 2] :: [Int]))
`expects` do
called once
-- findIds is never called
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
@@ -5,7 +5,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -32,6 +31,7 @@
import qualified Test.MockCat.Verify as Verify
+
ensureVerifiable ::
( MonadIO m
, Verify.ResolvableMock target
@@ -112,46 +112,44 @@
Nothing -> lift $ echoExplicitPartial label
_readFile ::
- ( MockBuilder params (FilePath -> Text) (Param FilePath)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text)
, MonadIO m
) =>
params ->
MockT m (FilePath -> Text)
_readFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "readFile" p
+ mockInstance <- unMockT $ mock (label "readFile") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance NoVerification)
pure mockInstance
_writeFile ::
- ( MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text -> ())
, MonadIO m
) =>
params ->
MockT m (FilePath -> Text -> ())
_writeFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "writeFile" p
+ mockInstance <- unMockT $ mock (label "writeFile") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification)
pure mockInstance
_getInput ::
- ( Verify.ResolvableParamsOf r ~ ()
+ ( MockDispatch (IsMockSpec params) params (MockT m) String
, MonadIO m
- , Typeable r
- , Show r
- , Eq r
+ , Typeable (Verify.ResolvableParamsOf String)
) =>
- r ->
- MockT m r
+ params ->
+ MockT m String
_getInput value = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "getInput" (Head :> param value)
+ mockInstance <- unMockT $ mock (label "getInput") value
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "getInput") mockInstance NoVerification)
pure mockInstance
_toUserInput ::
- ( MockBuilder params (String -> m (Maybe UserInput)) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m (Maybe UserInput))
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m (Maybe UserInput)) ~ Param String
@@ -159,29 +157,29 @@
params ->
MockT m (String -> m (Maybe UserInput))
_toUserInput p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "toUserInput" p
+ mockInstance <- unMockT $ mock (label "toUserInput") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "toUserInput") mockInstance NoVerification)
pure mockInstance
_getByPartial ::
- ( MockBuilder params (String -> IO Int) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO Int)
) =>
params ->
MockT IO (String -> IO Int)
_getByPartial p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "getBy" p
+ mockInstance <- unMockT $ mock (label "getBy") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "getBy") mockInstance NoVerification)
pure mockInstance
_echoPartial ::
- ( MockBuilder params (String -> IO ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO ())
) =>
params ->
MockT IO (String -> IO ())
_echoPartial p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "echo" p
+ mockInstance <- unMockT $ mock (label "echo") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "echo") mockInstance NoVerification)
pure mockInstance
@@ -212,16 +210,15 @@
_findIds ::
- ( Verify.ResolvableParamsOf r ~ ()
+ ( MockDispatch (IsMockSpec p) p (MockT m) [a]
, MonadIO m
- , Typeable r
- , Show r
- , Eq r
+ , Typeable [a]
) =>
- r ->
- MockT m r
+ p ->
+ MockT m [a]
_findIds p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_findIds" (Head :> param p)
+ mockInstance <- unMockT $ mock (label "_findIds") p
+
ensureVerifiable mockInstance
addDefinition
( Definition
@@ -232,13 +229,13 @@
pure mockInstance
_findById ::
- ( MockBuilder params (Int -> String) (Param Int)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (Int -> String)
, MonadIO m
) =>
params ->
MockT m (Int -> String)
_findById p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_findById" p
+ mockInstance <- unMockT $ mock (label "_findById") p
ensureVerifiable mockInstance
addDefinition
( Definition
@@ -249,12 +246,12 @@
pure mockInstance
_findByIdNI ::
- ( MockBuilder params (Int -> IO String) (Param Int)
+ ( MockDispatch (IsMockSpec params) params (MockT IO) (Int -> IO String)
) =>
params ->
MockT IO (Int -> IO String)
_findByIdNI p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_findByIdNI" p
+ mockInstance <- unMockT $ mock (label "_findByIdNI") p
ensureVerifiable mockInstance
addDefinition
( Definition
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,7 +1,6 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
diff --git a/test/Test/MockCat/SharedSpecDefs.hs b/test/Test/MockCat/SharedSpecDefs.hs
--- a/test/Test/MockCat/SharedSpecDefs.hs
+++ b/test/Test/MockCat/SharedSpecDefs.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
@@ -9,7 +7,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeApplications #-}
module Test.MockCat.SharedSpecDefs
( FileOperation(..),
diff --git a/test/Test/MockCat/ShouldBeCalledErrorDiffSpec.hs b/test/Test/MockCat/ShouldBeCalledErrorDiffSpec.hs
--- a/test/Test/MockCat/ShouldBeCalledErrorDiffSpec.hs
+++ b/test/Test/MockCat/ShouldBeCalledErrorDiffSpec.hs
@@ -16,9 +16,6 @@
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
@@ -39,49 +36,60 @@
spec = do
describe "Error Message Diff" do
it "shows diff for string arguments" do
- f <- mock $ (any :: Param String) ~> "ok"
+ 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\
- \ ^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"hello world\"\n\
+ \ but got: \"hello haskell\"\n\
+ \ " <> replicate 9 ' ' <> "^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"hello haskell\""
f `shouldBeCalled` "hello world" `shouldThrow` errorCall expectedError
it "shows diff for long list" do
- f <- mock $ (any :: Param [Int]) ~> "ok"
+ 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\
+ \\n\
+ \ Closest match:\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\
+ \ " <> replicate 18 ' ' <> "^^^^^^^^^^^^^^^\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\
- \ ^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]"
f `shouldBeCalled` [1..10] `shouldThrow` errorCall expectedError
it "shows diff for record" do
- f <- mock $ (any :: Param User) ~> "ok"
+ f <- mock ((any :: Param User) ~> "ok")
_ <- evaluate $ f (User "Fagen" 20)
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: User {name = \"Fagen\", age = 30}\n\
+ \ but got: User {name = \"Fagen\", age = 20}\n\
+ \ " <> replicate 30 ' ' <> "^^^\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\
- \ ^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. User {name = \"Fagen\", age = 20}"
f `shouldBeCalled` User "Fagen" 30 `shouldThrow` errorCall expectedError
it "shows diff for inOrderWith" do
- f <- mock $ (any :: Param String) ~> "ok"
+ f <- mock ((any :: Param String) ~> "ok")
_ <- evaluate $ f "a"
_ <- evaluate $ f "b"
let expectedError =
@@ -107,44 +115,55 @@
evaluate (f "aaa" 200) `shouldThrow` errorCall expectedError
it "shows diff for nested record" do
- f <- mock $ (any :: Param ComplexUser) ~> "ok"
+ f <- mock ((any :: Param ComplexUser) ~> "ok")
_ <- evaluate $ f (ComplexUser "Alice" (Config "Light" 1))
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\
+ \ " <> replicate 57 ' ' <> replicate 19 '^' <> "\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\
- \ ^^^^^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}"
f `shouldBeCalled` ComplexUser "Alice" (Config "Dark" 1) `shouldThrow` errorCall expectedError
it "shows diff for nested list" do
- f <- mock $ (any :: Param [[Int]]) ~> "ok"
+ f <- mock ((any :: Param [[Int]]) ~> "ok")
_ <- evaluate $ f [[1, 2], [3, 4]]
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: [[1,2], [3,5]]\n\
+ \ but got: [[1,2], [3,4]]\n\
+ \ " <> replicate 13 ' ' <> "^^^\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\
- \ ^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. [[1,2], [3,4]]"
f `shouldBeCalled` [[1, 2], [3, 5]] `shouldThrow` errorCall expectedError
it "shows multiple differences in nested record" do
- f <- mock $ (any :: Param ComplexUser) ~> "ok"
+ 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\
+ \\n\
+ \ Closest match:\n\
+ \ expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\
+ \ " <> replicate 23 ' ' <> replicate 53 '^' <> "\n\
\ Specific differences:\n\
\ - `name`:\n\
\ expected: \"Bob\"\n\
@@ -156,64 +175,80 @@
\ 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\
- \ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}"
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"
+ 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\
- \ ^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"{ name = \\\"Bob\\\" }\"\n\
+ \ but got: \"{ name = \\\"Alice\\\"\"\n\
+ \ " <> replicate 14 ' ' <> "^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"{ name = \\\"Alice\\\"\""
f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
it "handles completely broken structure strings" do
- f <- mock $ (any :: Param String) ~> "ok"
+ f <- mock ((any :: Param String) ~> "ok")
let actual = "NotARecord {,,,,,}"
- expected = "NotARecord { a = 1 }"
+ let 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\
- \ ^^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"NotARecord { a = 1 }\"\n\
+ \ but got: \"NotARecord {,,,,,}\"\n\
+ \ " <> replicate 15 ' ' <> "^^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"NotARecord {,,,,,}\""
f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
describe "extreme structural cases" do
it "handles extremely deep nesting" do
- f <- mock $ (any :: Param DeepNode) ~> "ok"
+ 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" <>
+ "\n" <>
+ " Closest match:\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 117 ' ' <> "^^^^^^\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 ' ' <> "^^^^^^"
+ " Call history (1 calls):\n" <>
+ " [Closest] 1. Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}"
f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
it "shows mismatches across multiple layers" do
- f <- mock $ (any :: Param MultiLayer) ~> "ok"
+ 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" <>
+ "\n" <>
+ " Closest match:\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 24 ' ' <> replicate 75 '^' <> "\n" <>
" Specific differences:\n" <>
" - `layer1`:\n" <>
" expected: \"X\"\n" <>
@@ -225,19 +260,22 @@
" 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 '^'
+ " Call history (1 calls):\n" <>
+ " [Closest] 1. MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}"
f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
it "handles cases where almost everything is different" do
- f <- mock $ (any :: Param Config) ~> "ok"
+ 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" <>
+ "\n" <>
+ " Closest match:\n" <>
+ " expected: Config {theme = \"Dark\", level = 99}\n" <>
+ " but got: Config {theme = \"Light\", level = 1}\n" <>
+ " " <> replicate 19 ' ' <> replicate 18 '^' <> "\n" <>
" Specific differences:\n" <>
" - `theme`:\n" <>
" expected: \"Dark\"\n" <>
@@ -246,8 +284,6 @@
" 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 '^'
+ " Call history (1 calls):\n" <>
+ " [Closest] 1. Config {theme = \"Light\", level = 1}"
f `shouldBeCalled` expected `shouldThrow` errorCall expectedError
diff --git a/test/Test/MockCat/ShouldBeCalledSpec.hs b/test/Test/MockCat/ShouldBeCalledSpec.hs
--- a/test/Test/MockCat/ShouldBeCalledSpec.hs
+++ b/test/Test/MockCat/ShouldBeCalledSpec.hs
@@ -3,7 +3,6 @@
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# OPTIONS_GHC -fno-hpc #-}
-{- HLINT ignore "Use newtype instead of data" -}
module Test.MockCat.ShouldBeCalledSpec (spec) where
diff --git a/test/Test/MockCat/TH/FunctionBuilderSpec.hs b/test/Test/MockCat/TH/FunctionBuilderSpec.hs
--- a/test/Test/MockCat/TH/FunctionBuilderSpec.hs
+++ b/test/Test/MockCat/TH/FunctionBuilderSpec.hs
@@ -4,6 +4,7 @@
import qualified Data.Text as T
import Language.Haskell.TH
+
import Test.Hspec
import Test.MockCat.Cons ((:>))
import Test.MockCat.Param (Param)
@@ -91,31 +92,8 @@
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
@@ -131,4 +109,5 @@
. 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.replace (T.pack "([a])") (T.pack "[a]")
. T.pack
diff --git a/test/Test/MockCat/THCompareSpec.hs b/test/Test/MockCat/THCompareSpec.hs
--- a/test/Test/MockCat/THCompareSpec.hs
+++ b/test/Test/MockCat/THCompareSpec.hs
@@ -55,6 +55,8 @@
, "Show."
, "Classes."
, "Internal."
+ , "Test.MockCat.Mock."
+ , "Test.MockCat.Types."
])
where
stripPrefixes [] t = t
@@ -83,6 +85,7 @@
, ("((:>)", "(")
, ("(:>) ", "")
, ("(:>)", "")
+ , ("([a])", "[a]")
]
. T.replace (T.pack "Head (Param") (T.pack "Head :>Param")
. T.replace (T.pack "Head :> Param") (T.pack "Head :>Param")
@@ -93,6 +96,14 @@
. 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 ()")
+ . T.replace (T.pack "Typeable m,") T.empty
+ . T.replace (T.pack ", Typeable m") T.empty
+ . T.replace (T.pack "Typeable a,") T.empty
+ . T.replace (T.pack ", Typeable a") T.empty
+ . T.replace (T.pack " )") (T.pack ")")
+ . T.replace (T.pack "Typeable [a]") (T.pack "Typeable a")
+ . T.replace (T.pack "Typeable ([a])") (T.pack "Typeable a")
+ . T.replace (T.pack "Typeable (ResultType m)") (T.pack "Typeable m")
where
applyReplacements reps txt =
L.foldl'
@@ -365,7 +376,7 @@
expectationFailure "TH generated signature not found: _toUserInput"
Just sig ->
normalizeSignature sig
- `shouldSatisfy` not . T.isInfixOf (T.pack "ResolvableParamsOf") . T.pack
+ `shouldNotSatisfy` T.isInfixOf (T.pack "ResolvableParamsOf") . T.pack
it "_produce signature matches handwritten" $
assertHelperSigMatches typeClassSpecPath generatedAssocSigMap "_produce"
diff --git a/test/Test/MockCat/TypeClassCommonSpec.hs b/test/Test/MockCat/TypeClassCommonSpec.hs
--- a/test/Test/MockCat/TypeClassCommonSpec.hs
+++ b/test/Test/MockCat/TypeClassCommonSpec.hs
@@ -10,13 +10,13 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedRecordDot #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
{- HLINT ignore "Use newtype instead of data" -}
module Test.MockCat.TypeClassCommonSpec where
@@ -24,6 +24,7 @@
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)
@@ -131,9 +132,9 @@
ArgsOfF r = ()
-- Generic Mock alias for a function type f
-type MockFor f = forall params. (MockBuilder params f (ArgsOfF f)) => params -> MockT IO f
+type MockFor f = forall params. (MockDispatch (IsMockSpec params) params (MockT IO) 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
+type MockForM m f = forall params. (MockDispatch (IsMockSpec params) params (MockT m) f) => params -> MockT m f
-- Per-spec dependency records to group required builders/mocks
data BasicDeps = BasicDeps
@@ -148,7 +149,7 @@
}
data MultipleDeps = MultipleDeps
- { _ask :: Environment -> MockT IO Environment
+ { _ask :: MockFor Environment
, _readFile :: MockFor (FilePath -> Text)
, _writeFile:: MockFor (FilePath -> Text -> ())
, _post :: MockFor (Text -> ())
@@ -157,7 +158,7 @@
data ReaderContextDeps = ReaderContextDeps
- { _ask :: Environment -> MockT IO Environment
+ { _ask :: MockFor Environment
, _readFile :: MockFor (FilePath -> Text)
, _writeFile:: MockFor (FilePath -> Text -> ())
}
@@ -201,11 +202,11 @@
}
data DefaultMethodDeps = DefaultMethodDeps
- { _defaultAction :: Int -> MockT IO Int
+ { _defaultAction :: MockFor Int
}
data AssociatedTypeFamiliesDeps = AssociatedTypeFamiliesDeps
- { _produce :: Int -> MockT IO Int
+ { _produce :: MockFor Int
}
data ConcurrencyAndUnliftIODeps = ConcurrencyAndUnliftIODeps
@@ -241,7 +242,7 @@
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 :: MockFor Int -> AssociatedTypeFamiliesDeps
pattern AssocTypeDeps f <- AssociatedTypeFamiliesDeps { _produce = f }
where AssocTypeDeps f = AssociatedTypeFamiliesDeps { _produce = f }
@@ -347,7 +348,7 @@
it "Program skips file write when input content contains 'ngWord'" do
result <- runMockT do
- _ <- _readFile ("input.txt" ~> pack "contains ngWord")
+ _ <- _readFile ("input.txt" ~> pack "contains ngWord")
_ <- _writeFile ("output.txt" ~> any ~> ())
`expects` do
called never
@@ -367,8 +368,8 @@
result <- runMockT do
_ <- _readFile $ "input.txt" ~> pack "content"
- _ <- _writeFile ("output.text" ~> pack "modifiedContent" ~> ())
- _ <- _post (pack "modifiedContent" ~> ())
+ _ <- _writeFile $ ("output.text" ~> pack "modifiedContent" ~> ())
+ _ <- _post $ (pack "modifiedContent" ~> ())
operationProgram2 "input.txt" "output.text" modifyContentStub
result `shouldBe` ()
@@ -389,7 +390,7 @@
_ <- _ask env
_ <- _readFile ("input.txt" ~> pack "content")
_ <- _writeFile ("output.text" ~> pack "modifiedContent" ~> ())
- _ <- _post ((pack "modifiedContent" <> pack ("+" <> show env)) ~> ())
+ _ <- _post (pack "modifiedContent" <> pack ("+" <> show env) ~> ())
apiFileOperationProgram modifyContentStub
result `shouldBe` ()
@@ -406,8 +407,8 @@
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" ~> ())
+ _ <- _readFile ("input.txt" ~> pack "content")
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
operationProgram3
r `shouldBe` ()
@@ -564,7 +565,7 @@
specDefaultMethodMocking (DefaultMethodDeps { _defaultAction }) = do
it "Default method is successfully overridden and stubbed value is returned" do
result <- runMockT do
- _ <- _defaultAction (99 :: Int)
+ _ <- _defaultAction (Head :> param (99 :: Int))
defaultAction
result `shouldBe` 99
@@ -577,7 +578,7 @@
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 (Head :> param (321 :: Int))
produce
v `shouldBe` 321
@@ -652,7 +653,7 @@
_ <- _readFile ("input.txt" ~> pack "content")
`expects` do
called once
- _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
+ _ <- _writeFile ("output.txt" ~> pack "content" ~> ())
-- readFile is never called, only writeFile is called
do
writeFile "output.txt" (pack "content")
@@ -660,7 +661,7 @@
it "Error when write stub expects call but only readFile is executed" do
(runMockT @IO do
- _ <- _readFile ("input.txt" ~> pack "content")
+ _ <- _readFile ("input.txt" ~> pack "content")
_ <- _writeFile ("output.txt" ~> pack "content" ~> ())
`expects` do
called once
@@ -676,7 +677,7 @@
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")
+ _ <- _ask (Head :> param (Environment "input.txt" "output.txt"))
`expects` do
called once
-- ask is never called
@@ -801,14 +802,14 @@
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)
+ _ <- _defaultAction (Head :> param (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)
+ _ <- _produce (Head :> param (321 :: Int))
`expects` do
called once
pure ()) `shouldThrow` missingCall "_produce"
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
@@ -8,12 +8,11 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DuplicateRecordFields #-}
module Test.MockCat.TypeClassSpec (spec) where
@@ -35,9 +34,9 @@
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)
+import Test.MockCat.Internal.Types (InvocationRecorder)
+
-- | No-op. Previously used StableName-based verification check, which breaks under HPC.
-- TH-generated code doesn't need this, so we make it a no-op for consistency.
ensureVerifiable :: Applicative m => a -> m ()
@@ -82,52 +81,51 @@
-- state f = lift (state f)
_ask ::
- ( Verify.ResolvableParamsOf env ~ ()
+ ( MockDispatch (IsMockSpec params) params (MockT m) env
, MonadIO m
+ , Verify.ResolvableParamsOf env ~ ()
, Typeable env
- , Show env
- , Eq env
) =>
- env ->
+ params ->
MockT m env
_ask p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "ask" (Head :> param p)
+ mockInstance <- unMockT $ mock (label "ask") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "ask") mockInstance NoVerification)
pure mockInstance
_readFile ::
- ( MockBuilder params (FilePath -> Text) (Param FilePath)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text)
, MonadIO m
) =>
params ->
MockT m (FilePath -> Text)
_readFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "readFile" p
+ mockInstance <- unMockT $ mock (label "readFile") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance NoVerification)
pure mockInstance
_writeFile ::
- ( MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text -> ())
, MonadIO m
) =>
params ->
MockT m (FilePath -> Text -> ())
_writeFile p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "writeFile" p
+ mockInstance <- unMockT $ mock (label "writeFile") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification)
pure mockInstance
_post ::
- ( MockBuilder params (Text -> ()) (Param Text)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (Text -> ())
, MonadIO m
) =>
params ->
MockT m (Text -> ())
_post p = MockT $ do
- mockFn <- liftIO $ createNamedMockFnWithParams "post" p
+ mockFn <- unMockT $ mock (label "post") p
ensureVerifiable mockFn
addDefinition (Definition (Proxy :: Proxy "post") mockFn NoVerification)
pure mockFn
@@ -292,7 +290,7 @@
mapConcurrently = traverse
_getBy ::
- ( MockBuilder params (String -> m Int) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m Int)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m Int) ~ Param String
@@ -300,13 +298,13 @@
params ->
MockT m (String -> m Int)
_getBy p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_getBy" p
+ mockInstance <- unMockT $ mock (label "_getBy") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_getBy") mockInstance NoVerification)
pure mockInstance
_echo ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -314,13 +312,13 @@
params ->
MockT m (String -> m ())
_echo p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_echo" p
+ mockInstance <- unMockT $ mock (label "_echo") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_echo") mockInstance NoVerification)
pure mockInstance
_fn2_1Sub ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -328,13 +326,13 @@
params ->
MockT m (String -> m ())
_fn2_1Sub p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fn2_1Sub" p
+ mockInstance <- unMockT $ mock (label "_fn2_1Sub") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fn2_1Sub") mockInstance NoVerification)
pure mockInstance
_fn2_2Sub ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -342,13 +340,13 @@
params ->
MockT m (String -> m ())
_fn2_2Sub p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fn2_2Sub" p
+ mockInstance <- unMockT $ mock (label "_fn2_2Sub") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fn2_2Sub") mockInstance NoVerification)
pure mockInstance
_fn3_1Sub ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -356,13 +354,13 @@
params ->
MockT m (String -> m ())
_fn3_1Sub p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_1Sub" p
+ mockInstance <- unMockT $ mock (label "_fn3_1Sub") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fn3_1Sub") mockInstance NoVerification)
pure mockInstance
_fn3_2Sub ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -370,13 +368,13 @@
params ->
MockT m (String -> m ())
_fn3_2Sub p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_2Sub" p
+ mockInstance <- unMockT $ mock (label "_fn3_2Sub") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fn3_2Sub") mockInstance NoVerification)
pure mockInstance
_fn3_3Sub ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -384,13 +382,13 @@
params ->
MockT m (String -> m ())
_fn3_3Sub p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fn3_3Sub" p
+ mockInstance <- unMockT $ mock (label "_fn3_3Sub") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fn3_3Sub") mockInstance NoVerification)
pure mockInstance
_getValueBy ::
- ( MockBuilder params (String -> m String) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m String)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m String) ~ Param String
@@ -398,13 +396,13 @@
params ->
MockT m (String -> m String)
_getValueBy p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_getValueBy" p
+ mockInstance <- unMockT $ mock (label "_getValueBy") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_getValueBy") mockInstance NoVerification)
pure mockInstance
_fnState ::
- ( MockBuilder params (Maybe s -> m s) (Param (Maybe s))
+ ( MockDispatch (IsMockSpec params) params (MockT m) (Maybe s -> m s)
, MonadIO m
, Typeable m
, Typeable s
@@ -413,12 +411,12 @@
params ->
MockT m (Maybe s -> m s)
_fnState p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fnState" p
+ mockInstance <- unMockT $ mock (label "_fnState") p
addDefinition (Definition (Proxy :: Proxy "_fnState") mockInstance NoVerification)
pure mockInstance
_fnState2 ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -426,13 +424,12 @@
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)
+ mockInstance <- unMockT $ mock (label "_fnState2") p
+ addDefinition (Definition (Proxy :: Proxy "_fnState2") mockInstance NoVerification)
pure mockInstance
_fnParam3_1 ::
- ( MockBuilder params (Int -> Bool -> m String) (Param Int :> Param Bool)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (Int -> Bool -> m String)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (Int -> Bool -> m String) ~ (Param Int :> Param Bool)
@@ -440,13 +437,13 @@
params ->
MockT m (Int -> Bool -> m String)
_fnParam3_1 p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_1" p
+ mockInstance <- unMockT $ mock (label "_fnParam3_1") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fnParam3_1") mockInstance NoVerification)
pure mockInstance
_fnParam3_2 ::
- ( MockBuilder params (m Int) ()
+ ( MockDispatch (IsMockSpec params) params (MockT m) (m Int)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (m Int) ~ ()
@@ -454,13 +451,13 @@
params ->
MockT m (m Int)
_fnParam3_2 p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_2" p
+ mockInstance <- unMockT $ mock (label "_fnParam3_2") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fnParam3_2") mockInstance NoVerification)
pure mockInstance
_fnParam3_3 ::
- ( MockBuilder params (m Bool) ()
+ ( MockDispatch (IsMockSpec params) params (MockT m) (m Bool)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (m Bool) ~ ()
@@ -468,13 +465,13 @@
params ->
MockT m (m Bool)
_fnParam3_3 p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_fnParam3_3" p
+ mockInstance <- unMockT $ mock (label "_fnParam3_3") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_fnParam3_3") mockInstance NoVerification)
pure mockInstance
_getByExplicit ::
- ( MockBuilder params (String -> m Int) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m Int)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m Int) ~ Param String
@@ -482,13 +479,13 @@
params ->
MockT m (String -> m Int)
_getByExplicit p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_getByExplicit" p
+ mockInstance <- unMockT $ mock (label "_getByExplicit") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_getByExplicit") mockInstance NoVerification)
pure mockInstance
_echoExplicit ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -496,37 +493,36 @@
params ->
MockT m (String -> m ())
_echoExplicit p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_echoExplicit" p
+ mockInstance <- unMockT $ mock (label "_echoExplicit") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_echoExplicit") mockInstance NoVerification)
pure mockInstance
_defaultAction ::
( MonadIO m
+ , MockDispatch (IsMockSpec params) params (MockT m) a
, Verify.ResolvableParamsOf a ~ ()
, Typeable a
- , Show a
- , Eq a
) =>
- a ->
+ params ->
MockT m a
-_defaultAction value = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_defaultAction" (Head :> param value)
+_defaultAction p = MockT $ do
+ mockInstance <- unMockT $ mock (label "_defaultAction") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_defaultAction") mockInstance NoVerification)
pure mockInstance
_produce ::
- ( MonadIO m
- , Verify.ResolvableParamsOf a ~ ()
- , Typeable a
- , Show a
- , Eq a
+ ( MockDispatch (IsMockSpec p) p (MockT m) (ResultType m)
+ , MonadIO m
+ , Typeable (InvocationRecorder (Verify.ResolvableParamsOf (ResultType m)))
+ , Typeable (Verify.ResolvableParamsOf (ResultType m))
+ , Typeable (ResultType m)
) =>
- a ->
- MockT m a
-_produce value = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_produce" (Head :> param value)
+ p ->
+ MockT m (ResultType m)
+_produce p = MockT $ do
+ mockInstance <- unMockT $ mock (label "_produce") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_produce") mockInstance NoVerification)
pure mockInstance
@@ -547,7 +543,7 @@
lift result
_readTTY ::
- ( MockBuilder params (m String) ()
+ ( MockDispatch (IsMockSpec params) params (MockT m) (m String)
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (m String) ~ ()
@@ -555,13 +551,13 @@
params ->
MockT m (m String)
_readTTY p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_readTTY" p
+ mockInstance <- unMockT $ mock (label "_readTTY") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_readTTY") mockInstance NoVerification)
pure mockInstance
_writeTTY ::
- ( MockBuilder params (String -> m ()) (Param String)
+ ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ())
, MonadIO m
, Typeable m
, Verify.ResolvableParamsOf (String -> m ()) ~ Param String
@@ -569,7 +565,7 @@
params ->
MockT m (String -> m ())
_writeTTY p = MockT $ do
- mockInstance <- liftIO $ createNamedMockFnWithParams "_writeTTY" p
+ mockInstance <- unMockT $ mock (label "_writeTTY") p
ensureVerifiable mockInstance
addDefinition (Definition (Proxy :: Proxy "_writeTTY") mockInstance NoVerification)
pure mockInstance
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
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
diff --git a/test/Test/MockCat/WithMockErrorDiffSpec.hs b/test/Test/MockCat/WithMockErrorDiffSpec.hs
--- a/test/Test/MockCat/WithMockErrorDiffSpec.hs
+++ b/test/Test/MockCat/WithMockErrorDiffSpec.hs
@@ -40,9 +40,14 @@
it "shows diff for string arguments" do
let expectedError =
"function was not called with the expected arguments.\n\
- \ expected: \"hello world\"\n\
- \ but got: \"hello haskell\"\n\
- \ ^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"hello world\"\n\
+ \ but got: \"hello haskell\"\n\
+ \ " <> replicate 9 ' ' <> "^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"hello haskell\""
withMock (do
f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` "hello world")
_ <- liftIO $ evaluate $ f "hello haskell"
@@ -52,15 +57,18 @@
it "shows diff for long list" do
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\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\
+ \ " <> replicate 18 ' ' <> "^^^^^^^^^^^^^^^\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\
- \ ^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]"
withMock (do
f <- mock ((any :: Param [Int]) ~> "ok") `expects` (called once `with` [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])
_ <- liftIO $ evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10]
@@ -70,15 +78,18 @@
it "shows diff for record" do
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: User {name = \"Fagen\", age = 30}\n\
+ \ but got: User {name = \"Fagen\", age = 20}\n\
+ \ " <> replicate 30 ' ' <> "^^^\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\
- \ ^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. User {name = \"Fagen\", age = 20}"
withMock (do
f <- mock ((any :: Param User) ~> "ok") `expects` (called once `with` User "Fagen" 30)
_ <- liftIO $ evaluate $ f (User "Fagen" 20)
@@ -106,7 +117,7 @@
\ \"bbb\", 200\n\
\ but got:\n\
\ \"aaa\", 200\n\
- \ ^^^"
+ \ " <> replicate 7 ' ' <> "^^^"
withMock (do
f <- mock $ do
onCase $ "aaa" ~> (100 :: Int) ~> "ok"
@@ -118,15 +129,18 @@
it "shows diff for nested record" do
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: ComplexUser {name = \"Alice\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}\n\
+ \ " <> replicate 57 ' ' <> replicate 19 '^' <> "\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\
- \ ^^^^^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 1}}"
withMock (do
f <- mock ((any :: Param ComplexUser) ~> "ok") `expects` (called once `with` ComplexUser "Alice" (Config "Dark" 1))
_ <- liftIO $ evaluate $ f (ComplexUser "Alice" (Config "Light" 1))
@@ -136,15 +150,18 @@
it "shows diff for nested list" do
let expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: [[1,2], [3,5]]\n\
+ \ but got: [[1,2], [3,4]]\n\
+ \ " <> replicate 13 ' ' <> "^^^\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\
- \ ^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. [[1,2], [3,4]]"
withMock (do
f <- mock ((any :: Param [[Int]]) ~> "ok") `expects` (called once `with` [[1, 2], [3, 5]])
_ <- liftIO $ evaluate $ f [[1, 2], [3, 4]]
@@ -156,6 +173,11 @@
expected = ComplexUser "Bob" (Config "Dark" 1)
expectedError =
"function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: ComplexUser {name = \"Bob\", config = Config {theme = \"Dark\", level = 1}}\n\
+ \ but got: ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}\n\
+ \ " <> replicate 23 ' ' <> replicate 53 '^' <> "\n\
\ Specific differences:\n\
\ - `name`:\n\
\ expected: \"Bob\"\n\
@@ -167,10 +189,8 @@
\ 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\
- \ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. ComplexUser {name = \"Alice\", config = Config {theme = \"Light\", level = 2}}"
withMock (do
f <- mock ((any :: Param ComplexUser) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
@@ -183,9 +203,14 @@
expected = "{ name = \"Bob\" }"
expectedError =
"function was not called with the expected arguments.\n\
- \ expected: \"{ name = \\\"Bob\\\" }\"\n\
- \ but got: \"{ name = \\\"Alice\\\"\"\n\
- \ ^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"{ name = \\\"Bob\\\" }\"\n\
+ \ but got: \"{ name = \\\"Alice\\\"\"\n\
+ \ " <> replicate 14 ' ' <> "^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"{ name = \\\"Alice\\\"\""
withMock (do
f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
@@ -194,12 +219,17 @@
it "handles completely broken structure strings" do
let actual = "NotARecord {,,,,,}"
- expected = "NotARecord { a = 1 }"
- expectedError =
+ let expected = "NotARecord { a = 1 }"
+ let expectedError =
"function was not called with the expected arguments.\n\
- \ expected: \"NotARecord { a = 1 }\"\n\
- \ but got: \"NotARecord {,,,,,}\"\n\
- \ ^^^^^^^^^"
+ \\n\
+ \ Closest match:\n\
+ \ expected: \"NotARecord { a = 1 }\"\n\
+ \ but got: \"NotARecord {,,,,,}\"\n\
+ \ " <> replicate 15 ' ' <> "^^^^^^^^^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. \"NotARecord {,,,,,}\""
withMock (do
f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
@@ -212,16 +242,19 @@
let actual = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 0}}}}}
expected = Node{val = 1, next = Node{val = 2, next = Node{val = 3, next = Node{val = 4, next = Node{val = 5, next = Leaf 1}}}}}
expectedError =
- "function was not called with the expected arguments.\n" <>
- " Specific difference in `next.next.next.next.next`:\n" <>
- " expected: Leaf 1\n" <>
- " but got: Leaf 0\n" <>
- " " <> replicate 5 ' ' <> "^\n" <>
- "\n" <>
- "Full context:\n" <>
- " expected: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 1}}}}}\n" <>
- " but got: Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}\n" <>
- " " <> replicate 115 ' ' <> "^^^^^^"
+ "function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\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 117 ' ' <> "^^^^^^\n\
+ \ Specific difference in `next.next.next.next.next`:\n\
+ \ expected: Leaf 1\n\
+ \ but got: Leaf 0\n\
+ \ " <> replicate 5 ' ' <> "^\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. Node {val = 1, next = Node {val = 2, next = Node {val = 3, next = Node {val = 4, next = Node {val = 5, next = Leaf 0}}}}}"
withMock (do
f <- mock ((any :: Param DeepNode) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
@@ -232,22 +265,25 @@
let actual = MultiLayer {layer1 = "A", sub = SubLayer {layer2 = "B", items = [Node {val = 1, next = Leaf 2}]}}
expected = MultiLayer {layer1 = "X", sub = SubLayer {layer2 = "Y", items = [Node {val = 1, next = Leaf 3}]}}
expectedError =
- "function was not called with the expected arguments.\n" <>
- " Specific differences:\n" <>
- " - `layer1`:\n" <>
- " expected: \"X\"\n" <>
- " but got: \"A\"\n" <>
- " - `sub.layer2`:\n" <>
- " expected: \"Y\"\n" <>
- " but got: \"B\"\n" <>
- " - `sub.items[0].next`:\n" <>
- " expected: Leaf 3\n" <>
- " but got: Leaf 2\n" <>
- "\n" <>
- "Full context:\n" <>
- " expected: MultiLayer {layer1 = \"X\", sub = SubLayer {layer2 = \"Y\", items = [Node {val = 1, next = Leaf 3}]}}\n" <>
- " but got: MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}\n" <>
- " " <> replicate 22 ' ' <> replicate 75 '^'
+ "function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\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 24 ' ' <> replicate 75 '^' <> "\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\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. MultiLayer {layer1 = \"A\", sub = SubLayer {layer2 = \"B\", items = [Node {val = 1, next = Leaf 2}]}}"
withMock (do
f <- mock ((any :: Param MultiLayer) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
@@ -258,19 +294,22 @@
let actual = Config "Light" 1
expected = Config "Dark" 99
expectedError =
- "function was not called with the expected arguments.\n" <>
- " Specific differences:\n" <>
- " - `theme`:\n" <>
- " expected: \"Dark\"\n" <>
- " but got: \"Light\"\n" <>
- " - `level`:\n" <>
- " expected: 99\n" <>
- " but got: 1\n" <>
- "\n" <>
- "Full context:\n" <>
- " expected: Config {theme = \"Dark\", level = 99}\n" <>
- " but got: Config {theme = \"Light\", level = 1}\n" <>
- " " <> replicate 17 ' ' <> replicate 18 '^'
+ "function was not called with the expected arguments.\n\
+ \\n\
+ \ Closest match:\n\
+ \ expected: Config {theme = \"Dark\", level = 99}\n\
+ \ but got: Config {theme = \"Light\", level = 1}\n\
+ \ " <> replicate 19 ' ' <> replicate 18 '^' <> "\n\
+ \ Specific differences:\n\
+ \ - `theme`:\n\
+ \ expected: \"Dark\"\n\
+ \ but got: \"Light\"\n\
+ \ - `level`:\n\
+ \ expected: 99\n\
+ \ but got: 1\n\
+ \\n\
+ \ Call history (1 calls):\n\
+ \ [Closest] 1. Config {theme = \"Light\", level = 1}"
withMock (do
f <- mock ((any :: Param Config) ~> "ok") `expects` (called once `with` expected)
_ <- liftIO $ evaluate $ f actual
diff --git a/test/Test/MockCat/WithMockSpec.hs b/test/Test/MockCat/WithMockSpec.hs
--- a/test/Test/MockCat/WithMockSpec.hs
+++ b/test/Test/MockCat/WithMockSpec.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE BlockArguments #-}
-{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
@@ -7,6 +7,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -44,39 +45,39 @@
spec = do
describe "withMock basic functionality" $ do
it "simple mock with expects" $ do
- withMock $ 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
+ 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
+ withMock (do
_ <- mock (any ~> True)
`expects` (called once `with` "a")
pure ()) `shouldThrow` anyErrorCall
it "error message when not called" $ do
- result <- try $ withMock $ do
+ result <- try $ withMock $ do
_ <- mock (any ~> True)
`expects` (called once `with` "a")
pure ()
case result of
Left (ErrorCall msg) -> do
let expected =
- "function was not called with the expected arguments.\n" <>
- " expected: \"a\"\n" <>
- " but the function was never called"
+ "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
+ withMock $ do
mockFn <- mock (any ~> True)
`expects` (called (atLeast 2) `with` "a")
@@ -85,20 +86,20 @@
void $ liftIO $ evaluate $ mockFn "a"
it "anything expectation" $ do
- withMock $ 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
+ 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
+ result <- try $ withMock $ do
_ <- mock (any @String ~> True)
`expects` called once
pure ()
@@ -112,34 +113,34 @@
_ -> fail "Expected ErrorCall"
it "never expectation without args succeeds when not called" $ do
- withMock $ do
+ withMock $ do
_ <- mock (any @String ~> True)
`expects` called never
pure ()
it "never expectation without args fails when called" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` called never
liftIO $ mockFn "a" `shouldBe` True
pure ()) `shouldThrow` anyErrorCall
it "never expectation with args succeeds when not called with that arg" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` (called never `with` "z")
liftIO $ mockFn "a" `shouldBe` True
pure ()
it "never expectation with args fails when called with that arg" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` (called never `with` "z")
liftIO $ mockFn "z" `shouldBe` True
pure ()) `shouldThrow` anyErrorCall
it "multiple expectations in do block" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 2) `with` "a"
@@ -150,7 +151,7 @@
pure ()
it "multiple expectations in do block fails when not all satisfied" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 2) `with` "a"
@@ -161,7 +162,7 @@
pure ()) `shouldThrow` anyErrorCall
it "multiple expectations in do block with never" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
called once `with` "a"
@@ -170,7 +171,7 @@
pure ()
it "multiple expectations in do block with never fails when violated" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
called once `with` "a"
@@ -180,7 +181,7 @@
pure ()) `shouldThrow` anyErrorCall
it "multiple expectations with different counts" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 3) `with` "a"
@@ -195,7 +196,7 @@
pure ()
it "multiple expectations fails when count is insufficient" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 3) `with` "a"
@@ -207,7 +208,7 @@
pure ()) `shouldThrow` anyErrorCall
it "multiple expectations fails when atLeast is not satisfied" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
called (atLeast 2) `with` "a"
@@ -218,7 +219,7 @@
pure ()) `shouldThrow` anyErrorCall
it "multiple expectations with mixed never and count" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 2) `with` "a"
@@ -230,7 +231,7 @@
pure ()
it "multiple expectations with never fails when never is violated" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
called (times 2) `with` "a"
@@ -244,7 +245,7 @@
describe "withMock verification failures" $ do
it "fails when called fewer times than expected" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any ~> True)
`expects` do
called (times 3) `with` "a"
@@ -254,7 +255,7 @@
pure ()) `shouldThrow` anyErrorCall
it "fails when called with unexpected arguments" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any ~> True)
`expects` do
called once `with` "a"
@@ -263,7 +264,7 @@
pure ()) `shouldThrow` anyErrorCall
it "fails when called but never expected" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any ~> True)
`expects` do
called never `with` "z"
@@ -283,7 +284,7 @@
describe "order verification" $ do
it "calledInOrder succeeds when called in correct order" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
calledInOrder ["a", "b", "c"]
@@ -294,7 +295,7 @@
pure ()
it "calledInOrder fails when called in wrong order" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
calledInOrder ["a", "b", "c"]
@@ -305,7 +306,7 @@
pure ()) `shouldThrow` anyErrorCall
it "calledInOrder fails when not all calls are made" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
calledInOrder ["a", "b", "c"]
@@ -316,7 +317,7 @@
pure ()) `shouldThrow` anyErrorCall
it "calledInSequence succeeds when sequence is followed" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
calledInSequence ["a", "c"]
@@ -327,7 +328,7 @@
pure ()
it "calledInSequence fails when sequence is violated" $ do
- withMock (do
+ withMock (do
mockFn <- mock (any @String ~> True)
`expects` do
calledInSequence ["a", "c"]
@@ -337,7 +338,7 @@
pure ()) `shouldThrow` anyErrorCall
it "calledInSequence succeeds with extra calls in between" $ do
- withMock $ do
+ withMock $ do
mockFn <- mock (any @String ~> True)
`expects` do
calledInSequence ["a", "c"]
@@ -350,10 +351,10 @@
describe "multiple mocks" $ do
it "can define multiple mocks in withMock" $ do
- withMock $ do
+ withMock $ do
fn1 <- mock (any @String ~> True)
`expects` do
- called once `with` "a"
+ called once `with` "a"
fn2 <- mock (any @String ~> any @String ~> False)
`expects` do
@@ -366,14 +367,14 @@
describe "withMock scope isolation" $ do
it "mocks from different withMock blocks do not interfere" $ do
-- First withMock block: expect one call
- withMock $ do
+ withMock $ do
fn1 <- mock (any ~> 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
+ withMock $ do
_ <- mock (any ~> True)
`expects` do
called never `with` "a"
@@ -459,4 +460,3 @@
runInIO $ void $ liftIO $ evaluate $ mockFn "first"
runInIO $ void $ liftIO $ evaluate $ mockFn "second"
runInIO $ void $ liftIO $ evaluate $ mockFn "third"
-