HMock 0.2.0.0 → 0.3.0.0

raw patch · 15 files changed

+375/−133 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• HMock.cabal +1/−1
• src/Test/HMock/Internal/Rule.hs +18/−1
• src/Test/HMock/Internal/State.hs +5/−1
• src/Test/HMock/Internal/Step.hs +7/−3
• src/Test/HMock/Internal/TH.hs +7/−8
• src/Test/HMock/MockMethod.hs +62/−28
• src/Test/HMock/MockT.hs +29/−4
• src/Test/HMock/Multiplicity.hs +25/−24
• src/Test/HMock/Rule.hs +12/−2
• src/Test/HMock/TH.hs +90/−51
• test/Classes.hs +36/−8
• test/Core.hs +57/−1
• test/Extras.hs +17/−1
• test/QuasiMockBase.hs +1/−0

@@ -1,5 +1,13 @@ # Revision history for hmock +## 0.3.0.0 -- 2021-06-30++* Methods with polymorphic return types can now be mocked if the return type has+  a `Typeable` constraint.+* Added `whenever` to associate a side effect to a method.+* Added `WholeMethodMatcher` to match entire method args at once.+* `allowUnexpected` no longer changes the default for expected calls.+ ## 0.2.0.0 -- 2021-06-24  * Added ambiguity checking.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               HMock-version:            0.2.0.0+version:            0.3.0.0 synopsis:           A flexible mock framework for testing effectful code. description:        HMock is a flexible mock framework for testing effectful                     code in Haskell.  Tests can set up expectations about

@@ -11,6 +11,23 @@ import {-# SOURCE #-} Test.HMock.Internal.State (MockT) import Test.HMock.Mockable (MockableBase (..)) +-- | A way to match an entire action, using conditions that might depend on the+-- relationship between arguments.+data WholeMethodMatcher cls name m r+  = JustMatcher (Matcher cls name m r)+  | Matcher cls name m r `SuchThat` (Action cls name m r -> Bool)++-- | Displays a WholeMethodMatcher.  The predicate isn't showable, but we can at+-- least indicate whether there is one present.+showWholeMatcher ::+  MockableBase cls =>+  Maybe (Action cls name m a) ->+  WholeMethodMatcher cls name m b ->+  String+showWholeMatcher a (JustMatcher m) = showMatcher a m+showWholeMatcher a (m `SuchThat` _) =+  showMatcher a m ++ " (with whole method matcher)"+ -- | A rule for matching a method and responding to it when it matches. -- -- The method may be matched by providing either an 'Action' to match exactly,@@ -40,6 +57,6 @@     (r :: Type)   where   (:=>) ::-    Matcher cls name m r ->+    WholeMethodMatcher cls name m r ->     [Action cls name m r -> MockT m r] ->     Rule cls name m r

@@ -49,7 +49,9 @@ -- | Full state of a mock. data MockState m = MockState   { mockExpectSet :: TVar (ExpectSet (Step m)),-    mockDefaults :: TVar [(Bool, Step m)],+    mockDefaults :: TVar [Step m],+    mockAllowUnexpected :: TVar [Step m],+    mockSideEffects :: TVar [Step m],     mockCheckAmbiguity :: TVar Bool,     mockClasses :: TVar (Set TypeRep),     mockParent :: Maybe (MockState m)@@ -61,6 +63,8 @@ initMockState parent =   MockState     <$> newTVarIO ExpectNothing+    <*> newTVarIO []+    <*> newTVarIO []     <*> newTVarIO []     <*> maybeM       (newTVarIO False)

@@ -12,7 +12,11 @@ import GHC.TypeLits (Symbol) import Test.HMock.ExpectContext (ExpectContext (..), MockableMethod) import Test.HMock.Internal.ExpectSet (ExpectSet (..))-import Test.HMock.Internal.Rule (Rule (..))+import Test.HMock.Internal.Rule+  ( Rule (..),+    WholeMethodMatcher (..),+    showWholeMatcher,+  ) import {-# SOURCE #-} Test.HMock.Internal.State (MockT) import Test.HMock.Internal.Util (Located (..), locate, withLoc) import Test.HMock.Mockable (MockableBase (..))@@ -34,7 +38,7 @@     (r :: Type)   where   (:->) ::-    Matcher cls name m r ->+    WholeMethodMatcher cls name m r ->     Maybe (Action cls name m r -> MockT m r) ->     SingleRule cls name m r @@ -47,7 +51,7 @@  instance Show (Step m) where   show (Step l@(Loc _ (m :-> _))) =-    withLoc (showMatcher Nothing m <$ l)+    withLoc (showWholeMatcher Nothing m <$ l)  -- | Expands a Rule into an expectation.  The expected multiplicity will be one -- if there are no responses; otherwise one call is expected per response.

@@ -72,16 +72,15 @@     subst (VarT x) | Just t <- lookup x classVars = t     subst t = t --- | Splits a function type into a list of bound type vars, context, and--- parameters and return value.  The return value is the last element of the--- list.-splitType :: Type -> ([Name], Cxt, [Type])+-- | Splits a function type into a list of bound type vars, context, parameter+-- types, and return value type.+splitType :: Type -> ([Name], Cxt, [Type], Type) splitType (ForallT tv cx b) =-  let (tvs, cxs, parts) = splitType b-   in (map tvName tv ++ tvs, cx ++ cxs, parts)+  let (tvs, cxs, params, retval) = splitType b+   in (map tvName tv ++ tvs, cx ++ cxs, params, retval) splitType (AppT (AppT ArrowT a) b) =-  let (tvs, cx, parts) = splitType b in (tvs, cx, a : parts)-splitType r = ([], [], [r])+  let (tvs, cx, params, retval) = splitType b in (tvs, cx, a : params, retval)+splitType r = ([], [], [], r)  -- | Gets all free type variable 'Name's in the given 'Type'. freeTypeVars :: Type -> [Name]

@@ -11,7 +11,7 @@ where  import Control.Concurrent.STM (TVar, readTVar, writeTVar)-import Control.Monad (forM, join)+import Control.Monad (forM, forM_, join, void) import Control.Monad.Extra (concatMapM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (ask)@@ -21,12 +21,13 @@ import Data.Function (on) import Data.Functor (($>)) import Data.List (intercalate, sortBy)-import Data.Maybe (catMaybes, fromMaybe, isNothing)+import Data.Maybe (catMaybes) 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.Rule (WholeMethodMatcher (..), showWholeMatcher) import Test.HMock.Internal.State   ( MockContext (..),     MockSetup (..),@@ -40,8 +41,19 @@ import Test.HMock.Internal.Util (Located (Loc), withLoc) import Test.HMock.MockT (describeExpectations) import Test.HMock.Mockable (MatchResult (..), Mockable (..), MockableBase (..))-import Control.Applicative ((<|>)) +matchWholeAction ::+  MockableBase cls =>+  WholeMethodMatcher cls name m a ->+  Action cls name m a ->+  MatchResult+matchWholeAction (JustMatcher m) a = matchAction m a+matchWholeAction (m `SuchThat` p) a = case matchAction m a of+  NoMatch n -> NoMatch n+  Match+    | p a -> Match+    | otherwise -> NoMatch 0+ -- | Implements mock delegation for actions. mockMethodImpl ::   forall cls name m r.@@ -61,20 +73,30 @@             (tryMatch (mockExpectSet state) <$> liveSteps expectSet)     let orderedPartial = snd <$> sortBy (compare `on` fst) (catMaybes partial)     defaults <- concatMapM (mockSetupSTM . readTVar . mockDefaults) states+    unexpected <-+      concatMapM+        (mockSetupSTM . readTVar . mockAllowUnexpected)+        states+    sideEffect <-+      getSideEffect+        <$> concatMapM (mockSetupSTM . readTVar . mockSideEffects) states     checkAmbig <- mockSetupSTM $ readTVar . mockCheckAmbiguity . head $ states-    case (full, orderedPartial, findDefault defaults) of-      (opts@(_ : _ : _), _, _)+    case ( full,+           orderedPartial,+           allowedUnexpected unexpected,+           findDefault defaults+         ) of+      (opts@(_ : _ : _), _, _, _)         | checkAmbig ->-          return $-            ambiguityError-              action-              ((\(s, _, _) -> s) <$> opts)-      ((_, choose, Just response) : _, _, _) -> choose >> return response-      ((_, choose, Nothing) : _, _, (_, d)) -> choose >> return d-      ([], _, (True, d)) -> return d-      ([], [], _) -> return (noMatchError action)-      ([], _, _) ->-        return (partialMatchError action orderedPartial)+          return $ ambiguityError action ((\(s, _, _) -> s) <$> opts)+      ((_, choose, Just response) : _, _, _, _) ->+        choose >> return (sideEffect >> response)+      ((_, choose, Nothing) : _, _, _, d) ->+        choose >> return (sideEffect >> d)+      ([], _, Just (Just resp), _) -> return (sideEffect >> resp)+      ([], _, Just Nothing, d) -> return (sideEffect >> d)+      ([], [], _, _) -> return (noMatchError action)+      ([], _, _, _) -> return (partialMatchError action orderedPartial)   where     tryMatch ::       TVar (ExpectSet (Step m)) ->@@ -84,27 +106,39 @@         (String, MockSetup m (), Maybe (MockT m r))     tryMatch tvar (Step expected, e)       | Just lrule@(Loc _ (m :-> impl)) <- cast expected =-        case matchAction m action of+        case matchWholeAction m action of           NoMatch n ->-            Left (Just (n, withLoc (showMatcher (Just action) m <$ lrule)))+            Left (Just (n, withLoc (showWholeMatcher (Just action) m <$ lrule)))           Match ->             Right-              ( withLoc (lrule $> showMatcher (Just action) m),+              ( withLoc (lrule $> showWholeMatcher (Just action) m),                 mockSetupSTM $ writeTVar tvar e,                 ($ action) <$> impl               )       | otherwise = Left Nothing -    findDefault :: [(Bool, Step m)] -> (Bool, MockT m r)-    findDefault defaults = go False Nothing defaults-      where go True (Just r) _ = (True, r)-            go allowed r ((thisAllowed, Step expected) : steps)-              | thisAllowed || isNothing r,-                Just (Loc _ (m :-> r')) <- cast expected,-                Match <- matchAction m action =-                  go (allowed || thisAllowed) (r <|> (($ action) <$> r')) steps-              | otherwise = go allowed r steps-            go allowed r [] = (allowed, fromMaybe (return surrogate) r)+    allowedUnexpected :: [Step m] -> Maybe (Maybe (MockT m r))+    allowedUnexpected [] = Nothing+    allowedUnexpected (Step unexpected : steps)+      | Just (Loc _ (m :-> impl)) <- cast unexpected,+        Match <- matchWholeAction m action =+        Just (($ action) <$> impl)+      | otherwise = allowedUnexpected steps++    findDefault :: [Step m] -> MockT m r+    findDefault [] = return surrogate+    findDefault (Step expected : steps)+      | Just (Loc _ (m :-> impl)) <- cast expected,+        Match <- matchWholeAction m action =+        maybe (findDefault steps) ($ action) impl+      | otherwise = findDefault steps++    getSideEffect :: [Step m] -> MockT m ()+    getSideEffect effects =+      forM_ effects $ \(Step expected) -> case cast expected of+        Just (Loc _ (m :-> Just impl))+          | Match <- matchWholeAction m action -> void (impl action)+        _ -> return ()  -- | Implements a method in a 'Mockable' monad by delegating to the mock -- framework.  If the method is called unexpectedly, an exception will be

@@ -24,6 +24,7 @@     MockContext,     allowUnexpected,     byDefault,+    whenever,   ) where @@ -33,6 +34,7 @@   ) import Control.Monad.Trans (lift) import Data.List (intercalate)+import Data.Maybe (listToMaybe) import Data.Proxy (Proxy (Proxy)) import GHC.Stack (callStack) import Test.HMock.ExpectContext (MockableMethod)@@ -43,7 +45,6 @@ import Test.HMock.Internal.Util (locate) import Test.HMock.Rule (Expectable (toRule)) import UnliftIO-import Data.Maybe (listToMaybe)  -- | Runs a test in the 'MockT' monad, handling all of the mocks. runMockT :: forall m a. MonadIO m => MockT m a -> m a@@ -182,8 +183,8 @@     state <- MockSetup ask     mockSetupSTM $       modifyTVar'-        (mockDefaults state)-        ((True, Step (locate callStack (m :-> listToMaybe r))) :)+        (mockAllowUnexpected state)+        (Step (locate callStack (m :-> listToMaybe r)) :)  -- | Sets a default action for *expected* matching calls.  The new default only -- applies to calls for which an expectation exists, but it lacks an explicit@@ -202,5 +203,29 @@   mockSetupSTM $     modifyTVar'       (mockDefaults state)-      ((False, Step (locate callStack (m :-> Just r))) :)+      (Step (locate callStack (m :-> Just r)) :) byDefault _ = error "Defaults must have exactly one response."++-- | Adds a side-effect, which happens whenever a matching call occurs, in+-- addition to the usual response.  The return value is entirely ignored.+--+-- Be warned: using side effects makes it easy to break abstraction boundaries.+-- Be aware that there may be other uses of a method besides the one which you+-- intend to intercept here.  If possible, add the desired behavior to the+-- response for the matching expectation instead.+whenever ::+  forall cls name m r ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    MockContext ctx+  ) =>+  Rule cls name m r ->+  ctx m ()+whenever (m :=> [r]) = fromMockSetup $ do+  initClassIfNeeded (Proxy :: Proxy cls)+  state <- MockSetup ask+  mockSetupSTM $+    modifyTVar'+      (mockSideEffects state)+      (Step (locate callStack (m :-> Just r)) :)+whenever _ = error "Side effects must have exactly one response."

@@ -21,22 +21,23 @@ data Multiplicity = Multiplicity Int (Maybe Int) deriving (Eq)  instance Show Multiplicity where-  show mult = go (normalize mult) where-    go m | not (feasible m) = "infeasible"-    go (Multiplicity 0 (Just 0)) = "never"-    go (Multiplicity 1 (Just 1)) = "once"-    go (Multiplicity 2 (Just 2)) = "twice"-    go (Multiplicity 0 Nothing) = "any number of times"-    go (Multiplicity 1 Nothing) = "at least once"-    go (Multiplicity 2 Nothing) = "at least twice"-    go (Multiplicity n Nothing) = "at least " ++ show n ++ " times"-    go (Multiplicity 0 (Just 1)) = "at most once"-    go (Multiplicity 0 (Just 2)) = "at most twice"-    go (Multiplicity 0 (Just n)) = "at most " ++ show n ++ " times"-    go (Multiplicity m (Just n))-      | m == n = show n ++ " times"-      | m == n - 1 = show m ++ " or " ++ show n ++ " times"-      | otherwise = show m ++ " to " ++ show n ++ " times"+  show mult = go (normalize mult)+    where+      go m | not (feasible m) = "infeasible"+      go (Multiplicity 0 (Just 0)) = "never"+      go (Multiplicity 1 (Just 1)) = "once"+      go (Multiplicity 2 (Just 2)) = "twice"+      go (Multiplicity 0 Nothing) = "any number of times"+      go (Multiplicity 1 Nothing) = "at least once"+      go (Multiplicity 2 Nothing) = "at least twice"+      go (Multiplicity n Nothing) = "at least " ++ show n ++ " times"+      go (Multiplicity 0 (Just 1)) = "at most once"+      go (Multiplicity 0 (Just 2)) = "at most twice"+      go (Multiplicity 0 (Just n)) = "at most " ++ show n ++ " times"+      go (Multiplicity m (Just n))+        | m == n = show n ++ " times"+        | m == n - 1 = show m ++ " or " ++ show n ++ " times"+        | otherwise = show m ++ " to " ++ show n ++ " times"  -- | A 'Multiplicity' value representing inconsistent expectations. infeasible :: Multiplicity@@ -70,12 +71,12 @@   (*) = error "Multiplicities are not closed under multiplication"    abs = id--  signum (Multiplicity 0 (Just 0)) = 0-  signum _ = 1+  signum = id  normalize :: Multiplicity -> Multiplicity-normalize (Multiplicity a b) = Multiplicity (max a 0) b+normalize m@(Multiplicity a b)+  | not (feasible m) = infeasible+  | otherwise = Multiplicity (max a 0) b  -- | Checks whether a certain number satisfies the 'Multiplicity'. meetsMultiplicity :: Multiplicity -> Int -> Bool@@ -114,7 +115,7 @@ -- >>> meetsMultiplicity (atLeast 2) 3 -- True atLeast :: Multiplicity -> Multiplicity-atLeast (Multiplicity n _) = Multiplicity n Nothing+atLeast (Multiplicity n _) = normalize $ Multiplicity n Nothing  -- | A 'Multiplicity' that means at most this many times. --@@ -125,7 +126,7 @@ -- >>> meetsMultiplicity (atMost 2) 3 -- False atMost :: Multiplicity -> Multiplicity-atMost (Multiplicity _ n) = Multiplicity 0 n+atMost (Multiplicity _ n) = normalize $ Multiplicity 0 n  -- | A 'Multiplicity' that means any number in this interval, endpoints -- included.  For example, @'between' 2 3@ means 2 or 3 times, while@@ -140,7 +141,7 @@ -- >>> meetsMultiplicity (between 2 3) 4 -- False between :: Multiplicity -> Multiplicity -> Multiplicity-between (Multiplicity m _) (Multiplicity _ n) = Multiplicity m n+between (Multiplicity m _) (Multiplicity _ n) = normalize $ Multiplicity m n  -- | Checks whether a 'Multiplicity' is capable of matching any number at all. --@@ -151,4 +152,4 @@ -- >>> feasible (once - 2) -- False feasible :: Multiplicity -> Bool-feasible (Multiplicity a b) = maybe True (>= a) b+feasible (Multiplicity a b) = maybe True (>= max 0 a) b

@@ -6,9 +6,16 @@ -- matching methods.  The 'Expectable' type class generalizes 'Rule', so that -- you can specify a bare 'Matcher' or 'Action' in most situations where a -- 'Rule' is needed but you don't want to specify the response.-module Test.HMock.Rule (Rule, Expectable (..), (|->), (|=>)) where+module Test.HMock.Rule+  ( Rule,+    Expectable (..),+    (|->),+    (|=>),+    WholeMethodMatcher (SuchThat),+  )+where -import Test.HMock.Internal.Rule (Rule (..))+import Test.HMock.Internal.Rule (Rule (..), WholeMethodMatcher (..)) import {-# SOURCE #-} Test.HMock.Internal.State (MockT) import Test.HMock.Mockable (MockableBase (Action, Matcher)) @@ -46,4 +53,7 @@   toRule = id  instance Expectable cls name m r (Matcher cls name m r) where+  toRule m = JustMatcher m :=> []++instance Expectable cls name m r (WholeMethodMatcher cls name m r) where   toRule m = m :=> []

@@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}  -- | This module provides Template Haskell splices that can be used to derive -- boilerplate instances for HMock.@@ -53,12 +56,12 @@ import Data.List (foldl', (\\)) import Data.Typeable (Typeable) import GHC.Stack (HasCallStack)-import GHC.TypeLits (Symbol)+import GHC.TypeLits (ErrorMessage (Text, (:$$:), (:<>:)), Symbol, TypeError) import Language.Haskell.TH hiding (Match, match) import Language.Haskell.TH.Syntax (Lift (lift))+import Test.HMock.Internal.State (MockT) import Test.HMock.Internal.TH-import Test.HMock.MockT (MockT)-import Test.HMock.MockMethod (mockMethod, mockDefaultlessMethod)+import Test.HMock.MockMethod (mockDefaultlessMethod, mockMethod) import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..)) import Test.HMock.Predicates (Predicate (..), eq) import Test.HMock.Rule (Expectable (..))@@ -320,49 +323,62 @@         instExtraMembers = extraMembers       }   where-    memberOrMethod :: Dec -> Either String Method -> Q (Either Dec Method)-    memberOrMethod dec (Left warning) = do-      when (mockVerbose options) $ reportWarning warning+    memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)+    memberOrMethod dec (Left warnings) = do+      when (mockVerbose options) $ mapM_ reportWarning warnings       return (Left dec)     memberOrMethod _ (Right method) = return (Right method) -getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either String Method)+getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method) getMethod instTy m tbl (SigD name ty) = do   simpleTy <- localizeMember instTy m (substTypeVars tbl ty)+  let (tvs, cx, args, mretval) = splitType simpleTy   return $ do-    let (tvs, cx, argsAndReturn) = splitType simpleTy-    (m', result) <- case last argsAndReturn of-      AppT (VarT m') result -> return (m', result)+    retval <- case mretval of+      AppT (VarT m') retval | m' == m -> return retval       _ ->-        Left $-          nameBase name-            ++ " can't be mocked: non-monadic result."-    when (m' /= m) $-      Left $-        nameBase name-          ++ " can't be mocked: return value in wrong monad."-    when (relevantContext result (tvs, cx) /= ([], [])) $-      Left $-        nameBase name-          ++ " can't be mocked: polymorphic return value."-    let argTypes =-          map-            (substTypeVar m (AppT (ConT ''MockT) (VarT m)))-            (init argsAndReturn)+        Left+          [ nameBase name+              ++ " can't be mocked: return value not in the expected monad."+          ]+    unless (all (isVarTypeable cx) (filter (`elem` tvs) (freeTypeVars retval))) $+      Left+        [ nameBase name+            ++ " can't be mocked: return value not Typeable."+        ]+    let argTypes = map (substTypeVar m (AppT (ConT ''MockT) (VarT m))) args     when (any hasNestedPolyType argTypes) $-      Left $-        nameBase name-          ++ " can't be mocked: rank-n types nested in arguments."+      Left+        [ nameBase name+            ++ " can't be mocked: rank-n types nested in arguments."+        ]+     return $       Method         { methodName = name,           methodTyVars = tvs,           methodCxt = cx,           methodArgs = argTypes,-          methodResult = result+          methodResult = retval         }-getMethod _ _ _ _ = return (Left "A non-value member cannot be mocked.")+  where+    isVarTypeable :: Cxt -> Name -> Bool+    isVarTypeable cx v = AppT (ConT ''Typeable) (VarT v) `elem` cx +getMethod _ _ _ (DataD _ name _ _ _ _) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ (NewtypeD _ name _ _ _ _) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ (TySynD name _ _) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ (DataFamilyD name _ _) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) =+  return (Left [nameBase name ++ " must be defined in manual MockT instance."])+getMethod _ _ _ _ = return (Left [])+ isKnownType :: Method -> Type -> Bool isKnownType method ty = null tyVars && null cx   where@@ -598,33 +614,56 @@  defineExpectableActions :: MockableOptions -> Instance -> Q [Dec] defineExpectableActions options inst =-  concatMapM (defineExpectableAction options inst) (instMethods inst)+  mapM (defineExpectableAction options inst) (instMethods inst) -defineExpectableAction :: MockableOptions -> Instance -> Method -> Q [Dec]+type ComplexExpectableMessage name =+  ( 'Text "Method " ':<>: 'Text name+      ':<>: 'Text " is too complex to expect with an Action."+  )+    ':$$: 'Text "Suggested fix: Use a Matcher instead of an Action."++defineExpectableAction :: MockableOptions -> Instance -> Method -> Q Dec defineExpectableAction options inst method = do   maybeCxt <- wholeCxt (methodArgs method)   argVars <- replicateM (length (methodArgs method)) (newName "a")   case maybeCxt of     Just cx -> do-      (: [])-        <$> instanceD-          (pure (methodCxt method ++ cx))-          ( appT-              (withMethodParams inst method [t|Expectable|])-              (withMethodParams inst method [t|Action|])-          )-          [ funD-              'toRule-              [ clause-                  [conP (getActionName options method) (map varP argVars)]-                  ( normalB $-                      let matcherCon = conE (getMatcherName options method)-                       in appE (varE 'toRule) (makeBody argVars matcherCon)-                  )-                  []-              ]-          ]-    _ -> pure []+      instanceD+        (pure (methodCxt method ++ cx))+        ( appT+            (withMethodParams inst method [t|Expectable|])+            (withMethodParams inst method [t|Action|])+        )+        [ funD+            'toRule+            [ clause+                [conP (getActionName options method) (map varP argVars)]+                ( normalB $+                    let matcherCon = conE (getMatcherName options method)+                     in appE (varE 'toRule) (makeBody argVars matcherCon)+                )+                []+            ]+        ]+    _ -> do+      checkExt UndecidableInstances+      instanceD+        ( (: [])+            <$> [t|+              TypeError+                ( ComplexExpectableMessage+                    $(litT $ strTyLit $ nameBase $ methodName method)+                )+              |]+        )+        ( appT+            (withMethodParams inst method [t|Expectable|])+            (withMethodParams inst method [t|Action|])+        )+        [ funD+            'toRule+            [clause [] (normalB [|undefined|]) []]+        ]   where     makeBody [] e = e     makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|]

@@ -190,8 +190,6 @@   it "returns the customized default value" $ do     example $       runMockT $ do-        expectAny WithSetup-         result <- withSetup         liftIO (result `shouldBe` "custom default") @@ -489,11 +487,35 @@       success       failure `shouldThrow` anyException +class MonadPolyResult m where+  polyResult :: Typeable a => a -> m a+  nonTypeablePolyResult :: a -> m a++deriveMockable ''MonadPolyResult++instance (MonadIO m, Typeable m) => MonadPolyResult (MockT m) where+  polyResult x = mockDefaultlessMethod (PolyResult x)+  nonTypeablePolyResult x = return x++polyResultTests :: SpecWith ()+polyResultTests = describe "MonadPolyResult" $ do+  it "generates mock impl" $+    example $ do+      decs <- runMockT $ do+        $(onReify [|expectAny|] ''MonadPolyResult)+        runQ (deriveMockable ''MonadPolyResult)+      evaluate (rnf decs)++  it "is mockable" $+    example . runMockT $ do+      expect $ PolyResult_ anything |=> \(PolyResult a) -> return (a :: Int)+      x <- polyResult (3 :: Int)+      liftIO $ x `shouldBe` 3+ class MonadExtraneousMembers m where   data SomeDataType m   favoriteNumber :: SomeDataType m -> Int   wrongMonad :: Monad n => m Int -> n Int-  polyResult :: a -> m a   nestedRankN :: ((forall a. a -> Bool) -> Bool) -> m ()    mockableMethod :: Int -> m ()@@ -504,7 +526,6 @@   data SomeDataType (MockT m) = SomeCon   favoriteNumber SomeCon = 42   wrongMonad _ = return 42-  polyResult = return   nestedRankN _ = return ()    mockableMethod a = mockMethod (MockableMethod a)@@ -522,15 +543,22 @@     example $ do       decs <- runMockT $ do         $(onReify [|expectAny|] ''MonadExtraneousMembers)-        expect $ QReport False "A non-value member cannot be mocked."         expect $-          QReport False "favoriteNumber can't be mocked: non-monadic result."+          QReport+            False+            "SomeDataType must be defined in manual MockT instance."         expect $           QReport             False-            "wrongMonad can't be mocked: return value in wrong monad."+            ( "favoriteNumber can't be mocked: "+                ++ "return value not in the expected monad."+            )         expect $-          QReport False "polyResult can't be mocked: polymorphic return value."+          QReport+            False+            ( "wrongMonad can't be mocked: "+                ++ "return value not in the expected monad."+            )         expect $           QReport             False

@@ -14,7 +14,7 @@ import Control.Monad.Reader (MonadReader (local), ask, runReaderT) import Control.Monad.State (execStateT, modify) import Control.Monad.Trans (liftIO)-import Data.IORef (newIORef, readIORef, writeIORef)+import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) import Data.List (isInfixOf, isPrefixOf) import Test.HMock import Test.Hspec@@ -213,6 +213,24 @@         expect $ WriteFile_ (hasSubstr "bar") anything         writeFile "bar.txt" "unknown contents" +    it "matches with WholeMethodMatcher" $+      example $ do+        let setExpectations =+              expect $+                WriteFile_ anything anything+                  `SuchThat` \(WriteFile f txt) -> txt `isInfixOf` f++            success = runMockT $ do+              setExpectations+              writeFile "foo.txt" "foo"++            failure = runMockT $ do+              setExpectations+              writeFile "foo.txt" "bar"++        success+        failure `shouldThrow` anyException+     it "stores source location in suchThat predicate" $       example $ do         let test = runMockT $ do@@ -637,6 +655,20 @@               <*> readFile "baz.txt"           liftIO (result `shouldBe` ("foo", "bar", "")) +    it "performs side effects" $+      example $+        runMockT $ do+          ref <- liftIO $ newIORef False++          allowUnexpected $ WriteFile_ anything anything+          whenever $+            WriteFile_ anything anything+              |=> const (liftIO (writeIORef ref True))++          writeFile "foo.txt" "foo"++          liftIO (readIORef ref `shouldReturn` True)+     it "doesn't adopt lax behavior for byDefault" $       example $ do         let test = runMockT $ do@@ -698,6 +730,30 @@             liftIO (result `shouldBe` ("foo #1", "bar #1", "foo #2", "bar #2"))        it "inherits defaults correctly" $+        example $+          runMockT $ do+            allowUnexpected $ WriteFile_ anything anything++            superCount <- liftIO $ newIORef (0 :: Int)+            subCount <- liftIO $ newIORef (0 :: Int)++            whenever $+              WriteFile_ anything anything+                |=> \_ -> liftIO $ modifyIORef superCount (+ 1)+            writeFile "foo.txt" "foo"++            nestMockT $ do+              whenever $+                WriteFile_ anything anything+                  |=> \_ -> liftIO $ modifyIORef subCount (+ 1)+              writeFile "foo.txt" "foo"++            writeFile "foo.txt" "foo"++            liftIO (readIORef superCount `shouldReturn` 3)+            liftIO (readIORef subCount `shouldReturn` 1)++      it "inherits side effects correctly" $         example $           runMockT $ do             allowUnexpected $ ReadFile "foo.txt" |-> "foo"

@@ -15,6 +15,11 @@       <$> (fromInteger <$> arbitrary)       <*> (fromInteger . getNonNegative <$> arbitrary) +guessMultiplicity :: [Int] -> Multiplicity+guessMultiplicity vals+  | null vals = -1+  | otherwise = between (fromIntegral (minimum vals)) (fromIntegral (maximum vals))+ multiplicityTests :: SpecWith () multiplicityTests = do   describe "Multiplicity" $ do@@ -38,9 +43,20 @@         \m1 m2 (NonNegative n) ->           let natSums k = [(i, k - i) | i <- [0 .. k]]            in meetsMultiplicity (m1 + m2) n-                == any+                === any                   (\(j, k) -> meetsMultiplicity m1 j && meetsMultiplicity m2 k)                   (natSums n)++    it "correctly implements difference" $+      property $ \m1 m2 ->+        m1 - m2+          === guessMultiplicity+            [ i - j+              | i <- [0 .. 100],+                meetsMultiplicity m1 i,+                j <- [0 .. 100],+                meetsMultiplicity m2 j+            ]  predicateTests :: SpecWith () predicateTests = do

@@ -9,6 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  module QuasiMockBase where