{-# LANGUAGE ScopedTypeVariables #-}

-- | Functions to delegate 'Action's to HMock to match expectations.  There is
-- one delegation function that works if the return type has a 'Default'
-- instance, and another that doesn't require the 'Default' instance, but causes
-- the method to return 'undefined' by default.
module Test.HMock.MockMethod
  ( mockMethod,
    mockDefaultlessMethod,
  )
where

import Control.Concurrent.STM (TVar, readTVar, writeTVar)
import Control.Monad (forM, join)
import Control.Monad.Extra (concatMapM)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ask)
import Data.Bifunctor (bimap)
import Data.Default (Default (def))
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Functor (($>))
import Data.List (intercalate, sortBy)
import Data.Maybe (catMaybes, fromMaybe, isNothing)
import Data.Proxy (Proxy (Proxy))
import Data.Typeable (cast)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Test.HMock.ExpectContext (MockableMethod)
import Test.HMock.Internal.ExpectSet (ExpectSet, liveSteps)
import Test.HMock.Internal.State
  ( MockContext (..),
    MockSetup (..),
    MockState (..),
    MockT,
    allStates,
    initClassIfNeeded,
    mockSetupSTM,
  )
import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step))
import Test.HMock.Internal.Util (Located (Loc), withLoc)
import Test.HMock.MockT (describeExpectations)
import Test.HMock.Mockable (MatchResult (..), Mockable (..), MockableBase (..))
import Control.Applicative ((<|>))

-- | Implements mock delegation for actions.
mockMethodImpl ::
  forall cls name m r.
  (HasCallStack, MonadIO m, MockableMethod cls name m r) =>
  r ->
  Action cls name m r ->
  MockT m r
mockMethodImpl :: r -> Action cls name m r -> MockT m r
mockMethodImpl r
surrogate Action cls name m r
action = MockT m (MockT m r) -> MockT m r
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (MockT m (MockT m r) -> MockT m r)
-> MockT m (MockT m r) -> MockT m r
forall a b. (a -> b) -> a -> b
$
  MockSetup m (MockT m r) -> MockT m (MockT m r)
forall (ctx :: (* -> *) -> * -> *) (m :: * -> *) a.
(MockContext ctx, MonadIO m) =>
MockSetup m a -> ctx m a
fromMockSetup (MockSetup m (MockT m r) -> MockT m (MockT m r))
-> MockSetup m (MockT m r) -> MockT m (MockT m r)
forall a b. (a -> b) -> a -> b
$ do
    Proxy cls -> MockSetup m ()
forall (cls :: (* -> *) -> Constraint) (m :: * -> *)
       (proxy :: ((* -> *) -> Constraint) -> *).
(Mockable cls, Typeable m, MonadIO m) =>
proxy cls -> MockSetup m ()
initClassIfNeeded (Proxy cls
forall k (t :: k). Proxy t
Proxy :: Proxy cls)
    [MockState m]
states <- MockState m -> [MockState m]
forall (m :: * -> *). MockState m -> [MockState m]
allStates (MockState m -> [MockState m])
-> MockSetup m (MockState m) -> MockSetup m [MockState m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (MockState m) STM (MockState m)
-> MockSetup m (MockState m)
forall (m :: * -> *) a.
ReaderT (MockState m) STM a -> MockSetup m a
MockSetup ReaderT (MockState m) STM (MockState m)
forall r (m :: * -> *). MonadReader r m => m r
ask
    ([Maybe (Int, String)]
partial, [(String, MockSetup m (), Maybe (MockT m r))]
full) <- ([([Maybe (Int, String)],
   [(String, MockSetup m (), Maybe (MockT m r))])]
 -> ([Maybe (Int, String)],
     [(String, MockSetup m (), Maybe (MockT m r))]))
-> MockSetup
     m
     [([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))])]
-> MockSetup
     m
     ([Maybe (Int, String)],
      [(String, MockSetup m (), Maybe (MockT m r))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[Maybe (Int, String)]] -> [Maybe (Int, String)])
-> ([[(String, MockSetup m (), Maybe (MockT m r))]]
    -> [(String, MockSetup m (), Maybe (MockT m r))])
-> ([[Maybe (Int, String)]],
    [[(String, MockSetup m (), Maybe (MockT m r))]])
-> ([Maybe (Int, String)],
    [(String, MockSetup m (), Maybe (MockT m r))])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[Maybe (Int, String)]] -> [Maybe (Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, MockSetup m (), Maybe (MockT m r))]]
-> [(String, MockSetup m (), Maybe (MockT m r))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[Maybe (Int, String)]],
  [[(String, MockSetup m (), Maybe (MockT m r))]])
 -> ([Maybe (Int, String)],
     [(String, MockSetup m (), Maybe (MockT m r))]))
-> ([([Maybe (Int, String)],
      [(String, MockSetup m (), Maybe (MockT m r))])]
    -> ([[Maybe (Int, String)]],
        [[(String, MockSetup m (), Maybe (MockT m r))]]))
-> [([Maybe (Int, String)],
     [(String, MockSetup m (), Maybe (MockT m r))])]
-> ([Maybe (Int, String)],
    [(String, MockSetup m (), Maybe (MockT m r))])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Maybe (Int, String)],
  [(String, MockSetup m (), Maybe (MockT m r))])]
-> ([[Maybe (Int, String)]],
    [[(String, MockSetup m (), Maybe (MockT m r))]])
forall a b. [(a, b)] -> ([a], [b])
unzip) (MockSetup
   m
   [([Maybe (Int, String)],
     [(String, MockSetup m (), Maybe (MockT m r))])]
 -> MockSetup
      m
      ([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))]))
-> MockSetup
     m
     [([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))])]
-> MockSetup
     m
     ([Maybe (Int, String)],
      [(String, MockSetup m (), Maybe (MockT m r))])
forall a b. (a -> b) -> a -> b
$
      [MockState m]
-> (MockState m
    -> MockSetup
         m
         ([Maybe (Int, String)],
          [(String, MockSetup m (), Maybe (MockT m r))]))
-> MockSetup
     m
     [([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [MockState m]
states ((MockState m
  -> MockSetup
       m
       ([Maybe (Int, String)],
        [(String, MockSetup m (), Maybe (MockT m r))]))
 -> MockSetup
      m
      [([Maybe (Int, String)],
        [(String, MockSetup m (), Maybe (MockT m r))])])
-> (MockState m
    -> MockSetup
         m
         ([Maybe (Int, String)],
          [(String, MockSetup m (), Maybe (MockT m r))]))
-> MockSetup
     m
     [([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))])]
forall a b. (a -> b) -> a -> b
$ \MockState m
state -> do
        ExpectSet (Step m)
expectSet <- STM (ExpectSet (Step m)) -> MockSetup m (ExpectSet (Step m))
forall a (m :: * -> *). STM a -> MockSetup m a
mockSetupSTM (STM (ExpectSet (Step m)) -> MockSetup m (ExpectSet (Step m)))
-> STM (ExpectSet (Step m)) -> MockSetup m (ExpectSet (Step m))
forall a b. (a -> b) -> a -> b
$ TVar (ExpectSet (Step m)) -> STM (ExpectSet (Step m))
forall a. TVar a -> STM a
readTVar (MockState m -> TVar (ExpectSet (Step m))
forall (m :: * -> *). MockState m -> TVar (ExpectSet (Step m))
mockExpectSet MockState m
state)
        ([Maybe (Int, String)],
 [(String, MockSetup m (), Maybe (MockT m r))])
-> MockSetup
     m
     ([Maybe (Int, String)],
      [(String, MockSetup m (), Maybe (MockT m r))])
forall (m :: * -> *) a. Monad m => a -> m a
return (([Maybe (Int, String)],
  [(String, MockSetup m (), Maybe (MockT m r))])
 -> MockSetup
      m
      ([Maybe (Int, String)],
       [(String, MockSetup m (), Maybe (MockT m r))]))
-> ([Maybe (Int, String)],
    [(String, MockSetup m (), Maybe (MockT m r))])
-> MockSetup
     m
     ([Maybe (Int, String)],
      [(String, MockSetup m (), Maybe (MockT m r))])
forall a b. (a -> b) -> a -> b
$
          [Either
   (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))]
-> ([Maybe (Int, String)],
    [(String, MockSetup m (), Maybe (MockT m r))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
            (TVar (ExpectSet (Step m))
-> (Step m, ExpectSet (Step m))
-> Either
     (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))
tryMatch (MockState m -> TVar (ExpectSet (Step m))
forall (m :: * -> *). MockState m -> TVar (ExpectSet (Step m))
mockExpectSet MockState m
state) ((Step m, ExpectSet (Step m))
 -> Either
      (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r)))
-> [(Step m, ExpectSet (Step m))]
-> [Either
      (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpectSet (Step m) -> [(Step m, ExpectSet (Step m))]
forall step. ExpectSet step -> [(step, ExpectSet step)]
liveSteps ExpectSet (Step m)
expectSet)
    let orderedPartial :: [String]
orderedPartial = (Int, String) -> String
forall a b. (a, b) -> b
snd ((Int, String) -> String) -> [(Int, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, String) -> (Int, String) -> Ordering)
-> [(Int, String)] -> [(Int, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, String) -> Int)
-> (Int, String)
-> (Int, String)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, String) -> Int
forall a b. (a, b) -> a
fst) ([Maybe (Int, String)] -> [(Int, String)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Int, String)]
partial)
    [(Bool, Step m)]
defaults <- (MockState m -> MockSetup m [(Bool, Step m)])
-> [MockState m] -> MockSetup m [(Bool, Step m)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (STM [(Bool, Step m)] -> MockSetup m [(Bool, Step m)]
forall a (m :: * -> *). STM a -> MockSetup m a
mockSetupSTM (STM [(Bool, Step m)] -> MockSetup m [(Bool, Step m)])
-> (MockState m -> STM [(Bool, Step m)])
-> MockState m
-> MockSetup m [(Bool, Step m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar [(Bool, Step m)] -> STM [(Bool, Step m)]
forall a. TVar a -> STM a
readTVar (TVar [(Bool, Step m)] -> STM [(Bool, Step m)])
-> (MockState m -> TVar [(Bool, Step m)])
-> MockState m
-> STM [(Bool, Step m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockState m -> TVar [(Bool, Step m)]
forall (m :: * -> *). MockState m -> TVar [(Bool, Step m)]
mockDefaults) [MockState m]
states
    Bool
checkAmbig <- STM Bool -> MockSetup m Bool
forall a (m :: * -> *). STM a -> MockSetup m a
mockSetupSTM (STM Bool -> MockSetup m Bool) -> STM Bool -> MockSetup m Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (TVar Bool -> STM Bool)
-> ([MockState m] -> TVar Bool) -> [MockState m] -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockState m -> TVar Bool
forall (m :: * -> *). MockState m -> TVar Bool
mockCheckAmbiguity (MockState m -> TVar Bool)
-> ([MockState m] -> MockState m) -> [MockState m] -> TVar Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MockState m] -> MockState m
forall a. [a] -> a
head ([MockState m] -> STM Bool) -> [MockState m] -> STM Bool
forall a b. (a -> b) -> a -> b
$ [MockState m]
states
    case ([(String, MockSetup m (), Maybe (MockT m r))]
full, [String]
orderedPartial, [(Bool, Step m)] -> (Bool, MockT m r)
findDefault [(Bool, Step m)]
defaults) of
      (opts :: [(String, MockSetup m (), Maybe (MockT m r))]
opts@((String, MockSetup m (), Maybe (MockT m r))
_ : (String, MockSetup m (), Maybe (MockT m r))
_ : [(String, MockSetup m (), Maybe (MockT m r))]
_), [String]
_, (Bool, MockT m r)
_)
        | Bool
checkAmbig ->
          MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (MockT m r -> MockSetup m (MockT m r))
-> MockT m r -> MockSetup m (MockT m r)
forall a b. (a -> b) -> a -> b
$
            Action cls name m r -> [String] -> MockT m r
forall (cls :: (* -> *) -> Constraint) (m :: * -> *)
       (name :: Symbol) r a.
(Mockable cls, MonadIO m) =>
Action cls name m r -> [String] -> MockT m a
ambiguityError
              Action cls name m r
action
              ((\(String
s, MockSetup m ()
_, Maybe (MockT m r)
_) -> String
s) ((String, MockSetup m (), Maybe (MockT m r)) -> String)
-> [(String, MockSetup m (), Maybe (MockT m r))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, MockSetup m (), Maybe (MockT m r))]
opts)
      ((String
_, MockSetup m ()
choose, Just MockT m r
response) : [(String, MockSetup m (), Maybe (MockT m r))]
_, [String]
_, (Bool, MockT m r)
_) -> MockSetup m ()
choose MockSetup m ()
-> MockSetup m (MockT m r) -> MockSetup m (MockT m r)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return MockT m r
response
      ((String
_, MockSetup m ()
choose, Maybe (MockT m r)
Nothing) : [(String, MockSetup m (), Maybe (MockT m r))]
_, [String]
_, (Bool
_, MockT m r
d)) -> MockSetup m ()
choose MockSetup m ()
-> MockSetup m (MockT m r) -> MockSetup m (MockT m r)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return MockT m r
d
      ([], [String]
_, (Bool
True, MockT m r
d)) -> MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return MockT m r
d
      ([], [], (Bool, MockT m r)
_) -> MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Action cls name m r -> MockT m r
forall (cls :: (* -> *) -> Constraint) (m :: * -> *)
       (name :: Symbol) r a.
(Mockable cls, MonadIO m) =>
Action cls name m r -> MockT m a
noMatchError Action cls name m r
action)
      ([], [String]
_, (Bool, MockT m r)
_) ->
        MockT m r -> MockSetup m (MockT m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Action cls name m r -> [String] -> MockT m r
forall (cls :: (* -> *) -> Constraint) (m :: * -> *)
       (name :: Symbol) r a.
(Mockable cls, MonadIO m) =>
Action cls name m r -> [String] -> MockT m a
partialMatchError Action cls name m r
action [String]
orderedPartial)
  where
    tryMatch ::
      TVar (ExpectSet (Step m)) ->
      (Step m, ExpectSet (Step m)) ->
      Either
        (Maybe (Int, String))
        (String, MockSetup m (), Maybe (MockT m r))
    tryMatch :: TVar (ExpectSet (Step m))
-> (Step m, ExpectSet (Step m))
-> Either
     (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))
tryMatch TVar (ExpectSet (Step m))
tvar (Step Located (SingleRule cls name m r)
expected, ExpectSet (Step m)
e)
      | Just lrule :: Located (SingleRule cls name m r)
lrule@(Loc Maybe String
_ (Matcher cls name m r
m :-> Maybe (Action cls name m r -> MockT m r)
impl)) <- Located (SingleRule cls name m r)
-> Maybe (Located (SingleRule cls name m r))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Located (SingleRule cls name m r)
expected =
        case Matcher cls name m r -> Action cls name m r -> MatchResult
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a.
MockableBase cls =>
Matcher cls name m a -> Action cls name m a -> MatchResult
matchAction Matcher cls name m r
m Action cls name m r
action of
          NoMatch Int
n ->
            Maybe (Int, String)
-> Either
     (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))
forall a b. a -> Either a b
Left ((Int, String) -> Maybe (Int, String)
forall a. a -> Maybe a
Just (Int
n, Located String -> String
withLoc (Maybe (Action cls name m r) -> Matcher cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a b.
MockableBase cls =>
Maybe (Action cls name m a) -> Matcher cls name m b -> String
showMatcher (Action cls name m r -> Maybe (Action cls name m r)
forall a. a -> Maybe a
Just Action cls name m r
action) Matcher cls name m r
m String -> Located (SingleRule cls name m r) -> Located String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Located (SingleRule cls name m r)
lrule)))
          MatchResult
Match ->
            (String, MockSetup m (), Maybe (MockT m r))
-> Either
     (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))
forall a b. b -> Either a b
Right
              ( Located String -> String
withLoc (Located (SingleRule cls name m r)
lrule Located (SingleRule cls name m r) -> String -> Located String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe (Action cls name m r) -> Matcher cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a b.
MockableBase cls =>
Maybe (Action cls name m a) -> Matcher cls name m b -> String
showMatcher (Action cls name m r -> Maybe (Action cls name m r)
forall a. a -> Maybe a
Just Action cls name m r
action) Matcher cls name m r
m),
                STM () -> MockSetup m ()
forall a (m :: * -> *). STM a -> MockSetup m a
mockSetupSTM (STM () -> MockSetup m ()) -> STM () -> MockSetup m ()
forall a b. (a -> b) -> a -> b
$ TVar (ExpectSet (Step m)) -> ExpectSet (Step m) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ExpectSet (Step m))
tvar ExpectSet (Step m)
e,
                ((Action cls name m r -> MockT m r)
-> Action cls name m r -> MockT m r
forall a b. (a -> b) -> a -> b
$ Action cls name m r
action) ((Action cls name m r -> MockT m r) -> MockT m r)
-> Maybe (Action cls name m r -> MockT m r) -> Maybe (MockT m r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Action cls name m r -> MockT m r)
impl
              )
      | Bool
otherwise = Maybe (Int, String)
-> Either
     (Maybe (Int, String)) (String, MockSetup m (), Maybe (MockT m r))
forall a b. a -> Either a b
Left Maybe (Int, String)
forall a. Maybe a
Nothing

    findDefault :: [(Bool, Step m)] -> (Bool, MockT m r)
    findDefault :: [(Bool, Step m)] -> (Bool, MockT m r)
findDefault [(Bool, Step m)]
defaults = Bool -> Maybe (MockT m r) -> [(Bool, Step m)] -> (Bool, MockT m r)
forall (m :: * -> *).
Bool -> Maybe (MockT m r) -> [(Bool, Step m)] -> (Bool, MockT m r)
go Bool
False Maybe (MockT m r)
forall a. Maybe a
Nothing [(Bool, Step m)]
defaults
      where go :: Bool -> Maybe (MockT m r) -> [(Bool, Step m)] -> (Bool, MockT m r)
go Bool
True (Just MockT m r
r) [(Bool, Step m)]
_ = (Bool
True, MockT m r
r)
            go Bool
allowed Maybe (MockT m r)
r ((Bool
thisAllowed, Step Located (SingleRule cls name m r)
expected) : [(Bool, Step m)]
steps)
              | Bool
thisAllowed Bool -> Bool -> Bool
|| Maybe (MockT m r) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (MockT m r)
r,
                Just (Loc Maybe String
_ (Matcher cls name m r
m :-> Maybe (Action cls name m r -> MockT m r)
r')) <- Located (SingleRule cls name m r)
-> Maybe (Located (SingleRule cls name m r))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Located (SingleRule cls name m r)
expected,
                MatchResult
Match <- Matcher cls name m r -> Action cls name m r -> MatchResult
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a.
MockableBase cls =>
Matcher cls name m a -> Action cls name m a -> MatchResult
matchAction Matcher cls name m r
m Action cls name m r
action =
                  Bool -> Maybe (MockT m r) -> [(Bool, Step m)] -> (Bool, MockT m r)
go (Bool
allowed Bool -> Bool -> Bool
|| Bool
thisAllowed) (Maybe (MockT m r)
r Maybe (MockT m r) -> Maybe (MockT m r) -> Maybe (MockT m r)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (((Action cls name m r -> MockT m r)
-> Action cls name m r -> MockT m r
forall a b. (a -> b) -> a -> b
$ Action cls name m r
action) ((Action cls name m r -> MockT m r) -> MockT m r)
-> Maybe (Action cls name m r -> MockT m r) -> Maybe (MockT m r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Action cls name m r -> MockT m r)
r')) [(Bool, Step m)]
steps
              | Bool
otherwise = Bool -> Maybe (MockT m r) -> [(Bool, Step m)] -> (Bool, MockT m r)
go Bool
allowed Maybe (MockT m r)
r [(Bool, Step m)]
steps
            go Bool
allowed Maybe (MockT m r)
r [] = (Bool
allowed, MockT m r -> Maybe (MockT m r) -> MockT m r
forall a. a -> Maybe a -> a
fromMaybe (r -> MockT m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
surrogate) Maybe (MockT m r)
r)

-- | Implements a method in a 'Mockable' monad by delegating to the mock
-- framework.  If the method is called unexpectedly, an exception will be
-- thrown.  However, an expected invocation without a specified response will
-- return the default value.
mockMethod ::
  ( HasCallStack,
    MonadIO m,
    MockableMethod cls name m r,
    Default r
  ) =>
  Action cls name m r ->
  MockT m r
mockMethod :: Action cls name m r -> MockT m r
mockMethod Action cls name m r
action =
  (HasCallStack => MockT m r) -> MockT m r
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => MockT m r) -> MockT m r)
-> (HasCallStack => MockT m r) -> MockT m r
forall a b. (a -> b) -> a -> b
$ r -> Action cls name m r -> MockT m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
(HasCallStack, MonadIO m, MockableMethod cls name m r) =>
r -> Action cls name m r -> MockT m r
mockMethodImpl r
forall a. Default a => a
def Action cls name m r
action

-- | Implements a method in a 'Mockable' monad by delegating to the mock
-- framework.  If the method is called unexpectedly, an exception will be
-- thrown.  However, an expected invocation without a specified response will
-- return undefined.  This can be used in place of 'mockMethod' when the return
-- type has no default.
mockDefaultlessMethod ::
  ( HasCallStack,
    MonadIO m,
    MockableMethod cls name m r
  ) =>
  Action cls name m r ->
  MockT m r
mockDefaultlessMethod :: Action cls name m r -> MockT m r
mockDefaultlessMethod Action cls name m r
action =
  (HasCallStack => MockT m r) -> MockT m r
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => MockT m r) -> MockT m r)
-> (HasCallStack => MockT m r) -> MockT m r
forall a b. (a -> b) -> a -> b
$ r -> Action cls name m r -> MockT m r
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) r.
(HasCallStack, MonadIO m, MockableMethod cls name m r) =>
r -> Action cls name m r -> MockT m r
mockMethodImpl r
forall a. HasCallStack => a
undefined Action cls name m r
action

-- | An error for an action that matches no expectations at all.
noMatchError ::
  (Mockable cls, MonadIO m) => Action cls name m r -> MockT m a
noMatchError :: Action cls name m r -> MockT m a
noMatchError Action cls name m r
a = do
  String
fullExpectations <- MockT m String
forall (m :: * -> *). MonadIO m => MockT m String
describeExpectations
  String -> MockT m a
forall a. HasCallStack => String -> a
error (String -> MockT m a) -> String -> MockT m a
forall a b. (a -> b) -> a -> b
$
    String
"Unexpected action: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Action cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a.
MockableBase cls =>
Action cls name m a -> String
showAction Action cls name m r
a
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nFull expectations:\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fullExpectations

-- | An error for an action that doesn't match the argument predicates for any
-- of the method's expectations.
partialMatchError ::
  (Mockable cls, MonadIO m) =>
  Action cls name m r ->
  [String] ->
  MockT m a
partialMatchError :: Action cls name m r -> [String] -> MockT m a
partialMatchError Action cls name m r
a [String]
partials = do
  String
fullExpectations <- MockT m String
forall (m :: * -> *). MonadIO m => MockT m String
describeExpectations
  String -> MockT m a
forall a. HasCallStack => String -> a
error (String -> MockT m a) -> String -> MockT m a
forall a b. (a -> b) -> a -> b
$
    String
"Wrong arguments: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Action cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a.
MockableBase cls =>
Action cls name m a -> String
showAction Action cls name m r
a
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nClosest matches:\n - "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n - " (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
5 [String]
partials)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nFull expectations:\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fullExpectations

-- | An error for an 'Action' that matches more than one 'Matcher'.  This only
-- triggers an error if ambiguity checks are on.
ambiguityError ::
  (Mockable cls, MonadIO m) =>
  Action cls name m r ->
  [String] ->
  MockT m a
ambiguityError :: Action cls name m r -> [String] -> MockT m a
ambiguityError Action cls name m r
a [String]
choices = do
  String
fullExpectations <- MockT m String
forall (m :: * -> *). MonadIO m => MockT m String
describeExpectations
  String -> MockT m a
forall a. HasCallStack => String -> a
error (String -> MockT m a) -> String -> MockT m a
forall a b. (a -> b) -> a -> b
$
    String
"Ambiguous action matched multiple expectations: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Action cls name m r -> String
forall (cls :: (* -> *) -> Constraint) (name :: Symbol)
       (m :: * -> *) a.
MockableBase cls =>
Action cls name m a -> String
showAction Action cls name m r
a
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nMatches:\n - "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n - " [String]
choices
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nFull expectations:\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fullExpectations