mockcat 1.3.1.0 → 1.3.2.0
raw patch · 12 files changed
+351/−67 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Test.MockCat.MockT: instance Control.Monad.Error.Class.MonadError e m => Control.Monad.Error.Class.MonadError e (Test.MockCat.MockT.MockT m)
+ Test.MockCat.MockT: instance Control.Monad.Reader.Class.MonadReader r m => Control.Monad.Reader.Class.MonadReader r (Test.MockCat.MockT.MockT m)
+ Test.MockCat.MockT: instance Control.Monad.State.Class.MonadState s m => Control.Monad.State.Class.MonadState s (Test.MockCat.MockT.MockT m)
+ Test.MockCat.MockT: instance Control.Monad.Writer.Class.MonadWriter w m => Control.Monad.Writer.Class.MonadWriter w (Test.MockCat.MockT.MockT m)
+ Test.MockCat.TH: deriveMockInstances :: Q Type -> Q [Dec]
+ Test.MockCat.TH: deriveNoopInstance :: Q Type -> Q [Dec]
+ Test.MockCat.TH.TypeUtils: getReturnType :: Type -> Type
Files
- CHANGELOG.md +11/−0
- README-ja.md +46/−0
- README.md +46/−0
- mockcat.cabal +2/−2
- src/Test/MockCat/MockT.hs +25/−1
- src/Test/MockCat/TH.hs +100/−4
- src/Test/MockCat/TH/FunctionBuilder.hs +13/−8
- src/Test/MockCat/TH/TypeUtils.hs +9/−1
- test/Spec.hs +2/−2
- test/Test/MockCat/DeferredTypeErrorsSpec.hs +0/−42
- test/Test/MockCat/DeriveSpec.hs +96/−0
- test/Test/MockCat/TypeClassCommonSpec.hs +1/−7
CHANGELOG.md view
@@ -6,6 +6,17 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.3.2.0] - 2026-01-04+### Added+- **New Derivation Macros**:+ - `deriveMockInstances`: Automatically derives `MockT` instances for user-defined "Capability" type classes (e.g., `MonadLogger`). It lifts operations to the base monad.+ - *Note*: Type Families are currently not supported.+ - `deriveNoopInstance`: Generates "No-op" instances where methods (returning `m ()`) do nothing. Useful for ignoring specific interactions (e.g., `MonadAuditor`).++### Improved+- **Compile-Time Verification**: Enhanced robustness of internal verification scripts (`verify_th_errors.sh`) to ensure consistent error reporting across GHC versions.+- **Documentation**: Clarified "Capability vs. Control" design philosophy and limitations regarding Type Families in `deriveMockInstances`.+ ## [1.3.1.0] - 2026-01-03 ### Added - **New Parameter Matcher**: Introduced `when` and `when_` as the primary functions for condition-based matching.
README-ja.md view
@@ -322,6 +322,52 @@ program -- writeFile は本物の IO インスタンスが走る ``` +#### 派生とカスタムインスタンス (Derivation and Custom Instances)++`MockT` を使用する際、モック対象の副作用とは直接関係のない型クラスを扱わなければならないことがあります。Mockcat は、これらのケースを補助するためのマクロを提供しています。++##### MTL インスタンス (`MonadReader`, `MonadError` 等)+`MockT` は、標準的な `mtl` の型クラス(`MonadReader`, `MonadError`, `MonadState`, `MonadWriter`)のインスタンスを標準で備えています。これらのインスタンスは、操作を自動的にベースモナドへリフト(持ち上げ)します。++##### カスタム型クラスの派生 (`deriveMockInstances`)+ベースモナドへリフトするだけでよいカスタムの "Capability" 型クラス(`MonadLogger`, `MonadConfig` 等)については、`deriveMockInstances` を使用できます。++```haskell+class Monad m => MonadLogger m where+ logInfo :: String -> m ()++deriveMockInstances [t|MonadLogger|]+```+これにより、`lift . logInfo` を呼び出す `MockT m` のインスタンスが自動生成されます。+> [!NOTE]+> 現在、`deriveMockInstances` は Type Families を持つ型クラスをサポートしていません。++##### 明示的な No-op インスタンス (`deriveNoopInstance`)+メソッド(特に `m ()` を返すもの)に対して、明示的なスタブ定義やベース実装を用意することなく、「何もしない」モックを作成したい場合があります。++```haskell+class Monad m => MonadAuditor m where+ audit :: String -> m ()++deriveNoopInstance [t|MonadAuditor|]+```+これにより、`audit` が単に `pure ()` を返す `MockT m` のインスタンスが生成されます。+++---++#### 設計思想: Capability vs. Control++Mockcat は、型クラスの派生において **Capability (能力)** と **Control (制御)** を区別します。++* **Capability (注入/リフト)**: コンテキストやツールを提供する型クラス(例:`MonadReader`, `MonadLogger`)。+ * **アプローチ**: `deriveMockInstances` や標準の `mtl` インスタンスを使用します。環境の一貫性を保つため、これらはベースモナドへリフトされるべきです。+* **Control (モック)**: 外部への副作用やビジネスロジックの境界を表す型クラス(例:`UserRepository`, `PaymentGateway`)。+ * **アプローチ**: `makeMock` を使用します。テスト対象のロジックを隔離するため、これらは明示的にスタブ定義や検証が行われる必要があります。++---++ #### IO アクションを返す (Monadic Return) `IO` を返す関数で、呼び出しごとに副作用(結果)を変えたい場合に使います。
README.md view
@@ -324,6 +324,52 @@ program -- writeFile runs the real IO instance ``` +#### Derivation and Custom Instances++When using `MockT`, you might need to handle type classes that are not directly related to the side effects you are mocking. Mockcat provides macros to help with these cases.++##### MTL Instances (`MonadReader`, `MonadError`, etc.)+`MockT` provides standard `mtl` instances (`MonadReader`, `MonadError`, `MonadState`, `MonadWriter`) out of the box. These instances automatically lift operations to the base monad.++##### Custom Type Class Derivation (`deriveMockInstances`)+For custom "Capability" type classes (like `MonadLogger`, `MonadConfig`) that should just be lifted to the base monad, use `deriveMockInstances`.++```haskell+class Monad m => MonadLogger m where+ logInfo :: String -> m ()++deriveMockInstances [t|MonadLogger|]+```+This generates an instance for `MockT m` that calls `lift . logInfo`.+> [!NOTE]+> `deriveMockInstances` currently does not support type classes with Type Families.++##### Explicit No-op Instances (`deriveNoopInstance`)+Sometimes you want a mock to do nothing for certain methods (especially those returning `m ()`) without having to define explicit stubs or provide a base implementation.++```haskell+class Monad m => MonadAuditor m where+ audit :: String -> m ()++deriveNoopInstance [t|MonadAuditor|]+```+This generates an instance for `MockT m` where `audit` simply returns `pure ()`.+++---++#### Design Philosophy: Capability vs. Control++Mockcat makes a distinction between **Capability** and **Control** when it comes to type class derivation.++* **Capability (Inject/Lift)**: Type classes that provide context or tools (e.g., `MonadReader`, `MonadLogger`).+ * **Approach**: Use `deriveMockInstances` or standard `mtl` instances. These should be lifted to the base monad to keep the environment consistent.+* **Control (Mock)**: Type classes that represent external side effects or business logic boundaries (e.g., `UserRepository`, `PaymentGateway`).+ * **Approach**: Use `makeMock`. These must be explicitly stubbed or verified to ensure the test isolates the logic under test.++---++ #### Monadic Return (`IO a`) Used when you want a function returning `IO` to have different side effects (results) for each call.
mockcat.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: mockcat-version: 1.3.1.0+version: 1.3.2.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.@@ -96,7 +96,7 @@ Test.MockCat.ConcurrencySpec Test.MockCat.ConfirmTHSpec Test.MockCat.ConsSpec- Test.MockCat.DeferredTypeErrorsSpec+ Test.MockCat.DeriveSpec Test.MockCat.ExampleSpec Test.MockCat.HPCFallbackSpec Test.MockCat.HPCNestSpec
src/Test/MockCat/MockT.hs view
@@ -9,6 +9,7 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-} module Test.MockCat.MockT ( MockT(..), Definition(..), Verification(..), runMockT,@@ -23,7 +24,10 @@ ) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Reader (ReaderT(..), runReaderT, asks)+import Control.Monad.Reader (ReaderT(..), runReaderT, asks, MonadReader(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Writer.Class (MonadWriter(..)) import GHC.TypeLits (KnownSymbol, symbolVal) import Data.Data (Proxy, Typeable) import Data.IORef (newIORef, IORef)@@ -72,6 +76,26 @@ instance {-# OVERLAPPING #-} Monad m => MonadWithMockContext (MockT m) where askWithMockContext = MockT $ asks envWithMockContext++instance {-# OVERLAPPABLE #-} MonadReader r m => MonadReader r (MockT m) where+ ask = lift ask+ local f (MockT (ReaderT m)) = MockT $ ReaderT $ \env -> local f (m env)+ reader = lift . reader++instance {-# OVERLAPPABLE #-} MonadError e m => MonadError e (MockT m) where+ throwError = lift . throwError+ catchError (MockT m) h = MockT $ catchError m (unMockT . h)++instance {-# OVERLAPPABLE #-} MonadState s m => MonadState s (MockT m) where+ get = lift get+ put = lift . put+ state = lift . state++instance {-# OVERLAPPABLE #-} MonadWriter w m => MonadWriter w (MockT m) where+ writer = lift . writer+ tell = lift . tell+ listen (MockT m) = MockT $ listen m+ pass (MockT m) = MockT $ pass m data Definition =
src/Test/MockCat/TH.hs view
@@ -18,16 +18,21 @@ makeAutoLiftMock, makePartialMock, makeAutoLiftPartialMock,+ deriveMockInstances,+ deriveNoopInstance, ) where -import Control.Monad (unless, when)+import Control.Monad (replicateM, unless, when)+import Control.Monad.Trans (lift) import Data.List (elemIndex, nub) import Data.Maybe (catMaybes) import qualified Data.Map.Strict as Map import Language.Haskell.TH- ( Cxt,+ ( Clause (..),+ Body (..),+ Cxt, Dec (..), Exp (..), Extension (..),@@ -44,6 +49,7 @@ Type (..), isExtEnabled, mkName,+ newName, pprint, reify, )@@ -73,7 +79,8 @@ ) import Test.MockCat.TH.TypeUtils ( splitApps,- substituteType+ substituteType,+ getReturnType ) import Test.MockCat.TH.FunctionBuilder ( createFnName,@@ -181,7 +188,7 @@ -- -- - MockT instance of the given typeclass -- - A stub function corresponding to a function of the original class type.--- The name of stub function is the name of the original function with a "_" appended.+-- THE name of stub function is the name of the original function with a "_" appended. -- -- This function automatically wraps the return value in a monad (Implicit Monadic Return). --@@ -606,3 +613,92 @@ verifyExtension :: Extension -> Q () verifyExtension e = isExtEnabled e >>= flip unless (fail $ "Language extensions `" ++ show e ++ "` is required.")++deriveMockInstances :: Q Type -> Q [Dec]+deriveMockInstances qType = do+ ty <- qType+ let className = getClassName ty+ classMetadata <- loadClassMetadata className+ monadVarName <- selectMonadVarName classMetadata+ let classParamNames = filter (className /=) (getClassNames ty)+ newTypeVars = drop (length classParamNames) (cmTypeVars classMetadata)+ let sigDecs = [dec | dec@(SigD _ _) <- cmDecs classMetadata]+ + let isSupportedDec (SigD _ _) = True+ isSupportedDec (PragmaD _) = True+ isSupportedDec _ = False+ let unsupportedDecs = filter (not . isSupportedDec) (cmDecs classMetadata)+ + instanceBodyDecsResult <- + case unsupportedDecs of+ (x:_) -> pure $ Left $ "deriveMockInstances: Unsupported declaration in class: " <> pprint x <> + ". This error is reported at the usage site, but the cause is the macro definition for `" <> show className <> "`."+ [] -> sequence <$> mapM (createLiftInstanceFnDec monadVarName) sigDecs++ case instanceBodyDecsResult of+ Right decs -> do+ instanceHead <- createInstanceType ty monadVarName newTypeVars+ let instanceConstraint = foldl AppT ty (map (VarT . getTypeVarName) newTypeVars)+ instanceDec <- instanceD+ (pure (instanceConstraint : cmContext classMetadata))+ (pure instanceHead)+ (map pure decs)+ pure [instanceDec]+ Left err -> fail err++createLiftInstanceFnDec :: Name -> Dec -> Q (Either String Dec)+createLiftInstanceFnDec _ (SigD fnName ty) = do+ let n = countArgs ty+ argNames <- replicateM n (newName "a")+ let params = map VarP argNames+ args = map VarE argNames+ body = NormalB $ AppE (VarE 'lift) (foldl AppE (VarE fnName) args)+ pure $ Right $ FunD fnName [Clause params body []]+createLiftInstanceFnDec _ dec = pure $ Left $ + "deriveMockInstances: Unsupported declaration in class: " <> pprint dec <> + ". Currently only standard method signatures are supported for automatic derivation."++deriveNoopInstance :: Q Type -> Q [Dec]+deriveNoopInstance qType = do+ ty <- qType+ let className = getClassName ty+ classMetadata <- loadClassMetadata className+ monadVarName <- selectMonadVarName classMetadata+ let classParamNames = filter (className /=) (getClassNames ty)+ newTypeVars = drop (length classParamNames) (cmTypeVars classMetadata)+ let sigDecs = [dec | dec@(SigD _ _) <- cmDecs classMetadata]+ instanceBodyDecs <- mapM createNoopInstanceFnDec sigDecs+ case sequence instanceBodyDecs of+ Right decs -> do+ instanceHead <- createInstanceType ty monadVarName newTypeVars+ instanceDec <- instanceD+ (pure (cmContext classMetadata))+ (pure instanceHead)+ (map pure decs)+ pure [instanceDec]+ Left err -> fail err++createNoopInstanceFnDec :: Dec -> Q (Either String Dec)+createNoopInstanceFnDec (SigD fnName ty) = do+ let n = countArgs ty+ let returnType = getReturnType ty+ case returnType of+ AppT _ (TupleT 0) -> do+ let params = replicate n WildP+ body = NormalB $ AppE (VarE 'pure) (ConE '())+ pure $ Right $ FunD fnName [Clause params body []]+ _ -> pure $ Left $ + "deriveNoopInstance: Function `" <> nameBase fnName <> "` does not return `m ()` (actual return type: " <> pprint returnType <> "). " <> + "`deriveNoopInstance` only supports functions that return `m ()`. " <> + "Please implement this instance manually or exclude this function from the derivation target."+createNoopInstanceFnDec dec = pure $ Left $ + "deriveNoopInstance: Unsupported declaration in class: " <> pprint dec <> + ". Currently only standard method signatures are supported for automatic derivation."++countArgs :: Type -> Int+countArgs (AppT (AppT ArrowT _) t) = 1 + countArgs t+countArgs (ForallT _ _ t) = countArgs t+countArgs (SigT t _) = countArgs t+countArgs (ParensT t) = countArgs t+countArgs _ = 0+
src/Test/MockCat/TH/FunctionBuilder.hs view
@@ -207,7 +207,7 @@ doCreateMockFnDecs :: MockType -> String -> Name -> Name -> Type -> Name -> Type -> Q [Dec] doCreateMockFnDecs mockType funNameStr mockFunName params funTypeInput monadVarName _ = do- let funType = sanitizeType [monadVarName] funTypeInput+ let funType = sanitizeType [monadVarName] (stripTopLevelForall funTypeInput) let resultType = AppT (AppT ArrowT (VarT params))@@ -250,9 +250,9 @@ pure $ newFunSig : [newFun] doCreateConstantMockFnDecs :: MockType -> String -> Name -> Type -> Name -> Q [Dec]-doCreateConstantMockFnDecs Partial funNameStr mockFunName ty monadVarName = do+doCreateConstantMockFnDecs Partial funNameStr mockFunName tyInput monadVarName = do let stubVar = mkName "p" - let tySanitized = sanitizeType [monadVarName] ty+ let tySanitized = sanitizeType [monadVarName] (stripTopLevelForall tyInput) let resultType = AppT (AppT ArrowT (VarT stubVar))@@ -295,12 +295,12 @@ mockBody <- createMockBody funNameStr [|p|] (VarT stubVar) newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []] pure $ newFunSig : [newFun]-doCreateConstantMockFnDecs Total funNameStr mockFunName ty monadVarName = do- case ty of+doCreateConstantMockFnDecs Total funNameStr mockFunName tyInput monadVarName = do+ case tyInput of -- Case 3: Generic (Polymorphic p) _ -> do let params = mkName "p"- let tySanitized = sanitizeType [monadVarName] ty+ let tySanitized = sanitizeType [monadVarName] (stripTopLevelForall tyInput) let resultType = AppT (AppT ArrowT (VarT params))@@ -337,8 +337,9 @@ pure [newFunSig, newFun] doCreateEmptyVerifyParamMockFnDecs :: String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]-doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funTypeInput monadVarName updatedType = do- let funType = sanitizeType [monadVarName] funTypeInput+doCreateEmptyVerifyParamMockFnDecs funNameStr mockFunName params funTypeInput monadVarName updatedTypeInput = do+ let funType = sanitizeType [monadVarName] (stripTopLevelForall funTypeInput)+ let updatedType = stripTopLevelForall updatedTypeInput newFunSig <- do let verifyParams = createMockBuilderVerifyParams updatedType resultType =@@ -440,6 +441,10 @@ safeIndex (_ : xs) n | n < 0 = Nothing | otherwise = safeIndex xs (n - 1)++stripTopLevelForall :: Type -> Type+stripTopLevelForall (ForallT _ _ t) = stripTopLevelForall t+stripTopLevelForall t = t generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp
src/Test/MockCat/TH/TypeUtils.hs view
@@ -7,7 +7,8 @@ needsTypeable, collectTypeableTargets, isStandardTypeCon,- isTypeFamily+ isTypeFamily,+ getReturnType ) where@@ -125,3 +126,10 @@ ] isStandardTypeCon _ = False ++getReturnType :: Type -> Type+getReturnType (AppT (AppT ArrowT _) t) = getReturnType t+getReturnType (ForallT _ _ t) = getReturnType t+getReturnType (SigT t _) = getReturnType t+getReturnType (ParensT t) = getReturnType t+getReturnType t = t
test/Spec.hs view
@@ -1,5 +1,6 @@ import Test.Hspec (hspec, describe, it) import Test.MockCat.MockSpec as Mock+import Test.MockCat.DeriveSpec as Derive import Test.MockCat.ConsSpec as Cons import Test.MockCat.ParamSpec as Param import Test.MockCat.AssociationListSpec as AssociationList@@ -26,7 +27,6 @@ import Test.MockCat.THCompareSpec as THCompare import ReadmeVerifySpec as ReadmeVerify import qualified Test.MockCat.HPCFallbackSpec as HPCFallback-import qualified Test.MockCat.DeferredTypeErrorsSpec as DeferredTypeErrors import qualified Test.MockCat.MultipleMocksSpec as MultipleMocks import Test.MockCat.UnsafeCheck () import Test.QuickCheck (property)@@ -44,6 +44,7 @@ main = hspec $ do Cons.spec Param.spec+ Derive.spec Mock.spec AssociationList.spec Example.spec@@ -68,7 +69,6 @@ WithMockErrorDiff.spec ReadmeVerify.spec HPCFallback.spec- DeferredTypeErrors.spec MultipleMocks.spec describe "Property Concurrency" $ do it "total apply count is preserved across threads" $ property ConcurrencyProp.prop_concurrent_total_apply_count
− test/Test/MockCat/DeferredTypeErrorsSpec.hs
@@ -1,42 +0,0 @@-{-# 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--import Test.Hspec-import Test.MockCat-import Control.Exception (evaluate)-import Control.Monad.IO.Class (liftIO)-import Prelude hiding (any)--spec :: Spec-spec = describe "Compile-time restrictions (Deferred Type Errors)" do- it "expects throws type error when applied directly to MockSpec instead of mock result" do- -- This expression should fail to typecheck because `expects` requires `m fn` (monadic action),- -- but here it is applied to `MockSpec` (pure value).- -- With -fdefer-type-errors, this becomes a runtime error.- let expression = (any ~> True) `expects` do- called once- - evaluate expression `shouldThrow` anyException-- it "expects throws type error when applied to instantiated mock function (f)" do- -- f <- mock ... returns a function `f`.- -- expects expects `m fn`, not `fn`.- -- This verifies that we cannot "attach" expectations to an existing function variable.- -- We type-annotate the block to ensure 'mock' has a concreter context (MockT IO),- -- so that the error is specifically about 'f' not matching 'm fn'.- let expression :: MockT IO ()- expression = do- f <- mock (any ~> (1 :: Int))- let val = f `expects` do- called once- liftIO $ evaluate val- pure ()- - -- Since the type error is deferred inside the IO action logic, we must run it to trigger the exception.- runMockT expression `shouldThrow` anyException-
+ test/Test/MockCat/DeriveSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{- HLINT ignore "Use newtype instead of data" -}+module Test.MockCat.DeriveSpec (spec) where++import Test.Hspec+import Test.MockCat+import Control.Monad (void)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), runReaderT)+import Control.Monad.Except (ExceptT(..), runExceptT)+import Control.Monad.IO.Class (MonadIO(..))++-- Target class for deriveMockInstances+class Monad m => Logger m where+ logInfo :: String -> m ()++instance Logger IO where+ logInfo _ = pure ()++deriveMockInstances [t|Logger|]++-- Complex patterns for deriveMockInstances+class Monad m => ComplexLogger m where+ logMany :: String -> [Int] -> m ()+ logIf :: Bool -> String -> m ()++instance ComplexLogger IO where+ logMany _ _ = pure ()+ logIf _ _ = pure ()++deriveMockInstances [t|ComplexLogger|]++-- Target class for deriveNoopInstance+class Monad m => Auditor m where+ audit :: String -> m ()++deriveNoopInstance [t|Auditor|]++-- Custom error for testing+data CustomError = CustomError String deriving (Eq, Show)++-- Direct MonadError mock test+makeAutoLiftMock [t|MonadError CustomError|]++-- Isolated monad to avoid MonadError IOException IO conflict+newtype TestM a = TestM { runTestM :: IO a } deriving (Functor, Applicative, Monad, MonadIO)++spec :: Spec+spec = do+ describe "MTL instances" $ do+ it "can use catchError directly in MockT" $ do+ let action = runMockT $ do+ let action' = throwError "error" :: MockT (ExceptT String IO) Int+ action' `catchError` (\e -> if e == "error" then pure 42 else throwError e)+ runExceptT action `shouldReturn` Right (42 :: Int)++ it "can use ask directly in MockT" $ do+ let action = runMockT (ask :: MockT (ReaderT String IO) String)+ runReaderT action "env" `shouldReturn` "env"++ describe "deriveMockInstances" $ do+ it "can derive basic custom typeclass instances" $ do+ runMockT (logInfo "hello" :: MockT IO ()) `shouldReturn` ()++ it "can derive complex custom typeclass instances (multi-args, list)" $ do+ runMockT (do+ logMany "counts" [1, 2, 3]+ logIf True "active"+ pure ()) `shouldReturn` ()++ describe "deriveNoopInstance" $ do+ it "doesn't require stubs for noop methods" $ do+ runMockT (audit "something" :: MockT IO ()) `shouldReturn` ()++ describe "makeMock/makeAutoLiftMock with MonadError" $ do+ it "can mock standard MonadError directly using isolated TestM" $ do+ let action :: MockT TestM ()+ action = do+ _throwError (CustomError "fail" ~> (pure () :: MockT TestM ()))+ void (throwError (CustomError "fail") :: MockT TestM ())+ runTestM (runMockT action) `shouldReturn` ()
test/Test/MockCat/TypeClassCommonSpec.hs view
@@ -31,8 +31,7 @@ import Control.Exception (ErrorCall(..), displayException) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader, ask)-import Control.Monad.State (MonadState(..), StateT, evalStateT)-import Control.Monad.Trans.Class (lift)+import Control.Monad.State (StateT, evalStateT) import Test.MockCat.SharedSpecDefs import qualified Data.List as List import Control.Concurrent.Async (async, wait)@@ -48,11 +47,6 @@ in (needle1 `List.isInfixOf` displayException err) || (needle2 `List.isInfixOf` displayException err) -- Orphan Instances needed for testing--instance MonadState s m => MonadState s (MockT m) where- get = lift get- put = lift . put- state f = lift (state f) -- Programs under test