diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Changelog for typeable-mock + +## 0.1.0.0 +- The first release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Boris Lykah (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +Mock any `Typeable` function or expression anywhere. + +A common approach to mocking in Haskell is with type classes, with instances for the real and test logic. Typeable-mock fills a niche for the projects that do not use granular type classes so much. It lets you mock any `Typeable` expression in context of nearly any monad. It works in a monad of a concrete type or a polymorphic one with class constraints. + +```haskell +-- Use mock in application. Here `useMock` is a user-written helper that +-- is aware of the application context and can look up mocks in there. +useMock "writeFile" writeFile >>= \f -> liftIO (f path contents) + +-- Declare mock in test. +writeFileMock <- makeMock "writeFile" + ((\_ _ -> pure ()) :: FilePath -> String -> IO ()) + +-- Check assertions +assertHasCalls + [ expectCall "/tmp/1.txt" "Hello world", + expectCall AnyVal (PredicateVal $ elem "Hello" . words) + ] + writeFileMock +``` + +See the package documentation and [examples/App.hs](https://github.com/lykahb/typeable-mock/blob/master/examples/App.hs) for more. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/src/Test/TypeableMock.hs b/src/Test/TypeableMock.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeableMock.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.TypeableMock + ( -- * Mocks and mock configuration + Mock (..), + MockConfig (..), + defaultMockConfig, + addMocksToConfig, + + -- * Creating and calling mocks + makeMock, + lookupMockFunction, + constN, + + -- * Checking calls + ActualCallRecord (..), + ActualVal (..), + ExpectedCallRecord (..), + ExpectedVal (..), + MockFailure (..), + MockFailureReason (..), + lookupMock, + lookupMockTyped, + useMockConvert, + assertHasCalls, + assertNotCalled, + assertAnyCall, + getCalls, + expectCall, + withResult, + callMatches, + resetMockCallRecords, + resetAllCallRecords, + + -- * Mocking polymorphic monads + -- $polymorphic + MockMonadIO (..), + fromMockMonadIO, + unMockMonadIO1, + unMockMonadIO2, + unMockMonadIO3, + unMockMonadIO4, + unMockMonadIO5, + -- $polymorphicAdvanced + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Exception (Exception, throwIO) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.CallStack (HasCallStack, SrcLoc (..), callStack) +import Data.Function.Variadic +import Data.Function.Variadic.Utils (composeN, constN) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import Data.List (foldl', intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Typeable (Proxy (Proxy), TypeRep, Typeable, cast, eqT, typeOf, typeRep, (:~:) (..)) + +data ActualCallRecord = ActualCallRecord [ActualVal] ActualVal + +data ActualVal = forall a. Typeable a => ActualVal a + +data Mock = forall x. + Typeable x => + Mock + { mockKey :: String, + mockCallRecord :: IORef [ActualCallRecord], + mockFunction :: IORef [ActualCallRecord] -> x + } + +instance Show Mock where + show Mock {..} = "Mock (" <> mockKey <> " :: " <> show tRep <> ")" + where + tRep = typeRep mockFunction + +-- | Mock configuration. When running production, use the `defaultMockConfig` without adding mocks to it - +-- it would call the real functions. +-- +-- The key or type of the mock created in a test suite may accidentally mismatch the key or type at the place where a mock is used. +-- Silently calling the real functions would make the test suite fragile. +-- So, when running on a test suite, protect against the mismatches by requiring that the mocks are present. +-- Set `mcShouldFailOnNotFound` to return True or allow a few special cases: +-- +-- > testMockConfig = defaultMockConfig { +-- > mcShouldFailOnNotFound = \\key tRep -> key ``notElem`` whitelist where +-- > -- Functions that are allowed to be called during tests. +-- > whitelist = ["readFile"] +-- > } +data MockConfig = MockConfig + { -- | A map of mocks. The key of the inner map is the @TypeRep@ of the function supplied when making a mock. + mcStorage :: Map String (Map TypeRep Mock), + -- | Decide whether to throw an error when a mock is not found. + mcShouldFailOnNotFound :: String -> TypeRep -> Bool + } + +instance Show MockConfig where + show MockConfig {..} = "MockConfig " <> show mcStorage + +defaultMockConfig :: MockConfig +defaultMockConfig = MockConfig mempty (\_ _ -> False) + +data MockFailure = MockFailure + { mfMock :: Mock, + mfLocation :: Maybe SrcLoc, + mfReason :: MockFailureReason + } + +data MockFailureReason + = MockFailureArgumentCountMismatch ActualCallRecord ExpectedCallRecord + | MockFailureArgumentTypeMismatch TypeRep TypeRep + | forall a. Show a => MockFailureArgumentValueMismatch a a + | forall a. Show a => MockFailureArgumentPredicateFailure a + | MockFailureUnexpectedCall ActualCallRecord + | MockFailureNotCalled ExpectedCallRecord + +instance Show MockFailureReason where + show reason = intercalate "\n" $ case reason of + MockFailureArgumentCountMismatch (ActualCallRecord actArgs _) (ExpectedCallRecord expArgs _) -> + ["Number of arguments does not match:", "expected: " ++ show (length expArgs), "but got: " ++ show (length actArgs)] + MockFailureArgumentTypeMismatch actual expected -> + ["Value type does not match:", "expected: " ++ show expected, "but got: " ++ show actual] + MockFailureArgumentValueMismatch actual expected -> + ["Value does not match:", "Expected: " ++ show expected, "but got: " ++ show actual] + MockFailureArgumentPredicateFailure actual -> + ["Predicate failed:", show actual] + MockFailureUnexpectedCall _ -> + ["Unexpected call"] -- We do not know if the arguments have an instance of Show to print them. + MockFailureNotCalled (ExpectedCallRecord expArgs _) -> + ["Expected call with arguments: " ++ show expArgs, "but was not called"] + +instance Show MockFailure where + show MockFailure {..} = + intercalate "\n" $ + ["Assertion failed for " <> show mfMock, show mfReason] <> maybe [] (\loc -> ["at:", prettyLocation loc]) mfLocation + where + prettyLocation SrcLoc {..} = srcLocFile ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol ++ " in " ++ srcLocPackage ++ ":" ++ srcLocModule + +instance Exception MockFailure + +-- | Wraps the function into a `Mock`. For successful lookup at the call site, +-- the type of the passed function must match the type of the mocked function. +-- +-- If the mocked function has polymorphic arguments, such as @print :: Show a => a -> IO ()@, +-- create a mock for each case. For example, if an app prints Int and Strings, create +-- two mocks: +-- +-- @ +-- mockConf \<- 'addMocksToConfig' defaultConf \<$> sequence +-- [ makeMock "print" (const $ pure () :: Int -> IO ()), +-- , makeMock "print" (const $ pure () :: String -> IO ()) +-- ] +-- @ +-- +-- For mocking functions with many arguments it is convenient to use `constN` and `asTypeOf`. +-- Using `asTypeOf` lets you omit the type annotation. These definitions create the same mock: +-- +-- @ +-- makeMock "someAction" ((\\_ _ _ -> pure "result") :: Arg1 -> Arg2 -> Arg3 -> SomeMonad ()) +-- makeMock "someAction" ('constN' $ pure "result" :: Arg1 -> Arg2 -> Arg3 -> SomeMonad ()) +-- makeMock "someAction" ('constN' $ pure "result" \`'asTypeOf'\` someAction) +-- @ +makeMock :: + (Function f args (m x) Typeable, Typeable f, Typeable x, MonadIO m) => + String -> + f -> + IO Mock +makeMock key f = do + actualCallRecord <- newIORef [] + pure $ Mock key actualCallRecord (`recordArgs` f) + +-- | A helper function to lookup the function. Likely you want to write a wrapper +-- that retrieves the @MockConfig@ from the environment. +-- +-- > withMock :: String -> f -> AppMonad f +-- > withMock key f = do +-- > mockConf <- getMockConfig <$> getEnv +-- > pure $ fromMaybe f (lookupMockFunction mockConf key) +-- > +-- > withMock "getSomething" getSomething >>= \f -> f someArg +lookupMockFunction :: forall f. Typeable f => MockConfig -> String -> Maybe f +lookupMockFunction conf key = case lookupMockTyped @f conf key of + Just Mock {..} -> case cast (mockFunction mockCallRecord) of + Just val -> Just val + Nothing -> + error $ + "lookupMockFunction: impossible happened. Cast failed for " <> key <> " from " + <> show (typeOf (mockFunction mockCallRecord)) + <> " to " + <> show (typeRep (Proxy :: Proxy f)) + Nothing -> Nothing + +recordArgs :: + (Typeable x, MonadIO m, Function f args (m x) Typeable) => + IORef [ActualCallRecord] -> + f -> + f +recordArgs callsRef = transformFunction (Proxy :: Proxy Typeable) fa fr [] + where + fa args a = ActualVal a : args + fr args mx = do + x <- mx + liftIO $ modifyIORef callsRef (ActualCallRecord (reverse args) (ActualVal x) :) + pure x + +-- | Reuse the mocks between the test items +resetMockCallRecords :: Mock -> IO () +resetMockCallRecords (Mock _ callsRef _) = writeIORef callsRef [] + +-- | Reuse the mocks between the test items +resetAllCallRecords :: MockConfig -> IO () +resetAllCallRecords MockConfig {..} = mapM_ (mapM_ resetMockCallRecords) mcStorage + +-- | Find a mock by name. If there are several mocks under the same name, use `lookupMockTyped`. +lookupMock :: HasCallStack => MockConfig -> String -> Mock +lookupMock MockConfig {..} key = case Map.lookup key mcStorage of + Nothing -> error $ "lookupMock: Mock " <> key <> " not found" + Just tMap -> case Map.elems tMap of + [mock] -> mock + _ -> error $ "lookupMock: There are " <> show (Map.size tMap) <> " mocks under the name \"" <> key <> "\". Use lookupMockTyped to disambiguate." + +-- | Find a mock by name and type. +lookupMockTyped :: forall t. (HasCallStack, Typeable t) => MockConfig -> String -> Maybe Mock +lookupMockTyped MockConfig {..} key = do + let tMap = Map.lookup key mcStorage + case tMap >>= Map.lookup tRep of + Just mock -> Just mock + Nothing | mcShouldFailOnNotFound key tRep -> case tMap of + Nothing -> + error $ + "lookupMockTyped: cannot find mock " <> key <> " :: " <> show tRep <> ". " + <> "There are no mocks under this name." + Just tMap' -> + error $ + "lookupMockTyped: cannot find mock " <> key <> " :: " <> show tRep <> ". " + <> "There are mocks with other types under the same name:\n" + <> unlines (map show $ Map.elems tMap') + Nothing -> Nothing + where + tRep = typeRep (Proxy :: Proxy t) + +-- | Build helpers using mocks in your application with this. +-- The conversion is for the case when the type of a function stored in mock +-- does not match the mocked function. Usually this is a case for a newtype +-- wrapper over a polymorphic monad like MockMonadIO. +useMockConvert :: + (Monad m, Typeable mock) => + -- | Get mock config from the context + -- | Convert the mock function. Usually it is @id@ or unwrapping function for an existential type like @MockMonadIO@. + m MockConfig -> + (mock -> f) -> + -- | Key of the mock + String -> + -- | The function that is being mocked + f -> + m f +useMockConvert getMockConfig conv key f = do + mockConfig <- getMockConfig + pure $ maybe f conv (lookupMockFunction mockConfig key) + +addMocksToConfig :: MockConfig -> [Mock] -> MockConfig +addMocksToConfig conf mocks = conf {mcStorage = mockMap} + where + mockMap = foldl' insertMock (mcStorage conf) mocks + insertMock m mock@Mock {..} = Map.insertWith insert mockKey singleMock m + where + singleMock = Map.singleton tRep mock + insert _ = Map.insert tRep mock + tRep = typeOf $ mockFunction undefined + +-- | Description of what value for mock call the assertions expect +data ExpectedVal + = AnyVal + | forall a. (Typeable a, Show a, Eq a) => ExpectedVal a + | forall a. (Typeable a, Show a) => PredicateVal (a -> Bool) + +instance Eq ExpectedVal where + (==) = error "Eq ExpectedVal not implemented" + +data ExpectedCallRecord = ExpectedCallRecord [ExpectedVal] ExpectedVal + +instance Show ExpectedVal where + show AnyVal = "AnyVal" + show (ExpectedVal a) = show a + show (PredicateVal p) = "PredicateVal p :: " <> show (typeOf p) + +-- | Use this to create `ExpectedCallRecord` +-- +-- Examples: +-- +-- @ +-- expectCall "email@example.com" True +-- @ +expectCall :: + (Function f args ExpectedCallRecord (Show & Eq & Typeable)) => + f +expectCall = createFunction (Proxy :: Proxy (Show & Eq & Typeable)) fa fr [] + where + fa args arg = (: args) $ case cast arg of + Just arg' -> arg' + Nothing -> ExpectedVal arg + fr args = ExpectedCallRecord (reverse args) AnyVal + +-- | Assert that mock returned the given result. +-- Sometimes it is more convenient than checking arguments. +withResult :: (Show a, Eq a, Typeable a) => ExpectedCallRecord -> a -> ExpectedCallRecord +withResult (ExpectedCallRecord args _) arg = ExpectedCallRecord args r + where + r = case cast arg of + Just arg' -> arg' + Nothing -> ExpectedVal arg + +checkCallRecord :: HasCallStack => ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason +checkCallRecord actCall@(ActualCallRecord actArgs actRes) expCall@(ExpectedCallRecord expArgs expRes) = + argFailure <|> resFailure + where + argFailure = + if length actArgs /= length expArgs + then Just $ MockFailureArgumentCountMismatch actCall expCall + else listToMaybe $ catMaybes $ zipWith matchArgs actArgs expArgs + resFailure = matchArgs actRes expRes + +matchArgs :: ActualVal -> ExpectedVal -> Maybe MockFailureReason +matchArgs _ AnyVal = Nothing +matchArgs (ActualVal actual) (ExpectedVal expected) = + case cast actual of + Just actual' | expected == actual' -> Nothing + Just actual' -> + Just $ + MockFailureArgumentValueMismatch actual' expected + Nothing -> + Just $ + MockFailureArgumentTypeMismatch (typeOf actual) (typeOf expected) +matchArgs (ActualVal (actual :: a)) (PredicateVal (p :: b -> Bool)) = + case eqT :: Maybe (a :~: b) of + Nothing -> Just $ MockFailureArgumentTypeMismatch (typeRep (Proxy :: Proxy a)) (typeRep (Proxy :: Proxy b)) + Just Refl -> + if p actual + then Nothing + else Just $ MockFailureArgumentPredicateFailure actual + +-- | Assert that all expected calls were made in the given order. +-- +-- @ +-- mock <- lookupMockInEnv "name" -- user-defined helper function for your app env +-- liftIO $ assertHasCalls [expectCall "arg1" "arg2"] mock +-- @ +assertHasCalls :: HasCallStack => [ExpectedCallRecord] -> Mock -> IO () +assertHasCalls expectedCalls mock = do + actualCalls <- getCalls mock + zipEqualLength actualCalls expectedCalls + where + throw = throwIO . MockFailure mock location + zipEqualLength [] [] = pure () + zipEqualLength (a : as) (e : es) = do + maybe (pure ()) throw $ checkCallRecord a e + zipEqualLength as es + zipEqualLength (a : _) _ = throw $ MockFailureUnexpectedCall a + zipEqualLength _ (e : _) = throw $ MockFailureNotCalled e + +-- | Assert the mock was never called. +assertNotCalled :: HasCallStack => Mock -> IO () +assertNotCalled = assertHasCalls [] + +-- | The expected call record matches the actual one. Note that it throws +-- error for the logic bugs when a mismatch is caused by wrong number +-- of arguments or wrong types. +callMatches :: ActualCallRecord -> ExpectedCallRecord -> Bool +callMatches actCall expCall = case checkCallRecord actCall expCall of + Nothing -> True + Just MockFailureArgumentValueMismatch {} -> False + Just MockFailureArgumentPredicateFailure {} -> False + Just reason -> error $ "callMatches: invalid arguments\n" <> show reason + +-- | Assert that the expected call happened at least once. +assertAnyCall :: ExpectedCallRecord -> Mock -> IO () +assertAnyCall expCall mock = do + actualCalls <- getCalls mock + unless (any (\actCall -> isNothing $ checkCallRecord actCall expCall) actualCalls) $ do + throwIO $ MockFailure mock location $ MockFailureNotCalled expCall + +-- | Get list of calls. Use together with 'callMatches' +-- when the existing assert* functions are not flexible enough. +getCalls :: Mock -> IO [ActualCallRecord] +getCalls Mock {..} = reverse <$> readIORef mockCallRecord + +location :: HasCallStack => Maybe SrcLoc +location = case reverse callStack of + (_, loc) : _ -> Just loc + [] -> Nothing + +-- $polymorphic +-- It is common to have the application logic live in a polymorphic monad +-- that is constrained with several type classes. +-- However, only the monomorphic types have an instance of Typeable and can be mocked. +-- The solution is to wrap a polymorphic function with a concrete existential type. +-- +-- The library provides MockMonadIO that lets you write a mock fitting in +-- any context that has @MonadIO@. +-- +-- Define a mock and add it to the config: +-- +-- > makeMock (const $ pure "getSomething" :: Int -> MockMonadIO String) +-- +-- Then use it at the call site. Before calling the mock, you need to unwrap the existential type. +-- It is a good idea to define your own helpers for getting the mock config and mock lookup. +-- That would make calling mocks much more concise. See more at examples/App.hs. +-- +-- Here is a verbose example that expands both retrieving and transforming the mock. +-- +-- > insideAppPolymorphicMonad :: (HasEnv m, MonadIO m) => Int -> m () +-- > insideAppPolymorphicMonad arg = do +-- > mockConf <- getMockConfig <$> getEnv +-- > let mock = lookupMockFunction mockConf "getSomething" +-- > (maybe unMockMonadIO1 getSomething mock) arg +-- +-- With your own helpers it can look like this: +-- +-- > insideAppPolymorphicMonad :: (HasEnv m, MonadIO m) => Int -> m () +-- > insideAppPolymorphicMonad arg = do +-- > myMockHelper unMockMonadIO1 getSomething mock >>= \f -> f arg + +-- $polymorphicAdvanced +-- === Advanced polymorphic mocks +-- If your mock needs to be aware of a custom class to return a result, and +-- be able to called from polymorphic code, make your own wrapper similar +-- to MockMonadIO. For example: +-- +-- > newtype MockMonadHasMyEnv a = MockMonadHasMyEnv { +-- > unMockMonadHasMyEnv :: forall m. (MonadIO m, HasMyEnv m) => m a +-- > } +-- +-- > makeMock (\a -> getMyEnv >>= makeFakeResult ... :: Int -> MockMonadHasMyEnv String) + +-- | Helper for making polymorphic mock functions. +newtype MockMonadIO a = MockMonadIO {unMockMonadIO :: forall m. MonadIO m => m a} + +instance Functor MockMonadIO where + fmap f (MockMonadIO m) = MockMonadIO (fmap f m) + +instance Applicative MockMonadIO where + pure a = MockMonadIO (pure a) + MockMonadIO f <*> MockMonadIO a = MockMonadIO (f <*> a) + +instance Monad MockMonadIO where + MockMonadIO ma >>= f = MockMonadIO $ ma >>= unMockMonadIO . f + +instance MonadIO MockMonadIO where + liftIO m = MockMonadIO (liftIO m) + +-- | The family of functions unMockMonadIO is specialized with the number of arguments. +-- Unlike @fromMockMonadIO@, the monad @m@ can be polymorphic at the call site. +unMockMonadIO1 :: (a -> MockMonadIO x) -> (forall m. MonadIO m => a -> m x) +unMockMonadIO1 f = unMockMonadIO . f + +unMockMonadIO2 :: (a -> b -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> m x) +unMockMonadIO2 f = unMockMonadIO1 . f + +unMockMonadIO3 :: (a -> b -> c -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> m x) +unMockMonadIO3 f = unMockMonadIO2 . f + +unMockMonadIO4 :: (a -> b -> c -> d -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> d -> m x) +unMockMonadIO4 f = unMockMonadIO3 . f + +unMockMonadIO5 :: (a -> b -> c -> d -> e -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> d -> e -> m x) +unMockMonadIO5 f = unMockMonadIO4 . f + +-- | Changes the return type of a function from @MockMonadIO x@ to @m x@. +-- The @m@ must be a concrete type at the call site. +-- If the caller is in a polymorphic monad, use one of the @unMockMonadIO@ instead. +fromMockMonadIO :: + forall m x args f' f. + (MonadIO m, Function f' args (MockMonadIO x) EmptyConstraint, Function f args (m x) EmptyConstraint) => + f' -> + f +fromMockMonadIO = composeN unMockMonadIO diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Maybe (fromMaybe, isNothing) +import Data.Typeable (Typeable) +import Test.Hspec +import Test.TypeableMock + +main :: IO () +main = hspec $ do + let withMock :: Typeable f => MockConfig -> String -> f -> f + withMock conf key f = fromMaybe f (lookupMockFunction conf key) + printWithMock :: (Show a, Typeable a) => MockConfig -> a -> IO () + printWithMock conf = withMock conf "print" print + printStringMock <- runIO $ makeMock "print" (const $ pure () :: String -> IO ()) + + let mockConf :: MockConfig + mockConf = defaultMockConfig `addMocksToConfig` [printStringMock] + + before_ (resetAllCallRecords mockConf) $ do + describe "Assertions" $ do + describe "expectCall" $ do + it "mocks a single argument function" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall "one"] printStringMock + + it "mocks a multiple arguments function" $ do + let print2 :: Int -> Int -> IO () + print2 a b = print (a, b) + print2WithMock conf = withMock conf "print2" print2 1 2 + + print2Mock <- makeMock "print2" ((\_ _ -> pure ()) :: Int -> Int -> IO ()) + print2WithMock $ defaultMockConfig `addMocksToConfig` [print2Mock] + assertHasCalls [expectCall (1 :: Int) (2 :: Int)] print2Mock + + it "mocks polymorphic monads with MockMonadIO" $ do + -- Polymorphic types cannot be used with Typeable typeOf. This library has a workaround for monads. + let print5 a b c d e = liftIO $ print (a, b, c, d, e) + let printInMonadIO :: forall m. MonadIO m => MockConfig -> Bool -> Char -> Char -> Char -> Char -> m () + printInMonadIO conf = + maybe print5 unMockMonadIO5 (lookupMockFunction conf "print5") + let printInIO :: MockConfig -> Bool -> Char -> Char -> Char -> Char -> IO () + printInIO conf = + maybe print5 fromMockMonadIO (lookupMockFunction conf "print5") + + print5Mock <- makeMock "print5" (constN $ pure () :: Bool -> Char -> Char -> Char -> Char -> MockMonadIO ()) + + let mockConf' :: MockConfig + mockConf' = mockConf `addMocksToConfig` [print5Mock] + printInMonadIO mockConf' True 'a' 'b' 'c' 'd' + printInIO mockConf' True 'a' 'b' 'c' 'd' + assertHasCalls [expectCall True 'a' 'b' 'c' 'd', expectCall True 'a' 'b' 'c' 'd'] print5Mock + + describe "assertHasCalls" $ do + it "mocks multiple calls" $ do + printWithMock mockConf "one" + printWithMock mockConf "two" + assertHasCalls + [ expectCall "one", + expectCall "two" + ] + printStringMock + + it "fails when there are more calls than expected" $ + do + printWithMock mockConf "one" + printWithMock mockConf "two" + assertHasCalls [expectCall "one"] printStringMock + `shouldThrow` \case + MockFailure {mfReason = MockFailureUnexpectedCall {}} -> True + _ -> False + + it "fails when there are fewer calls than expected" $ do + printWithMock mockConf "one" + assertHasCalls + [ expectCall "one", + expectCall "two" + ] + printStringMock + `shouldThrow` \case + MockFailure {mfReason = MockFailureNotCalled {}} -> True + _ -> False + + it "fails when a call is with different arguments" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall "two"] printStringMock `shouldThrow` \case + MockFailure {mfReason = MockFailureArgumentValueMismatch {}} -> True + _ -> False + + it "fails when a call returns different result" $ do + let doubleFunc :: Int -> IO Int + doubleFunc a = print a >> pure (a * 2) + doubleMock <- makeMock "double" ((\a -> pure (a * 2)) `asTypeOf` doubleFunc) + let mockConf' = mockConf `addMocksToConfig` [doubleMock] + + void $ withMock mockConf' "double" doubleFunc 5 + assertHasCalls [expectCall AnyVal `withResult` (10 :: Int)] doubleMock + assertHasCalls [expectCall AnyVal `withResult` (11 :: Int)] doubleMock + `shouldThrow` \case + MockFailure {mfReason = MockFailureArgumentValueMismatch {}} -> True + _ -> False + + describe "assertNotCalled" $ do + it "succeeds when mock was not called" $ do + assertNotCalled printStringMock + + it "fails when mock was called" $ do + printWithMock mockConf "one" + assertNotCalled printStringMock `shouldThrow` \case + MockFailure {mfReason = MockFailureUnexpectedCall {}} -> True + _ -> False + + describe "assertNotCalled" $ do + it "fails when mock was not called" $ do + printWithMock mockConf "two" + assertAnyCall (expectCall "one") printStringMock + `shouldThrow` \case + MockFailure {mfReason = MockFailureNotCalled {}} -> True + _ -> False + + describe "Config" $ do + it "addMocksToConfig overrides mocks" $ do + printIntMock1 <- makeMock "print" (const $ pure () :: Int -> IO ()) + printIntMock2 <- makeMock "print" (const $ pure () :: Int -> IO ()) + let mockConf' = mockConf `addMocksToConfig` [printIntMock1, printIntMock2] + printWithMock mockConf' (1 :: Int) + assertHasCalls [expectCall (1 :: Int)] printIntMock2 + + printIntMock3 <- makeMock "print" (const $ pure () :: Int -> IO ()) + let mockConf'' = mockConf `addMocksToConfig` [printIntMock3] + printWithMock mockConf'' (1 :: Int) + assertHasCalls [expectCall (1 :: Int)] printIntMock3 + + describe "Arguments comparison" $ do + it "checks argument count" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall "a" "b"] printStringMock `shouldThrow` \case + MockFailure {mfReason = MockFailureArgumentCountMismatch {}} -> True + _ -> False + + it "checks argument types" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall ()] printStringMock `shouldThrow` \case + MockFailure {mfReason = MockFailureArgumentTypeMismatch {}} -> True + _ -> False + + it "checks predicate for argument" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall (PredicateVal (== "one"))] printStringMock + assertHasCalls [expectCall (PredicateVal (== "two"))] printStringMock + `shouldThrow` \case + MockFailure {mfReason = MockFailureArgumentPredicateFailure {}} -> True + _ -> False + + it "ignores expected argument when it is AnyVal" $ do + printWithMock mockConf "one" + assertHasCalls [expectCall AnyVal] printStringMock + + describe "Retrieving mocks" $ do + describe "lookupMock" $ do + it "finds mock" $ do + show (lookupMock mockConf "print") `shouldBe` show printStringMock + + it "finds mocks with different types" $ do + printIntMock <- makeMock "print" (const $ pure () :: Int -> IO ()) + let mockConf' = mockConf `addMocksToConfig` [printIntMock] + printWithMock mockConf' "one" + printWithMock mockConf' (1 :: Int) + assertHasCalls [expectCall "one"] printStringMock + assertHasCalls [expectCall (1 :: Int)] printIntMock + + it "fails for multiple mocks with the same name" $ do + printIntMock <- makeMock "print" ((\_ -> pure ()) :: Int -> IO ()) + let mockConf' = mockConf `addMocksToConfig` [printIntMock] + (lookupMock mockConf' "print" `seq` pure ()) + `shouldThrow` errorCall "lookupMock: There are 2 mocks under the name \"print\". Use lookupMockTyped to disambiguate." + + it "fails when there is no mock" $ do + (lookupMock mockConf "noSuchMock" `seq` pure ()) + `shouldThrow` errorCall "lookupMock: Mock noSuchMock not found" + + describe "lookupMockTyped" $ do + it "finds mock" $ do + printIntMock <- makeMock "print" ((\_ -> pure ()) :: Int -> IO ()) + let mockConf' = mockConf `addMocksToConfig` [printIntMock] + let Just mock = lookupMockTyped @(Int -> IO ()) mockConf' "print" + show mock `shouldBe` show printIntMock + + it "fails when mcShouldFailOnNotFound and there are no mocks with the given name " $ do + let mockConf' = mockConf {mcShouldFailOnNotFound = \_ _ -> True} + withMock mockConf' "printDoesNotExist" print () + `shouldThrow` errorCall "lookupMockTyped: cannot find mock printDoesNotExist :: () -> IO (). There are no mocks under this name." + + it "fails when mcShouldFailOnNotFound and there are other mocks with the same name" $ do + let mockConf' = mockConf {mcShouldFailOnNotFound = \_ _ -> True} + (lookupMockTyped @(Int -> IO ()) mockConf' "print" `seq` pure ()) + `shouldThrow` errorCall "lookupMockTyped: cannot find mock print :: Int -> IO (). There are mocks with other types under the same name:\nMock (print :: [Char] -> IO ())\n" + + it "returns Nothing when there are no mocks with the given name" $ do + lookupMockTyped @(Int -> IO ()) mockConf "noSuchMock" + `shouldSatisfy` isNothing + + it "returns Nothing when there are other mocks with the same name" $ do + lookupMockTyped @(Int -> IO ()) mockConf "print" + `shouldSatisfy` isNothing + + describe "Display" $ do + it "shows Mock correctly" $ do + mock <- makeMock "print" (const $ pure () :: Int -> IO ()) + show mock `shouldBe` "Mock (print :: Int -> IO ())" diff --git a/typeable-mock.cabal b/typeable-mock.cabal new file mode 100644 --- /dev/null +++ b/typeable-mock.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: typeable-mock +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/lykahb/typeable-mock#readme +bug-reports: https://github.com/lykahb/typeable-mock/issues +author: Boris Lykah +maintainer: lykahb@gmail.com +copyright: 2021 Boris Lykah +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/lykahb/typeable-mock + +library + exposed-modules: + Test.TypeableMock + other-modules: + Paths_typeable_mock + hs-source-dirs: + src + default-extensions: + FlexibleContexts + GADTs + LambdaCase + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeOperators + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , call-stack >=0.2.0 + , containers + , variadic-function >=0.1.0.0 && <0.2 + default-language: Haskell2010 + +test-suite typeable-mock-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_typeable_mock + hs-source-dirs: + test + default-extensions: + FlexibleContexts + GADTs + LambdaCase + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeOperators + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , call-stack >=0.2.0 + , containers + , hspec + , typeable-mock + , variadic-function >=0.1.0.0 && <0.2 + default-language: Haskell2010