{-# 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
  { Mock -> String
mockKey :: String,
    Mock -> IORef [ActualCallRecord]
mockCallRecord :: IORef [ActualCallRecord],
    ()
mockFunction :: IORef [ActualCallRecord] -> x
  }

instance Show Mock where
  show :: Mock -> String
show Mock {String
IORef [ActualCallRecord]
IORef [ActualCallRecord] -> x
mockFunction :: IORef [ActualCallRecord] -> x
mockCallRecord :: IORef [ActualCallRecord]
mockKey :: String
mockFunction :: ()
mockCallRecord :: Mock -> IORef [ActualCallRecord]
mockKey :: Mock -> String
..} = String
"Mock (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mockKey String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tRep String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
    where
      tRep :: TypeRep
tRep = (IORef [ActualCallRecord] -> x) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep IORef [ActualCallRecord] -> x
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.
    MockConfig -> Map String (Map TypeRep Mock)
mcStorage :: Map String (Map TypeRep Mock),
    -- | Decide whether to throw an error when a mock is not found.
    MockConfig -> String -> TypeRep -> Bool
mcShouldFailOnNotFound :: String -> TypeRep -> Bool
  }

instance Show MockConfig where
  show :: MockConfig -> String
show MockConfig {Map String (Map TypeRep Mock)
String -> TypeRep -> Bool
mcShouldFailOnNotFound :: String -> TypeRep -> Bool
mcStorage :: Map String (Map TypeRep Mock)
mcShouldFailOnNotFound :: MockConfig -> String -> TypeRep -> Bool
mcStorage :: MockConfig -> Map String (Map TypeRep Mock)
..} = String
"MockConfig " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map String (Map TypeRep Mock) -> String
forall a. Show a => a -> String
show Map String (Map TypeRep Mock)
mcStorage

defaultMockConfig :: MockConfig
defaultMockConfig :: MockConfig
defaultMockConfig = Map String (Map TypeRep Mock)
-> (String -> TypeRep -> Bool) -> MockConfig
MockConfig Map String (Map TypeRep Mock)
forall a. Monoid a => a
mempty (\String
_ TypeRep
_ -> Bool
False)

data MockFailure = MockFailure
  { MockFailure -> Mock
mfMock :: Mock,
    MockFailure -> Maybe SrcLoc
mfLocation :: Maybe SrcLoc,
    MockFailure -> MockFailureReason
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 :: MockFailureReason -> String
show MockFailureReason
reason = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ case MockFailureReason
reason of
    MockFailureArgumentCountMismatch (ActualCallRecord [ActualVal]
actArgs ActualVal
_) (ExpectedCallRecord [ExpectedVal]
expArgs ExpectedVal
_) ->
      [String
"Number of arguments does not match:", String
"expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([ExpectedVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpectedVal]
expArgs), String
"but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([ActualVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ActualVal]
actArgs)]
    MockFailureArgumentTypeMismatch TypeRep
actual TypeRep
expected ->
      [String
"Value type does not match:", String
"expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
expected, String
"but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
actual]
    MockFailureArgumentValueMismatch a
actual a
expected ->
      [String
"Value does not match:", String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expected, String
"but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
actual]
    MockFailureArgumentPredicateFailure a
actual ->
      [String
"Predicate failed:", a -> String
forall a. Show a => a -> String
show a
actual]
    MockFailureUnexpectedCall ActualCallRecord
_ ->
      [String
"Unexpected call"] -- We do not know if the arguments have an instance of Show to print them.
    MockFailureNotCalled (ExpectedCallRecord [ExpectedVal]
expArgs ExpectedVal
_) ->
      [String
"Expected call with arguments: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ExpectedVal] -> String
forall a. Show a => a -> String
show [ExpectedVal]
expArgs, String
"but was not called"]

instance Show MockFailure where
  show :: MockFailure -> String
show MockFailure {Maybe SrcLoc
MockFailureReason
Mock
mfReason :: MockFailureReason
mfLocation :: Maybe SrcLoc
mfMock :: Mock
mfReason :: MockFailure -> MockFailureReason
mfLocation :: MockFailure -> Maybe SrcLoc
mfMock :: MockFailure -> Mock
..} =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      [String
"Assertion failed for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Mock -> String
forall a. Show a => a -> String
show Mock
mfMock, MockFailureReason -> String
forall a. Show a => a -> String
show MockFailureReason
mfReason] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (SrcLoc -> [String]) -> Maybe SrcLoc -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\SrcLoc
loc -> [String
"at:", SrcLoc -> String
prettyLocation SrcLoc
loc]) Maybe SrcLoc
mfLocation
    where
      prettyLocation :: SrcLoc -> String
prettyLocation SrcLoc {Int
String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} = String
srcLocFile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcLocPackage String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 :: String -> f -> IO Mock
makeMock String
key f
f = do
  IORef [ActualCallRecord]
actualCallRecord <- [ActualCallRecord] -> IO (IORef [ActualCallRecord])
forall a. a -> IO (IORef a)
newIORef []
  Mock -> IO Mock
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mock -> IO Mock) -> Mock -> IO Mock
forall a b. (a -> b) -> a -> b
$ String
-> IORef [ActualCallRecord]
-> (IORef [ActualCallRecord] -> f)
-> Mock
forall x.
Typeable x =>
String
-> IORef [ActualCallRecord]
-> (IORef [ActualCallRecord] -> x)
-> Mock
Mock String
key IORef [ActualCallRecord]
actualCallRecord (IORef [ActualCallRecord] -> f -> f
forall x (m :: * -> *) f (args :: [*]).
(Typeable x, MonadIO m, Function f args (m x) Typeable) =>
IORef [ActualCallRecord] -> f -> f
`recordArgs` f
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 :: MockConfig -> String -> Maybe f
lookupMockFunction MockConfig
conf String
key = case MockConfig -> String -> Maybe Mock
forall t.
(HasCallStack, Typeable t) =>
MockConfig -> String -> Maybe Mock
lookupMockTyped @f MockConfig
conf String
key of
  Just Mock {String
IORef [ActualCallRecord]
IORef [ActualCallRecord] -> x
mockFunction :: IORef [ActualCallRecord] -> x
mockCallRecord :: IORef [ActualCallRecord]
mockKey :: String
mockFunction :: ()
mockCallRecord :: Mock -> IORef [ActualCallRecord]
mockKey :: Mock -> String
..} -> case x -> Maybe f
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (IORef [ActualCallRecord] -> x
mockFunction IORef [ActualCallRecord]
mockCallRecord) of
    Just f
val -> f -> Maybe f
forall a. a -> Maybe a
Just f
val
    Maybe f
Nothing ->
      String -> Maybe f
forall a. HasCallStack => String -> a
error (String -> Maybe f) -> String -> Maybe f
forall a b. (a -> b) -> a -> b
$
        String
"lookupMockFunction: impossible happened. Cast failed for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" from "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (x -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (IORef [ActualCallRecord] -> x
mockFunction IORef [ActualCallRecord]
mockCallRecord))
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (Proxy f -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f))
  Maybe Mock
Nothing -> Maybe f
forall a. Maybe a
Nothing

recordArgs ::
  (Typeable x, MonadIO m, Function f args (m x) Typeable) =>
  IORef [ActualCallRecord] ->
  f ->
  f
recordArgs :: IORef [ActualCallRecord] -> f -> f
recordArgs IORef [ActualCallRecord]
callsRef = Proxy Typeable
-> (forall a. Typeable a => [ActualVal] -> a -> [ActualVal])
-> ([ActualVal] -> m x -> m x)
-> [ActualVal]
-> ConstructFunction args (m x)
-> f
forall f (args :: [*]) r (argC :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) acc r0.
Function f args r argC =>
proxy argC
-> (forall a. argC a => acc -> a -> acc)
-> (acc -> r0 -> r)
-> acc
-> ConstructFunction args r0
-> f
transformFunction (Proxy Typeable
forall k (t :: k). Proxy t
Proxy :: Proxy Typeable) forall a. Typeable a => [ActualVal] -> a -> [ActualVal]
fa [ActualVal] -> m x -> m x
fr []
  where
    fa :: [ActualVal] -> a -> [ActualVal]
fa [ActualVal]
args a
a = a -> ActualVal
forall a. Typeable a => a -> ActualVal
ActualVal a
a ActualVal -> [ActualVal] -> [ActualVal]
forall a. a -> [a] -> [a]
: [ActualVal]
args
    fr :: [ActualVal] -> m x -> m x
fr [ActualVal]
args m x
mx = do
      x
x <- m x
mx
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [ActualCallRecord]
-> ([ActualCallRecord] -> [ActualCallRecord]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [ActualCallRecord]
callsRef ([ActualVal] -> ActualVal -> ActualCallRecord
ActualCallRecord ([ActualVal] -> [ActualVal]
forall a. [a] -> [a]
reverse [ActualVal]
args) (x -> ActualVal
forall a. Typeable a => a -> ActualVal
ActualVal x
x) ActualCallRecord -> [ActualCallRecord] -> [ActualCallRecord]
forall a. a -> [a] -> [a]
:)
      x -> m x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x

-- | Reuse the mocks between the test items
resetMockCallRecords :: Mock -> IO ()
resetMockCallRecords :: Mock -> IO ()
resetMockCallRecords (Mock String
_ IORef [ActualCallRecord]
callsRef IORef [ActualCallRecord] -> x
_) = IORef [ActualCallRecord] -> [ActualCallRecord] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ActualCallRecord]
callsRef []

-- | Reuse the mocks between the test items
resetAllCallRecords :: MockConfig -> IO ()
resetAllCallRecords :: MockConfig -> IO ()
resetAllCallRecords MockConfig {Map String (Map TypeRep Mock)
String -> TypeRep -> Bool
mcShouldFailOnNotFound :: String -> TypeRep -> Bool
mcStorage :: Map String (Map TypeRep Mock)
mcShouldFailOnNotFound :: MockConfig -> String -> TypeRep -> Bool
mcStorage :: MockConfig -> Map String (Map TypeRep Mock)
..} = (Map TypeRep Mock -> IO ())
-> Map String (Map TypeRep Mock) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Mock -> IO ()) -> Map TypeRep Mock -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Mock -> IO ()
resetMockCallRecords) Map String (Map TypeRep Mock)
mcStorage

-- | Find a mock by name. If there are several mocks under the same name, use `lookupMockTyped`.
lookupMock :: HasCallStack => MockConfig -> String -> Mock
lookupMock :: MockConfig -> String -> Mock
lookupMock MockConfig {Map String (Map TypeRep Mock)
String -> TypeRep -> Bool
mcShouldFailOnNotFound :: String -> TypeRep -> Bool
mcStorage :: Map String (Map TypeRep Mock)
mcShouldFailOnNotFound :: MockConfig -> String -> TypeRep -> Bool
mcStorage :: MockConfig -> Map String (Map TypeRep Mock)
..} String
key = case String -> Map String (Map TypeRep Mock) -> Maybe (Map TypeRep Mock)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String (Map TypeRep Mock)
mcStorage of
  Maybe (Map TypeRep Mock)
Nothing -> String -> Mock
forall a. HasCallStack => String -> a
error (String -> Mock) -> String -> Mock
forall a b. (a -> b) -> a -> b
$ String
"lookupMock: Mock " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not found"
  Just Map TypeRep Mock
tMap -> case Map TypeRep Mock -> [Mock]
forall k a. Map k a -> [a]
Map.elems Map TypeRep Mock
tMap of
    [Mock
mock] -> Mock
mock
    [Mock]
_ -> String -> Mock
forall a. HasCallStack => String -> a
error (String -> Mock) -> String -> Mock
forall a b. (a -> b) -> a -> b
$ String
"lookupMock: There are " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Map TypeRep Mock -> Int
forall k a. Map k a -> Int
Map.size Map TypeRep Mock
tMap) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mocks under the name \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\". Use lookupMockTyped to disambiguate."

-- | Find a mock by name and type.
lookupMockTyped :: forall t. (HasCallStack, Typeable t) => MockConfig -> String -> Maybe Mock
lookupMockTyped :: MockConfig -> String -> Maybe Mock
lookupMockTyped MockConfig {Map String (Map TypeRep Mock)
String -> TypeRep -> Bool
mcShouldFailOnNotFound :: String -> TypeRep -> Bool
mcStorage :: Map String (Map TypeRep Mock)
mcShouldFailOnNotFound :: MockConfig -> String -> TypeRep -> Bool
mcStorage :: MockConfig -> Map String (Map TypeRep Mock)
..} String
key = do
  let tMap :: Maybe (Map TypeRep Mock)
tMap = String -> Map String (Map TypeRep Mock) -> Maybe (Map TypeRep Mock)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String (Map TypeRep Mock)
mcStorage
  case Maybe (Map TypeRep Mock)
tMap Maybe (Map TypeRep Mock)
-> (Map TypeRep Mock -> Maybe Mock) -> Maybe Mock
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeRep -> Map TypeRep Mock -> Maybe Mock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
tRep of
    Just Mock
mock -> Mock -> Maybe Mock
forall a. a -> Maybe a
Just Mock
mock
    Maybe Mock
Nothing | String -> TypeRep -> Bool
mcShouldFailOnNotFound String
key TypeRep
tRep -> case Maybe (Map TypeRep Mock)
tMap of
      Maybe (Map TypeRep Mock)
Nothing ->
        String -> Maybe Mock
forall a. HasCallStack => String -> a
error (String -> Maybe Mock) -> String -> Maybe Mock
forall a b. (a -> b) -> a -> b
$
          String
"lookupMockTyped: cannot find mock " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tRep String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"There are no mocks under this name."
      Just Map TypeRep Mock
tMap' ->
        String -> Maybe Mock
forall a. HasCallStack => String -> a
error (String -> Maybe Mock) -> String -> Maybe Mock
forall a b. (a -> b) -> a -> b
$
          String
"lookupMockTyped: cannot find mock " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tRep String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"There are mocks with other types under the same name:\n"
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Mock -> String) -> [Mock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Mock -> String
forall a. Show a => a -> String
show ([Mock] -> [String]) -> [Mock] -> [String]
forall a b. (a -> b) -> a -> b
$ Map TypeRep Mock -> [Mock]
forall k a. Map k a -> [a]
Map.elems Map TypeRep Mock
tMap')
    Maybe Mock
Nothing -> Maybe Mock
forall a. Maybe a
Nothing
  where
    tRep :: TypeRep
tRep = Proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall k (t :: k). Proxy t
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 :: m MockConfig -> (mock -> f) -> String -> f -> m f
useMockConvert m MockConfig
getMockConfig mock -> f
conv String
key f
f = do
  MockConfig
mockConfig <- m MockConfig
getMockConfig
  f -> m f
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f -> m f) -> f -> m f
forall a b. (a -> b) -> a -> b
$ f -> (mock -> f) -> Maybe mock -> f
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f
f mock -> f
conv (MockConfig -> String -> Maybe mock
forall f. Typeable f => MockConfig -> String -> Maybe f
lookupMockFunction MockConfig
mockConfig String
key)

addMocksToConfig :: MockConfig -> [Mock] -> MockConfig
addMocksToConfig :: MockConfig -> [Mock] -> MockConfig
addMocksToConfig MockConfig
conf [Mock]
mocks = MockConfig
conf {mcStorage :: Map String (Map TypeRep Mock)
mcStorage = Map String (Map TypeRep Mock)
mockMap}
  where
    mockMap :: Map String (Map TypeRep Mock)
mockMap = (Map String (Map TypeRep Mock)
 -> Mock -> Map String (Map TypeRep Mock))
-> Map String (Map TypeRep Mock)
-> [Mock]
-> Map String (Map TypeRep Mock)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map String (Map TypeRep Mock)
-> Mock -> Map String (Map TypeRep Mock)
insertMock (MockConfig -> Map String (Map TypeRep Mock)
mcStorage MockConfig
conf) [Mock]
mocks
    insertMock :: Map String (Map TypeRep Mock)
-> Mock -> Map String (Map TypeRep Mock)
insertMock Map String (Map TypeRep Mock)
m mock :: Mock
mock@Mock {String
IORef [ActualCallRecord]
IORef [ActualCallRecord] -> x
mockFunction :: IORef [ActualCallRecord] -> x
mockCallRecord :: IORef [ActualCallRecord]
mockKey :: String
mockFunction :: ()
mockCallRecord :: Mock -> IORef [ActualCallRecord]
mockKey :: Mock -> String
..} = (Map TypeRep Mock -> Map TypeRep Mock -> Map TypeRep Mock)
-> String
-> Map TypeRep Mock
-> Map String (Map TypeRep Mock)
-> Map String (Map TypeRep Mock)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Map TypeRep Mock -> Map TypeRep Mock -> Map TypeRep Mock
insert String
mockKey Map TypeRep Mock
singleMock Map String (Map TypeRep Mock)
m
      where
        singleMock :: Map TypeRep Mock
singleMock = TypeRep -> Mock -> Map TypeRep Mock
forall k a. k -> a -> Map k a
Map.singleton TypeRep
tRep Mock
mock
        insert :: Map TypeRep Mock -> Map TypeRep Mock -> Map TypeRep Mock
insert Map TypeRep Mock
_ = TypeRep -> Mock -> Map TypeRep Mock -> Map TypeRep Mock
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeRep
tRep Mock
mock
        tRep :: TypeRep
tRep = x -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (x -> TypeRep) -> x -> TypeRep
forall a b. (a -> b) -> a -> b
$ IORef [ActualCallRecord] -> x
mockFunction IORef [ActualCallRecord]
forall a. HasCallStack => a
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
  == :: ExpectedVal -> ExpectedVal -> Bool
(==) = String -> ExpectedVal -> ExpectedVal -> Bool
forall a. HasCallStack => String -> a
error String
"Eq ExpectedVal not implemented"

data ExpectedCallRecord = ExpectedCallRecord [ExpectedVal] ExpectedVal

instance Show ExpectedVal where
  show :: ExpectedVal -> String
show ExpectedVal
AnyVal = String
"AnyVal"
  show (ExpectedVal a
a) = a -> String
forall a. Show a => a -> String
show a
a
  show (PredicateVal a -> Bool
p) = String
"PredicateVal p :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show ((a -> Bool) -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a -> Bool
p)

-- | Use this to create `ExpectedCallRecord`
--
-- Examples:
--
-- @
-- expectCall "email@example.com" True
-- @
expectCall ::
  (Function f args ExpectedCallRecord (Show & Eq & Typeable)) =>
  f
expectCall :: f
expectCall = Proxy ((Show & Eq) & Typeable)
-> (forall a.
    (&) (Show & Eq) Typeable a =>
    [ExpectedVal] -> a -> [ExpectedVal])
-> ([ExpectedVal] -> ExpectedCallRecord)
-> [ExpectedVal]
-> f
forall f (args :: [*]) r (argC :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) acc.
Function f args r argC =>
proxy argC
-> (forall a. argC a => acc -> a -> acc) -> (acc -> r) -> acc -> f
createFunction (Proxy ((Show & Eq) & Typeable)
forall k (t :: k). Proxy t
Proxy :: Proxy (Show & Eq & Typeable)) forall a.
(Typeable a, Show a, Eq a) =>
[ExpectedVal] -> a -> [ExpectedVal]
forall a.
(&) (Show & Eq) Typeable a =>
[ExpectedVal] -> a -> [ExpectedVal]
fa [ExpectedVal] -> ExpectedCallRecord
fr []
  where
    fa :: [ExpectedVal] -> a -> [ExpectedVal]
fa [ExpectedVal]
args a
arg = (ExpectedVal -> [ExpectedVal] -> [ExpectedVal]
forall a. a -> [a] -> [a]
: [ExpectedVal]
args) (ExpectedVal -> [ExpectedVal]) -> ExpectedVal -> [ExpectedVal]
forall a b. (a -> b) -> a -> b
$ case a -> Maybe ExpectedVal
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
arg of
      Just ExpectedVal
arg' -> ExpectedVal
arg'
      Maybe ExpectedVal
Nothing -> a -> ExpectedVal
forall a. (Typeable a, Show a, Eq a) => a -> ExpectedVal
ExpectedVal a
arg
    fr :: [ExpectedVal] -> ExpectedCallRecord
fr [ExpectedVal]
args = [ExpectedVal] -> ExpectedVal -> ExpectedCallRecord
ExpectedCallRecord ([ExpectedVal] -> [ExpectedVal]
forall a. [a] -> [a]
reverse [ExpectedVal]
args) ExpectedVal
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 -> a -> ExpectedCallRecord
withResult (ExpectedCallRecord [ExpectedVal]
args ExpectedVal
_) a
arg = [ExpectedVal] -> ExpectedVal -> ExpectedCallRecord
ExpectedCallRecord [ExpectedVal]
args ExpectedVal
r
  where
    r :: ExpectedVal
r = case a -> Maybe ExpectedVal
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
arg of
      Just ExpectedVal
arg' -> ExpectedVal
arg'
      Maybe ExpectedVal
Nothing -> a -> ExpectedVal
forall a. (Typeable a, Show a, Eq a) => a -> ExpectedVal
ExpectedVal a
arg

checkCallRecord :: HasCallStack => ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
checkCallRecord :: ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
checkCallRecord actCall :: ActualCallRecord
actCall@(ActualCallRecord [ActualVal]
actArgs ActualVal
actRes) expCall :: ExpectedCallRecord
expCall@(ExpectedCallRecord [ExpectedVal]
expArgs ExpectedVal
expRes) =
  Maybe MockFailureReason
argFailure Maybe MockFailureReason
-> Maybe MockFailureReason -> Maybe MockFailureReason
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe MockFailureReason
resFailure
  where
    argFailure :: Maybe MockFailureReason
argFailure =
      if [ActualVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ActualVal]
actArgs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [ExpectedVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpectedVal]
expArgs
        then MockFailureReason -> Maybe MockFailureReason
forall a. a -> Maybe a
Just (MockFailureReason -> Maybe MockFailureReason)
-> MockFailureReason -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$ ActualCallRecord -> ExpectedCallRecord -> MockFailureReason
MockFailureArgumentCountMismatch ActualCallRecord
actCall ExpectedCallRecord
expCall
        else [MockFailureReason] -> Maybe MockFailureReason
forall a. [a] -> Maybe a
listToMaybe ([MockFailureReason] -> Maybe MockFailureReason)
-> [MockFailureReason] -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$ [Maybe MockFailureReason] -> [MockFailureReason]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe MockFailureReason] -> [MockFailureReason])
-> [Maybe MockFailureReason] -> [MockFailureReason]
forall a b. (a -> b) -> a -> b
$ (ActualVal -> ExpectedVal -> Maybe MockFailureReason)
-> [ActualVal] -> [ExpectedVal] -> [Maybe MockFailureReason]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ActualVal -> ExpectedVal -> Maybe MockFailureReason
matchArgs [ActualVal]
actArgs [ExpectedVal]
expArgs
    resFailure :: Maybe MockFailureReason
resFailure = ActualVal -> ExpectedVal -> Maybe MockFailureReason
matchArgs ActualVal
actRes ExpectedVal
expRes

matchArgs :: ActualVal -> ExpectedVal -> Maybe MockFailureReason
matchArgs :: ActualVal -> ExpectedVal -> Maybe MockFailureReason
matchArgs ActualVal
_ ExpectedVal
AnyVal = Maybe MockFailureReason
forall a. Maybe a
Nothing
matchArgs (ActualVal a
actual) (ExpectedVal a
expected) =
  case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
actual of
    Just a
actual' | a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual' -> Maybe MockFailureReason
forall a. Maybe a
Nothing
    Just a
actual' ->
      MockFailureReason -> Maybe MockFailureReason
forall a. a -> Maybe a
Just (MockFailureReason -> Maybe MockFailureReason)
-> MockFailureReason -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$
        a -> a -> MockFailureReason
forall a. Show a => a -> a -> MockFailureReason
MockFailureArgumentValueMismatch a
actual' a
expected
    Maybe a
Nothing ->
      MockFailureReason -> Maybe MockFailureReason
forall a. a -> Maybe a
Just (MockFailureReason -> Maybe MockFailureReason)
-> MockFailureReason -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$
        TypeRep -> TypeRep -> MockFailureReason
MockFailureArgumentTypeMismatch (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
actual) (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
expected)
matchArgs (ActualVal (a
actual :: a)) (PredicateVal (a -> Bool
p :: b -> Bool)) =
  case Maybe (a :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (a :~: b) of
    Maybe (a :~: a)
Nothing -> MockFailureReason -> Maybe MockFailureReason
forall a. a -> Maybe a
Just (MockFailureReason -> Maybe MockFailureReason)
-> MockFailureReason -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$ TypeRep -> TypeRep -> MockFailureReason
MockFailureArgumentTypeMismatch (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy b))
    Just a :~: a
Refl ->
      if a -> Bool
p a
a
actual
        then Maybe MockFailureReason
forall a. Maybe a
Nothing
        else MockFailureReason -> Maybe MockFailureReason
forall a. a -> Maybe a
Just (MockFailureReason -> Maybe MockFailureReason)
-> MockFailureReason -> Maybe MockFailureReason
forall a b. (a -> b) -> a -> b
$ a -> MockFailureReason
forall a. Show a => a -> MockFailureReason
MockFailureArgumentPredicateFailure a
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 :: [ExpectedCallRecord] -> Mock -> IO ()
assertHasCalls [ExpectedCallRecord]
expectedCalls Mock
mock = do
  [ActualCallRecord]
actualCalls <- Mock -> IO [ActualCallRecord]
getCalls Mock
mock
  [ActualCallRecord] -> [ExpectedCallRecord] -> IO ()
zipEqualLength [ActualCallRecord]
actualCalls [ExpectedCallRecord]
expectedCalls
  where
    throw :: MockFailureReason -> IO ()
throw = MockFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MockFailure -> IO ())
-> (MockFailureReason -> MockFailure) -> MockFailureReason -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mock -> Maybe SrcLoc -> MockFailureReason -> MockFailure
MockFailure Mock
mock Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location
    zipEqualLength :: [ActualCallRecord] -> [ExpectedCallRecord] -> IO ()
zipEqualLength [] [] = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    zipEqualLength (ActualCallRecord
a : [ActualCallRecord]
as) (ExpectedCallRecord
e : [ExpectedCallRecord]
es) = do
      IO ()
-> (MockFailureReason -> IO ()) -> Maybe MockFailureReason -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) MockFailureReason -> IO ()
throw (Maybe MockFailureReason -> IO ())
-> Maybe MockFailureReason -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
checkCallRecord ActualCallRecord
a ExpectedCallRecord
e
      [ActualCallRecord] -> [ExpectedCallRecord] -> IO ()
zipEqualLength [ActualCallRecord]
as [ExpectedCallRecord]
es
    zipEqualLength (ActualCallRecord
a : [ActualCallRecord]
_) [ExpectedCallRecord]
_ = MockFailureReason -> IO ()
throw (MockFailureReason -> IO ()) -> MockFailureReason -> IO ()
forall a b. (a -> b) -> a -> b
$ ActualCallRecord -> MockFailureReason
MockFailureUnexpectedCall ActualCallRecord
a
    zipEqualLength [ActualCallRecord]
_ (ExpectedCallRecord
e : [ExpectedCallRecord]
_) = MockFailureReason -> IO ()
throw (MockFailureReason -> IO ()) -> MockFailureReason -> IO ()
forall a b. (a -> b) -> a -> b
$ ExpectedCallRecord -> MockFailureReason
MockFailureNotCalled ExpectedCallRecord
e

-- | Assert the mock was never called.
assertNotCalled :: HasCallStack => Mock -> IO ()
assertNotCalled :: Mock -> IO ()
assertNotCalled = HasCallStack => [ExpectedCallRecord] -> Mock -> IO ()
[ExpectedCallRecord] -> Mock -> IO ()
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 :: ActualCallRecord -> ExpectedCallRecord -> Bool
callMatches ActualCallRecord
actCall ExpectedCallRecord
expCall = case HasCallStack =>
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
checkCallRecord ActualCallRecord
actCall ExpectedCallRecord
expCall of
  Maybe MockFailureReason
Nothing -> Bool
True
  Just MockFailureArgumentValueMismatch {} -> Bool
False
  Just MockFailureArgumentPredicateFailure {} -> Bool
False
  Just MockFailureReason
reason -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"callMatches: invalid arguments\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MockFailureReason -> String
forall a. Show a => a -> String
show MockFailureReason
reason

-- | Assert that the expected call happened at least once.
assertAnyCall :: ExpectedCallRecord -> Mock -> IO ()
assertAnyCall :: ExpectedCallRecord -> Mock -> IO ()
assertAnyCall ExpectedCallRecord
expCall Mock
mock = do
  [ActualCallRecord]
actualCalls <- Mock -> IO [ActualCallRecord]
getCalls Mock
mock
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ActualCallRecord -> Bool) -> [ActualCallRecord] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ActualCallRecord
actCall -> Maybe MockFailureReason -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe MockFailureReason -> Bool)
-> Maybe MockFailureReason -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
ActualCallRecord -> ExpectedCallRecord -> Maybe MockFailureReason
checkCallRecord ActualCallRecord
actCall ExpectedCallRecord
expCall) [ActualCallRecord]
actualCalls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MockFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MockFailure -> IO ()) -> MockFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Mock -> Maybe SrcLoc -> MockFailureReason -> MockFailure
MockFailure Mock
mock Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location (MockFailureReason -> MockFailure)
-> MockFailureReason -> MockFailure
forall a b. (a -> b) -> a -> b
$ ExpectedCallRecord -> MockFailureReason
MockFailureNotCalled ExpectedCallRecord
expCall

-- | Get list of calls. Use together with 'callMatches'
-- when the existing assert* functions are not flexible enough.
getCalls :: Mock -> IO [ActualCallRecord]
getCalls :: Mock -> IO [ActualCallRecord]
getCalls Mock {String
IORef [ActualCallRecord]
IORef [ActualCallRecord] -> x
mockFunction :: IORef [ActualCallRecord] -> x
mockCallRecord :: IORef [ActualCallRecord]
mockKey :: String
mockFunction :: ()
mockCallRecord :: Mock -> IORef [ActualCallRecord]
mockKey :: Mock -> String
..} = [ActualCallRecord] -> [ActualCallRecord]
forall a. [a] -> [a]
reverse ([ActualCallRecord] -> [ActualCallRecord])
-> IO [ActualCallRecord] -> IO [ActualCallRecord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [ActualCallRecord] -> IO [ActualCallRecord]
forall a. IORef a -> IO a
readIORef IORef [ActualCallRecord]
mockCallRecord

location :: HasCallStack => Maybe SrcLoc
location :: Maybe SrcLoc
location = case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse [(String, SrcLoc)]
HasCallStack => [(String, SrcLoc)]
callStack of
  (String
_, SrcLoc
loc) : [(String, SrcLoc)]
_ -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
loc
  [] -> Maybe SrcLoc
forall a. Maybe a
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 {MockMonadIO a -> forall (m :: * -> *). MonadIO m => m a
unMockMonadIO :: forall m. MonadIO m => m a}

instance Functor MockMonadIO where
  fmap :: (a -> b) -> MockMonadIO a -> MockMonadIO b
fmap a -> b
f (MockMonadIO forall (m :: * -> *). MonadIO m => m a
m) = (forall (m :: * -> *). MonadIO m => m b) -> MockMonadIO b
forall a. (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
MockMonadIO ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f m a
forall (m :: * -> *). MonadIO m => m a
m)

instance Applicative MockMonadIO where
  pure :: a -> MockMonadIO a
pure a
a = (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
forall a. (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
MockMonadIO (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
  MockMonadIO forall (m :: * -> *). MonadIO m => m (a -> b)
f <*> :: MockMonadIO (a -> b) -> MockMonadIO a -> MockMonadIO b
<*> MockMonadIO forall (m :: * -> *). MonadIO m => m a
a = (forall (m :: * -> *). MonadIO m => m b) -> MockMonadIO b
forall a. (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
MockMonadIO (m (a -> b)
forall (m :: * -> *). MonadIO m => m (a -> b)
f m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
forall (m :: * -> *). MonadIO m => m a
a)

instance Monad MockMonadIO where
  MockMonadIO forall (m :: * -> *). MonadIO m => m a
ma >>= :: MockMonadIO a -> (a -> MockMonadIO b) -> MockMonadIO b
>>= a -> MockMonadIO b
f = (forall (m :: * -> *). MonadIO m => m b) -> MockMonadIO b
forall a. (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
MockMonadIO ((forall (m :: * -> *). MonadIO m => m b) -> MockMonadIO b)
-> (forall (m :: * -> *). MonadIO m => m b) -> MockMonadIO b
forall a b. (a -> b) -> a -> b
$ m a
forall (m :: * -> *). MonadIO m => m a
ma m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MockMonadIO b -> m b
forall a. MockMonadIO a -> forall (m :: * -> *). MonadIO m => m a
unMockMonadIO (MockMonadIO b -> m b) -> (a -> MockMonadIO b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MockMonadIO b
f

instance MonadIO MockMonadIO where
  liftIO :: IO a -> MockMonadIO a
liftIO IO a
m = (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
forall a. (forall (m :: * -> *). MonadIO m => m a) -> MockMonadIO a
MockMonadIO (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m)

-- | The family of functions unMockMonadIO<N> 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 :: (a -> MockMonadIO x) -> forall (m :: * -> *). MonadIO m => a -> m x
unMockMonadIO1 a -> MockMonadIO x
f = MockMonadIO x -> m x
forall a. MockMonadIO a -> forall (m :: * -> *). MonadIO m => m a
unMockMonadIO (MockMonadIO x -> m x) -> (a -> MockMonadIO x) -> a -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MockMonadIO x
f

unMockMonadIO2 :: (a -> b -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> m x)
unMockMonadIO2 :: (a -> b -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> m x
unMockMonadIO2 a -> b -> MockMonadIO x
f = (b -> MockMonadIO x) -> b -> m x
forall a x.
(a -> MockMonadIO x) -> forall (m :: * -> *). MonadIO m => a -> m x
unMockMonadIO1 ((b -> MockMonadIO x) -> b -> m x)
-> (a -> b -> MockMonadIO x) -> a -> b -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> MockMonadIO x
f

unMockMonadIO3 :: (a -> b -> c -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> m x)
unMockMonadIO3 :: (a -> b -> c -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> c -> m x
unMockMonadIO3 a -> b -> c -> MockMonadIO x
f = (b -> c -> MockMonadIO x) -> b -> c -> m x
forall a b x.
(a -> b -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> m x
unMockMonadIO2 ((b -> c -> MockMonadIO x) -> b -> c -> m x)
-> (a -> b -> c -> MockMonadIO x) -> a -> b -> c -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> MockMonadIO x
f

unMockMonadIO4 :: (a -> b -> c -> d -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> d -> m x)
unMockMonadIO4 :: (a -> b -> c -> d -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> c -> d -> m x
unMockMonadIO4 a -> b -> c -> d -> MockMonadIO x
f = (b -> c -> d -> MockMonadIO x) -> b -> c -> d -> m x
forall a b c x.
(a -> b -> c -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> c -> m x
unMockMonadIO3 ((b -> c -> d -> MockMonadIO x) -> b -> c -> d -> m x)
-> (a -> b -> c -> d -> MockMonadIO x) -> a -> b -> c -> d -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> MockMonadIO x
f

unMockMonadIO5 :: (a -> b -> c -> d -> e -> MockMonadIO x) -> (forall m. MonadIO m => a -> b -> c -> d -> e -> m x)
unMockMonadIO5 :: (a -> b -> c -> d -> e -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> c -> d -> e -> m x
unMockMonadIO5 a -> b -> c -> d -> e -> MockMonadIO x
f = (b -> c -> d -> e -> MockMonadIO x) -> b -> c -> d -> e -> m x
forall a b c d x.
(a -> b -> c -> d -> MockMonadIO x)
-> forall (m :: * -> *). MonadIO m => a -> b -> c -> d -> m x
unMockMonadIO4 ((b -> c -> d -> e -> MockMonadIO x) -> b -> c -> d -> e -> m x)
-> (a -> b -> c -> d -> e -> MockMonadIO x)
-> a
-> b
-> c
-> d
-> e
-> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> e -> MockMonadIO x
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<N>@ 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 :: f' -> f
fromMockMonadIO = (MockMonadIO x -> m x) -> f' -> f
forall f (args :: [*]) b g a.
(Function f args b EmptyConstraint,
 Function g args a EmptyConstraint) =>
(a -> b) -> g -> f
composeN MockMonadIO x -> m x
forall a. MockMonadIO a -> forall (m :: * -> *). MonadIO m => m a
unMockMonadIO