mockcat 0.2.1.0 → 0.3.0.0

raw patch · 13 files changed

+1330/−121 lines, 13 filesdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

API changes (from Hackage documentation)

Files

• README.md +261/−46
• mockcat.cabal +11/−13
• src/Test/MockCat.hs +5/−1
• src/Test/MockCat/Mock.hs +76/−19
• src/Test/MockCat/MockT.hs +112/−0
• src/Test/MockCat/Param.hs +1/−15
• src/Test/MockCat/TH.hs +451/−2
• test/Spec.hs +4/−0
• test/Test/MockCat/ExampleSpec.hs +32/−4
• test/Test/MockCat/MockSpec.hs +75/−21
• test/Test/MockCat/ParamSpec.hs +1/−0
• test/Test/MockCat/TypeClassSpec.hs +121/−0
• test/Test/MockCat/TypeClassTHSpec.hs +180/−0

@@ -4,15 +4,205 @@  [日本語版 README はこちら](https://github.com/pujoheadsoft/mockcat/blob/master/README-ja.md) -mockcat is a simple mocking library that supports testing in Haskell.+# Overview+mockcat is a simple and flexible mocking library. -It mainly provides two features:-- Creating stub functions-- Verifying if the expected arguments were applied+There are two main things you can do with mocks:+1. Create stub functions+2. Verify whether the stub functions were applied as expected -Stub functions can return not only monadic values but also pure values.+You can create two types of mocks:+1. Mocks for monad type classes+2. Mocks for functions +**1** The monad type classes refer to classes like the following: ```haskell+class Monad m => FileOperation m where+  readFile :: FilePath -> m Text+  writeFile :: FilePath -> Text -> m ()+```++**2** The functions refer to regular functions like the following:  +(You can mock functions wrapped in a monad like IO (), as well as constant functions)+```haskell+calc :: Int -> Int+echo :: String -> IO ()+constantValue :: String+```++# Mock of monad type class+## Example usage+For example, suppose the following monad type class `FileOperation` and a function `operationProgram` that uses `FileOperation` are defined.+```haskell+class Monad m => FileOperation m where+  readFile :: FilePath -> m Text+  writeFile :: FilePath -> Text -> m ()++operationProgram :: FileOperation m => FileOperation m+  FileOperation m =>+  FilePath ->+  FilePath ->+  m ()+operationProgram inputPath outputPath = do+  content <- readFile inputPath+  writeFile outputPath content+```++You can generate a mock of the typeclass `FileOperation` by using the `makeMock` function as follows  +`makeMock [t|FileOperation|]`++Then following two things will be generated: +1. a `MockT` instance of typeclass `FileOperation+2. a stub function based on a function defined in the typeclass `FileOperation`  +  Stub functions are created as functions with `_` prefix added to the original function.  +  In this case, `_readFile` and `_writeFile` are generated.++Mocks can be used as follows.+```haskell+spec :: Spec+spec = do+  it "Read, and output files" do+    result <- runMockT do+      _readFile ("input.txt" |> pack "content")+      _writeFile ("output.txt" |> pack "content" |> ())+      operationProgram "input.txt" "output.txt"++    result `shouldBe` ()+```+Stub functions are passed arguments that are expected to be applied to the function, concatenated by `|>`.  +The last value of `|>` is the return value of the function.++Mocks are run with `runMockT`.++## Verification+After execution, the stub function is verified to see if it is applied as expected.  +For example, the expected argument of the stub function `_writeFile` in the above example is changed from `"content"` to `"edited content"`.+```haskell+result <- runMockT do+  _readFile ("input.txt" |> pack "content")+  _writeFile ("output.txt" |> pack "edited content" |> ())+  operationProgram "input.txt" "output.txt"+```+If you run the test, the test will fail and you will get the following error message.+```console+uncaught exception: ErrorCall+function `_writeFile` was not applied to the expected arguments.+  expected: "output.txt", "edited content"+  but got: "output.txt", "content"+```++Suppose also that you did not use the stub function corresponding to the function you are using in your test case, as follows+```haskell+result <- runMockT do+  _readFile ("input.txt" |> pack "content")+  -- _writeFile ("output.txt" |> pack "content" |> ())+  operationProgram "input.txt" "output.txt"+```+Again, when you run the test, the test fails and you get the following error message.+```console+no answer found stub function `_writeFile`.+````++## Verify the number of times applied+For example, suppose you want to write a test for not applying `_writeFile` if it contains a specific string as follows.+```haskell+operationProgram inputPath outputPath = do+  content <- readFile inputPath+  unless (pack "ngWord" `isInfixOf` content) $+    writeFile outputPath content+```++This can be accomplished by using the `applyTimesIs` function as follows.+```haskell+import Test.MockCat as M+...+it "Read, and output files (contain ng word)" do+  result <- runMockT do+    _readFile ("input.txt" |> pack "contains ngWord")+    _writeFile ("output.txt" |> M.any |> ()) `applyTimesIs` 0+    operationProgram "input.txt" "output.txt"++  result `shouldBe` ()+```+You can verify that it was not applied by specifying ``0``.++Or you can use the `neverApply` function to accomplish the same thing.+```haskell+result <- runMockT do+  _readFile ("input.txt" |> pack "contains ngWord")+  neverApply $ _writeFile ("output.txt" |> M.any |> ())+  operationProgram "input.txt" "output.txt"+```++``M.any`` is a parameter that matches any value.  +This example uses `M.any` to verify that the `writeFile` function does not apply to any value.++As described below, mockcat provides a variety of parameters other than `M.any`.++## Mock constant functions+mockcat can also mock constant functions.  +Let's mock `MonadReader` and use the `ask` stub function.+```haskell+data Environment = Environment { inputPath :: String, outputPath :: String }++operationProgram ::: MonadReader Environment m =>+  MonadReader Environment m =>+  FileOperation m =>+  m ()+operationProgram = do+  (Environment inputPath outputPath) <- ask+  content <- readFile inputPath+  writeFile outputPath content++makeMock [t|MonadReader Environment|]]++spec :: Spec+spec = do+  it "Read, and output files (with MonadReader)" do+    r <- runMockT do+      _ask (Environment "input.txt" "output.txt")+      _readFile ("input.txt" |> pack "content")+      _writeFile ("output.txt" |> pack "content" |> ())+      operationProgram+    r `shouldBe` ()+```+Now let's try to avoid using ``ask``.+```haskell+operationProgram = do+  content <- readFile "input.txt"+  writeFile "output.txt" content+```+Then the test run fails and you will see that the stub function was not applied.+```haskell+It has never been applied function `_ask`+```++## Rename stub functions+The prefix and suffix of the generated stub functions can optionally be changed.  +For example, the following will generate the functions `stub_readFile_fn` and `stub_writeFile_fn`.+```haskell+makeMockWithOptions [t|FileOperation|] options { prefix = "stub_", suffix = "_fn" }+```+If no options are specified, it defaults to ``_``.++## Code generated by makeMock+Although you do not need to be aware of it, the ``makeMock`` function generates the following code.+```haskell+-- MockT instance+instance (Monad m) => FileOperation (MockT m) where+  readFile :: Monad m => FilePath -> MockT m Text+  writeFile :: Monad m => FilePath -> Text -> MockT m ()++_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), Monad m) => params -> MockT m ()+_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), Monad m) => params -> MockT m ()+```++# Mocking functions+In addition to mocking monad type classes, mockcat can also mock regular functions.  +Unlike monad type mocks, the original function is not required.++## Example usage+````haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-} import Test.Hspec@@ -20,23 +210,24 @@  spec :: Spec spec = do-  it "Example of usage" do-    -- Create a Mock (applying “value” returns the pure value True)+  it "usage example" do+    -- create a mock (applying "value" returns the pure value True)     mock <- createMock $ "value" |> True -    -- Extract the stub function from the mock+    -- extract a stub function from a mock     let stubFunction = stubFn mock -    -- Verify the results of applying an argument+    -- verify the result of applying the function     stubFunction "value" `shouldBe` True -    -- Verify if the expected value ("value") was applied+    -- verify that the expected value ("value") has been applied     mock `shouldApplyTo` "value"+ ``` -# Stub Functions-## Simple Stub Functions-To create stub functions, use the createStubFn function.+## Stub functions+To create a stub function directly, use the `createStubFn` function.  +If you don't need verification, you can use this one. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -45,26 +236,27 @@  spec :: Spec spec = do-  it "can create a stub function" do-    -- Create+  it "can generate stub functions" do+    -- generate     f <- createStubFn $ "param1" |> "param2" |> pure @IO () -    -- Apply+    -- apply     actual <- f "param1" "param2" -    -- Verify+    -- Verification     actual `shouldBe` () ```-To createStubFn, you pass the expected arguments concatenated with |>.-The final value after |> is the return value of the function.+The `createStubFn` function is passed a sequence of `|>` arguments that the function is expected to apply.+The last value of `|>` is the return value of the function. -If unexpected arguments are applied to the stub function, an error occurs.+If the stub function is applied to an argument it is not expected to be applied to, an error is returned. ```console-uncaught exception: ErrorCall+Uncaught exception: ErrorCall Expected arguments were not applied to the function.   expected: "value"   but got: "valuo"-```+````+ ## Named Stub Functions You can name stub functions. ```haskell@@ -79,17 +271,36 @@     f <- createNamedStubFun "named stub" $ "x" |> "y" |> True     f "x" "z" `shouldBe` True ```-If the expected arguments are not applied, the error message will include this name.+The error message printed when a stub function is not applied to an expected argument will include this name. ```console uncaught exception: ErrorCall Expected arguments were not applied to the function `named stub`.   expected: "x","y"   but got: "x","z" ```-## Flexible Stub Functions-You can create a flexible stub function by giving the `createStubFn` function a conditional expression instead of a specific value.  -This allows you to return expected values for arbitrary values, strings matching specific patterns, etc. +## Constant stub functions+To create a stub function that returns a constant, use the `createConstantMock` or `createNamedConstantMock` function.  ++```haskell+spec :: Spec+spec = do+  it "createConstantMock" do+    m <- createConstantMock "foo"+    stubFn m `shouldBe` "foo"+    shouldApplyToAnything m++  it "createNamedConstantMock" do+    m <- createNamedConstantMock "const" "foo"+    stubFn m `shouldBe` "foo""+    shouldApplyToAnything m+```++## Flexible stub functions+Flexible stub functions can be generated by giving the `createStubFn` function a conditional expression rather than a concrete value.  +This can be used to return expected values for arbitrary values or strings that match a specific pattern.  +This is also true for the stub function when generating a mock of a monad type.+ ### any any matches any value. ```haskell@@ -157,9 +368,8 @@     f 6 `shouldBe` "return value" ``` -## Stub Functions that Return Different Values for Each Applied Argument-By applying a list in the form of x |> y to the `createStubFn` function,   -you can create stub functions that return different values for each applied argument.+## Stub functions that return different values for each argument applied+By applying the `createStubFn` function to a list of x |> y format, you can create a stub function that returns a different value for each argument you apply. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -179,8 +389,8 @@     f "b" `shouldBe` "return y" ``` -## Stub Function That Returns Different Values for the Same Arguments-When applying a list of x |> y pairs to the `createStubFn` function, you can create a stub function that returns different values for the same arguments by ensuring the return values differ for the same input arguments.+## Stub functions that return different values when applied to the same argument+When the `createStubFn` function is applied to a list of x |> y format, with the same arguments but different return values, you can create stub functions that return different values when applied to the same arguments. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -201,14 +411,13 @@     v3 <- evaluate $ f "arg"     v1 `shouldBe` "x"     v2 `shouldBe` "y"-    v3 `shouldBe` "y" -- After the second time, “y” is returned.+    v3 `shouldBe` "y" -- After the second time, "y" is returned. ``` -# Verification-## Verify if the Expected Arguments were Applied-You can verify if the expected arguments were applied using the `shouldApplyTo` function.-To perform the verification, create a mock using the `createMock` function instead of the `createStubFn` function.-In this case, use the `stubFn` function to extract the stub function from the mock.+## Verify that expected arguments are applied+The `shouldApplyTo` function can be used to verify that a stub function has been applied to the expected arguments.  +If you want to verify this, you need to create a mock with the `createMock` function instead of the `createStubFn` function.  +In this case, stub functions are taken from the mock with the `stubFn` function. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -228,8 +437,8 @@     mock `shouldApplyTo` "value" ``` ### Note-The recording of the application of arguments is done at the time the return value of the stub function is evaluated.  -Therefore, verification must be done after evaluation.+The record that it has been applied is made at the time the return value of the stub function is evaluated.  +Therefore, verification must occur after the return value is evaluated. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -251,8 +460,8 @@   but got: Never been called. ``` -## Verify the Number of Times the Expected Arguments were Applied-You can verify the number of times the expected arguments were applied using the `shouldApplyTimes` function.+## Verify the number of times the stub function was applied to the expected argument+The number of times a stub function is applied to an expected argument can be verified with the `shouldApplyTimes` function. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -267,8 +476,14 @@     print $ stubFn m "value"     m `shouldApplyTimes` (2 :: Int) `to` "value" ```-## Verify if the Arguments were Applied in the Expected Order-You can verify if the arguments were applied in the expected order using the `shouldApplyInOrder` function.+## Verify that a function has been applied to something+You can verify that a function has been applied to something with the `shouldApplyToAnything` function.++## Verify the number of times a function has been applied to something+The number of times a function has been applied to something can be verified with the `shouldApplyTimesToAnything` function.++## Verify that stub functions are applied in the expected order+The `shouldApplyInOrder` function can be used to verify that the order in which they were applied is the expected order. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}@@ -287,9 +502,9 @@                            ] ``` -## Verify if the Arguments were Applied in the Expected Partial Order-The `shouldApplyInOrder` function strictly verifies the order of application,  -but the `shouldApplyInPartialOrder` function can verify if the order of application matches partially.+## Verify that they were applied in the expected order (partial match)+While the `shouldApplyInOrder` function verifies the exact order of application,  +The `shouldApplyInPartialOrder` function allows you to verify that the order of application is partially matched. ```haskell {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-}

@@ -1,24 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           mockcat-version:        0.2.1.0-synopsis:       Simple mock function library for test in Haskell.-description:    mockcat is simple mock library for test in Haskell.-                .-                mockcat provides so-called stubbing and verification functions.-                .-                Stub functions can return values of Pure Types as well as value of Monadic Types.+version:        0.3.0.0+synopsis:       Mock library for test in Haskell.+description:    mockcat is a mock library for testing Haskell.                 .-                Example:+                mockcat provides monad type class generation and stub and verification functions.                 .-                @-                f \<- createStubFn $ "expected arg" |\> "return value"-                print $ f "expected arg" -- "return value" -                @+                Stub functions can return values of pure types as well as values of monad types.                 .                 For more please see the README on GitHub at <https://github.com/pujoheadsoft/mockcat#readme> category:       Testing@@ -44,6 +37,7 @@       Test.MockCat.AssociationList       Test.MockCat.Cons       Test.MockCat.Mock+      Test.MockCat.MockT       Test.MockCat.Param       Test.MockCat.ParamDivider       Test.MockCat.TH@@ -54,6 +48,7 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -fprint-potential-instances   build-depends:       base >=4.7 && <5+    , mtl >=2.3.1 && <2.4     , template-haskell >=2.18 && <2.23     , text >=2.0 && <2.2   default-language: Haskell2010@@ -67,6 +62,8 @@       Test.MockCat.ExampleSpec       Test.MockCat.MockSpec       Test.MockCat.ParamSpec+      Test.MockCat.TypeClassSpec+      Test.MockCat.TypeClassTHSpec       Paths_mockcat   hs-source-dirs:       test@@ -75,6 +72,7 @@       base >=4.7 && <5     , hspec     , mockcat+    , mtl >=2.3.1 && <2.4     , template-haskell >=2.18 && <2.23     , text >=2.0 && <2.2   default-language: Haskell2010

@@ -2,10 +2,14 @@   (      module Test.MockCat.Mock,     module Test.MockCat.Cons,-    module Test.MockCat.Param+    module Test.MockCat.Param,+    module Test.MockCat.MockT,+    module Test.MockCat.TH   ) where  import Test.MockCat.Mock import Test.MockCat.Cons import Test.MockCat.Param+import Test.MockCat.MockT+import Test.MockCat.TH

@@ -16,8 +16,13 @@   - Verify applied mock function. -} module Test.MockCat.Mock-  ( createMock,+  ( Mock,+    MockBuilder,+    build,+    createMock,     createNamedMock,+    createConstantMock,+    createNamedConstantMock,     createStubFn,     createNamedStubFn,     stubFn,@@ -29,13 +34,13 @@     shouldApplyTimesLessThanEqual,     shouldApplyTimesGreaterThan,     shouldApplyTimesLessThan,-    to,-    module Test.MockCat.Cons,-    module Test.MockCat.Param+    shouldApplyToAnything,+    shouldApplyTimesToAnything,+    to   ) where -import Control.Monad (guard)+import Control.Monad (guard, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Function ((&)) import Data.IORef (IORef, modifyIORef', newIORef, readIORef)@@ -48,6 +53,7 @@ import Test.MockCat.ParamDivider import Test.MockCat.AssociationList (AssociationList, lookup, update, insert, empty, member) import Prelude hiding (lookup)+import GHC.Stack (HasCallStack)  data Mock fun params = Mock (Maybe MockName) fun (Verifier params) @@ -83,6 +89,22 @@   m (Mock fun verifyParams) createMock params = liftIO $ build Nothing params +{- | Create a constant mock.+From this mock, you can generate constant functions and verify the functions.++  @+  import Test.Hspec+  import Test.MockCat+  ...+  it "stub & verify" do+    m \<- createConstantMock "foo"+    stubFn m \`shouldBe\` "foo"+    shouldApplyToAnything m+  @+-}+createConstantMock :: MonadIO m => a -> m (Mock a ())+createConstantMock a = liftIO $ build Nothing $ param a+ {- | Create a named mock. If the test fails, this name is used. This may be useful if you have multiple mocks.    @@@ -102,6 +124,10 @@   m (Mock fun verifyParams) createNamedMock name params = liftIO $ build (Just name) params +-- | Create a named constant mock.+createNamedConstantMock :: MonadIO m => MockName -> fun -> m (Mock fun ())+createNamedConstantMock name a = liftIO $ build (Just name) (param a)+ -- | Extract the stub function from the mock. stubFn :: Mock fun v -> fun stubFn (Mock _ f _) = f@@ -123,7 +149,6 @@   m fun createStubFn params = stubFn <$> createMock params - -- | Create a named stub function. createNamedStubFn ::   MockBuilder params fun verifyParams =>@@ -245,6 +270,16 @@     makeMock name s (\a2 -> unsafePerformIO $ extractReturnValueWithValidate name params (p a2) s)  instance+  MockBuilder (Param r) r ()+  where+  build name params = do+    s <- liftIO $ newIORef appliedRecord+    let v = value params+    makeMock name s $ unsafePerformIO (do+      liftIO $ appendAppliedParams s ()+      pure v)++instance   (Show a, Eq a, Show b, Eq b, Show c, Eq c, Show d, Eq d, Show e, Eq e, Show f, Eq f, Show g, Eq g, Show h, Eq h, Show i, Eq i) =>   MockBuilder     [Param a :> Param b :> Param c :> Param d :> Param e :> Param f :> Param g :> Param h :> Param i :> Param r]@@ -408,7 +443,7 @@ message name expected actual =   intercalate     "\n"-    [ "Expected arguments were not applied to the function" <> mockNameLabel name <> ".",+    [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",       "  expected: " <> show expected,       "   but got: " <> show actual     ]@@ -417,7 +452,7 @@ messageForMultiMock name expecteds actual =   intercalate     "\n"-    [ "Expected arguments were not applied to the function" <> mockNameLabel name <> ".",+    [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",       "  expected one of the following:",       intercalate "\n" $ ("    " <>) . show <$> expecteds,       "  but got:",@@ -436,7 +471,7 @@ -- | Class for verifying mock function. class Verify params input where   -- | Verifies that the function has been applied to the expected arguments.-  shouldApplyTo :: Mock fun params -> input -> IO ()+  shouldApplyTo :: HasCallStack => Mock fun params -> input -> IO ()  instance (Eq a, Show a) => Verify (Param a) a where   shouldApplyTo v a = verify v (MatchAny (param a))@@ -467,7 +502,7 @@   VerifyFailed $     intercalate       "\n"-      [ "Expected arguments were not applied to the function" <> mockNameLabel name <> ".",+      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments.",         "  expected: " <> show expected,         "   but got: " <> formatAppliedParamsList appliedParams       ]@@ -495,7 +530,7 @@   --   m \`shouldApplyTimes\` (2 :: Int) \`to\` "value"    -- @   ---  shouldApplyTimes :: Eq params => Mock fun params -> countType -> a -> IO ()+  shouldApplyTimes :: HasCallStack => Eq params => Mock fun params -> countType -> a -> IO ()  instance VerifyCount CountVerifyMethod (Param a) a where   shouldApplyTimes v count a = verifyCount v (param a) count@@ -540,7 +575,7 @@       errorWithoutStackTrace $         intercalate           "\n"-          [ "The expected argument was not applied the expected number of times to the function" <> mockNameLabel name <> ".",+          [ "function" <> mockNameLabel name <> " was not applied the expected number of times to the expected arguments.",             "  expected: " <> show method,             "   but got: " <> show appliedCount           ]@@ -562,14 +597,14 @@   --   print $ stubFn m "b" True   --   m \`shouldApplyInOrder\` ["a" |\> True, "b" |\> True]   -- @-  shouldApplyInOrder :: Mock fun params -> [input] -> IO ()+  shouldApplyInOrder :: HasCallStack => Mock fun params -> [input] -> IO ()    -- | Verify that functions are applied in the expected order.   --   -- Unlike @'shouldApplyInOrder'@, not all applications need to match exactly.   --   -- As long as the order matches, the verification succeeds.-  shouldApplyInPartialOrder :: Mock fun params -> [input] -> IO ()+  shouldApplyInPartialOrder :: HasCallStack => Mock fun params -> [input] -> IO ()  instance (Eq a, Show a) => VerifyOrder (Param a) a where   shouldApplyInOrder v a = verifyOrder ExactlySequence v $ param <$> a@@ -622,7 +657,7 @@   VerifyFailed $     intercalate       "\n"-      [ "Expected arguments were not applied to the function" <> mockNameLabel name <> " in the expected order.",+      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order.",         "  expected order:",         intercalate "\n" $ ("    " <>) . show <$> expectedValues,         "  but got:",@@ -646,7 +681,7 @@   VerifyFailed $     intercalate       "\n"-      [ "Expected arguments were not applied to the function" <> mockNameLabel name <> " in the expected order (count mismatch).",+      [ "function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order (count mismatch).",         "  expected: " <> show (length expectedValues),         "   but got: " <> show (length appliedValues)       ]@@ -656,7 +691,7 @@   VerifyFailed $     intercalate       "\n"-      ( ("Expected arguments were not applied to the function" <> mockNameLabel name <> " in the expected order.") : (verifyOrderFailedMesssage <$> fails)+      ( ("function" <> mockNameLabel name <> " was not applied to the expected arguments in the expected order.") : (verifyOrderFailedMesssage <$> fails)       )  verifyOrderFailedMesssage :: Show a => VerifyOrderResult a -> String@@ -694,6 +729,7 @@ mapWithIndex :: (Int -> a -> b) -> [a] -> [b] mapWithIndex f xs = [f i x | (i, x) <- zip [0 ..] xs] +-- | Verify that the function has been applied to the expected arguments at least the expected number of times. shouldApplyTimesGreaterThanEqual ::   VerifyCount CountVerifyMethod params a =>   Eq params =>@@ -703,6 +739,7 @@   IO () shouldApplyTimesGreaterThanEqual m i = shouldApplyTimes m (GreaterThanEqual i) +-- | Verify that the function is applied to the expected arguments less than or equal to the expected number of times. shouldApplyTimesLessThanEqual ::   VerifyCount CountVerifyMethod params a =>   Eq params =>@@ -712,6 +749,7 @@   IO () shouldApplyTimesLessThanEqual m i = shouldApplyTimes m (LessThanEqual i) +-- | Verify that the function has been applied to the expected arguments a greater number of times than expected. shouldApplyTimesGreaterThan ::   VerifyCount CountVerifyMethod params a =>   Eq params =>@@ -721,6 +759,7 @@   IO () shouldApplyTimesGreaterThan m i = shouldApplyTimes m (GreaterThan i) +-- | Verify that the function has been applied to the expected arguments less than the expected number of times. shouldApplyTimesLessThan ::   VerifyCount CountVerifyMethod params a =>   Eq params =>@@ -730,8 +769,6 @@   IO () shouldApplyTimesLessThan m i = shouldApplyTimes m (LessThan i) -- type AppliedParamsList params = [params] type AppliedParamsCounter params = AssociationList params Int @@ -780,3 +817,23 @@ safeIndex xs n   | n < 0 = Nothing   | otherwise = listToMaybe (drop n xs)++-- | Verify that it was apply to anything.+shouldApplyToAnything :: HasCallStack => Mock fun params -> IO ()+shouldApplyToAnything (Mock name _ (Verifier ref)) = do+  appliedParamsList <- readAppliedParamsList ref+  when (null appliedParamsList) $ error $ "It has never been applied function" <> mockNameLabel name++-- | Verify that it was apply to anything (times).+shouldApplyTimesToAnything :: Mock fun params -> Int -> IO ()+shouldApplyTimesToAnything (Mock name _ (Verifier ref)) count = do+  appliedParamsList <- readAppliedParamsList ref+  let appliedCount = length appliedParamsList+  when (count /= appliedCount) $ +        errorWithoutStackTrace $+        intercalate+          "\n"+          [ "function" <> mockNameLabel name <> " was not applied the expected number of times.",+            "  expected: " <> show count,+            "   but got: " <> show appliedCount+          ]

@@ -0,0 +1,112 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Test.MockCat.MockT (MockT(..), Definition(..), runMockT, applyTimesIs, neverApply) where+import Control.Monad.State+import GHC.TypeLits (KnownSymbol)+import Data.Data (Proxy)+import Test.MockCat.Mock (Mock, shouldApplyTimesToAnything)+import Data.Foldable (for_)++newtype MockT m a = MockT { st :: StateT [Definition] m a }+  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)++data Definition = forall f p sym. KnownSymbol sym => Definition {+  symbol :: Proxy sym,+  mock :: Mock f p,+  verify :: Mock f p -> IO ()+}++{- | Run MockT monad.+  After run, verification is performed to see if the stub function has been applied.++  @+  import Test.Hspec+  import Test.MockCat+  ...++  class (Monad m) => FileOperation m where+    writeFile :: FilePath -\> Text -\> m ()+    readFile :: FilePath -\> m Text++  operationProgram ::+    FileOperation m =\>+    FilePath -\>+    FilePath -\>+    m ()+  operationProgram inputPath outputPath = do+    content \<- readFile inputPath+    writeFile outputPath content++  makeMock [t|FileOperation|]++  spec :: Spec+  spec = do+    it "test runMockT" do+      result \<- runMockT do+        _readFile $ "input.txt" |\> pack "content"+        _writeFile $ "output.text" |\> pack "content" |\> ()+        operationProgram "input.txt" "output.text"++      result `shouldBe` ()+  @++-}+runMockT :: MonadIO m => MockT m a -> m a+runMockT (MockT s) = do+  r <- runStateT s []+  let+    !a = fst r+    defs = snd r+  for_ defs (\(Definition _ m v) -> liftIO $ v m)+  pure a++{- | Specify how many times a stub function should be applied.++  @+  import Test.Hspec+  import Test.MockCat+  ...++  class (Monad m) => FileOperation m where+    writeFile :: FilePath -\> Text -\> m ()+    readFile :: FilePath -\> m Text++  operationProgram ::+    FileOperation m =>+    FilePath ->+    FilePath ->+    m ()+  operationProgram inputPath outputPath = do+    content <- readFile inputPath+    when (content == pack "ng") $ writeFile outputPath content++  makeMock [t|FileOperation|]++  spec :: Spec+  spec = do+    it "test runMockT" do+      result <- runMockT do+        _readFile ("input.txt" |> pack "content")+        _writeFile ("output.text" |> pack "content" |> ()) `applyTimesIs` 0+        operationProgram "input.txt" "output.text"++      result `shouldBe` ()++  @++-}+applyTimesIs :: Monad m => MockT m () -> Int -> MockT m ()+applyTimesIs (MockT st) a = MockT do+  defs <- lift $ execStateT st []+  let newDefs = map (\(Definition s m _) -> Definition s m (`shouldApplyTimesToAnything` a)) defs+  modify (++ newDefs)++neverApply :: Monad m => MockT m () -> MockT m ()+neverApply (MockT st) = MockT do+  defs <- lift $ execStateT st []+  let newDefs = map (\(Definition s m _) -> Definition s m (`shouldApplyTimesToAnything` 0)) defs+  modify (++ newDefs)

@@ -14,20 +14,17 @@ -- -- This parameter can be used when creating and verifying the mock. module Test.MockCat.Param-  ( Param,+  ( Param(..),     value,     param,     (|>),     expect,     expect_,-    expectByExpr,     any   ) where -import Language.Haskell.TH import Test.MockCat.Cons ((:>) (..))-import Test.MockCat.TH import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (any) @@ -105,14 +102,3 @@ -} expect_ :: (a -> Bool) -> Param a expect_ f = ExpectCondition f "[some condition]"--{- | Create a conditional parameter based on @Q Exp@. --  In applying a mock function, if the argument does not satisfy this condition, an error is raised.--  The conditional expression is displayed in the error message.--}-expectByExpr :: Q Exp -> Q Exp-expectByExpr qf = do-  str <- showExp qf-  [|ExpectCondition $qf str|]

@@ -1,10 +1,51 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-local-binds #-} -module Test.MockCat.TH (showExp) where+module Test.MockCat.TH (showExp, expectByExpr, makeMock, makeMockWithOptions, MockOptions(..), options) where -import Language.Haskell.TH (Exp (..), Lit (..), Pat (..), Q, pprint)+import Language.Haskell.TH+    ( Exp(..),+      Lit(..),+      Pat(..),+      Q,+      pprint,+      Name,+      Dec(..),+      Info(..),+      reify,+      mkName,+      Type(..),+      Quote(newName),+      Cxt,+      TyVarBndr(..),+      Pred,+      isExtEnabled,+      Extension(..) ) import Language.Haskell.TH.PprLib (Doc, hcat, parens, text) import Language.Haskell.TH.Syntax (nameBase)+import Test.MockCat.Param (Param(..))+import Test.MockCat.Cons ((:>))+import Test.MockCat.MockT+import Data.Data (Proxy(..))+import Data.List (find, nub, elemIndex)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Unsafe.Coerce (unsafeCoerce)+import Control.Monad.State (modify, get)+import Data.Maybe (fromMaybe, isJust)+import GHC.IO (unsafePerformIO)+import Language.Haskell.TH.Lib+import Data.Text (splitOn, unpack, pack)+import Test.MockCat.Mock (MockBuilder)+import Control.Monad (guard, unless)+import Data.Function ((&))  showExp :: Q Exp -> Q String showExp qexp = show . pprintExp <$> qexp@@ -45,3 +86,411 @@ pprintLit (StringL s) = text (show s) pprintLit (CharL c) = text (show c) pprintLit l = text (pprint l)++{- | Create a conditional parameter based on @Q Exp@. ++  In applying a mock function, if the argument does not satisfy this condition, an error is raised.++  The conditional expression is displayed in the error message.+-}+expectByExpr :: Q Exp -> Q Exp+expectByExpr qf = do+  str <- showExp qf+  [|ExpectCondition $qf str|]++{- | Options for generating mocks. ++  - prefix: Stub function prefix+  - suffix: stub function suffix+-}+data MockOptions = MockOptions { prefix :: String, suffix :: String }++{- | Default Options.++  Stub function names are prefixed with “_”.+-}+options :: MockOptions+options = MockOptions { prefix = "_", suffix = "" }++{- | Create a mock of the typeclasses that returns a monad according to the `MockOptions`. ++  Given a monad type class, generate the following.++  - MockT instance of the given typeclass+  - A stub function corresponding to a function of the original class type.+The name of stub function is the name of the original function with a “_” appended.++  @+  class (Monad m) => FileOperation m where+    writeFile :: FilePath -\> Text -\> m ()+    readFile :: FilePath -\> m Text++  makeMockWithOptions [t|FileOperation|] options { prefix = "stub_" }++  it "test runMockT" do+    result \<- runMockT do+      stub_readFile $ "input.txt" |\> pack "content"+      stub_writeFile $ "output.text" |\> pack "content" |\> ()+      somethingProgram++    result `shouldBe` ()+  @++-}+makeMockWithOptions :: Q Type -> MockOptions -> Q [Dec]+makeMockWithOptions = doMakeMock++{- | Create a mock of a typeclasses that returns a monad. ++  Given a monad type class, generate the following.++  - MockT instance of the given typeclass+  - A stub function corresponding to a function of the original class type.+The name of stub function is the name of the original function with a “_” appended.++  The prefix can be changed.+  In that case, use `makeMockWithOptions`.++  @+  class (Monad m) => FileOperation m where+    writeFile :: FilePath -\> Text -\> m ()+    readFile :: FilePath -\> m Text++  makeMock [t|FileOperation|]++  it "test runMockT" do+    result \<- runMockT do+      _readFile $ "input.txt" |\> pack "content"+      _writeFile $ "output.text" |\> pack "content" |\> ()+      somethingProgram++    result `shouldBe` ()+  @++-}+makeMock :: Q Type -> Q [Dec]+makeMock = flip doMakeMock options++doMakeMock :: Q Type -> MockOptions -> Q [Dec]+doMakeMock t options = do+  verifyExtension DataKinds+  verifyExtension FlexibleInstances+  verifyExtension FlexibleContexts++  ty <- t+  className <- getClassName <$> t++  reify className >>= \case+    ClassI (ClassD _ _ [] _ _) _ ->+      fail $ "A type parameter is required for class " <> show className++    ClassI (ClassD cxt _ typeVars _ decs) _ -> do+      monadVarNames <- getMonadVarNames cxt typeVars+      case nub monadVarNames of+        [] -> fail "Monad parameter not found."+        (monadVarName : rest)+          | length rest > 1 -> fail "Monad parameter must be unique."+          | otherwise -> makeMockDecs ty className monadVarName cxt typeVars decs options++    t -> error $ "unsupported type: " <> show t+++makeMockDecs :: Type -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec]+makeMockDecs ty className monadVarName cxt typeVars decs options = do+  let classParamNames = filter (className /=) (getClassNames ty)+      newTypeVars = drop (length classParamNames) typeVars+      varAppliedTypes = zipWith (\t i -> VarAppliedType t (safeIndex classParamNames i)) (getTypeVarNames typeVars) [0..]++  newCxt <- createCxt monadVarName cxt+  m <- appT (conT ''Monad) (varT monadVarName)++  let hasMonad = any (\(ClassName2VarNames c _) -> c == ''Monad) $ toClassInfos newCxt++  instanceDec <- instanceD+    (pure $ newCxt ++ ([m | not hasMonad]))+    (createInstanceType ty monadVarName newTypeVars)+    (map (createInstanceFnDec options) decs)++  mockFnDecs <- concat <$> mapM (createMockFnDec monadVarName varAppliedTypes options) decs++  pure $ instanceDec : mockFnDecs++getMonadVarNames :: Cxt -> [TyVarBndr a] -> Q [Name]+getMonadVarNames cxt typeVars = do+  let+    parentClassInfos = toClassInfos cxt++    typeVarNames = getTypeVarNames typeVars+    -- VarInfos (class names is empty)+    emptyClassVarInfos = map (`VarName2ClassNames` []) typeVarNames++  varInfos <- collectVarInfos parentClassInfos emptyClassVarInfos++  pure $ (\(VarName2ClassNames n _) -> n) <$> filterMonadicVarInfos varInfos++getTypeVarNames :: [TyVarBndr a] -> [Name]+getTypeVarNames = map getTypeVarName++getTypeVarName :: TyVarBndr a -> Name+getTypeVarName (PlainTV name _) = name+getTypeVarName (KindedTV name _ _) = name++toClassInfos :: Cxt -> [ClassName2VarNames]+toClassInfos = map toClassInfo++toClassInfo :: Pred -> ClassName2VarNames+toClassInfo (AppT t1 t2) = do+  let (ClassName2VarNames name vars) = toClassInfo t1+  ClassName2VarNames name (vars ++ getTypeNames t2)+toClassInfo (ConT name) = ClassName2VarNames name []+toClassInfo _ = error "Unsupported Type structure"++getTypeNames :: Pred -> [Name]+getTypeNames (VarT name) = [name]+getTypeNames (ConT name) = [name]+getTypeNames _ = []++collectVarInfos :: [ClassName2VarNames] -> [VarName2ClassNames] -> Q [VarName2ClassNames]+collectVarInfos classInfos = mapM (collectVarInfo classInfos)++collectVarInfo :: [ClassName2VarNames] -> VarName2ClassNames -> Q VarName2ClassNames+collectVarInfo classInfos (VarName2ClassNames vName classNames) =  do+  varClassNames <- collectVarClassNames vName classInfos+  pure $ VarName2ClassNames vName (classNames ++ varClassNames)++collectVarClassNames :: Name -> [ClassName2VarNames] -> Q [Name]+collectVarClassNames varName classInfos = do+  let targetClassInfos = filterClassInfo varName classInfos+  concat <$> mapM (collectVarClassNames_ varName) targetClassInfos++collectVarClassNames_ :: Name -> ClassName2VarNames -> Q [Name]+collectVarClassNames_ name (ClassName2VarNames cName vNames) = do+  case elemIndex name vNames of+    Nothing -> pure []+    Just i -> do+      ClassI (ClassD cxt _ typeVars _ _) _ <- reify cName+      let+        -- type variable names+        typeVarNames = getTypeVarNames typeVars+        -- type variable name of same position+        typeVarName = typeVarNames !! i+        -- parent class information+        parentClassInfos = toClassInfos cxt++      case parentClassInfos of+        [] -> pure [cName]+        _ -> do+          result <- concat <$> mapM (collectVarClassNames_ typeVarName) parentClassInfos+          pure $ cName : result++filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames]+filterClassInfo name = filter (hasVarName name)+  where+  hasVarName :: Name -> ClassName2VarNames -> Bool+  hasVarName name (ClassName2VarNames _ varNames) = name `elem` varNames++filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames]+filterMonadicVarInfos = filter hasMonadInVarInfo++hasMonadInVarInfo :: VarName2ClassNames -> Bool+hasMonadInVarInfo (VarName2ClassNames _ classNames) = ''Monad `elem` classNames++createCxt :: Name -> Cxt -> Q Cxt+createCxt monadVarName = mapM (createPred monadVarName)++createPred :: Name -> Pred -> Q Pred+createPred monadVarName a@(AppT t@(ConT ty) b@(VarT varName))+  | monadVarName == varName && ty == ''Monad = pure a+  | monadVarName == varName && ty /= ''Monad = appT (pure t) (appT (conT ''MockT) (varT varName))+  | otherwise = appT (createPred monadVarName t) (pure b)+createPred monadVarName (AppT ty a@(VarT varName))+  | monadVarName == varName = appT (pure ty) (appT (conT ''MockT) (varT varName))+  | otherwise = appT (createPred monadVarName ty) (pure a)+createPred monadVarName (AppT ty1 ty2) = appT (createPred monadVarName ty1) (createPred monadVarName ty2)+createPred _ ty = pure ty++createInstanceType :: Type -> Name -> [TyVarBndr a] -> Q Type+createInstanceType className monadName tvbs = do+  types <- mapM (tyVarBndrToType monadName) tvbs+  pure $ foldl AppT className types++tyVarBndrToType :: Name -> TyVarBndr a -> Q Type+tyVarBndrToType monadName (PlainTV name _)+  | monadName == name = appT (conT ''MockT) (varT monadName)+  | otherwise = varT name+tyVarBndrToType monadName (KindedTV name _ _)+  | monadName == name = appT (conT ''MockT) (varT monadName)+  | otherwise = varT name++createInstanceFnDec :: MockOptions -> Dec -> Q Dec+createInstanceFnDec options (SigD fnName funType) = do+  names <- sequence $ typeToNames funType+  let r = mkName "result"+      params = varP <$> names+      args = varE <$> names+      fnNameStr = createFnName fnName options+      genStubFn = case names of+        [] -> $([|generateConstantStubFn|])+        _  -> $([|generateStubFn args|])++      fnBody = [| MockT $ do+                    defs <- get+                    let mock = defs+                               & findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr)))+                               & fromMaybe (error $ "no answer found stub function `" ++ fnNameStr ++ "`.")+                        $(bangP $ varP r) = $(genStubFn [| mock |])+                    pure $(varE r) |]+      fnClause = clause params (normalB fnBody) []+  funD fnName [fnClause]+createInstanceFnDec _ dec = fail $ "unsuported dec: " <> pprint dec++generateStubFn :: [Q Exp] -> Q Exp -> Q Exp+generateStubFn args mock = foldl appE [| stubFn $(mock) |] args++generateConstantStubFn :: Q Exp -> Q Exp+generateConstantStubFn mock = [| stubFn $(mock) |]++createMockFnDec :: Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]+createMockFnDec monadVarName varAppliedTypes options (SigD funName ty) = do+  let funNameStr = createFnName funName options+      mockFunName = mkName funNameStr+      params = mkName "p"++  if isConstant ty then+    doCreateConstantMockFnDec funNameStr mockFunName params monadVarName+  else do+    let+      updatedType = updateType ty varAppliedTypes+      funType = createMockBuilderFnType monadVarName updatedType+    doCreateMockFnDec funNameStr mockFunName params funType monadVarName updatedType++createMockFnDec _ _ _ dec = fail $ "unsupport dec: " <> pprint dec++doCreateMockFnDec :: Quote m => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]+doCreateMockFnDec funNameStr mockFunName params funType monadVarName updatedType = do+  newFunSig <- do+    let verifyParams = createMockBuilderVerifyParams updatedType+    sigD mockFunName [t|+      (MockBuilder $(varT params) ($(pure funType)) ($(pure verifyParams)), Monad $(varT monadVarName))+      => $(varT params) -> MockT $(varT monadVarName) ()|]++  createMockFn <- [|createNamedMock|]++  mockBody <- createMockBody funNameStr createMockFn+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]++  pure $ newFunSig : [newFun]++doCreateConstantMockFnDec :: Quote m => String -> Name -> Name -> Name -> m [Dec]+doCreateConstantMockFnDec funNameStr mockFunName params monadVarName = do+  newFunSig <- sigD mockFunName [t|Monad $(varT monadVarName) => $(varT params) -> MockT $(varT monadVarName) ()|]+  createMockFn <- [|createNamedConstantMock|]+  mockBody <- createMockBody funNameStr createMockFn+  newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []]+  pure $ newFunSig : [newFun]++createMockBody :: Quote m => String -> Exp -> m Exp+createMockBody funNameStr createMockFn =+  [| MockT $ modify (++ [Definition+                    (Proxy :: Proxy $(litT (strTyLit funNameStr)))+                    (unsafePerformIO $ $(pure createMockFn) $(litE (stringL funNameStr)) p)+                    shouldApplyToAnything]) |]++isConstant :: Type -> Bool+isConstant (AppT (VarT _) (VarT _)) = True+isConstant (VarT _) = True+isConstant (ConT _) = True+isConstant _ = False++updateType :: Type -> [VarAppliedType] -> Type+updateType (AppT (VarT v1) (VarT v2)) varAppliedTypes = do+  let+    x = maybe (VarT v1) ConT (findClass v1 varAppliedTypes)+    y = maybe (VarT v2) ConT (findClass v2 varAppliedTypes)+  AppT x y+updateType ty _ = ty++hasClass :: Name -> [VarAppliedType] -> Bool+hasClass varName = any (\(VarAppliedType v c) -> (v == varName) && isJust c)++findClass :: Name -> [VarAppliedType] -> Maybe Name+findClass varName types = do+  guard $ hasClass varName types+  (VarAppliedType _ c) <- find (\(VarAppliedType v _) -> v == varName) types+  c++createFnName :: Name -> MockOptions -> String+createFnName funName options = do+  options.prefix <> nameBase funName <> options.suffix++createMockBuilderFnType :: Name -> Type -> Type+createMockBuilderFnType monadVarName a@(AppT (VarT var) ty)+  | monadVarName == var = ty+  | otherwise = a+createMockBuilderFnType monadVarName (AppT ty ty2) = AppT ty (createMockBuilderFnType monadVarName ty2)+createMockBuilderFnType monadVarName (ForallT _ _ ty) = createMockBuilderFnType monadVarName ty+createMockBuilderFnType _ ty = ty++createMockBuilderVerifyParams :: Type -> Type+createMockBuilderVerifyParams (AppT (AppT ArrowT ty) (AppT (VarT _) _)) = AppT (ConT ''Param) ty+createMockBuilderVerifyParams (AppT (AppT ArrowT ty) ty2) =+  AppT (AppT (ConT ''(:>)) (AppT (ConT ''Param) ty) ) (createMockBuilderVerifyParams ty2)+createMockBuilderVerifyParams (AppT (VarT _) (ConT c)) = AppT (ConT ''Param) (ConT c)+createMockBuilderVerifyParams (ForallT _ _ ty) = createMockBuilderVerifyParams ty+createMockBuilderVerifyParams a = a++findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a+findParam pa definitions = do+  let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions+  fmap (\(Definition _ mock _) -> unsafeCoerce mock) definition++typeToNames :: Type -> [Q Name]+typeToNames (AppT (AppT ArrowT _) t2) = newName "a" : typeToNames t2+typeToNames (ForallT _ _ ty) = typeToNames ty+typeToNames _ = []++getClassName :: Type -> Name+getClassName (ConT name) = name+getClassName (AppT ty _) = getClassName ty+getClassName d = error $ "unsupported class definition: " <> show d++getClassNames :: Type -> [Name]+getClassNames (AppT (ConT name1) (ConT name2)) = [name1, name2]+getClassNames (AppT ty (ConT name)) = getClassNames ty ++ [name]+getClassNames (AppT ty1 ty2) = getClassNames ty1 ++ getClassNames ty2+getClassNames _ = []++data ClassName2VarNames = ClassName2VarNames Name [Name]++instance Show ClassName2VarNames where+  show (ClassName2VarNames cName varNames) = showClassDef cName varNames++data VarName2ClassNames = VarName2ClassNames Name [Name]++instance Show VarName2ClassNames where+  show (VarName2ClassNames varName classNames) = show varName <> " class is " <> unwords (showClassName <$> classNames)++data VarAppliedType = VarAppliedType { name :: Name, appliedClassName :: Maybe Name }+  deriving (Show)++showClassName :: Name -> String+showClassName n = splitLast "." $ show n++showClassDef :: Name -> [Name] -> String+showClassDef className varNames = showClassName className <> " " <> unwords (show <$> varNames)++splitLast :: String -> String -> String+splitLast delimiter = last . split delimiter++split :: String -> String -> [String]+split delimiter str = unpack <$> splitOn (pack delimiter) (pack str)++safeIndex :: [a] -> Int -> Maybe a+safeIndex [] _ = Nothing+safeIndex (x:_) 0 = Just x+safeIndex (_:xs) n+  | n < 0     = Nothing+  | otherwise = safeIndex xs (n - 1)++verifyExtension :: Extension -> Q ()+verifyExtension e = isExtEnabled e >>= flip unless (fail $ "Language extensions `" ++ show e ++ "` is required.")

@@ -4,6 +4,8 @@ import Test.MockCat.ParamSpec as Param import Test.MockCat.AssociationListSpec as AssociationList import Test.MockCat.ExampleSpec as Example+import Test.MockCat.TypeClassSpec as TypeClass+import Test.MockCat.TypeClassTHSpec as TypeClassTH  main :: IO () main = do@@ -13,3 +15,5 @@     Mock.spec     AssociationList.spec     Example.spec+    TypeClass.spec+    TypeClassTH.spec

@@ -1,16 +1,44 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}  module Test.MockCat.ExampleSpec (spec) where  import Test.Hspec import Test.MockCat-import Prelude hiding (and, any, not, or)+import Prelude hiding (writeFile, readFile, and, any, not, or) import GHC.IO (evaluate)+import Data.Text hiding (any) +class (Monad m) => FileOperation m where+  writeFile :: FilePath -> Text -> m ()+  readFile :: FilePath -> m Text++makeMock [t|FileOperation|]++operationProgram ::+  FileOperation m =>+  FilePath ->+  FilePath ->+  m ()+operationProgram inputPath outputPath = do+  content <- readFile inputPath+  writeFile outputPath content+ spec :: Spec spec = do+  it "" do+    result <- runMockT do+      _readFile $ "input.txt" |> pack "Content"+      _writeFile $ "output.text" |> pack "Content" |> ()+      operationProgram "input.txt" "output.text"++    result `shouldBe` ()+   it "stub & verify" do     -- create a mock     mock <- createMock $ "value" |> True@@ -68,15 +96,15 @@     f "something" `shouldBe` "return value"    it "expect" do-    f <- createStubFn $ expect (> 5) "> 5" |> "return value"+    f <- createStubFn $ expect (> (5 :: Int)) "> 5" |> "return value"     f 6 `shouldBe` "return value"    it "expect_" do-    f <- createStubFn $ expect_ (> 5) |> "return value"+    f <- createStubFn $ expect_ (> (5 :: Int)) |> "return value"     f 6 `shouldBe` "return value"    it "expectByExpr" do-    f <- createStubFn $ $(expectByExpr [|(> 5)|]) |> "return value"+    f <- createStubFn $ $(expectByExpr [|(> (5 :: Int))|]) |> "return value"     f 6 `shouldBe` "return value"    it "multi" do

@@ -14,7 +14,7 @@ import qualified Control.Exception as E import Data.Function ((&)) import Test.Hspec-import Test.MockCat.Mock+import Test.MockCat   ( any,     expectByExpr,     stubFn,@@ -26,11 +26,14 @@     shouldApplyTimesLessThan,     shouldApplyTimesLessThanEqual,     shouldApplyTo,+    shouldApplyToAnything,     createMock,     createStubFn,     createNamedMock,     to,-    (|>)+    (|>), +    createConstantMock,+    createNamedConstantMock   ) import Prelude hiding (any) @@ -43,7 +46,7 @@         f True `shouldBe` False        it "arity = 2" do-        f <- createStubFn $ True |> False |> True +        f <- createStubFn $ True |> False |> True         f True False `shouldBe` True        it "arity = 3" do@@ -86,6 +89,7 @@           applyFailed = Just (`stubFn` "x"),           expected = False,           verifyApply = (`shouldApplyTo` "a"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = (`shouldApplyTo` "2"),           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` "a"         }@@ -98,6 +102,7 @@           applyFailed = Just (\m -> stubFn m "a" "x"),           expected = True,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "2" |> "b",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b")         }@@ -110,6 +115,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "x"),           expected = False,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "d",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c")         }@@ -122,6 +128,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "x"),           expected = True,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "x",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d")         }@@ -134,6 +141,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "x"),           expected = False,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "x",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e")         }@@ -146,6 +154,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "x"),           expected = True,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "x",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f")         }@@ -158,6 +167,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "x"),           expected = False,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "y",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g")         }@@ -170,6 +180,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "x"),           expected = False,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "x",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h")         }@@ -182,6 +193,7 @@           applyFailed = Just (\m -> stubFn m "a" "b" "c" "d" "e" "f" "g" "h" "x"),           expected = False,           verifyApply = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "i",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = \m -> shouldApplyTo m $ "a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "x",           verifyApplyCount = \m c -> m `shouldApplyTimes` c `to` ("a" |> "b" |> "c" |> "d" |> "e" |> "f" |> "g" |> "h" |> "i")         }@@ -204,6 +216,7 @@           verifyApply = \m -> do             m `shouldApplyTo` "1"             m `shouldApplyTo` "2",+          verifyApplyAny = shouldApplyToAnything,           verifyApplyFailed = (`shouldApplyTo` "3"),           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` "1"@@ -230,6 +243,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2")             m `shouldApplyTo` ("2" |> "3"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2")             m `shouldApplyTimes` c `to` ("2" |> "3"),@@ -256,6 +270,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3")             m `shouldApplyTo` ("2" |> "3" |> "4"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4"),@@ -282,6 +297,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5"),@@ -308,6 +324,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6"),@@ -334,6 +351,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7"),@@ -360,6 +378,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8"),@@ -386,6 +405,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9"),@@ -412,6 +432,7 @@           verifyApply = \m -> do             m `shouldApplyTo` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9")             m `shouldApplyTo` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "10"),+          verifyApplyAny = shouldApplyToAnything,           verifyApplyCount = \m c -> do             m `shouldApplyTimes` c `to` ("1" |> "2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9")             m `shouldApplyTimes` c `to` ("2" |> "3" |> "4" |> "5" |> "6" |> "7" |> "8" |> "9" |> "10"),@@ -610,7 +631,7 @@           m <- createMock $ "a" |> pure @IO True           stubFn m "b"             `shouldThrow` errorCall-              "Expected arguments were not applied to the function.\n\+              "function was not applied to the expected arguments.\n\               \  expected: \"a\"\n\               \   but got: \"b\"" @@ -622,7 +643,7 @@               ]           stubFn m "aaa" 200             `shouldThrow` errorCall-              "Expected arguments were not applied to the function.\n\+              "function was not applied to the expected arguments.\n\               \  expected one of the following:\n\               \    \"aaa\",100\n\               \    \"bbb\",200\n\@@ -635,7 +656,7 @@           evaluate $ stubFn m "A"           m `shouldApplyTo` "X"             `shouldThrow` errorCall-              "Expected arguments were not applied to the function.\n\+              "function was not applied to the expected arguments.\n\               \  expected: \"X\"\n\               \   but got: \"A\"" @@ -643,7 +664,7 @@           m <- createMock $ "X" |> pure @IO True           m `shouldApplyTo` "X"             `shouldThrow` errorCall-              "Expected arguments were not applied to the function.\n\+              "function was not applied to the expected arguments.\n\               \  expected: \"X\"\n\               \   but got: It has never been applied" @@ -651,7 +672,7 @@           m <- createMock $ any |> pure @IO True           evaluate $ stubFn m "A"           let e =-                "The expected argument was not applied the expected number of times to the function.\n\+                "function was not applied the expected number of times to the expected arguments.\n\                 \  expected: 2\n\                 \   but got: 1"           m `shouldApplyTimes` (2 :: Int) `to` "A" `shouldThrow` errorCall e@@ -662,7 +683,7 @@           evaluate $ stubFn m "C"           evaluate $ stubFn m "A"           let e =-                "Expected arguments were not applied to the function in the expected order.\n\+                "function was not applied to the expected arguments in the expected order.\n\                 \  expected 1st applied: \"A\"\n\                 \   but got 1st applied: \"B\"\n\                 \  expected 2nd applied: \"B\"\n\@@ -676,7 +697,7 @@           evaluate $ stubFn m "B"           evaluate $ stubFn m "C"           let e =-                "Expected arguments were not applied to the function in the expected order (count mismatch).\n\+                "function was not applied to the expected arguments in the expected order (count mismatch).\n\                 \  expected: 3\n\                 \   but got: 2"           m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e@@ -686,7 +707,7 @@           evaluate $ stubFn m "B"           evaluate $ stubFn m "A"           let e =-                "Expected arguments were not applied to the function in the expected order.\n\+                "function was not applied to the expected arguments in the expected order.\n\                 \  expected order:\n\                 \    \"A\"\n\                 \    \"C\"\n\@@ -699,17 +720,21 @@           m <- createMock $ any |> False           evaluate $ stubFn m "B"           let e =-                "Expected arguments were not applied to the function in the expected order (count mismatch).\n\+                "function was not applied to the expected arguments in the expected order (count mismatch).\n\                 \  expected: 2\n\                 \   but got: 1"           m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e +        it "verify applied anything" do+          m <- createMock $ "X" |> True+          shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function"+     describe "named mock" do       describe "aply" do         it "simple mock" do           m <- createNamedMock "mock function" $ "a" |> pure @IO ()           let e =-                "Expected arguments were not applied to the function `mock function`.\n\+                "function `mock function` was not applied to the expected arguments.\n\                 \  expected: \"a\"\n\                 \   but got: \"b\""           stubFn m "b" `shouldThrow` errorCall e@@ -722,7 +747,7 @@                 "bbb" |> False |> pure @IO False               ]           let e =-                "Expected arguments were not applied to the function `mock function`.\n\+                "function `mock function` was not applied to the expected arguments.\n\                 \  expected one of the following:\n\                 \    \"aaa\",True\n\                 \    \"bbb\",False\n\@@ -735,7 +760,7 @@           m <- createNamedMock "mock function" $ any |> pure @IO ()           evaluate $ stubFn m "A"           let e =-                "Expected arguments were not applied to the function `mock function`.\n\+                "function `mock function` was not applied to the expected arguments.\n\                 \  expected: \"X\"\n\                 \   but got: \"A\""           m `shouldApplyTo` "X" `shouldThrow` errorCall e@@ -744,7 +769,7 @@           m <- createNamedMock "mock function" $ any |> pure @IO ()           evaluate $ stubFn m "A"           let e =-                "The expected argument was not applied the expected number of times to the function `mock function`.\n\+                "function `mock function` was not applied the expected number of times to the expected arguments.\n\                 \  expected: 2\n\                 \   but got: 1"           m `shouldApplyTimes` (2 :: Int) `to` "A" `shouldThrow` errorCall e@@ -755,7 +780,7 @@           evaluate $ stubFn m "C"           evaluate $ stubFn m "A"           let e =-                "Expected arguments were not applied to the function `mock function` in the expected order.\n\+                "function `mock function` was not applied to the expected arguments in the expected order.\n\                 \  expected 1st applied: \"A\"\n\                 \   but got 1st applied: \"B\"\n\                 \  expected 2nd applied: \"B\"\n\@@ -769,7 +794,7 @@           evaluate $ stubFn m "B"           evaluate $ stubFn m "C"           let e =-                "Expected arguments were not applied to the function `createStubFnc` in the expected order (count mismatch).\n\+                "function `createStubFnc` was not applied to the expected arguments in the expected order (count mismatch).\n\                 \  expected: 3\n\                 \   but got: 2"           m `shouldApplyInOrder` ["A", "B", "C"] `shouldThrow` errorCall e@@ -779,7 +804,7 @@           evaluate $ stubFn m "B"           evaluate $ stubFn m "A"           let e =-                "Expected arguments were not applied to the function `mock function` in the expected order.\n\+                "function `mock function` was not applied to the expected arguments in the expected order.\n\                 \  expected order:\n\                 \    \"A\"\n\                 \    \"C\"\n\@@ -792,16 +817,20 @@           m <- createNamedMock "createStubFnc" $ any |> pure @IO ()           evaluate $ stubFn m "B"           let e =-                "Expected arguments were not applied to the function `createStubFnc` in the expected order (count mismatch).\n\+                "function `createStubFnc` was not applied to the expected arguments in the expected order (count mismatch).\n\                 \  expected: 2\n\                 \   but got: 1"           m `shouldApplyInPartialOrder` ["A", "C"] `shouldThrow` errorCall e +        it "verify applied anything" do+          m <- createNamedMock "mock" $ "X" |> True+          shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function `mock`"+   describe "use expectation" do     it "expectByExpr" do       f <- createStubFn $ $(expectByExpr [|\x -> x == "y" || x == "z"|]) |> True       f "y" `shouldBe` True-  +   describe "repeatable" do     it "arity = 1" do       f <- createStubFn [@@ -837,6 +866,25 @@       v4 `shouldBe` (3 :: Int)       v5 `shouldBe` (2 :: Int) +  describe "constant" do+    it "createConstantMock" do+      m <- createConstantMock "foo"+      stubFn m `shouldBe` "foo"+      shouldApplyToAnything m++    it "createNamedConstantMock" do+      m <- createNamedConstantMock "const" "foo"+      stubFn m `shouldBe` "foo"+      shouldApplyToAnything m++    it "createConstantMock (error message)" do+      m <- createConstantMock "foo"+      shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function"++    it "createNamedConstantMock (error message)" do+      m <- createNamedConstantMock "constant" "foo"+      shouldApplyToAnything m `shouldThrow` errorCall "It has never been applied function `constant`"+ data Fixture mock r = Fixture   { name :: String,     create :: IO mock,@@ -844,6 +892,7 @@     applyFailed :: Maybe (mock -> r),     expected :: r,     verifyApply :: mock -> IO (),+    verifyApplyAny :: mock -> IO (),     verifyApplyFailed :: mock -> IO (),     verifyApplyCount :: mock -> Int -> IO ()   }@@ -904,6 +953,11 @@     m <- f.create     evaluate $ f.apply m     f.verifyApplyCount m 3 `shouldThrow` anyErrorCall++  it "verify any" do+    m <- f.create+    evaluate $ f.apply m+    f.verifyApplyAny m  mockOrderTest :: VerifyOrderFixture mock r -> SpecWith (Arg Expectation) mockOrderTest f = describe f.name do

@@ -8,6 +8,7 @@ import Test.Hspec import Test.MockCat.Cons import Test.MockCat.Param as P+import Test.MockCat.TH (expectByExpr)  spec :: Spec spec = do

@@ -0,0 +1,121 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Test.MockCat.TypeClassSpec (spec) where++import Data.Text (Text, pack)+import Test.Hspec (Spec, it, shouldBe)+import Test.MockCat+import Prelude hiding (readFile, writeFile)+import Data.Data+import Data.List (find)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Unsafe.Coerce (unsafeCoerce)+import Data.Maybe (fromMaybe)+import GHC.IO (unsafePerformIO)+import Control.Monad.Reader (MonadReader)+import Control.Monad.Reader.Class (ask, MonadReader (local))+import Control.Monad.State++class Monad m => FileOperation m where+  readFile :: FilePath -> m Text+  writeFile :: FilePath -> Text -> m ()++class Monad m => ApiOperation m where+  post :: Text -> m ()++program ::+  (MonadReader String m, FileOperation m, ApiOperation m) =>+  FilePath ->+  FilePath ->+  (Text -> Text) ->+  m ()+program inputPath outputPath modifyText = do+  e <- ask+  content <- readFile inputPath+  let modifiedContent = modifyText content+  writeFile outputPath modifiedContent+  post $ modifiedContent <> pack ("+" <> e)++instance (Monad m) => FileOperation (MockT m) where+  readFile path = MockT do+    defs <- get+    let+      mock = fromMaybe (error "no answer found stub function `readFile`.") $ findParam (Proxy :: Proxy "readFile") defs+      !result = stubFn mock path+    pure result++  writeFile path content = MockT do+    defs <- get+    let+      mock = fromMaybe (error "no answer found stub function `writeFile`.") $ findParam (Proxy :: Proxy "writeFile") defs+      !result = stubFn mock path content+    pure result++instance Monad m => ApiOperation (MockT m) where+  post content = MockT do+    defs <- get+    let+      mock = fromMaybe (error "no answer found stub function `post`.") $ findParam (Proxy :: Proxy "post") defs+      !result = stubFn mock content+    pure result++instance Monad m => MonadReader String (MockT m) where+  ask = MockT do+    defs <- get+    let+      mock = fromMaybe (error "no answer found stub function `ask`.") $ findParam (Proxy :: Proxy "ask") defs+      !result = stubFn mock+    pure result+  local = undefined++_ask :: Monad m => params -> MockT m ()+_ask p = MockT $ do+  modify (++ [Definition+    (Proxy :: Proxy "ask")+    (unsafePerformIO $ createNamedConstantMock "ask" p)+    shouldApplyToAnything])++_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), Monad m) => params -> MockT m ()+_readFile p = MockT $ do+  modify (++ [Definition+    (Proxy :: Proxy "readFile")+    (unsafePerformIO $ createNamedMock "readFile" p)+    shouldApplyToAnything])++_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), Monad m) => params -> MockT m ()+_writeFile p = MockT $ modify (++ [Definition+  (Proxy :: Proxy "writeFile")+  (unsafePerformIO $ createNamedMock "writeFile" p)+  shouldApplyToAnything])++_post :: (MockBuilder params (Text -> ()) (Param Text), Monad m) => params -> MockT m ()+_post p = MockT $ modify (++ [Definition+  (Proxy :: Proxy "post")+  (unsafePerformIO $ createNamedMock "post" p)+  shouldApplyToAnything])++findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a+findParam pa definitions = do+  let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions+  fmap (\(Definition _ mock _) -> unsafeCoerce mock) definition++spec :: Spec+spec = it "Read, edit, and output files" do+  modifyContentStub <- createStubFn $ pack "content" |> pack "modifiedContent"++  result <- runMockT do+    _ask "environment"+    _readFile ("input.txt" |> pack "content")+    _writeFile $ "output.text" |> pack "modifiedContent" |> ()+    _post $ pack "modifiedContent+environment" |> ()+    program "input.txt" "output.text" modifyContentStub++  result `shouldBe` ()

@@ -0,0 +1,180 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Test.MockCat.TypeClassTHSpec (spec) where++import Prelude hiding (readFile, writeFile)+import Data.Text (Text, pack, isInfixOf)+import Test.Hspec+import Test.MockCat as M+import Control.Monad.State+import Control.Monad.Reader (MonadReader, ask)+import Control.Monad (unless)++class Monad m => FileOperation m where+  writeFile :: FilePath -> Text -> m ()+  readFile :: FilePath -> m Text++class Monad m => ApiOperation m where+  post :: Text -> m ()++operationProgram ::+  FileOperation m =>+  FilePath ->+  FilePath ->+  m ()+operationProgram inputPath outputPath = do+  content <- readFile inputPath+  unless (pack "ngWord" `isInfixOf` content) $+    writeFile outputPath content++operationProgram2 ::+  (FileOperation m, ApiOperation m) =>+  FilePath ->+  FilePath ->+  (Text -> Text) ->+  m ()+operationProgram2 inputPath outputPath modifyText = do+  content <- readFile inputPath+  let modifiedContent = modifyText content+  writeFile outputPath modifiedContent+  post modifiedContent++data Environment = Environment { inputPath :: String, outputPath :: String }++operationProgram3 ::+  MonadReader Environment m =>+  FileOperation m =>+  m ()+operationProgram3 = do+  (Environment inputPath outputPath) <- ask+  content <- readFile inputPath+  writeFile outputPath content++class (Eq s, Show s, MonadState s m) => MonadStateSub s m where+  fn_state :: Maybe s -> m s++class (MonadState String m) => MonadStateSub2 s m where+  fn_state2 :: String -> m ()++class Monad m => MonadVar2_1 m a where+class MonadVar2_1 m a => MonadVar2_1Sub m a where+  fn2_1Sub :: String -> m ()++class Monad m => MonadVar2_2 a m where+class MonadVar2_2 a m => MonadVar2_2Sub a m where+  fn2_2Sub :: String -> m ()++class Monad m => MonadVar3_1 m a b where+class MonadVar3_1 m a b => MonadVar3_1Sub m a b where+  fn3_1Sub :: String -> m ()++class Monad m => MonadVar3_2 a m b where+class MonadVar3_2 a m b => MonadVar3_2Sub a m b where+  fn3_2Sub :: String -> m ()++class Monad m => MonadVar3_3 a b m where+class MonadVar3_3 a b m => MonadVar3_3Sub a b m where+  fn3_3Sub :: String -> m ()++--makeMock [t|MonadReader Bool|]+makeMock [t|MonadReader Environment|]+makeMock [t|MonadState String|]+makeMock [t|MonadStateSub|]+makeMock [t|MonadStateSub2|]+makeMock [t|MonadVar2_1Sub|]+makeMock [t|MonadVar2_2Sub|]+makeMock [t|MonadVar3_1Sub|]+makeMock [t|MonadVar3_2Sub|]+makeMock [t|MonadVar3_3Sub|]+makeMock [t|FileOperation|]+makeMockWithOptions [t|ApiOperation|] options { prefix = "stub_", suffix = "_fn" }++class Monad m => ParamThreeMonad a b m | m -> a, m -> b where+  fnParam3_1 :: a -> b -> m String+  fnParam3_2 :: m a+  fnParam3_3 :: m b++makeMock [t|ParamThreeMonad String Bool|]++monadStateSubExec :: MonadStateSub String m => String -> m String+monadStateSubExec s = do+  r <- fn_state (pure "X")+  pure $ s <> r++threeParamMonadExec :: ParamThreeMonad String Bool m => m String+threeParamMonadExec = do+  v1 <- fnParam3_1 "foo" True+  v2 <- fnParam3_2+  v3 <- fnParam3_3+  pure $ v1 <> v2 <> show v3++spec :: Spec+spec = do+  it "Read, and output files" do+    result <- runMockT do+      _readFile ("input.txt" |> pack "content")+      _writeFile ("output.txt" |> pack "content" |> ())+      operationProgram "input.txt" "output.txt"++    result `shouldBe` ()++  it "Read, and output files (contain ng word)" do+    result <- runMockT do+      _readFile ("input.txt" |> pack "contains ngWord")+      _writeFile ("output.txt" |> M.any |> ()) `applyTimesIs` 0+      operationProgram "input.txt" "output.txt"++    result `shouldBe` ()++  it "Read, and output files (contain ng word)2" do+    result <- runMockT do+      _readFile ("input.txt" |> pack "contains ngWord")+      neverApply $ _writeFile ("output.txt" |> M.any |> ())+      operationProgram "input.txt" "output.txt"++    result `shouldBe` ()++  it "Read, and output files (with MonadReader)" do+    r <- runMockT do+      _ask (Environment "input.txt" "output.txt")+      _readFile ("input.txt" |> pack "content")+      _writeFile ("output.txt" |> pack "content" |> ())+      operationProgram3+    r `shouldBe` ()+++  it "Read, edit, and output files2" do+    modifyContentStub <- createStubFn $ pack "content" |> pack "modifiedContent"++    result <- runMockT do+      _readFile $ "input.txt" |> pack "content"+      _writeFile ("output.text" |> pack "modifiedContent" |> ()) +      stub_post_fn (pack "modifiedContent" |> ())+      operationProgram2 "input.txt" "output.text" modifyContentStub++    result `shouldBe` ()+  +  it "MonadState subclass mock" do+    r <- runMockT do+      _fn_state $ Just "X" |> "Y"+      monadStateSubExec "foo"+    r `shouldBe` "fooY"++  it "3 param Moand mock" do+    r <- runMockT do+      _fnParam3_1 $ "foo" |> True |> "Result1"+      _fnParam3_2 "Result2"+      _fnParam3_3 False+      threeParamMonadExec+    r `shouldBe` "Result1Result2False"