diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,17 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.3.0.0] - 2026-01-03 +### Added +- **Type-Safe Verification Result**: Generated mock helpers now return `MockResult params`. This type carries parameter information, enabling robust type inference and compile-time safety checks when using declarative verification (`expects`). + - *This change is part of an ongoing effort to make misuse of mocks impossible at the type level.* + +### Changed +- **Breaking Change**: Due to the introduction of `MockResult`, generated mock helpers (e.g., `_myMethod`) no longer return the mock function itself (`MockT m (FunctionType)`). + - Code that previously relied on capturing the returned function (e.g., `fn <- _myMethod ...`) will need to be updated. +- **Refactoring**: Reorganized internal test verification logic to utilize `MockResult` properties. +- **Internal**: Refactored test suite organization for better maintainability. + ## [1.2.1.0] - 2026-01-01 ### Added - **Dynamic Language Extension Detection**: `mockcat` now automatically identifies and requests only necessary extensions (e.g., `MultiParamTypeClasses`, `UndecidableInstances`) based on the target class definition. 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.2.1.0 +version: 1.3.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. @@ -120,6 +120,7 @@ Test.MockCat.TH.TypeUtilsSpec Test.MockCat.THCompareSpec Test.MockCat.TypeClassCommonSpec + Test.MockCat.TypeClassMinimalSpec Test.MockCat.TypeClassSpec Test.MockCat.TypeClassTHSpec Test.MockCat.UnsafeCheck diff --git a/src/Test/MockCat/Internal/Registry/Core.hs b/src/Test/MockCat/Internal/Registry/Core.hs --- a/src/Test/MockCat/Internal/Registry/Core.hs +++ b/src/Test/MockCat/Internal/Registry/Core.hs @@ -20,6 +20,7 @@ , markUnitUsed , isGuardActive , getLastRecorder + , getLastRecorderRaw , resetMockHistory ) where @@ -35,8 +36,10 @@ import Control.Exception (bracket_) import Control.Monad (forM_) import Control.Concurrent (ThreadId, myThreadId) -import Data.Dynamic (Dynamic, toDyn, fromDynamic) +import Data.Dynamic (Dynamic(..), toDyn, fromDynamic) import Data.Typeable (Typeable) +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map @@ -94,6 +97,7 @@ Map.insertWith (++) tid [(name, dyn)] m -- | Get the last registered recorder (peek only, does not remove). +-- | Get the last registered recorder (peek only, does not remove). getLastRecorder :: Typeable a => IO (Maybe MockName, Maybe a) getLastRecorder = do tid <- myThreadId @@ -103,6 +107,17 @@ Nothing -> pure (Nothing, Nothing) Just [] -> pure (Nothing, Nothing) Just ((name, dyn) : _) -> pure (name, fromDynamic dyn) + +-- | Get the last registered recorder as raw Any (unwrapped from Dynamic). +getLastRecorderRaw :: IO (Maybe MockName, Maybe Any) +getLastRecorderRaw = do + tid <- myThreadId + atomically $ do + store <- readTVar threadMockHistory + case Map.lookup tid store of + Nothing -> pure (Nothing, Nothing) + Just [] -> pure (Nothing, Nothing) + Just ((name, Dynamic _ v) : _) -> pure (name, Just (unsafeCoerce v)) -- | Reset the mock history for the current thread. resetMockHistory :: IO () 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 @@ -8,6 +8,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -134,6 +135,13 @@ class CreateStubFn a where stubImpl :: a +-- | Type class for extracting result or unit. + + + + + + -- | Type family to distinguish MockSpec from other parameters. type family IsMockSpec p :: Bool where IsMockSpec (MockSpec p e) = 'True @@ -142,7 +150,7 @@ -- | 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 +class MockDispatch (flag :: Bool) p m fn | flag p m -> fn where mockDispatchImpl :: Label -> p -> m fn -- Generic instance for named mocks (flag ~ 'False) @@ -160,9 +168,15 @@ 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 + BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) params :: m (BuiltMock fn verifyParams) + _ <- liftIO $ MockRegistry.register (Just name) recorder fn + pure fn + + + + + -- Specific instance for MockSpec (flag ~ 'True) instance ( MonadIO m @@ -177,7 +191,7 @@ 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) + BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock (Just name) (toParams params) :: m (BuiltMock fn verifyParams) _ <- liftIO $ MockRegistry.register (Just name) recorder fn WithMockContext ctxRef <- askWithMockContext @@ -206,8 +220,9 @@ where mockImpl p = do let params = toParams p - BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing params - liftIO $ MockRegistry.register Nothing recorder fn + BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing params :: m (BuiltMock fn verifyParams) + _ <- liftIO $ MockRegistry.register Nothing recorder fn + pure fn -- | Create a mock function from MockSpec. -- MockSpec can optionally contain expectations. @@ -228,7 +243,7 @@ CreateMockFn (MockSpec params [Expectation verifyParams] -> m fn) where mockImpl (MockSpec params exps) = do - BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing (toParams params) + BuiltMock { builtMockFn = fn, builtMockRecorder = recorder } <- buildMock Nothing (toParams params) :: m (BuiltMock fn verifyParams) _ <- liftIO $ MockRegistry.register Nothing recorder fn WithMockContext ctxRef <- askWithMockContext 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 @@ -78,6 +78,7 @@ updateType ) import Test.MockCat.Verify (ResolvableParamsOf) +import Test.MockCat.WithMock (MockResult(..)) import Data.Dynamic (Dynamic, toDyn) import Data.Proxy (Proxy(..)) import Data.List (find, nubBy, nub) @@ -210,7 +211,7 @@ let resultType = AppT (AppT ArrowT (VarT params)) - (AppT (AppT (ConT ''MockT) (VarT monadVarName)) funType) + (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (AppT (ConT ''MockResult) (AppT (ConT ''ResolvableParamsOf) funType))) mockTType = AppT (ConT ''MockT) (VarT monadVarName) flag = AppT (ConT ''IsMockSpec) (VarT params) @@ -255,7 +256,7 @@ let resultType = AppT (AppT ArrowT (VarT stubVar)) - (AppT (AppT (ConT ''MockT) (VarT monadVarName)) tySanitized) + (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (AppT (ConT ''MockResult) (AppT (ConT ''ResolvableParamsOf) tySanitized))) let mockTType = AppT (ConT ''MockT) (VarT monadVarName) let flag = AppT (ConT ''IsMockSpec) (VarT stubVar) @@ -303,7 +304,7 @@ let resultType = AppT (AppT ArrowT (VarT params)) - (AppT (AppT (ConT ''MockT) (VarT monadVarName)) tySanitized) + (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (AppT (ConT ''MockResult) (AppT (ConT ''ResolvableParamsOf) tySanitized))) mockTType = AppT (ConT ''MockT) (VarT monadVarName) flag = AppT (ConT ''IsMockSpec) (VarT params) @@ -343,7 +344,7 @@ resultType = AppT (AppT ArrowT (VarT params)) - (AppT (AppT (ConT ''MockT) (VarT monadVarName)) funType) + (AppT (AppT (ConT ''MockT) (VarT monadVarName)) (AppT (ConT ''MockResult) (AppT (ConT ''ResolvableParamsOf) funType))) mockTType = AppT (ConT ''MockT) (VarT monadVarName) flag = AppT (ConT ''IsMockSpec) (VarT params) @@ -387,7 +388,7 @@ mockInstance NoVerification ) - pure mockInstance + pure (MockResult ()) |] createFnName :: Name -> MockOptions -> String 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 @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} @@ -11,7 +10,6 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} @@ -144,7 +142,7 @@ candidates <- resolveForVerification target case candidates of [] -> verificationFailure - _ -> pure $ map (\(name, recorder) -> ResolvedMock name recorder) candidates + _ -> pure $ map (uncurry ResolvedMock) candidates resolveForVerification :: forall target params. @@ -399,20 +397,20 @@ if compareCount method callCount then pure Nothing else pure $ Just $ countWithArgsMismatchMessage mockName method callCount - + CountAnyVerification method -> tryVerifyCallCount mockName recorder method - + OrderVerification method argsList -> case doVerifyOrder method mockName invocationList argsList of Nothing -> pure Nothing Just (VerifyFailed msg) -> pure $ Just msg - + SimpleVerification args -> case doVerify mockName invocationList (MatchAny args) of Nothing -> pure Nothing Just (VerifyFailed msg) -> pure $ Just msg - + AnyVerification -> do if null invocationList then pure $ Just $ intercalate "\n" ["Function" <> mockNameLabel mockName <> " was never called"] 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 @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} @@ -17,6 +18,7 @@ module Test.MockCat.WithMock ( withMock , expects + , MockResult(..) , called , with , calledInOrder @@ -41,9 +43,7 @@ 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.Verify (verifyExpectationDirect) import Test.MockCat.Internal.Types ( VerifyOrderMethod(..) , WithMockContext(..) @@ -55,14 +55,20 @@ , InvocationRecorder(..) , ResolvedMock(..) ) -import qualified Test.MockCat.Internal.MockRegistry as MockRegistry +import qualified Test.MockCat.Internal.Registry.Core as MockRegistry +import Unsafe.Coerce (unsafeCoerce) import Test.MockCat.Param (Param(..), param, EqParams(..)) import Data.Kind (Type) import Data.Proxy (Proxy(..)) +-- | A specialized Unit type that carries the parameter type information. +-- This is used to improve type inference for unit-returning mock helpers. +newtype MockResult params = MockResult () + deriving (Show, Eq) + -- | Run a block with mock expectations that are automatically verified withMock :: ReaderT WithMockContext IO a -> IO a withMock action = do @@ -93,50 +99,135 @@ -- | Register expectations for a mock function -- Accepts an Expectations builder --- The params type is inferred from the mock function type or the expectation -class BuildExpectations fn exp where - buildExpectations :: fn -> exp -> [Expectation (ResolvableParamsOf fn)] +-- The params type is usually inferred from the mock function, but can be overridden +class BuildExpectations fn exp params | fn exp -> params where + buildExpectations :: fn -> exp -> [Expectation params] -- | Instance for direct Expectations value --- The params type must match ResolvableParamsOf fn -instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (Expectations params ()) where +instance {-# OVERLAPPABLE #-} forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (Expectations params ()) params where buildExpectations _ = runExpectations +-- | Instance for function form when fn is MockResult +instance {-# OVERLAPPING #-} forall params. BuildExpectations (MockResult params) (MockResult params -> Expectations params ()) params where + buildExpectations _ f = runExpectations (f (MockResult ())) + +-- | Instance for direct Expectations value when fn is MockResult +instance {-# OVERLAPPING #-} forall params. BuildExpectations (MockResult params) (Expectations params ()) params where + buildExpectations _ = runExpectations + +-- | Instance for direct Expectations value when fn is () +instance {-# OVERLAPPING #-} forall params. BuildExpectations () (Expectations params ()) params where + buildExpectations _ = runExpectations + -- | Instance for function form (fn -> Expectations params ()) --- This allows passing a function that receives the mock function -instance forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (fn -> Expectations params ()) where +instance {-# OVERLAPPABLE #-} forall fn params. (ResolvableParamsOf fn ~ params) => BuildExpectations fn (fn -> Expectations params ()) params where buildExpectations fn f = runExpectations (f fn) -expects :: - forall m fn exp params. +-- | Type class for dispatching expectations based on mock function type +class ExpectsDispatch fn exp m where + expects :: m fn -> exp -> m fn + +-- | Specialized instance for MockResult helpers (handles type inference) +instance {-# OVERLAPPING #-} (exp ~ Expectations params (), ExpectsDispatchImpl 'True (MockResult params) (Expectations params ()) m) => ExpectsDispatch (MockResult params) exp m where + expects = expectsDispatchImpl @'True + +-- | Specialized instance for Unit helpers (fallback) +instance {-# OVERLAPPING #-} (exp ~ Expectations params (), ExpectsDispatchImpl 'True () (Expectations params ()) m) => ExpectsDispatch () exp m where + expects = expectsDispatchImpl @'True + +-- | Generic instance for normal mocks +instance {-# OVERLAPPABLE #-} (ExpectsDispatchImpl 'False fn exp m) => ExpectsDispatch fn exp m where + expects = expectsDispatchImpl @'False + +-- | Internal class for implementation dispatch +class ExpectsDispatchImpl (flag :: Bool) fn exp m where + expectsDispatchImpl :: m fn -> exp -> m fn + +-- | Instance for normal mocks (flag ~ 'False) +-- Strict matching of params +instance ( MonadIO m , MonadWithMockContext m , ResolvableMock fn , ResolvableParamsOf fn ~ params , ExtractParams exp , ExpParams exp ~ params - , BuildExpectations fn exp + , BuildExpectations fn exp params , Show params , EqParams params ) => - m fn -> - exp -> - m fn -expects mockFnM exp = do - (WithMockContext ctxVar) <- askWithMockContext - -- Try to help type inference by using exp first - let _ = extractParams exp :: Proxy params - mockFn <- mockFnM - -- Get the recorder from the thread-local store (set by mock/register) - -- This avoids StableName lookup and is HPC-safe - (mockName, mRecorder) <- liftIO $ MockRegistry.getLastRecorder @(InvocationRecorder params) - let resolved = case mRecorder of - Just recorder -> ResolvedMock mockName recorder - Nothing -> error "expects: mock recorder not found. Use mock inside withMock/runMockT." - let expectations = buildExpectations mockFn exp - let actions = map (verifyExpectationDirect resolved) expectations - liftIO $ atomically $ modifyTVar' ctxVar (++ actions) - pure mockFn + ExpectsDispatchImpl 'False fn exp m + where + expectsDispatchImpl mockFnM exp = do + (WithMockContext ctxVar) <- askWithMockContext + -- Try to help type inference by using exp first + let _ = extractParams exp :: Proxy params + mockFn <- mockFnM + -- Get the recorder from the thread-local store (set by mock/register) + -- This avoids StableName lookup and is HPC-safe + (mockName, mRecorder) <- liftIO $ MockRegistry.getLastRecorder @(InvocationRecorder params) + + let resolved = case mRecorder of + Just recorder -> ResolvedMock mockName recorder + Nothing -> errorWithoutStackTrace "expects: mock recorder not found. Use mock inside withMock/runMockT." + + let expectations = buildExpectations mockFn exp + let actions = map (verifyExpectationDirect resolved) expectations + liftIO $ atomically $ modifyTVar' ctxVar (++ actions) + pure mockFn + +-- | Instance for MockResult mocks (flag ~ 'True) +-- Dynamic resolution using expectation params +instance + ( MonadIO m + , MonadWithMockContext m + , BuildExpectations (MockResult params) (Expectations params ()) params + , Show params + , EqParams params + ) => + ExpectsDispatchImpl 'True (MockResult params) (Expectations params ()) m + where + expectsDispatchImpl mockFnM exp = do + (WithMockContext ctxVar) <- askWithMockContext + _ <- mockFnM + (mockName, mRecorder) <- liftIO MockRegistry.getLastRecorderRaw + resolved <- case mRecorder of + Just raw -> do + let recorder = unsafeCoerce raw :: InvocationRecorder params + pure $ ResolvedMock mockName recorder + Nothing -> errorWithoutStackTrace "expects: mock recorder not found (Dynamic Resolution Failed). Ensure the mock helper function was called." + -- Use the expectations directly since we know the context + let expectations = runExpectations exp + let actions = map (verifyExpectationDirect resolved) expectations + liftIO $ atomically $ modifyTVar' ctxVar (++ actions) + pure (MockResult ()) + +-- | Instance for Unit mocks (flag ~ 'True) +-- Dynamic resolution using expectation params +instance + ( MonadIO m + , MonadWithMockContext m + , BuildExpectations () (Expectations params ()) params + , Show params + , EqParams params + ) => + ExpectsDispatchImpl 'True () (Expectations params ()) m + where + expectsDispatchImpl mockFnM exp = do + (WithMockContext ctxVar) <- askWithMockContext + _ <- mockFnM + (mockName, mRecorder) <- liftIO MockRegistry.getLastRecorderRaw + resolved <- case mRecorder of + Just raw -> do + let recorder = unsafeCoerce raw :: InvocationRecorder params + pure $ ResolvedMock mockName recorder + Nothing -> errorWithoutStackTrace "expects: mock recorder not found (Dynamic Resolution Failed). Ensure the mock helper function was called." + let expectations = buildExpectations () exp + let actions = map (verifyExpectationDirect resolved) expectations + liftIO $ atomically $ modifyTVar' ctxVar (++ actions) + pure () + + -- | Create a count expectation builder -- The params type is inferred from the mock function in expects 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 #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} @@ -33,7 +34,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 #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} @@ -25,7 +26,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. @@ -38,7 +39,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 #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} @@ -61,7 +62,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/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,9 @@ import Test.MockCat.ParamSpec as Param import Test.MockCat.AssociationListSpec as AssociationList import Test.MockCat.ExampleSpec as Example +import Test.MockCat.TypeClassMinimalSpec as TypeClassMinimal import Test.MockCat.TypeClassSpec as TypeClass + import Test.MockCat.TypeClassTHSpec as TypeClassTH import Test.MockCat.PartialMockSpec as PartialMock import Test.MockCat.PartialMockTHSpec as PartialMockTH @@ -45,6 +47,7 @@ Mock.spec AssociationList.spec Example.spec + TypeClassMinimal.spec TypeClass.spec TypeClassTH.spec PartialMock.spec 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,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -37,7 +38,7 @@ withRunInIO \runInIO -> do as <- replicateM threads (async $ do replicateM_ callsPerThread $ do - _ <- runInIO (action 123) + runInIO (action 123) threadDelay 100) mapM_ wait as @@ -52,7 +53,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,8 +63,8 @@ let threads = 50 :: Int callsPerThread = 20 :: Int total = threads * callsPerThread :: Int - _ <- (runMockT $ do - _ <- _action ((any ~> (1 :: Int))) + (runMockT $ do + _action ((any ~> (1 :: Int))) `expects` do called (times total) parallelCallActionWithDelay threads callsPerThread @@ -72,7 +73,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 @@ -82,7 +83,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 --- a/test/Test/MockCat/DeferredTypeErrorsSpec.hs +++ b/test/Test/MockCat/DeferredTypeErrorsSpec.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE DataKinds #-} module Test.MockCat.DeferredTypeErrorsSpec (spec) where @@ -32,7 +34,7 @@ f <- mock (any ~> (1 :: Int)) let val = f `expects` do called once - _ <- liftIO $ evaluate val + liftIO $ evaluate val pure () -- Since the type error is deferred inside the IO action logic, we must run it to trigger the exception. 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 @@ -3,12 +3,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -42,8 +41,6 @@ makeMock [t|Teletype|] - - class Monad m => StrictTest m where strictFunc :: String -> m () @@ -52,8 +49,6 @@ makeMock [t|StrictTest|] - - spec :: Spec spec = do it "Default makeMock is strict (requires pure)" do @@ -96,15 +91,16 @@ it "echo1" do result <- runMockT do - _readTTY $ pure @IO "" + _readTTY (pure @IO "") `expects` called once echoProgram result `shouldBe` () it "echo2" do result <- runMockT do - _readTTY $ do + _readTTY (do onCase $ pure @IO "a" - onCase $ pure @IO "" + onCase $ pure @IO "") + `expects` called (times 2) _writeTTY $ "a" ~> pure @IO () echoProgram 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,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,8 +35,8 @@ f2 <- mock $ "2" ~> (2 :: Int) -- Execute both - _ <- evaluate $ f1 "1" - _ <- evaluate $ f2 "2" + evaluate $ f1 "1" + evaluate $ f2 "2" -- Verify f1. -- If fallback picks f2 (latest or first), verification might fail or see wrong calls. @@ -51,8 +52,8 @@ fA <- mock (label "mockA") $ "A" ~> (1 :: Int) fB <- mock (label "mockB") $ "B" ~> (2 :: Int) - _ <- evaluate $ fA "A" - _ <- evaluate $ fB "B" + evaluate $ fA "A" + evaluate $ fB "B" fA `shouldBeCalled` "A" fB `shouldBeCalled` "B" diff --git a/test/Test/MockCat/HPCNestSpec.hs b/test/Test/MockCat/HPCNestSpec.hs --- a/test/Test/MockCat/HPCNestSpec.hs +++ b/test/Test/MockCat/HPCNestSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.MockCat.HPCNestSpec (spec) where @@ -15,7 +16,7 @@ it "RunMockT nested in IO: outer mock with 'shouldBeCalled' becomes unverifiable inside runMockT" $ do outer <- mock (param "outer" ~> True) -- execution in IO context - _ <- evaluate (outer "outer") + evaluate (outer "outer") runMockT @IO $ do -- runMockT resets history, so 'outer' should not be verifiable here. @@ -24,7 +25,7 @@ it "RunMockT nested in IO: outer mock is verifiable AFTER runMockT returns" $ do outer <- mock (param "outer" ~> True) - _ <- evaluate (outer "outer") + evaluate (outer "outer") runMockT @IO $ do pure () @@ -35,12 +36,11 @@ it "withMock (using expects) is immune to history reset" $ do withMock $ do - f <- mock (param "a" ~> True) - `expects` do + f <- mock (param "a" ~> True) `expects` do called once `with` "a" liftIO $ do - _ <- evaluate (f "a") + evaluate (f "a") -- Nested runMockT clears history, but expectations capture the recorder directly. runMockT @IO $ pure () @@ -49,32 +49,30 @@ it "Sibling runMockT blocks are isolated" $ do runMockT @IO $ do f1 <- mock (param "a" ~> True) - _ <- liftIO $ evaluate (f1 "a") + liftIO $ evaluate (f1 "a") liftIO $ f1 `shouldBeCalled` "a" runMockT @IO $ do f2 <- mock (param "a" ~> True) - _ <- liftIO $ evaluate (f2 "a") + liftIO $ evaluate (f2 "a") liftIO $ f2 `shouldBeCalled` "a" it "Nested withMock blocks work correctly even with same-type mocks" $ do withMock $ do -- Outer mock - outer <- mock (param "a" ~> True) - `expects` do + outer <- mock (param "a" ~> True) `expects` do called once liftIO $ do - _ <- evaluate (outer "a") + evaluate (outer "a") -- Inner withMock withMock $ do -- Inner mock with SAME signature - inner <- mock (param "a" ~> True) - `expects` do + inner <- mock (param "a" ~> True) `expects` do called once - _ <- liftIO $ evaluate (inner "a") + liftIO $ evaluate (inner "a") pure () pure () @@ -82,7 +80,7 @@ it "Nested runMockT: inner block clears outer block's history" $ do runMockT @IO $ do outer <- mock (param "a" ~> True) - _ <- liftIO $ evaluate (outer "a") + liftIO $ evaluate (outer "a") -- At this point, outer is verifiable liftIO $ outer `shouldBeCalled` "a" @@ -96,7 +94,7 @@ -- Inner mock should work checking inner <- mock (param "b" ~> True) - _ <- liftIO $ evaluate (inner "b") + liftIO $ evaluate (inner "b") liftIO $ inner `shouldBeCalled` "b" -- After inner block returns, history is NOT restored (resetMockHistory is destructive). @@ -107,11 +105,12 @@ it "withMock inside runMockT works correctly" $ do runMockT @IO $ do f <- mock (param "a" ~> True) - _ <- liftIO $ evaluate (f "a") + liftIO $ evaluate (f "a") liftIO $ withMock $ do - g <- mock (param "b" ~> True) `expects` do called once - _ <- liftIO $ evaluate (g "b") + g <- mock (param "b" ~> True) + pure g `expects` do called once + liftIO $ evaluate (g "b") pure () -- withMock does not reset history, so 'f' should still be verifiable diff --git a/test/Test/MockCat/Internal/MockRegistrySpec.hs b/test/Test/MockCat/Internal/MockRegistrySpec.hs --- a/test/Test/MockCat/Internal/MockRegistrySpec.hs +++ b/test/Test/MockCat/Internal/MockRegistrySpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Test.MockCat.Internal.MockRegistrySpec (spec) where import Test.Hspec @@ -14,7 +15,7 @@ it "register and lookup" do let f = (+ 1) :: Int -> Int ref <- newTVarIO InvocationRecord { invocations = [] :: [Int], invocationCounts = empty } - _ <- attachVerifierToFn f (Just "name", InvocationRecorder ref ParametricFunction) + attachVerifierToFn f (Just "name", InvocationRecorder ref ParametricFunction) results <- lookupVerifierForFn f case results of [(mockName, dyn)] -> do diff --git a/test/Test/MockCat/MockSpec.hs b/test/Test/MockCat/MockSpec.hs --- a/test/Test/MockCat/MockSpec.hs +++ b/test/Test/MockCat/MockSpec.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-type-defaults #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {- HLINT ignore "Use newtype instead of data" -} 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 @@ -13,9 +13,7 @@ spec = describe "MockT + expects integration" do it "allows expects inside runMockT" do runMockT @IO do - f <- - mock (any @String ~> True) - `expects` do - called once `with` "foo" + f <- mock (any @String ~> True) + `expects` called once `with` "foo" _ <- liftIO $ evaluate (f "foo") pure () diff --git a/test/Test/MockCat/MultipleMocksSpec.hs b/test/Test/MockCat/MultipleMocksSpec.hs --- a/test/Test/MockCat/MultipleMocksSpec.hs +++ b/test/Test/MockCat/MultipleMocksSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.MockCat.MultipleMocksSpec (spec) where @@ -27,8 +28,8 @@ called once -- Call them to satisfy expectations - _ <- liftIO $ evaluate $ f "A" - _ <- liftIO $ evaluate $ g "B" + liftIO $ evaluate $ f "A" + liftIO $ evaluate $ g "B" pure () @@ -40,13 +41,13 @@ f <- mock ("A" ~> (1 :: Int)) `expects` do called once - _ <- mock ("B" ~> (2 :: Int)) `expects` do + 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" + liftIO $ evaluate $ f "B" pure () -- We expect failure because expectations were not met. 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 @@ -43,13 +43,13 @@ -- Dependency record to group builders data PartialMockDeps = PartialMockDeps - { _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) + { _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 (MockResult (Verify.ResolvableParamsOf String)) + , _getBy :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO Int)) => params -> MockT IO (MockResult (Verify.ResolvableParamsOf (String -> IO Int))) + , _echo :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO ())) => params -> MockT IO (MockResult (Verify.ResolvableParamsOf (String -> IO ()))) + , _writeFile :: forall params m. (MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text -> ()), MonadIO m) => params -> MockT m (MockResult (Verify.ResolvableParamsOf (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 (MockResult (Verify.ResolvableParamsOf [a])) + , _findById :: forall params m. (MockDispatch (IsMockSpec params) params (MockT m) (Int -> String), MonadIO m) => params -> MockT m (MockResult (Verify.ResolvableParamsOf (Int -> String))) + , _findByIdNI :: forall params. (MockDispatch (IsMockSpec params) params (MockT IO) (Int -> IO String)) => params -> MockT IO (MockResult (Verify.ResolvableParamsOf (Int -> IO String))) } -- Main Entry Point @@ -78,14 +78,14 @@ describe "UserInputGetter" do it "Get user input (has input)" do result <- runMockT do - _ <- _getInput ("value" :: String) + _getInput ("value" :: String) i <- getInput toUserInput i result `shouldBe` Just (UserInput "value") it "Get user input (no input)" do result <- runMockT do - _ <- _getInput ("" :: String) + _getInput ("" :: String) i <- getInput toUserInput i result `shouldBe` Nothing @@ -93,35 +93,35 @@ describe "FileOperation" do it "IO" do result <- runMockT do - _ <- _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ()) + _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ()) pure () result `shouldBe` () it "MaybeT" do result <- runMaybeT do runMockT do - _ <- _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ()) + _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ()) pure () result `shouldBe` Just () it "ReaderT" do result <- flip runReaderT "foo" do runMockT do - _ <- _writeFile (("output.text" :: FilePath) ~> pack ("ReaderT content foo" :: String) ~> ()) + _writeFile (("output.text" :: FilePath) ~> pack ("ReaderT content foo" :: String) ~> ()) pure () result `shouldBe` () describe "Handwritten Partial Mock Test" do it "IO" do result <- runMockT do - _ <- _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ()) + _writeFile (("output.text" :: FilePath) ~> pack ("IO content" :: String) ~> ()) programAction result `shouldBe` () it "MaybeT" do result <- runMaybeT do runMockT do - _ <- _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ()) + _writeFile (("output.text" :: FilePath) ~> pack ("MaybeT content" :: String) ~> ()) pure () result `shouldBe` Just () @@ -135,14 +135,14 @@ specExplicitMonadicReturns (PartialMockDeps { _echo, _getBy }) = describe "Explicit Monadic Returns" do it "Return monadic value test" do result <- runMockT $ do - _ <- _echo $ ("3" :: String) ~> pure @IO () + _echo $ ("3" :: String) ~> pure @IO () v <- getByExplicitPartial "abc" echoExplicitPartial (show v) result `shouldBe` () it "Override getBy via stub" do result <- runMockT do - _ <- _getBy $ ("abc" :: String) ~> pure @IO (123 :: Int) + _getBy $ ("abc" :: String) ~> pure @IO (123 :: Int) getByExplicitPartial "abc" result `shouldBe` 123 @@ -160,13 +160,13 @@ it "partial findIds" do values <- runMockT $ do - _ <- _findIds ([1 :: Int, 2] :: [Int]) + _findIds ([1 :: Int, 2] :: [Int]) findValue @Int @String values `shouldBe` ["{id: 1}", "{id: 2}"] it "partial findById" do values <- runMockT $ do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "id1" onCase $ (2 :: Int) ~> "id2" onCase $ (3 :: Int) ~> "id3" @@ -175,7 +175,7 @@ it "Concurrent execution correctly calls and collects results from mocks (async)" do result <- runMockT do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "id1" onCase $ (2 :: Int) ~> "id2" withRunInIO $ \runInIO -> do @@ -191,14 +191,14 @@ let argError :: Selector ErrorCall argError err = "was not called with the expected arguments" `isInfixOf` displayException (err :: ErrorCall) (runMockT @IO do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "id1" -- calling findValue will hit findById for id 2 which is not covered by mock findValue @Int @String) `shouldThrow` argError it "duplicate cases prefer first" do result <- runMockT $ do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "first" onCase $ (1 :: Int) ~> "second" findById 1 @@ -206,7 +206,7 @@ it "findValue returns empty when findIds returns empty list" do result <- runMockT $ do - _ <- _findIds ([] :: [Int]) + _findIds ([] :: [Int]) findValue @Int @String result `shouldBe` [] @@ -214,7 +214,7 @@ it "error message contains mock name when unexpected arg is used" do let nameMsg = "function `_findById` was not called with the expected arguments" (runMockT @IO do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "id1" -- call with unexpected arg to trigger message findById (2 :: Int)) `shouldThrow` (\(err :: ErrorCall) -> nameMsg `isInfixOf` displayException err) @@ -224,7 +224,7 @@ let argError :: Selector ErrorCall argError err = "was not called with the expected arguments" `isInfixOf` displayException (err :: ErrorCall) (runMockT @IO do - _ <- _findById $ do + _findById $ do onCase $ (1 :: Int) ~> "id1" -- calling findValue will hit findById for id 2 which is not covered by mock, -- and because a mock function exists for _findById, it will error rather than fallback. @@ -233,7 +233,7 @@ describe "Implicit monadic return options" do it "partial findById with explicit monadic returns (implicitMonadicReturn=False)" do result <- runMockT $ do - _ <- _findByIdNI $ do + _findByIdNI $ do onCase $ (1 :: Int) ~> pure @IO "id1" onCase $ (2 :: Int) ~> pure @IO "id2" onCase $ (3 :: Int) ~> pure @IO "id3" @@ -260,7 +260,7 @@ it "fails when _findIds is defined but findIds is never called" do (runMockT @IO do - _ <- _findIds (Head :> param ([1 :: Int, 2] :: [Int])) + _findIds (Head :> param ([1 :: Int, 2] :: [Int])) `expects` do called once -- findIds is never called @@ -272,7 +272,7 @@ onCase $ (1 :: Int) ~> "id1" onCase $ (2 :: Int) ~> "id2" onCase $ (3 :: Int) ~> "id3" - _ <- _findById casesDef `expects` do + _findById casesDef `expects` do called once -- findById is never called pure ()) `shouldThrow` missingCall "_findById" 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 @@ -10,7 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Test.MockCat.PartialMockSpec (spec) where @@ -27,11 +26,8 @@ import Data.Data import GHC.TypeLits (KnownSymbol, symbolVal) import Unsafe.Coerce (unsafeCoerce) - import qualified Test.MockCat.Verify as Verify - - ensureVerifiable :: ( MonadIO m , Verify.ResolvableMock target @@ -45,7 +41,6 @@ [] -> Verify.verificationFailure _ -> pure () - instance UserInputGetter IO where getInput = getLine toUserInput "" = pure Nothing @@ -55,7 +50,6 @@ echoExplicitPartial _ = pure () getByExplicitPartial s = pure (length s) - instance (MonadIO m, FileOperation m) => FileOperation (MockT m) where readFile path = MockT do defs <- getDefinitions @@ -128,12 +122,12 @@ , MonadIO m ) => params -> - MockT m (FilePath -> Text -> ()) + MockT m (MockResult (Verify.ResolvableParamsOf (FilePath -> Text -> ()))) _writeFile p = MockT $ do mockInstance <- unMockT $ mock (label "writeFile") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _getInput :: ( MockDispatch (IsMockSpec params) params (MockT m) String @@ -141,12 +135,12 @@ , Typeable (Verify.ResolvableParamsOf String) ) => params -> - MockT m String + MockT m (MockResult (Verify.ResolvableParamsOf String)) _getInput value = MockT $ do mockInstance <- unMockT $ mock (label "getInput") value ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "getInput") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _toUserInput :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m (Maybe UserInput)) @@ -166,23 +160,23 @@ ( MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO Int) ) => params -> - MockT IO (String -> IO Int) + MockT IO (MockResult (Verify.ResolvableParamsOf (String -> IO Int))) _getByPartial p = MockT $ do mockInstance <- unMockT $ mock (label "getBy") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "getBy") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _echoPartial :: ( MockDispatch (IsMockSpec params) params (MockT IO) (String -> IO ()) ) => params -> - MockT IO (String -> IO ()) + MockT IO (MockResult (Verify.ResolvableParamsOf (String -> IO ()))) _echoPartial p = MockT $ do mockInstance <- unMockT $ mock (label "echo") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "echo") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a findParam pa definitions = do @@ -215,7 +209,7 @@ , Typeable [a] ) => p -> - MockT m [a] + MockT m (MockResult (Verify.ResolvableParamsOf [a])) _findIds p = MockT $ do mockInstance <- unMockT $ mock (label "_findIds") p @@ -226,14 +220,14 @@ mockInstance NoVerification ) - pure mockInstance + pure (MockResult ()) _findById :: ( MockDispatch (IsMockSpec params) params (MockT m) (Int -> String) , MonadIO m ) => params -> - MockT m (Int -> String) + MockT m (MockResult (Verify.ResolvableParamsOf (Int -> String))) _findById p = MockT $ do mockInstance <- unMockT $ mock (label "_findById") p ensureVerifiable mockInstance @@ -243,13 +237,13 @@ mockInstance NoVerification ) - pure mockInstance + pure (MockResult ()) _findByIdNI :: ( MockDispatch (IsMockSpec params) params (MockT IO) (Int -> IO String) ) => params -> - MockT IO (Int -> IO String) + MockT IO (MockResult (Verify.ResolvableParamsOf (Int -> IO String))) _findByIdNI p = MockT $ do mockInstance <- unMockT $ mock (label "_findByIdNI") p ensureVerifiable mockInstance @@ -259,7 +253,7 @@ mockInstance NoVerification ) - pure mockInstance + pure (MockResult ()) spec :: Spec spec = PartialMockCommonSpec.spec deps (program "input.txt" "output.text") 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 @@ -12,16 +12,15 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Test.MockCat.PartialMockTHSpec (spec) where import Test.MockCat import qualified Test.MockCat.PartialMockCommonSpec as PartialMockCommonSpec import Test.MockCat.SharedSpecDefs -import Test.MockCat.Impl () import Prelude hiding (readFile, writeFile) -import Test.Hspec (Spec) +import Test.Hspec (Spec, describe) +import Test.MockCat.Impl () instance UserInputGetter IO where getInput = getLine @@ -40,7 +39,8 @@ makePartialMock [t|FinderNoImplicit|] spec :: Spec -spec = PartialMockCommonSpec.spec deps (program "input.txt" "output.text") +spec = describe "PartialMockTHSpec" $ + PartialMockCommonSpec.spec deps (program "input.txt" "output.text") where deps = PartialMockCommonSpec.PartialMockDeps { PartialMockCommonSpec._getInput = Test.MockCat.PartialMockTHSpec._getInput 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 @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-partial-fields #-} @@ -31,7 +32,7 @@ describe "Error Message Diff" do it "shows diff for string arguments" do f <- mock ((any :: Param String) ~> "ok") - _ <- evaluate $ f "hello haskell" + evaluate $ f "hello haskell" let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -46,7 +47,7 @@ it "shows diff for user-defined type (Post)" do f <- mock (Post 2 "wrong" ~> "ok") - _ <- evaluate $ f (Post 2 "wrong") + evaluate $ f (Post 2 "wrong") let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -68,7 +69,7 @@ it "shows diff for long list" do f <- mock ((any :: Param [Int]) ~> "ok") - _ <- evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10] + evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10] let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -87,7 +88,7 @@ it "shows diff for record" do f <- mock ((any :: Param User) ~> "ok") - _ <- evaluate $ f (User "Fagen" 20) + evaluate $ f (User "Fagen" 20) let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -106,8 +107,8 @@ it "shows diff for inOrderWith" do f <- mock ((any :: Param String) ~> "ok") - _ <- evaluate $ f "a" - _ <- evaluate $ f "b" + evaluate $ f "a" + evaluate $ f "b" let expectedError = "function was not called with the expected arguments in the expected order.\n\ \ expected 2nd call: \"c\"\n\ @@ -132,7 +133,7 @@ it "shows diff for nested record" do f <- mock ((any :: Param ComplexUser) ~> "ok") - _ <- evaluate $ f (ComplexUser "Alice" (Config "Light" 1)) + evaluate $ f (ComplexUser "Alice" (Config "Light" 1)) let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -151,7 +152,7 @@ it "shows diff for nested list" do f <- mock ((any :: Param [[Int]]) ~> "ok") - _ <- evaluate $ f [[1, 2], [3, 4]] + evaluate $ f [[1, 2], [3, 4]] let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -172,7 +173,7 @@ f <- mock ((any :: Param ComplexUser) ~> "ok") let actual = ComplexUser "Alice" (Config "Light" 2) expected = ComplexUser "Bob" (Config "Dark" 1) - _ <- evaluate $ f actual + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -200,7 +201,7 @@ f <- mock ((any :: Param String) ~> "ok") let actual = "{ name = \"Alice\"" expected = "{ name = \"Bob\" }" - _ <- evaluate $ f actual + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -217,7 +218,7 @@ f <- mock ((any :: Param String) ~> "ok") let actual = "NotARecord {,,,,,}" let expected = "NotARecord { a = 1 }" - _ <- evaluate $ f actual + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n\ \\n\ @@ -236,7 +237,7 @@ -- 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 + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n" <> "\n" <> @@ -257,7 +258,7 @@ 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 + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n" <> "\n" <> @@ -284,7 +285,7 @@ f <- mock ((any :: Param Config) ~> "ok") let actual = Config "Light" 1 expected = Config "Dark" 99 - _ <- evaluate $ f actual + evaluate $ f actual let expectedError = "function was not called with the expected arguments.\n" <> "\n" <> diff --git a/test/Test/MockCat/ShouldBeCalledMockMSpec.hs b/test/Test/MockCat/ShouldBeCalledMockMSpec.hs --- a/test/Test/MockCat/ShouldBeCalledMockMSpec.hs +++ b/test/Test/MockCat/ShouldBeCalledMockMSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-type-defaults #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# OPTIONS_GHC -fno-hpc #-} module Test.MockCat.ShouldBeCalledMockMSpec (spec) where 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 @@ -212,52 +212,52 @@ describe "Monadic mocks" do it "shouldBeCalled with IO mock" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` ("a" ~> (1 :: Int)) it "shouldBeCalled times with IO mock" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled inOrderWith with IO mock" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "b" (2 :: Int) - _ <- f "c" (3 :: Int) + f "a" (1 :: Int) + f "b" (2 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)] it "shouldBeCalled inPartialOrderWith with IO mock" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "b" (2 :: Int) - _ <- f "c" (3 :: Int) + f "a" (1 :: Int) + f "b" (2 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` inPartialOrderWith ["a" ~> (1 :: Int), "c" ~> (3 :: Int)] it "shouldBeCalled anything with IO mock" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` anything it "shouldBeCalled times without args with IO mock" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "b" (2 :: Int) - _ <- f "c" (3 :: Int) + f "a" (1 :: Int) + f "b" (2 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` times 3 describe "Named mocks (error messages)" do it "shouldBeCalled with name in error message" do f <- mock (label "named mock") $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` ("b" ~> (1 :: Int)) `shouldThrow` anyErrorCall it "shouldBeCalled times with name in error message" do f <- mock (label "named mock") $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) let e = "function `named mock` was not called the expected number of times with the expected arguments.\n\ \ expected: 3\n\ @@ -266,15 +266,15 @@ it "shouldBeCalled inOrderWith with name in error message" do f <- mock (label "named mock") $ any ~> any ~> pure @IO True - _ <- f "b" (2 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "c" (3 :: Int) + f "b" (2 :: Int) + f "a" (1 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)] `shouldThrow` errorContains "expected 1st call:" it "shouldBeCalled inPartialOrderWith with name in error message" do f <- mock (label "named mock") $ any ~> any ~> pure @IO True - _ <- f "b" (2 :: Int) - _ <- f "a" (1 :: Int) + f "b" (2 :: Int) + f "a" (1 :: Int) let e = "function `named mock` was not called with the expected arguments in the expected order.\n\ \ expected order:\n\ @@ -304,8 +304,8 @@ it "shouldBeCalled times failure with detailed error message" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) let e = "function was not called the expected number of times with the expected arguments.\n\ \ expected: 3\n\ @@ -320,56 +320,56 @@ describe "Multiple arguments with typed values" do it "shouldBeCalled with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` ("a" ~> (1 :: Int)) it "shouldBeCalled times with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (times 3 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled atLeast with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (atLeast 3 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled atMost with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (atMost 3 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled greaterThan with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (greaterThan 2 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled lessThan with multiple typed arguments" do f <- mock $ "a" ~> (1 :: Int) ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) - _ <- f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) + f "a" (1 :: Int) f `shouldBeCalled` (lessThan 4 `withArgs` ("a" ~> (1 :: Int))) it "shouldBeCalled inOrderWith with multiple typed arguments" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "b" (2 :: Int) - _ <- f "c" (3 :: Int) + f "a" (1 :: Int) + f "b" (2 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` inOrderWith ["a" ~> (1 :: Int), "b" ~> (2 :: Int), "c" ~> (3 :: Int)] it "shouldBeCalled inPartialOrderWith with multiple typed arguments" do f <- mock $ any ~> any ~> pure @IO True - _ <- f "a" (1 :: Int) - _ <- f "b" (2 :: Int) - _ <- f "c" (3 :: Int) + f "a" (1 :: Int) + f "b" (2 :: Int) + f "c" (3 :: Int) f `shouldBeCalled` inPartialOrderWith ["a" ~> (1 :: Int), "c" ~> (3 :: Int)] describe "High arity mocks" do 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 @@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FunctionalDependencies #-} @@ -63,6 +62,7 @@ , "Internal." , "Test.MockCat.Mock." , "Test.MockCat.Types." + , "Test.MockCat.WithMock." ]) where stripPrefixes [] t = t @@ -374,7 +374,7 @@ it "_findIds signature matches handwritten" $ assertHelperSigMatches partialMockSpecPath generatedFinderSigMap "_findIds" - it "_toUserInput signature omits redundant ResolvableParamsOf constraint" do + it "_toUserInput signature contains ResolvableParamsOf (due to MockResult wrapper)" do let genSig = Map.lookup "_toUserInput" generatedUserInputSigMap case genSig of @@ -382,7 +382,7 @@ expectationFailure "TH generated signature not found: _toUserInput" Just sig -> normalizeSignature sig - `shouldNotSatisfy` T.isInfixOf (T.pack "ResolvableParamsOf") . T.pack + `shouldSatisfy` 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 @@ -24,6 +24,7 @@ import Prelude hiding (readFile, writeFile, any) import Test.Hspec import Test.MockCat +import Test.MockCat.Verify (ResolvableParamsOf) import Data.Kind (Type) import Data.Text (Text, pack, isInfixOf) @@ -132,9 +133,9 @@ ArgsOfF r = () -- Generic Mock alias for a function type f -type MockFor f = forall params. (MockDispatch (IsMockSpec params) params (MockT IO) f) => params -> MockT IO f +type MockFor f = forall params. (MockDispatch (IsMockSpec params) params (MockT IO) f) => params -> MockT IO (MockResult (ResolvableParamsOf f)) -- Generic Mock alias for an arbitrary base monad m -type MockForM m f = forall params. (MockDispatch (IsMockSpec params) params (MockT m) f) => params -> MockT m f +type MockForM m f = forall params. (MockDispatch (IsMockSpec params) params (MockT m) f) => params -> MockT m (MockResult (ResolvableParamsOf f)) -- Per-spec dependency records to group required builders/mocks data BasicDeps = BasicDeps @@ -347,16 +348,16 @@ specBasicStubbingAndVerification (BasicDeps { _readFile, _writeFile }) = do it "Program reads content and writes it to output path" do result <- runMockT do - _ <- _readFile $ "input.txt" ~> pack "content" - _ <- _writeFile $ "output.txt" ~> pack "content" ~> () + _readFile $ "input.txt" ~> pack "content" + _writeFile $ "output.txt" ~> pack "content" ~> () operationProgram "input.txt" "output.txt" result `shouldBe` () it "Program skips file write when input content contains 'ngWord'" do result <- runMockT do - _ <- _readFile ("input.txt" ~> pack "contains ngWord") - _ <- _writeFile ("output.txt" ~> any ~> ()) + _readFile ("input.txt" ~> pack "contains ngWord") + _writeFile ("output.txt" ~> any ~> ()) `expects` do called never operationProgram "input.txt" "output.txt" @@ -374,9 +375,9 @@ modifyContentStub <- mock $ pack "content" ~> pack "modifiedContent" result <- runMockT do - _ <- _readFile $ "input.txt" ~> pack "content" - _ <- _writeFile $ ("output.text" ~> pack "modifiedContent" ~> ()) - _ <- _post $ (pack "modifiedContent" ~> ()) + _readFile $ "input.txt" ~> pack "content" + _writeFile ("output.text" ~> pack "modifiedContent" ~> ()) + _post (pack "modifiedContent" ~> ()) operationProgram2 "input.txt" "output.text" modifyContentStub result `shouldBe` () @@ -394,10 +395,10 @@ let env = Environment "input.txt" "output.text" result <- runMockT do - _ <- _ask env - _ <- _readFile ("input.txt" ~> pack "content") - _ <- _writeFile ("output.text" ~> pack "modifiedContent" ~> ()) - _ <- _post (pack "modifiedContent" <> pack ("+" <> show env) ~> ()) + _ask env + _readFile ("input.txt" ~> pack "content") + _writeFile ("output.text" ~> pack "modifiedContent" ~> ()) + _post (pack "modifiedContent" <> pack ("+" <> show env) ~> ()) apiFileOperationProgram modifyContentStub result `shouldBe` () @@ -413,9 +414,9 @@ specMonadReaderContextMocking (ReaderContextDeps { _ask, _readFile, _writeFile }) = do it "Program successfully uses MonadReader to find paths and executes FileOperation" do r <- runMockT do - _ <- _ask (Environment "input.txt" "output.txt") - _ <- _readFile ("input.txt" ~> pack "content") - _ <- _writeFile ("output.txt" ~> pack "content" ~> ()) + _ask (Environment "input.txt" "output.txt") + _readFile ("input.txt" ~> pack "content") + _writeFile ("output.txt" ~> pack "content" ~> ()) operationProgram3 r `shouldBe` () @@ -427,8 +428,8 @@ specSequentialIOStubbing (SequentialIODeps { _readTTY, _writeTTY }) = do it "Recursive program echo2 reads sequential input and writes output until empty string" do result <- runMockT do - _ <- _readTTY $ casesIO ["a", ""] - _ <- _writeTTY $ "a" ~> pure @IO () + _readTTY $ casesIO ["a", ""] + _writeTTY $ "a" ~> pure @IO () echo2 result `shouldBe` () @@ -440,8 +441,8 @@ specImplicitMonadicReturnValues (ImplicitMonadicReturnDeps { _getBy, _echo }) = do it "Program correctly uses and echoes the implicitly stubbed monadic return value" do result <- runMockT do - _ <- _getBy $ "s" ~> pure @IO (10 :: Int) - _ <- _echo $ "10" ~> pure @IO () + _getBy $ "s" ~> pure @IO (10 :: Int) + _echo $ "10" ~> pure @IO () echoProgram "s" result `shouldBe` () @@ -454,7 +455,7 @@ specArgumentPatternMatching (ArgumentPatternMatchingDeps { _getValueBy }) = do it "Multi-case stubbing correctly dispatches and collects results for distinct arguments" do result <- runMockT do - _ <- _getValueBy $ do + _getValueBy $ do onCase $ "a" ~> pure @IO "ax" onCase $ "b" ~> pure @IO "bx" onCase $ "c" ~> pure @IO "cx" @@ -470,7 +471,7 @@ specMonadStateTransformerSupport (MonadStateTransformerDeps { _fnState, _fnState2 }) = do it "Mock with StateT correctly consumes input and returns next value" do let action = runMockT $ do - _ <- _fnState $ do + _fnState $ do onCase $ Just "current" ~> pure @(StateT String IO) "next" onCase $ Nothing ~> pure @(StateT String IO) "default" fnState (Just "current") @@ -479,7 +480,7 @@ it "Mock in StateT correctly executes and leaves the state unchanged (unit return)" do let action = runMockT $ do - _ <- _fnState2 $ "label" ~> pure @(StateT String IO) () + _fnState2 $ "label" ~> pure @(StateT String IO) () fnState2 @String "label" result <- evalStateT action "initial" result `shouldBe` () @@ -496,31 +497,31 @@ specMultiParamTypeClassArity (MultiParamTypeClassArityDeps { _fn2_1Sub, _fn2_2Sub, _fn3_1Sub, _fn3_2Sub, _fn3_3Sub }) = do it "Type variable MonadVar2_1Sub is correctly resolved and mocked" do result <- runMockT do - _ <- _fn2_1Sub $ "alpha" ~> pure @IO () + _fn2_1Sub $ "alpha" ~> pure @IO () fn2_1Sub @(MockT IO) @String "alpha" result `shouldBe` () it "Type variable MonadVar2_2Sub is correctly resolved and mocked" do result <- runMockT do - _ <- _fn2_2Sub $ "beta" ~> pure @IO () + _fn2_2Sub $ "beta" ~> pure @IO () fn2_2Sub @String @(MockT IO) "beta" result `shouldBe` () it "Type variable MonadVar3_1Sub is correctly resolved and mocked" do result <- runMockT do - _ <- _fn3_1Sub $ "gamma" ~> pure @IO () + _fn3_1Sub $ "gamma" ~> pure @IO () fn3_1Sub @(MockT IO) @String @String "gamma" result `shouldBe` () it "Type variable MonadVar3_2Sub is correctly resolved and mocked" do result <- runMockT do - _ <- _fn3_2Sub $ "delta" ~> pure @IO () + _fn3_2Sub $ "delta" ~> pure @IO () fn3_2Sub @String @(MockT IO) @String "delta" result `shouldBe` () it "Type variable MonadVar3_3Sub is correctly resolved and mocked" do result <- runMockT do - _ <- _fn3_3Sub $ "epsilon" ~> pure @IO () + _fn3_3Sub $ "epsilon" ~> pure @IO () fn3_3Sub @String @String @(MockT IO) "epsilon" result `shouldBe` () @@ -532,10 +533,10 @@ specFunctionalDependenciesSupport (FunctionalDependenciesDeps { _fnParam3_1, _fnParam3_2, _fnParam3_3 }) = do it "FunDeps are correctly resolved allowing multiple actions to return values" do result <- runMockT $ do - _ <- _fnParam3_1 $ do + _fnParam3_1 $ do onCase $ (1 :: Int) ~> True ~> pure @IO "combined" - _ <- _fnParam3_2 $ casesIO [1 :: Int] - _ <- _fnParam3_3 $ casesIO [True] + _fnParam3_2 $ casesIO [1 :: Int] + _fnParam3_3 $ casesIO [True] r1 <- fnParam3_1 (1 :: Int) True r2 <- fnParam3_2 r3 <- fnParam3_3 @@ -550,8 +551,8 @@ specExplicitMonadicReturnValues (ExplicitMonadicReturnDeps { _getByExplicit, _echoExplicit }) = do it "Explicitly stubbed function returns value and subsequent action is verified" do result <- runMockT do - _ <- _getByExplicit $ "key" ~> pure @IO (42 :: Int) - _ <- _echoExplicit $ "value" ~> pure @IO () + _getByExplicit $ "key" ~> pure @IO (42 :: Int) + _echoExplicit $ "value" ~> pure @IO () v <- getByExplicit "key" echoExplicit "value" pure v @@ -559,8 +560,8 @@ it "Helper program correctly uses and echoes the explicitly stubbed monadic return value" do result <- runMockT do - _ <- _getByExplicit $ "s" ~> pure @IO (10 :: Int) - _ <- _echoExplicit $ "10" ~> pure @IO () + _getByExplicit $ "s" ~> pure @IO (10 :: Int) + _echoExplicit $ "10" ~> pure @IO () echoProgramExplicit "s" result `shouldBe` () @@ -572,7 +573,7 @@ specDefaultMethodMocking (DefaultMethodDeps { _defaultAction }) = do it "Default method is successfully overridden and stubbed value is returned" do result <- runMockT do - _ <- _defaultAction (Head :> param (99 :: Int)) + _defaultAction (Head :> param (99 :: Int)) defaultAction result `shouldBe` 99 @@ -585,7 +586,7 @@ specAssociatedTypeFamiliesSupport (AssociatedTypeFamiliesDeps { _produce }) = do it "Associated Type family is correctly resolved and mocked stub value is returned" do v <- runMockT do - _ <- _produce (Head :> param (321 :: Int)) + _produce (Head :> param (321 :: Int)) produce v `shouldBe` 321 @@ -598,7 +599,7 @@ specConcurrencyAndUnliftIO (ConcurrencyAndUnliftIODeps { _readFile }) = do it "Concurrent execution (mapConcurrently) correctly calls and collects results from mocks" do result <- runMockT do - _ <- _readFile $ do + _readFile $ do onCase $ "file1.txt" ~> pack "content1" onCase $ "file2.txt" ~> pack "content2" processFiles ["file1.txt", "file2.txt"] @@ -606,7 +607,7 @@ it "MonadUnliftIO correctly handles internal async operation and verification" do result <- runMockT do - _ <- _readFile $ do + _readFile $ do onCase $ "test.txt" ~> pack "content" content <- withRunInIO $ \runInIO -> do @@ -620,7 +621,7 @@ it "MonadUnliftIO basic runInIO functionality is verified correctly" do result <- runMockT do - _ <- _readFile $ do + _readFile $ do onCase $ "test.txt" ~> pack "test content" content <- withRunInIO $ \runInIO -> do @@ -640,7 +641,7 @@ it "User defined class method handles shared user-defined type correctly" do let p = Post 1 "title" runMockT @IO $ do - _ <- _processPost $ do + _processPost $ do -- verify that we can match exactly on the user defined type onCase $ p ~> True @@ -657,7 +658,7 @@ specBasicVerificationFailureDetection (BasicDeps { _readFile, _writeFile }) = describe "verification failures (FileOperation)" do it "Error when read stub is defined but target function readFile is never called" do (runMockT @IO do - _ <- _readFile ("input.txt" ~> pack "content") + _readFile ("input.txt" ~> pack "content") `expects` do called once -- readFile is never called @@ -665,7 +666,7 @@ it "Error when write stub is defined but target function writeFile is never called" do (runMockT @IO do - _ <- _writeFile ("output.txt" ~> pack "content" ~> ()) + _writeFile ("output.txt" ~> pack "content" ~> ()) `expects` do called once -- writeFile is never called @@ -673,10 +674,10 @@ it "Error when read stub expects call but only writeFile is executed" do (runMockT @IO do - _ <- _readFile ("input.txt" ~> pack "content") + _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") @@ -684,8 +685,8 @@ it "Error when write stub expects call but only readFile is executed" do (runMockT @IO do - _ <- _readFile ("input.txt" ~> pack "content") - _ <- _writeFile ("output.txt" ~> pack "content" ~> ()) + _readFile ("input.txt" ~> pack "content") + _writeFile ("output.txt" ~> pack "content" ~> ()) `expects` do called once -- writeFile is never called, only readFile is called @@ -700,7 +701,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 (Head :> param (Environment "input.txt" "output.txt")) + _ask (Head :> param (Environment "input.txt" "output.txt")) `expects` do called once -- ask is never called @@ -712,14 +713,14 @@ specImplicitReturnVerificationFailureDetection (ImplicitMonadicReturnDeps { _getBy, _echo }) = describe "verification failures (TestClass)" do it "Error when _getBy stub expects call but getBy is never executed" do (runMockT @IO do - _ <- _getBy ("s" ~> pure @IO (10 :: Int)) + _getBy ("s" ~> pure @IO (10 :: Int)) `expects` do called once pure ()) `shouldThrow` missingCall "_getBy" it "Error when _echo stub expects call but echo is never executed" do (runMockT @IO do - _ <- _echo ("10" ~> pure @IO ()) + _echo ("10" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_echo" @@ -730,35 +731,35 @@ specMultiParamVerificationFailureDetection (MultiParamTypeClassArityDeps { _fn2_1Sub, _fn2_2Sub, _fn3_1Sub, _fn3_2Sub, _fn3_3Sub }) = describe "verification failures (SubVars)" do it "Error when _fn2_1Sub stub expects call but fn2_1Sub is never executed" do (runMockT @IO do - _ <- _fn2_1Sub ("alpha" ~> pure @IO ()) + _fn2_1Sub ("alpha" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_fn2_1Sub" it "Error when _fn2_2Sub stub expects call but fn2_2Sub is never executed" do (runMockT @IO do - _ <- _fn2_2Sub ("beta" ~> pure @IO ()) + _fn2_2Sub ("beta" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_fn2_2Sub" it "Error when _fn3_1Sub stub expects call but fn3_1Sub is never executed" do (runMockT @IO do - _ <- _fn3_1Sub ("gamma" ~> pure @IO ()) + _fn3_1Sub ("gamma" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_fn3_1Sub" it "Error when _fn3_2Sub stub expects call but fn3_2Sub is never executed" do (runMockT @IO do - _ <- _fn3_2Sub ("delta" ~> pure @IO ()) + _fn3_2Sub ("delta" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_fn3_2Sub" it "Error when _fn3_3Sub stub expects call but fn3_3Sub is never executed" do (runMockT @IO do - _ <- _fn3_3Sub ("epsilon" ~> pure @IO ()) + _fn3_3Sub ("epsilon" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_fn3_3Sub" @@ -769,7 +770,7 @@ specArgumentMatchingVerificationFailureDetection (ArgumentPatternMatchingDeps { _getValueBy }) = describe "verification failures (MultiApply)" do it "Error when multi-case stub _getValueBy expects call but getValueBy is never executed" do (runMockT @IO do - _ <- _getValueBy (do onCase $ "a" ~> pure @IO "ax") + _getValueBy (do onCase $ "a" ~> pure @IO "ax") `expects` do called once pure ()) `shouldThrow` missingCall "_getValueBy" @@ -780,7 +781,7 @@ specFunDepsVerificationFailureDetection (FunctionalDependenciesDeps { _fnParam3_1, _fnParam3_2, _fnParam3_3 }) = describe "verification failures (ParamThreeMonad)" do it "Error when FunDep stub _fnParam3_1 expects call but fnParam3_1 is never executed" do (runMockT @IO do - _ <- _fnParam3_1 (do + _fnParam3_1 (do onCase $ (1 :: Int) ~> True ~> pure @IO "combined") `expects` do called once @@ -788,14 +789,14 @@ it "Error when FunDep stub _fnParam3_2 expects call but fnParam3_2 is never executed" do (runMockT @IO do - _ <- _fnParam3_2 (casesIO [1 :: Int]) + _fnParam3_2 (casesIO [1 :: Int]) `expects` do called once pure ()) `shouldThrow` missingCall "_fnParam3_2" it "Error when FunDep stub _fnParam3_3 expects call but fnParam3_3 is never executed" do (runMockT @IO do - _ <- _fnParam3_3 (casesIO [True]) + _fnParam3_3 (casesIO [True]) `expects` do called once pure ()) `shouldThrow` missingCall "_fnParam3_3" @@ -806,14 +807,14 @@ specExplicitReturnVerificationFailureDetection (ExplicitMonadicReturnDeps { _getByExplicit, _echoExplicit }) = describe "verification failures (ExplicitReturn)" do it "Error when explicit stub _getByExplicit expects call but getByExplicit is never executed" do (runMockT @IO do - _ <- _getByExplicit ("key" ~> pure @IO (42 :: Int)) + _getByExplicit ("key" ~> pure @IO (42 :: Int)) `expects` do called once pure ()) `shouldThrow` missingCall "_getByExplicit" it "Error when explicit stub _echoExplicit expects call but echoExplicit is never executed" do (runMockT @IO do - _ <- _echoExplicit ("value" ~> pure @IO ()) + _echoExplicit ("value" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_echoExplicit" @@ -825,14 +826,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 (Head :> param (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 (Head :> param (321 :: Int)) + _produce (Head :> param (321 :: Int)) `expects` do called once pure ()) `shouldThrow` missingCall "_produce" @@ -843,14 +844,14 @@ specSequentialStubbingVerificationFailureDetection (SequentialIODeps { _readTTY, _writeTTY }) = describe "verification failures (TTY)" do it "Error when sequential stub _readTTY expects call but readTTY is never executed" do (runMockT @IO do - _ <- _readTTY (casesIO ["a", ""]) + _readTTY (casesIO ["a", ""]) `expects` do called once pure ()) `shouldThrow` missingCall "_readTTY" it "Error when sequential stub _writeTTY expects call but writeTTY is never executed" do (runMockT @IO do - _ <- _writeTTY ("a" ~> pure @IO ()) + _writeTTY ("a" ~> pure @IO ()) `expects` do called once pure ()) `shouldThrow` missingCall "_writeTTY" diff --git a/test/Test/MockCat/TypeClassMinimalSpec.hs b/test/Test/MockCat/TypeClassMinimalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/MockCat/TypeClassMinimalSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.MockCat.TypeClassMinimalSpec (spec) where + +import Test.Hspec +import Test.MockCat +import Data.Text (Text, pack) +import Test.MockCat.Verify (ResolvableParamsOf) +import Prelude hiding (readFile, writeFile, any) + +import Data.Proxy (Proxy(..)) +import Control.Exception (ErrorCall, displayException, evaluate) +import Data.List (isInfixOf) +import Data.Typeable (cast) +import GHC.TypeLits (symbolVal) +import Control.Monad.IO.Class (liftIO) + +-- Helper for error matching +missingCallHandwritten :: String -> Selector ErrorCall +missingCallHandwritten name err = + let needle1 = "function `" <> name <> "` was not called the expected number of times." + needle2 = "function `_" <> name <> "` was not called the expected number of times." + in (needle1 `isInfixOf` displayException err) || (needle2 `isInfixOf` displayException err) + +-- Handwritten polymorphic return helpers +_readFile :: + ( MockDispatch (IsMockSpec spec) spec (MockT IO) (FilePath -> Text) + ) => + spec -> + MockT IO (MockResult (ResolvableParamsOf (FilePath -> Text))) +_readFile p = MockT $ do + fn <- unMockT (mock (label "readFile") p :: MockT IO (FilePath -> Text)) + addDefinition (Definition (Proxy :: Proxy "readFile") fn NoVerification) + pure (MockResult ()) + +_writeFile :: + ( MockDispatch (IsMockSpec spec) spec (MockT IO) (FilePath -> Text -> ()) + ) => + spec -> + MockT IO (MockResult (ResolvableParamsOf (FilePath -> Text -> ()))) +_writeFile p = MockT $ do + fn <- unMockT (mock (label "writeFile") p :: MockT IO (FilePath -> Text -> ())) + addDefinition (Definition (Proxy :: Proxy "writeFile") fn NoVerification) + pure (MockResult ()) + +readFile :: FilePath -> MockT IO Text +readFile path = do + defs <- getDefinitions + let stubs = reverse [f | Definition (p :: Proxy sym) fn _ <- defs, symbolVal p == "readFile", Just f <- [cast fn :: Maybe (FilePath -> Text)]] + case stubs of + [] -> error "readFile: no stub defined or type mismatch" + (f : _) -> pure (f path) + +writeFile :: FilePath -> Text -> MockT IO () +writeFile path content = do + defs <- getDefinitions + let stubs = reverse [f | Definition (p :: Proxy sym) fn _ <- defs, symbolVal p == "writeFile", Just f <- [cast fn :: Maybe (FilePath -> Text -> ())]] + case stubs of + [] -> error "writeFile: no stub defined or type mismatch" + (f : _) -> pure (f path content) + +spec :: Spec +spec = do + describe "Polymorphic return tests (Clean)" do + it "Program definition suppresses unused-do-bind warning (expects not used)" do + -- Just verify that this compiles without warning + runMockT do + _readFile $ "input.txt" ~> pack "content" + _writeFile $ "output.txt" ~> pack "content" ~> () + pure () + + it "Error when read stub is defined but target function readFile is never called (expects used)" do + (runMockT @IO do + _readFile ("input.txt" ~> pack "content") + `expects` called once + -- readFile is never called + pure ()) `shouldThrow` missingCallHandwritten "readFile" + + it "Arguments can be verified even if the helper returns () (Dynamic Resolution + Coercion)" do + runMockT do + _readFile ("input.txt" ~> pack "content") `expects` called once + _ <- readFile "input.txt" >>= liftIO . evaluate + pure () + + it "Arguments can be verified with 'with' (Dynamic Resolution + Coercion)" do + runMockT do + _readFile ("input.txt" ~> pack "content") `expects` (called once `with` "input.txt") + _ <- readFile "input.txt" >>= liftIO . evaluate + pure () + + it "Can verify arguments for functions returning () without type annotations (writeFile)" do + runMockT do + _writeFile ("output.txt" ~> pack "content" ~> ()) `expects` called once + -- Execute the function and force evaluation + writeFile "output.txt" (pack "content") >>= liftIO . evaluate + pure () 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 @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} @@ -11,16 +12,20 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Test.MockCat.TypeClassSpec (spec) where -import Data.Text (Text) -import Test.Hspec (Spec) +import Data.Text (Text, pack) +import qualified Data.List as List +import Test.Hspec (Spec, shouldBe, shouldThrow, Selector, describe, it) +import Control.Exception (ErrorCall, displayException) import Test.MockCat import Prelude hiding (readFile, writeFile, any) + import Data.Data import Data.List (find) import GHC.TypeLits (KnownSymbol, symbolVal) @@ -88,48 +93,48 @@ , Typeable env ) => params -> - MockT m env + MockT m (MockResult (Verify.ResolvableParamsOf env)) _ask p = MockT $ do mockInstance <- unMockT $ mock (label "ask") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "ask") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _readFile :: ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text) , MonadIO m ) => params -> - MockT m (FilePath -> Text) + MockT m (MockResult (Verify.ResolvableParamsOf (FilePath -> Text))) _readFile p = MockT $ do mockInstance <- unMockT $ mock (label "readFile") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "readFile") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _writeFile :: ( MockDispatch (IsMockSpec params) params (MockT m) (FilePath -> Text -> ()) , MonadIO m ) => params -> - MockT m (FilePath -> Text -> ()) + MockT m (MockResult (Verify.ResolvableParamsOf (FilePath -> Text -> ()))) _writeFile p = MockT $ do mockInstance <- unMockT $ mock (label "writeFile") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "writeFile") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _post :: ( MockDispatch (IsMockSpec params) params (MockT m) (Text -> ()) , MonadIO m ) => params -> - MockT m (Text -> ()) + MockT m (MockResult (Verify.ResolvableParamsOf (Text -> ()))) _post p = MockT $ do mockFn <- unMockT $ mock (label "post") p ensureVerifiable mockFn addDefinition (Definition (Proxy :: Proxy "post") mockFn NoVerification) - pure mockFn + pure (MockResult ()) findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a findParam pa definitions = do @@ -297,12 +302,12 @@ , Verify.ResolvableParamsOf (String -> m Int) ~ Param String ) => params -> - MockT m (String -> m Int) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m Int))) _getBy p = MockT $ do mockInstance <- unMockT $ mock (label "_getBy") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_getBy") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _echo :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -311,12 +316,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _echo p = MockT $ do mockInstance <- unMockT $ mock (label "_echo") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_echo") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fn2_1Sub :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -325,12 +330,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fn2_1Sub p = MockT $ do mockInstance <- unMockT $ mock (label "_fn2_1Sub") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fn2_1Sub") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fn2_2Sub :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -339,12 +344,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fn2_2Sub p = MockT $ do mockInstance <- unMockT $ mock (label "_fn2_2Sub") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fn2_2Sub") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fn3_1Sub :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -353,12 +358,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fn3_1Sub p = MockT $ do mockInstance <- unMockT $ mock (label "_fn3_1Sub") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fn3_1Sub") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fn3_2Sub :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -367,12 +372,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fn3_2Sub p = MockT $ do mockInstance <- unMockT $ mock (label "_fn3_2Sub") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fn3_2Sub") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fn3_3Sub :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -381,12 +386,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fn3_3Sub p = MockT $ do mockInstance <- unMockT $ mock (label "_fn3_3Sub") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fn3_3Sub") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _getValueBy :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m String) @@ -395,12 +400,12 @@ , Verify.ResolvableParamsOf (String -> m String) ~ Param String ) => params -> - MockT m (String -> m String) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m String))) _getValueBy p = MockT $ do mockInstance <- unMockT $ mock (label "_getValueBy") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_getValueBy") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fnState :: ( MockDispatch (IsMockSpec params) params (MockT m) (Maybe s -> m s) @@ -410,11 +415,11 @@ , Verify.ResolvableParamsOf (Maybe s -> m s) ~ Param (Maybe s) ) => params -> - MockT m (Maybe s -> m s) + MockT m (MockResult (Verify.ResolvableParamsOf (Maybe s -> m s))) _fnState p = MockT $ do mockInstance <- unMockT $ mock (label "_fnState") p addDefinition (Definition (Proxy :: Proxy "_fnState") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fnState2 :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -423,11 +428,11 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _fnState2 p = MockT $ do mockInstance <- unMockT $ mock (label "_fnState2") p addDefinition (Definition (Proxy :: Proxy "_fnState2") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fnParam3_1 :: ( MockDispatch (IsMockSpec params) params (MockT m) (Int -> Bool -> m String) @@ -436,12 +441,12 @@ , Verify.ResolvableParamsOf (Int -> Bool -> m String) ~ (Param Int :> Param Bool) ) => params -> - MockT m (Int -> Bool -> m String) + MockT m (MockResult (Verify.ResolvableParamsOf (Int -> Bool -> m String))) _fnParam3_1 p = MockT $ do mockInstance <- unMockT $ mock (label "_fnParam3_1") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fnParam3_1") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fnParam3_2 :: ( MockDispatch (IsMockSpec params) params (MockT m) (m Int) @@ -450,12 +455,12 @@ , Verify.ResolvableParamsOf (m Int) ~ () ) => params -> - MockT m (m Int) + MockT m (MockResult (Verify.ResolvableParamsOf (m Int))) _fnParam3_2 p = MockT $ do mockInstance <- unMockT $ mock (label "_fnParam3_2") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fnParam3_2") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _fnParam3_3 :: ( MockDispatch (IsMockSpec params) params (MockT m) (m Bool) @@ -464,12 +469,12 @@ , Verify.ResolvableParamsOf (m Bool) ~ () ) => params -> - MockT m (m Bool) + MockT m (MockResult (Verify.ResolvableParamsOf (m Bool))) _fnParam3_3 p = MockT $ do mockInstance <- unMockT $ mock (label "_fnParam3_3") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_fnParam3_3") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _getByExplicit :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m Int) @@ -478,12 +483,12 @@ , Verify.ResolvableParamsOf (String -> m Int) ~ Param String ) => params -> - MockT m (String -> m Int) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m Int))) _getByExplicit p = MockT $ do mockInstance <- unMockT $ mock (label "_getByExplicit") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_getByExplicit") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _echoExplicit :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -492,12 +497,12 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _echoExplicit p = MockT $ do mockInstance <- unMockT $ mock (label "_echoExplicit") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_echoExplicit") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _defaultAction :: ( MonadIO m @@ -506,12 +511,12 @@ , Typeable a ) => params -> - MockT m a + MockT m (MockResult (Verify.ResolvableParamsOf a)) _defaultAction p = MockT $ do mockInstance <- unMockT $ mock (label "_defaultAction") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_defaultAction") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _produce :: ( MockDispatch (IsMockSpec p) p (MockT m) (ResultType m) @@ -521,12 +526,12 @@ , Typeable (ResultType m) ) => p -> - MockT m (ResultType m) + MockT m (MockResult (Verify.ResolvableParamsOf (ResultType m))) _produce p = MockT $ do mockInstance <- unMockT $ mock (label "_produce") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_produce") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) instance MonadIO m => Teletype (MockT m) where readTTY = MockT do @@ -550,12 +555,12 @@ , Verify.ResolvableParamsOf (m String) ~ () ) => params -> - MockT m (m String) + MockT m (MockResult (Verify.ResolvableParamsOf (m String))) _readTTY p = MockT $ do mockInstance <- unMockT $ mock (label "_readTTY") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_readTTY") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _writeTTY :: ( MockDispatch (IsMockSpec params) params (MockT m) (String -> m ()) @@ -564,24 +569,24 @@ , Verify.ResolvableParamsOf (String -> m ()) ~ Param String ) => params -> - MockT m (String -> m ()) + MockT m (MockResult (Verify.ResolvableParamsOf (String -> m ()))) _writeTTY p = MockT $ do mockInstance <- unMockT $ mock (label "_writeTTY") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_writeTTY") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) _processPost :: ( MockDispatch (IsMockSpec params) params (MockT m) (Post -> Bool) , MonadIO m ) => params -> - MockT m (Post -> Bool) + MockT m (MockResult (Verify.ResolvableParamsOf (Post -> Bool))) _processPost p = MockT $ do mockInstance <- unMockT $ mock (label "_processPost") p ensureVerifiable mockInstance addDefinition (Definition (Proxy :: Proxy "_processPost") mockInstance NoVerification) - pure mockInstance + pure (MockResult ()) instance MonadIO m => UserDefinedClass (MockT m) where processPost p = MockT do @@ -592,8 +597,54 @@ !result = mockFn p lift $ pure result +-- Handwritten polymorphic return helpers for testing +_readFileHandwritten :: + ( MockDispatch (IsMockSpec params) params (MockT IO) (FilePath -> Text) + ) => + params -> + MockT IO (MockResult (Verify.ResolvableParamsOf (FilePath -> Text))) +_readFileHandwritten p = do + fn <- mock (label "readFile") p :: MockT IO (FilePath -> Text) + addDefinition (Definition (Proxy :: Proxy "readFile") fn NoVerification) + pure (MockResult ()) + +_writeFileHandwritten :: + ( MockDispatch (IsMockSpec params) params (MockT IO) (FilePath -> Text -> ()) + ) => + params -> + MockT IO (MockResult (Verify.ResolvableParamsOf (FilePath -> Text -> ()))) +_writeFileHandwritten p = do + fn <- mock (label "writeFile") p :: MockT IO (FilePath -> Text -> ()) + addDefinition (Definition (Proxy :: Proxy "writeFile") fn NoVerification) + pure (MockResult ()) + +-- Helper for error matching (same logic as TypeClassCommonSpec) +missingCallHandwritten :: String -> Selector ErrorCall +missingCallHandwritten name err = + let needle1 = "function `" <> name <> "` was not called the expected number of times." + needle2 = "function `_" <> name <> "` was not called the expected number of times." + in (needle1 `List.isInfixOf` displayException err) || (needle2 `List.isInfixOf` displayException err) + spec :: Spec spec = do + -- Handwritten polymorphic return tests + describe "Handwritten polymorphic return tests" do + it "Program reads content and writes it to output path (expects not used)" do + result <- runMockT do + _readFileHandwritten $ "input.txt" ~> pack "content" + _writeFileHandwritten $ "output.txt" ~> pack "content" ~> () + SpecCommon.operationProgram "input.txt" "output.txt" + + result `shouldBe` () + + it "Error when read stub is defined but target function readFile is never called (expects used)" do + (runMockT @IO do + _readFileHandwritten ("input.txt" ~> pack "content") + `expects` do + called once + -- readFile is never called + pure ()) `shouldThrow` missingCallHandwritten "readFile" + -- build SpecDeps and call aggregated spec entrypoint let deps = SpecCommon.SpecDeps { SpecCommon.basicDeps = SpecCommon.BasicDeps _readFile _writeFile 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 @@ -24,6 +24,7 @@ import qualified Test.MockCat.TypeClassCommonSpec as SpecCommon --makeAutoLiftMock [t|MonadReader Bool|] + makeAutoLiftMock [t|MonadReader SpecCommon.Environment|] makeMock [t|MonadVar2_1Sub|] makeMock [t|MonadVar2_2Sub|] @@ -51,33 +52,33 @@ produce = pure 0 spec :: Spec -spec = do - -- build SpecDeps and call aggregated spec entrypoint - let deps = SpecCommon.SpecDeps - { SpecCommon.basicDeps = SpecCommon.BasicDeps _readFile _writeFile - , SpecCommon.mixedDeps = SpecCommon.MixedDeps _readFile _writeFile _post - , SpecCommon.multipleDeps = SpecCommon.MultipleDeps _ask _readFile _writeFile _post +spec = describe "TypeClassTHSpec" $ do + -- build SpecDeps and call aggregated spec entrypoint + let deps = SpecCommon.SpecDeps + { SpecCommon.basicDeps = SpecCommon.BasicDeps _readFile _writeFile + , SpecCommon.mixedDeps = SpecCommon.MixedDeps _readFile _writeFile _post + , SpecCommon.multipleDeps = SpecCommon.MultipleDeps _ask _readFile _writeFile _post - , SpecCommon.readerContextDeps = SpecCommon.ReaderContextDeps _ask _readFile _writeFile - , SpecCommon.sequentialIODeps = SpecCommon.SequentialIODeps _readTTY _writeTTY - , SpecCommon.ttyDeps = SpecCommon.TtyDeps _readTTY _writeTTY - , SpecCommon.implicitMonadicReturnDeps = SpecCommon.ImplicitMonadicReturnDeps _getBy _echo - , SpecCommon.testClassDeps = SpecCommon.TestClassDeps _getBy _echo - , SpecCommon.argumentPatternMatchingDeps = SpecCommon.ArgumentPatternMatchingDeps _getValueBy - , SpecCommon.multiApplyDeps = SpecCommon.MultiApplyDeps _getValueBy - , SpecCommon.monadStateTransformerDeps = SpecCommon.MonadStateTransformerDeps _fnState _fnState2 - , SpecCommon.stateDeps = SpecCommon.StateDeps _fnState _fnState2 - , SpecCommon.multiParamTypeClassArityDeps = SpecCommon.MultiParamTypeClassArityDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub - , SpecCommon.multiParamDeps = SpecCommon.MultiParamDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub - , SpecCommon.functionalDependenciesDeps = SpecCommon.FunctionalDependenciesDeps _fnParam3_1 _fnParam3_2 _fnParam3_3 - , SpecCommon.funDeps = SpecCommon.FunDeps _fnParam3_1 _fnParam3_2 _fnParam3_3 - , SpecCommon.explicitMonadicReturnDeps = SpecCommon.ExplicitMonadicReturnDeps _getByExplicit _echoExplicit - , SpecCommon.explicitReturnDeps = SpecCommon.ExplicitReturnDeps _getByExplicit _echoExplicit - , SpecCommon.defaultMethodDeps = SpecCommon.DefaultMethodDeps _defaultAction - , SpecCommon.associatedTypeFamiliesDeps = SpecCommon.AssociatedTypeFamiliesDeps _produce - , SpecCommon.assocTypeDeps = SpecCommon.AssocTypeDeps _produce - , SpecCommon.concurrencyAndUnliftIODeps = SpecCommon.ConcurrencyAndUnliftIODeps _readFile - , SpecCommon.concurrencyDeps = SpecCommon.ConcurrencyDeps _readFile - , SpecCommon.userDefinedTypeDeps = SpecCommon.UserDefinedTypeDeps _processPost - } - SpecCommon.spec deps + , SpecCommon.readerContextDeps = SpecCommon.ReaderContextDeps _ask _readFile _writeFile + , SpecCommon.sequentialIODeps = SpecCommon.SequentialIODeps _readTTY _writeTTY + , SpecCommon.ttyDeps = SpecCommon.TtyDeps _readTTY _writeTTY + , SpecCommon.implicitMonadicReturnDeps = SpecCommon.ImplicitMonadicReturnDeps _getBy _echo + , SpecCommon.testClassDeps = SpecCommon.TestClassDeps _getBy _echo + , SpecCommon.argumentPatternMatchingDeps = SpecCommon.ArgumentPatternMatchingDeps _getValueBy + , SpecCommon.multiApplyDeps = SpecCommon.MultiApplyDeps _getValueBy + , SpecCommon.monadStateTransformerDeps = SpecCommon.MonadStateTransformerDeps _fnState _fnState2 + , SpecCommon.stateDeps = SpecCommon.StateDeps _fnState _fnState2 + , SpecCommon.multiParamTypeClassArityDeps = SpecCommon.MultiParamTypeClassArityDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub + , SpecCommon.multiParamDeps = SpecCommon.MultiParamDeps _fn2_1Sub _fn2_2Sub _fn3_1Sub _fn3_2Sub _fn3_3Sub + , SpecCommon.functionalDependenciesDeps = SpecCommon.FunctionalDependenciesDeps _fnParam3_1 _fnParam3_2 _fnParam3_3 + , SpecCommon.funDeps = SpecCommon.FunDeps _fnParam3_1 _fnParam3_2 _fnParam3_3 + , SpecCommon.explicitMonadicReturnDeps = SpecCommon.ExplicitMonadicReturnDeps _getByExplicit _echoExplicit + , SpecCommon.explicitReturnDeps = SpecCommon.ExplicitReturnDeps _getByExplicit _echoExplicit + , SpecCommon.defaultMethodDeps = SpecCommon.DefaultMethodDeps _defaultAction + , SpecCommon.associatedTypeFamiliesDeps = SpecCommon.AssociatedTypeFamiliesDeps _produce + , SpecCommon.assocTypeDeps = SpecCommon.AssocTypeDeps _produce + , SpecCommon.concurrencyAndUnliftIODeps = SpecCommon.ConcurrencyAndUnliftIODeps _readFile + , SpecCommon.concurrencyDeps = SpecCommon.ConcurrencyDeps _readFile + , SpecCommon.userDefinedTypeDeps = SpecCommon.UserDefinedTypeDeps _processPost + } + SpecCommon.spec deps 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 @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,7 +47,7 @@ \ [Closest] 1. \"hello haskell\"" withMock (do f <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` "hello world") - _ <- liftIO $ evaluate $ f "hello haskell" + liftIO $ evaluate $ f "hello haskell" pure () ) `shouldThrow` errorCall expectedError @@ -67,7 +68,7 @@ \ ^^^^^^^^^^^^^^^^^^^" withMock (do f <- mock (Post 1 "title" ~> "ok") - _ <- liftIO $ evaluate $ f (Post 2 "wrong") + liftIO $ evaluate $ f (Post 2 "wrong") pure () ) `shouldThrow` errorCall expectedError @@ -88,7 +89,7 @@ \ [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] + liftIO $ evaluate $ f [1, 2, 3, 4, 5, 0, 7, 8, 9, 10] pure () ) `shouldThrow` errorCall expectedError @@ -109,7 +110,7 @@ \ [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) + liftIO $ evaluate $ f (User "Fagen" 20) pure () ) `shouldThrow` errorCall expectedError @@ -121,8 +122,8 @@ \ ^^" withMock (do f <- mock ((any :: Param String) ~> "ok") `expects` calledInOrder ["a", "c"] - _ <- liftIO $ evaluate $ f "a" - _ <- liftIO $ evaluate $ f "b" + liftIO $ evaluate $ f "a" + liftIO $ evaluate $ f "b" pure () ) `shouldThrow` errorCall expectedError @@ -139,7 +140,7 @@ f <- mock $ do onCase $ "aaa" ~> (100 :: Int) ~> "ok" onCase $ "bbb" ~> (200 :: Int) ~> "ok" - _ <- liftIO $ evaluate (f "aaa" 200) + liftIO $ evaluate (f "aaa" 200) pure () ) `shouldThrow` errorCall expectedError @@ -160,7 +161,7 @@ \ [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)) + liftIO $ evaluate $ f (ComplexUser "Alice" (Config "Light" 1)) pure () ) `shouldThrow` errorCall expectedError @@ -181,7 +182,7 @@ \ [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]] + liftIO $ evaluate $ f [[1, 2], [3, 4]] pure () ) `shouldThrow` errorCall expectedError @@ -210,46 +211,50 @@ \ [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 + liftIO $ evaluate $ f actual pure () ) `shouldThrow` errorCall expectedError describe "robustness (broken formats)" do it "handles unbalanced braces gracefully (fallback to standard message)" do + f <- mock ((any :: Param String) ~> "ok") let actual = "{ name = \"Alice\"" expected = "{ name = \"Bob\" }" - expectedError = - "function was not called with the expected arguments.\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\\\"\"" + evaluate $ f actual + let expectedError = + "function was not called with the expected arguments.\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 + f' <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected) + liftIO $ evaluate $ f' actual pure () ) `shouldThrow` errorCall expectedError it "handles completely broken structure strings" do + f <- mock ((any :: Param String) ~> "ok") let actual = "NotARecord {,,,,,}" let expected = "NotARecord { a = 1 }" + evaluate $ f actual let expectedError = - "function was not called with the expected arguments.\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 {,,,,,}\"" + "function was not called with the expected arguments.\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 + f'' <- mock ((any :: Param String) ~> "ok") `expects` (called once `with` expected) + liftIO $ evaluate $ f'' actual pure () ) `shouldThrow` errorCall expectedError @@ -274,7 +279,7 @@ \ [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 + liftIO $ evaluate $ f actual pure () ) `shouldThrow` errorCall expectedError @@ -303,7 +308,7 @@ \ [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 + liftIO $ evaluate $ f actual pure () ) `shouldThrow` errorCall expectedError @@ -329,6 +334,6 @@ \ [Closest] 1. Config {theme = \"Light\", level = 1}" withMock (do f <- mock ((any :: Param Config) ~> "ok") `expects` (called once `with` expected) - _ <- liftIO $ evaluate $ f actual + liftIO $ evaluate $ f actual pure () ) `shouldThrow` errorCall expectedError 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,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} @@ -55,39 +56,35 @@ it "should work with expects and specific value" $ do withMock $ do let p = Post 1 "title" - f <- mock (any ~> True) - `expects` (called once `with` p) + f <- mock (any @Post ~> True) `expects` (called once `with` p) liftIO $ f p `shouldBe` True it "should work with expects and ANY" $ do withMock $ do let p = Post 1 "title" - f <- mock (any @Post ~> True) - `expects` (called once `with` any @Post) + f <- mock (any @Post ~> True) `expects` (called once `with` any @Post) liftIO $ f p `shouldBe` True describe "withMock basic functionality" $ do it "simple mock with expects" $ do withMock $ do - mockFn <- mock (any ~> True) - `expects` (called once `with` "a") + mockFn <- mock (any @String ~> True) `expects` (called once `with` "a") liftIO $ mockFn "a" `shouldBe` True it "simple mock with expects using param" $ do withMock $ do - mockFn <- mock (any ~> True) - `expects` (called once `with` param "a") + mockFn <- mock (any @String ~> True) `expects` (called once `with` param "a") liftIO $ mockFn "a" `shouldBe` True it "fails when not called" $ do withMock (do - _ <- mock (any ~> True) + mock (any @String ~> True) `expects` (called once `with` "a") pure ()) `shouldThrow` anyErrorCall it "error message when not called" $ do result <- try $ withMock $ do - _ <- mock (any ~> True) + mock (any @String ~> True) `expects` (called once `with` "a") pure () case result of @@ -101,8 +98,7 @@ it "atLeast expectation" $ do withMock $ do - mockFn <- mock (any ~> True) - `expects` (called (atLeast 2) `with` "a") + mockFn <- mock (any @String ~> True) `expects` (called (atLeast 1) `with` "a") void $ liftIO $ evaluate $ mockFn "a" void $ liftIO $ evaluate $ mockFn "a" @@ -110,14 +106,14 @@ it "anything expectation" $ do withMock $ do - mockFn <- mock (any ~> True) - `expects` called once + mockFn <- mock (any @String ~> True) + pure mockFn `expects` called once void $ liftIO $ evaluate $ mockFn "a" it "anything expectation error message when not called" $ do result <- try $ withMock $ do - _ <- mock (any @String ~> True) + mock (any @String ~> True) `expects` called once pure () case result of @@ -135,35 +131,35 @@ it "never expectation without args succeeds when not called" $ do withMock $ do - _ <- mock (any @String ~> True) + mock (any @String ~> True) `expects` called never pure () it "never expectation without args fails when called" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` called never + pure mockFn `expects` called never liftIO $ mockFn "a" `shouldBe` True pure ()) `shouldThrow` anyErrorCall it "never expectation with args succeeds when not called with that arg" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` (called never `with` "z") + pure mockFn `expects` (called never `with` "z") liftIO $ mockFn "a" `shouldBe` True pure () it "never expectation with args fails when called with that arg" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` (called never `with` "z") + pure mockFn `expects` (called never `with` "z") liftIO $ mockFn "z" `shouldBe` True pure ()) `shouldThrow` anyErrorCall it "multiple expectations in do block" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 2) `with` "a" called once `with` "b" liftIO $ mockFn "a" `shouldBe` True @@ -174,7 +170,7 @@ it "multiple expectations in do block fails when not all satisfied" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 2) `with` "a" called once `with` "b" liftIO $ mockFn "a" `shouldBe` True @@ -185,7 +181,7 @@ it "multiple expectations in do block with never" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called once `with` "a" called never `with` "z" liftIO $ mockFn "a" `shouldBe` True @@ -194,7 +190,7 @@ it "multiple expectations in do block with never fails when violated" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called once `with` "a" called never `with` "z" liftIO $ mockFn "a" `shouldBe` True @@ -204,7 +200,7 @@ it "multiple expectations with different counts" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 3) `with` "a" called (atLeast 2) `with` "b" called once `with` "c" @@ -219,7 +215,7 @@ it "multiple expectations fails when count is insufficient" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 3) `with` "a" called once `with` "b" liftIO $ mockFn "a" `shouldBe` True @@ -231,7 +227,7 @@ it "multiple expectations fails when atLeast is not satisfied" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (atLeast 2) `with` "a" called once `with` "b" liftIO $ mockFn "a" `shouldBe` True @@ -242,7 +238,7 @@ it "multiple expectations with mixed never and count" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 2) `with` "a" called never `with` "z" called once `with` "b" @@ -254,7 +250,7 @@ it "multiple expectations with never fails when never is violated" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do called (times 2) `with` "a" called never `with` "z" called once `with` "b" @@ -267,8 +263,8 @@ describe "withMock verification failures" $ do it "fails when called fewer times than expected" $ do withMock (do - mockFn <- mock (any ~> True) - `expects` do + mockFn <- mock (any @String ~> True) + pure mockFn `expects` do called (times 3) `with` "a" liftIO $ evaluate $ mockFn "a" @@ -277,8 +273,8 @@ it "fails when called with unexpected arguments" $ do withMock (do - mockFn <- mock (any ~> True) - `expects` do + mockFn <- mock (any @String ~> True) + pure mockFn `expects` do called once `with` "a" liftIO $ evaluate $ mockFn "b" @@ -286,8 +282,8 @@ it "fails when called but never expected" $ do withMock (do - mockFn <- mock (any ~> True) - `expects` do + mockFn <- mock (any @String ~> True) + pure mockFn `expects` do called never `with` "z" liftIO $ evaluate $ mockFn "z" @@ -307,7 +303,7 @@ it "calledInOrder succeeds when called in correct order" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInOrder ["a", "b", "c"] liftIO $ mockFn "a" `shouldBe` True @@ -318,7 +314,7 @@ it "calledInOrder fails when called in wrong order" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInOrder ["a", "b", "c"] liftIO $ mockFn "a" `shouldBe` True @@ -329,7 +325,7 @@ it "calledInOrder fails when not all calls are made" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInOrder ["a", "b", "c"] liftIO $ mockFn "a" `shouldBe` True @@ -340,7 +336,7 @@ it "calledInSequence succeeds when sequence is followed" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInSequence ["a", "c"] liftIO $ mockFn "a" `shouldBe` True @@ -351,7 +347,7 @@ it "calledInSequence fails when sequence is violated" $ do withMock (do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInSequence ["a", "c"] liftIO $ mockFn "c" `shouldBe` True -- Wrong: "a" should come first @@ -361,7 +357,7 @@ it "calledInSequence succeeds with extra calls in between" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInSequence ["a", "c"] liftIO $ mockFn "a" `shouldBe` True @@ -374,11 +370,11 @@ it "can define multiple mocks in withMock" $ do withMock $ do fn1 <- mock (any @String ~> True) - `expects` do + pure fn1 `expects` do called once `with` "a" fn2 <- mock (any @String ~> any @String ~> False) - `expects` do + pure fn2 `expects` do called once `with` ("x" ~> "y") liftIO $ fn1 "a" `shouldBe` True @@ -389,14 +385,14 @@ it "mocks from different withMock blocks do not interfere" $ do -- First withMock block: expect one call withMock $ do - fn1 <- mock (any ~> True) - `expects` do + fn1 <- mock (any @String ~> True) + pure fn1 `expects` do called once `with` "a" liftIO $ evaluate $ fn1 "a" -- Second withMock block: expect zero (if leaked, would see 1 and fail) withMock $ do - _ <- mock (any ~> True) + mock (any @String ~> True) `expects` do called never `with` "a" pure () @@ -404,21 +400,21 @@ it "multiple sequential withMock blocks are independent" $ do -- Block 1: call with "x" withMock $ do - fn1 <- mock (any ~> True) - `expects` do + fn1 <- mock (any @String ~> True) + pure fn1 `expects` do called once `with` "x" liftIO $ evaluate $ fn1 "x" -- Block 2: call with "y" withMock $ do - fn2 <- mock (any ~> True) - `expects` do + fn2 <- mock (any @String ~> True) + pure fn2 `expects` do called once `with` "y" liftIO $ evaluate $ fn2 "y" -- Block 3: no calls withMock $ do - _ <- mock (any ~> True) + mock (any ~> True) `expects` do called never `with` "z" pure () @@ -427,7 +423,7 @@ it "counts calls across parallel threads" $ do withMock $ do mockFn <- mock (any ~> True) - `expects` do + pure mockFn `expects` do called (times 10) withRunInIO $ \runInIO -> do @@ -440,7 +436,7 @@ it "handles concurrent calls with different arguments" $ do withMock $ do mockFn <- mock (any ~> True) - `expects` do + pure mockFn `expects` do called (times 5) `with` "a" called (times 5) `with` "b" @@ -458,7 +454,7 @@ withMock $ do mockFn <- mock (any ~> True) - `expects` do + pure mockFn `expects` do called (times total) withRunInIO $ \runInIO -> do @@ -473,7 +469,7 @@ it "concurrent calls preserve order expectations" $ do withMock $ do mockFn <- mock (any @String ~> True) - `expects` do + pure mockFn `expects` do calledInOrder ["first", "second", "third"] withRunInIO $ \runInIO -> do