HMock 0.1.0.1 → 0.2.0.0

raw patch · 39 files changed

+4514/−4108 lines, 39 filesdep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• HMock.cabal +16/−11
• src/Test/HMock.hs +65/−90
• src/Test/HMock/ExpectContext.hs +190/−0
• src/Test/HMock/Internal/ExpectSet.hs +9/−10
• src/Test/HMock/Internal/Expectable.hs +0/−342
• src/Test/HMock/Internal/MockT.hs +0/−301
• src/Test/HMock/Internal/MockT.hs-boot +0/−12
• src/Test/HMock/Internal/Mockable.hs +0/−55
• src/Test/HMock/Internal/Multiplicity.hs +0/−153
• src/Test/HMock/Internal/Predicates.hs +0/−944
• src/Test/HMock/Internal/Rule.hs +45/−0
• src/Test/HMock/Internal/State.hs +193/−0
• src/Test/HMock/Internal/State.hs-boot +18/−0
• src/Test/HMock/Internal/Step.hs +108/−0
• src/Test/HMock/Internal/TH.hs +194/−656
• src/Test/HMock/Internal/TH/Util.hs +0/−208
• src/Test/HMock/Internal/Util.hs +7/−0
• src/Test/HMock/MockMethod.hs +181/−0
• src/Test/HMock/MockT.hs +206/−0
• src/Test/HMock/Mockable.hs +78/−0
• src/Test/HMock/Multiplicity.hs +154/−0
• src/Test/HMock/Predicates.hs +980/−0
• src/Test/HMock/Rule.hs +49/−0
• src/Test/HMock/TH.hs +698/−24
• test/Classes.hs +76/−113
• test/Core.hs +105/−2
• test/Demo.hs +8/−6
• test/DocTests/All.hs +4/−4
• test/DocTests/Test/HMock/Internal/Multiplicity.hs +0/−166
• test/DocTests/Test/HMock/Internal/Predicates.hs +0/−898
• test/DocTests/Test/HMock/Multiplicity.hs +142/−0
• test/DocTests/Test/HMock/Predicates.hs +874/−0
• test/ExpectSet.hs +5/−2
• test/Extras.hs +4/−2
• test/QuasiMock.hs +39/−67
• test/QuasiMockBase.hs +45/−0
• test/TH.hs +6/−17
• test/Util/TH.hs +0/−25

@@ -1,5 +1,20 @@ # Revision history for hmock +## 0.2.0.0 -- 2021-06-24++* Added ambiguity checking.+  * This is an optional feature, which is off by default.+  * To make it easier to avoid ambiguity, there is now an `allowUnexpected` that+  * causes unexpected calls to be ignored and optionally provide a response, but+    doesn't comflict with expectations that override it.  Ambiuguous uses of+    `expectAny` can often be replaced with `allowUnexpected`.+* Restricted mockable setup to defaults to avoid race conditions.+  * Setup handlers now run in the `MockSetup` monad.+  * Adding expectations from setup is no longer allowed.  However, you can use+    `allowUnexpected` to allow unexpected calls.+* Added `nestMockT` and `withNestedMockT` to the API.+* Exported smaller modules to make selective imports easier.+ ## 0.1.0.1 -- 2021-06-20  * Fixed a bad dependency that broke some GHC versions.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               HMock-version:            0.1.0.1+version:            0.2.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@@ -29,15 +29,19 @@  library     exposed-modules:  Test.HMock,+                      Test.HMock.ExpectContext,+                      Test.HMock.Mockable,+                      Test.HMock.MockMethod,+                      Test.HMock.MockT,+                      Test.HMock.Multiplicity,+                      Test.HMock.Predicates,+                      Test.HMock.Rule,                       Test.HMock.TH,-                      Test.HMock.Internal.Multiplicity,-                      Test.HMock.Internal.MockT,                       Test.HMock.Internal.ExpectSet,-                      Test.HMock.Internal.Expectable,-                      Test.HMock.Internal.Mockable,-                      Test.HMock.Internal.Predicates,+                      Test.HMock.Internal.Rule,+                      Test.HMock.Internal.State,+                      Test.HMock.Internal.Step,                       Test.HMock.Internal.TH,-                      Test.HMock.Internal.TH.Util,                       Test.HMock.Internal.Util     build-depends:    base >=4.11.0 && < 4.16,                       constraints >= 0.13 && < 0.14,@@ -49,6 +53,7 @@                       mono-traversable >= 1.0.15 && < 1.1,                       mtl >= 2.2.2 && < 2.3,                       regex-tdfa >= 1.3.1 && < 1.4,+                      stm >= 2.5.0 && < 2.6,                       syb >= 0.7.2 && < 0.8,                       template-haskell >= 2.13.0 && < 2.18,                       transformers-base >= 0.4.5 && < 0.5,@@ -64,14 +69,14 @@                       Core,                       Demo,                       DocTests.All,-                      DocTests.Test.HMock.Internal.Multiplicity,-                      DocTests.Test.HMock.Internal.Predicates,+                      DocTests.Test.HMock.Multiplicity,+                      DocTests.Test.HMock.Predicates,                       ExpectSet,                       Extras,                       QuasiMock,+                      QuasiMockBase,                       TH,-                      Util.DeriveRecursive,-                      Util.TH+                      Util.DeriveRecursive     build-depends:    HMock,                       QuickCheck,                       base,

@@ -49,102 +49,77 @@ -- 'runMockT' to begin a test with mocks, 'expect' to set up your expected -- actions and responses, and finally execute your code. module Test.HMock-  ( -- * Running mocks-    MockT,-    runMockT,-    withMockT,-    describeExpectations,-    verifyExpectations,-    byDefault,+  ( +    -- * The 'Mockable' class -    -- * Setting expectations-    MockableMethod,-    Expectable (..),-    Rule,-    (|=>),-    (|->),-    ExpectContext,-    expect,-    expectN,-    expectAny,-    inSequence,-    inAnyOrder,-    anyOf,-    times,-    consecutiveTimes,+    -- | HMock starts with the 'Mockable' class (most of which is actually in+    -- its superclass, 'MockableBase').  This class is implemented for each+    -- interface you want to mock, and describes which actions are possible,+    -- and how to match and compare them.  It's a lot of boilerplate, so you'll+    -- usually derive it with Template Haskell, but the instance must exist.+    module Test.HMock.Mockable, +    -- * Running mocks++    -- | Tests with mocks run in the 'MockT' monad transformer, which wraps a+    -- base monad and adds the ability to delegate methods to HMock for+    -- matching.  'runMockT' is the entry point for 'MockT'.+    --+    -- This module also defines the more restricted 'MockSetup;' monad, which+    -- is used to set up defaults for a type.+    module Test.HMock.MockT,++    -- * Rules for actions and responses++    -- | The bread and butter of mocks is matching actions and specifying+    -- responses.  Matchers and corresponding responses are combined into a+    -- 'Rule'+    module Test.HMock.Rule,++    -- * Combinators for building test plans++    -- | A complete execution plans consists of a collection of individual rules+    -- combined in various ways.  HMock defines a set of composable combinators+    -- for the execution plan.+    module Test.HMock.ExpectContext,+     -- * Predicates-    Predicate (..),-    anything,-    eq,-    neq,-    gt,-    geq,-    lt,-    leq,-    just,-    left,-    right,-    zipP,-    zip3P,-    zip4P,-    zip5P,-    andP,-    orP,-    notP,-    startsWith,-    endsWith,-    hasSubstr,-    hasSubsequence,-    caseInsensitive,-    matchesRegex,-    matchesCaseInsensitiveRegex,-    containsRegex,-    containsCaseInsensitiveRegex,-    isEmpty,-    nonEmpty,-    sizeIs,-    elemsAre,-    unorderedElemsAre,-    each,-    contains,-    containsAll,-    containsOnly,-    containsKey,-    containsEntry,-    keysAre,-    entriesAre,-    approxEq,-    finite,-    infinite,-    nAn,-    is,-    qIs,-    with,-    qWith,-    qMatch,-    typed, +    -- | When matching methods, you can either match on exact parameter values,+    -- or using 'Predicate's.  The 'Predicate' type either accepts or rejects+    -- values of parameters, and HMock provides an extensive library of standard+    -- 'Predicate's to make it easier to match exactly what you want to.+    module Test.HMock.Predicates,+     -- * Multiplicity-    Multiplicity,-    meetsMultiplicity,-    once,-    anyMultiplicity,-    atLeast,-    atMost,-    between, -    -- * Implementing mocks-    MockableBase (..),-    Mockable (..),-    MatchResult (..),-    mockMethod,-    mockDefaultlessMethod,+    -- | For repeated actions in your execution plan, you often want to control+    -- the number of times somrthing is allowed to happen.  This is called a+    -- 'Multiplicity'.+    module Test.HMock.Multiplicity,++    -- * Delegating mocks++    -- | In order to run your test code with the 'MockT', you need instances of+    -- your effect classes for the 'MockT' type.  If you mock all methods of the+    -- class, this can be derived using Template Haskell.  For partial mocks,+    -- you'll need to write the instances yourself, using 'mockMethod' and its+    -- cousin 'mockDefaultlessMethod'.+    module Test.HMock.MockMethod,++    -- * Template Haskell generator++    -- | These are the Template Haskell splices which generate boilerplate for+    -- your classes to be used with HMock.+    module Test.HMock.TH,   ) where -import Test.HMock.Internal.Expectable-import Test.HMock.Internal.MockT-import Test.HMock.Internal.Mockable-import Test.HMock.Internal.Multiplicity-import Test.HMock.Internal.Predicates+import Test.HMock.ExpectContext+import Test.HMock.MockT+import Test.HMock.MockMethod+import Test.HMock.Mockable+import Test.HMock.Multiplicity+import Test.HMock.Predicates+import Test.HMock.Rule+import Test.HMock.TH

@@ -0,0 +1,190 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}++-- | This module defines the 'ExpectContext' class, whose members provide the+-- combinators for building the execution plan for your mocks.  Notably, there+-- is a 'Test.HMock.MockT.MockT' instance for 'ExpectContext', so you can use+-- these combinators to add expectations inside your tests that run in+-- 'Test.HMock.MockT.MockT', as well as nesting them in other combinators.+module Test.HMock.ExpectContext+  ( MockableMethod,+    ExpectContext (..),+  )+where++import Control.Monad.IO.Class (MonadIO)+import Data.Kind (Constraint, Type)+import Data.Typeable (Typeable)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (KnownSymbol, Symbol)+import Test.HMock.Mockable (Mockable)+import Test.HMock.Multiplicity (Multiplicity)+import Test.HMock.Rule (Expectable)++-- | All constraints needed to mock a method with the given class, name, base+-- monad, and return type.+type MockableMethod+  (cls :: (Type -> Type) -> Constraint)+  (name :: Symbol)+  (m :: Type -> Type)+  (r :: Type) =+  (Mockable cls, Typeable m, KnownSymbol name, Typeable r)++-- | Type class for contexts in which one can build expectations.  Notably, this+-- includes `Test.HMock.MockT.MockT`, which expects actions to be performed+-- during a test.+--+-- The methods of this class represent the user-facing API for build your+-- execution plan for mocks.+class ExpectContext (ctx :: (Type -> Type) -> Type -> Type) where+  -- | Creates an expectation that an action is performed once per given+  -- response (or exactly once if there is no response).+  --+  -- @+  -- 'Test.HMock.MockT.runMockT' '$' do+  --   'expect' '$'+  --     ReadFile "foo.txt"+  --       'Test.HMock.Rule.|->' "lorem ipsum"+  --       'Test.HMock.Rule.|->' "oops, the file changed out from under me!"+  --   callCodeUnderTest+  -- @+  --+  -- In this example, `readFile` must be called exactly twice by the tested+  -- code, and will return "lorem ipsum" the first time, but something different the+  -- second time.+  expect ::+    ( HasCallStack,+      MonadIO m,+      MockableMethod cls name m r,+      Expectable cls name m r expectable+    ) =>+    expectable ->+    ctx m ()++  -- | Creates an expectation that an action is performed some number of times.+  --+  -- @+  --   'Test.HMock.MockT.runMockT' '$' do+  --     'expect' '$' MakeList+  --     'expectN' ('Test.HMock.atLeast' 2) '$'+  --       CheckList "Cindy Lou Who" 'Test.HMock.Rule.|->' "nice"+  --+  --     callCodeUnderTest+  -- @+  expectN ::+    ( HasCallStack,+      MonadIO m,+      MockableMethod cls name m r,+      Expectable cls name m r expectable+    ) =>+    -- | The number of times the action should be performed.+    Multiplicity ->+    -- | The action and its response.+    expectable ->+    ctx m ()++  -- | Specifies a response if a matching action is performed, but doesn't+  -- expect anything.  This is equivalent to @'expectN'+  -- 'Test.HMock.Multiplicity.anyMultiplicity'@, but shorter.+  --+  -- In this example, the later use of 'expectAny' overrides earlier uses, but+  -- only for calls that match its conditions.+  --+  -- @+  --   'Test.HMock.MockT.runMockT' '$' do+  --     'expectAny' '$' ReadFile_ anything 'Test.HMock.Rule.|->' "tlhIngan maH!"+  --     'expectAny' '$' ReadFile "config.txt" 'Test.HMock.Rule.|->' "lang: klingon"+  --+  --     callCodeUnderTest+  -- @+  expectAny ::+    ( HasCallStack,+      MonadIO m,+      MockableMethod cls name m r,+      Expectable cls name m r expectable+    ) =>+    expectable ->+    ctx m ()++  -- | Creates a sequential expectation.  Other actions can still happen during+  -- the sequence, but these specific expectations must be met in this order.+  --+  -- @+  --   'inSequence'+  --     [ 'expect' '$' MoveForward,+  --       'expect' '$' TurnRight,+  --       'expect' '$' MoveForward+  --     ]+  -- @+  --+  -- Beware of using 'inSequence' too often.  It is appropriate when the+  -- property you are testing is that the order of effects is correct.  If+  -- that's not the purpose of the test, consider adding several independent+  -- expectations, instead.  This avoids over-asserting, and keeps your tests+  -- less brittle.+  inSequence ::+    MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m ()++  -- | Combines multiple expectations, which can occur in any order.  Most of+  -- the time, you can achieve the same thing by expecting each separately, but+  -- this can be combined in complex expectations to describe more complex+  -- ordering constraints.+  --+  -- If ambiguity checking is disabled, the choice is left-biased, so earlier+  -- options are preferred over ambiguous later options.+  --+  -- @+  --   'inSequence'+  --     [ 'inAnyOrder'+  --         [ 'expect' '$' AdjustMirrors,+  --           'expect' '$' FastenSeatBelt+  --         ],+  --       'expect' '$' StartCar+  --     ]+  -- @+  inAnyOrder ::+    MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m ()++  -- | Combines multiple expectations, requiring exactly one of them to occur.+  -- If ambiguity checking is disabled, the choice is left-biased, so earlier+  -- options are preferred over ambiguous later options.+  --+  -- @+  --   'anyOf'+  --     [ 'expect' $ ApplyForJob,+  --       'expect' $ ApplyForUniversity+  --     ]+  -- @+  anyOf ::+    MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m ()++  -- | Creates a parent expectation that the child expectation will happen a+  -- certain number of times.  Unlike `expectN`, the child expectation can be+  -- arbitrarily complex and span multiple actions.  Also unlike 'expectN', each+  -- new execution will restart response sequences for rules with more than one+  -- response.+  --+  -- Different occurrences of the child can be interleaved.  If ambiguity+  -- checking is disabled, progressing on an existing occurrence is preferred+  -- over starting a new occurrence when it's ambiguous.+  times ::+    MonadIO m =>+    Multiplicity ->+    (forall ctx'. ExpectContext ctx' => ctx' m ()) ->+    ctx m ()++  -- | Creates a parent expectation that the child expectation will happen a+  -- certain number of times.  Unlike `expectN`, the child expectation can be+  -- arbitrarily complex and span multiple actions.  Also unlike 'expectN', each+  -- new execution will restart response sequences for rules with more than one+  -- response.+  --+  -- Different occurrences of the child must happen consecutively, with one+  -- finishing before the next begins.+  consecutiveTimes ::+    MonadIO m =>+    Multiplicity ->+    (forall ctx'. ExpectContext ctx' => ctx' m ()) ->+    ctx m ()

@@ -3,14 +3,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +-- | The internal core language of expectations in HMock. module Test.HMock.Internal.ExpectSet where -import Test.HMock.Internal.Multiplicity+import Test.HMock.Multiplicity   ( Multiplicity,     between,-    exhaustable,-    feasible,-    normalize,+    feasible, meetsMultiplicity   )  -- | A set of expected steps and their responses.  This is the "core" language@@ -40,9 +39,9 @@ satisfied (ExpectInterleave e f) = satisfied e && satisfied f satisfied (ExpectEither e f) = satisfied e || satisfied f satisfied (ExpectMulti mult e) =-  feasible mult && (exhaustable mult || satisfied e)+  feasible mult && (meetsMultiplicity mult 0 || satisfied e) satisfied (ExpectConsecutive mult e) =-  feasible mult && (exhaustable mult || satisfied e)+  feasible mult && (meetsMultiplicity mult 0 || satisfied e)  -- | Computes the live steps of the ExpectSet.  In other words: which individual -- steps can be matched right now, and what are the remaining expectations in@@ -107,7 +106,7 @@   | ExpectNothing <- e' = ExpectNothing   | m == 0 = ExpectNothing   | m == 1 = e'-  | otherwise = ExpectMulti (normalize m) e'+  | otherwise = ExpectMulti m e'   where     e' = simplify e simplify (ExpectConsecutive m e)@@ -115,7 +114,7 @@   | ExpectNothing <- e' = ExpectNothing   | m == 0 = ExpectNothing   | m == 1 = e'-  | otherwise = ExpectConsecutive (normalize m) e'+  | otherwise = ExpectConsecutive m e'   where     e' = simplify e simplify other = other@@ -196,9 +195,9 @@       | satisfied e || satisfied f = ExpectNothing       | otherwise = ExpectEither (go e) (go f)     go (ExpectMulti m e)-      | exhaustable m = ExpectNothing+      | meetsMultiplicity m 0 = ExpectNothing       | otherwise = ExpectMulti m (go e)     go (ExpectConsecutive m e)-      | exhaustable m = ExpectNothing+      | meetsMultiplicity m 0 = ExpectNothing       | otherwise = ExpectConsecutive m (go e)     go other = other

@@ -1,342 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}--module Test.HMock.Internal.Expectable where--import Control.Monad.Trans (MonadIO)-import Data.Kind (Constraint, Type)-import Data.Maybe (listToMaybe)-import Data.Typeable-import GHC.Stack (CallStack, HasCallStack, callStack)-import GHC.TypeLits (KnownSymbol, Symbol)-import Test.HMock.Internal.ExpectSet-import {-# SOURCE #-} Test.HMock.Internal.MockT-import Test.HMock.Internal.Mockable-import Test.HMock.Internal.Multiplicity-import Test.HMock.Internal.Util (Located (Loc), locate, withLoc)---- | Something that can be expected.  This type class covers a number of cases:------   * Expecting an exact 'Action'.---   * Expecting anything that matches a 'Matcher'.---   * Adding a return value (with '|->') or response (with '|=>').-class Expectable cls name m r e | e -> cls name m r where-  toRule :: e -> Rule cls name m r---- | 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,--- or a 'Matcher'.  Exact matching is only available when all method arguments--------- A 'Rule' may have zero or more responses, which are attached using '|->' and--- '|=>'.  If there are no responses for a 'Rule', then there must be a default--- response for that action, and it is used.  If more than one response is--- added, the rule will perform the responses in order, repeating the last--- response if there are additional matches.------ Example:------ @--- 'expect' $---   GetLine_ 'Test.HMock.anything'---     '|->' "hello"---     '|=>' \(GetLine prompt) -> "The prompt was " ++ prompt---     '|->' "quit"--- @-data-  Rule-    (cls :: (Type -> Type) -> Constraint)-    (name :: Symbol)-    (m :: Type -> Type)-    (r :: Type)-  where-  (:=>) ::-    Matcher cls name m r ->-    [Action cls name m r -> MockT m r] ->-    Rule cls name m r---- | Attaches a response to an expectation.  This is a very flexible response,--- which can look at arguments, do things in the base monad, set up more--- expectations, etc.  The matching 'Action' is passed to the response, and is--- guaranteed to be a match so it's fine to just pattern match on the correct--- method.-(|=>) ::-  Expectable cls name m r expectable =>-  expectable ->-  (Action cls name m r -> MockT m r) ->-  Rule cls name m r-e |=> r = m :=> (rs ++ [r]) where m :=> rs = toRule e--infixl 1 |=>---- | Attaches a return value to an expectation.  This is more convenient than--- '|=>' in the common case where you just want to return a known result.--- @e '|->' r@ means the same thing as @e '|=>' 'const' ('return' r)@.-(|->) ::-  (Monad m, Expectable cls name m r expectable) =>-  expectable ->-  r ->-  Rule cls name m r-m |-> r = m |=> const (return r)--infixl 1 |->--instance Expectable cls name m r (Rule cls name m r) where-  toRule = id--instance Expectable cls name m r (Matcher cls name m r) where-  toRule m = m :=> []---- | All constraints needed to mock a method with the given class, name, base--- monad, and return type.-type MockableMethod-  (cls :: (Type -> Type) -> Constraint)-  (name :: Symbol)-  (m :: Type -> Type)-  (r :: Type) =-  (Mockable cls, Typeable m, KnownSymbol name, Typeable r)---- | A Rule that contains only a single response.  This is the target for--- desugaring the multi-response rule format.-data-  SingleRule-    (cls :: (Type -> Type) -> Constraint)-    (name :: Symbol)-    (m :: Type -> Type)-    (r :: Type)-  where-  (:->) ::-    Matcher cls name m r ->-    Maybe (Action cls name m r -> MockT m r) ->-    SingleRule cls name m r---- | A single step of an expectation.-data Step m where-  Step ::-    MockableMethod cls name m r =>-    Located (SingleRule cls name m r) ->-    Step m--instance Show (Step m) where-  show (Step l@(Loc _ (m :-> _))) =-    withLoc (showMatcher 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.-expandRule ::-  MockableMethod cls name m r =>-  CallStack ->-  Rule cls name m r ->-  ExpectSet (Step m)-expandRule callstack (m :=> []) =-  ExpectStep (Step (locate callstack (m :-> Nothing)))-expandRule callstack (m :=> rs) =-  foldr1-    ExpectInterleave-    (map (ExpectStep . Step . locate callstack . (m :->) . Just) rs)---- | Expands a Rule into an expectation, given a target multiplicity.  It is an--- error if there are too many responses for the multiplicity.  If there are--- too few responses, the last response will be repeated.-expandRepeatRule ::-  MockableMethod cls name m r =>-  Multiplicity ->-  CallStack ->-  Rule cls name m r ->-  ExpectSet (Step m)-expandRepeatRule mult _ (_ :=> rs)-  | not (feasible (mult - fromIntegral (length rs))) =-    error $-      show (length rs)-        ++ " responses is too many for multiplicity "-        ++ show mult-expandRepeatRule mult callstack (m :=> (r1 : r2 : rs)) =-  ExpectSequence first (expandRepeatRule (mult - 1) callstack (m :=> (r2 : rs)))-  where-    first-      | exhaustable mult =-        ExpectMulti-          (atMost 1)-          (ExpectStep (Step (locate callstack (m :-> Just r1))))-      | otherwise = ExpectStep (Step (locate callstack (m :-> Just r1)))-expandRepeatRule mult callstack (m :=> rs) =-  ExpectMulti mult (ExpectStep (Step (locate callstack (m :-> listToMaybe rs))))---- | Type class for contexts in which it makes sense to express an expectation.--- Notably, this includes `MockT`, which expects actions to be performed during--- a test.-class ExpectContext (t :: (Type -> Type) -> Type -> Type) where-  fromExpectSet :: MonadIO m => ExpectSet (Step m) -> t m ()--newtype Expected m a = Expected {unwrapExpected :: ExpectSet (Step m)}--instance ExpectContext Expected where-  fromExpectSet = Expected---- | Creates an expectation that an action is performed once per given--- response (or exactly once if there is no response).------ @--- 'runMockT' '$' do---   'expect' '$'---     ReadFile "foo.txt"---       '|->' "lorem ipsum"---       '|->' "oops, the file changed out from under me!"---   callCodeUnderTest--- @------ In this example, `readFile` must be called exactly twice by the tested code,--- and will return "lorem ipsum" the first time, but something different the--- second time.-expect ::-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r,-    Expectable cls name m r expectable,-    ExpectContext ctx-  ) =>-  expectable ->-  ctx m ()-expect e = fromExpectSet (expandRule callStack (toRule e))---- | Creates an expectation that an action is performed some number of times.------ @---   'runMockT' '$' do---     'expect' '$' MakeList---     'expectN' ('Test.HMock.atLeast' 2) '$'---       CheckList "Cindy Lou Who" '|->' "nice"------     callCodeUnderTest--- @-expectN ::-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r,-    Expectable cls name m r expectable,-    ExpectContext ctx-  ) =>-  -- | The number of times the action should be performed.-  Multiplicity ->-  -- | The action and its response.-  expectable ->-  ctx m ()-expectN mult e = fromExpectSet (expandRepeatRule mult callStack (toRule e))---- | Specifies a response if a matching action is performed, but doesn't expect--- anything.  This is equivalent to @'expectN' 'anyMultiplicity'@, but shorter.------ In this example, the later use of 'whenever' overrides earlier uses, but only--- for calls that match its conditions.------ @---   'runMockT' '$' do---     'whenever' '$' ReadFile_ anything '|->' "tlhIngan maH!"---     'whenever' '$' ReadFile "config.txt" '|->' "lang: klingon"------     callCodeUnderTest--- @-expectAny ::-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r,-    Expectable cls name m r expectable,-    ExpectContext ctx-  ) =>-  expectable ->-  ctx m ()-expectAny e =-  fromExpectSet (expandRepeatRule anyMultiplicity callStack (toRule e))---- | Creates a sequential expectation.  Other actions can still happen during--- the sequence, but these specific expectations must be met in this order.------ @---   'inSequence'---     [ 'expect' '$' MoveForward,---       'expect' '$' TurnRight,---       'expect' '$' MoveForward---     ]--- @------ Beware of using 'inSequence' too often.  It is appropriate when the property--- you are testing is that the order of effects is correct.  If that's not the--- purpose of the test, consider adding several independent expectations,--- instead.  This avoids over-asserting, and keeps your tests less brittle.-inSequence ::-  (MonadIO m, ExpectContext ctx) =>-  (forall ctx'. ExpectContext ctx' => [ctx' m ()]) ->-  ctx m ()-inSequence es = fromExpectSet (foldr1 ExpectSequence (map unwrapExpected es))---- | Combines multiple expectations, which can occur in any order.  Most of the--- time, you can achieve the same thing by expecting each separately, but this--- can be combined in complex expectations to describe more complex ordering--- constraints.------ @---   'inSequence'---     [ 'inAnyOrder'---         [ 'expect' '$' AdjustMirrors,---           'expect' '$' FastenSeatBelt---         ],---       'expect' '$' StartCar---     ]--- @-inAnyOrder ::-  (MonadIO m, ExpectContext ctx) =>-  (forall ctx'. ExpectContext ctx' => [ctx' m ()]) ->-  ctx m ()-inAnyOrder es = fromExpectSet (foldr1 ExpectInterleave (map unwrapExpected es))---- | Combines multiple expectations, requiring exactly one of them to occur.------ @---   'anyOf'---     [ 'expect' $ ApplyForJob,---       'expect' $ ApplyForUniversity---     ]--- @-anyOf ::-  (MonadIO m, ExpectContext ctx) =>-  (forall ctx'. ExpectContext ctx' => [ctx' m ()]) ->-  ctx m ()-anyOf es = fromExpectSet (foldr1 ExpectEither (map unwrapExpected es))---- | Creates a parent expectation that the child expectation will happen a--- certain number of times.  Unlike `expectN`, the child expectation can be--- arbitrarily complex and span multiple actions.  Also unlike 'expectN', each--- new execution will restart response sequences for rules with more than one--- response.------ Different occurrences of the child can be interleaved.  In case of ambiguity,--- progressing on an existing occurrence is preferred over starting a new--- occurrence.-times :: (MonadIO m, ExpectContext ctx) =>-  Multiplicity ->-  (forall ctx'. ExpectContext ctx' => ctx' m ()) ->-  ctx m ()-times mult e = fromExpectSet (ExpectMulti mult (unwrapExpected e))---- | Creates a parent expectation that the child expectation will happen a--- certain number of times.  Unlike `expectN`, the child expectation can be--- arbitrarily complex and span multiple actions.  Also unlike 'expectN', each--- new execution will restart response sequences for rules with more than one--- response.------ Different occurrences of the child must happen consecutively, with one--- finishing before the next begins.-consecutiveTimes :: (MonadIO m, ExpectContext ctx) =>-  Multiplicity ->-  (forall ctx'. ExpectContext ctx' => ctx' m ()) ->-  ctx m ()-consecutiveTimes mult e =-  fromExpectSet (ExpectConsecutive mult (unwrapExpected e))

@@ -1,301 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--module Test.HMock.Internal.MockT where--import Control.Concurrent (MVar)-import Control.Monad (forM_, unless)-import Control.Monad.Base (MonadBase)-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)-import Control.Monad.Cont (MonadCont)-import Control.Monad.Except (MonadError)-import Control.Monad.RWS (MonadRWS)-import Control.Monad.Reader-  ( MonadReader (ask, local, reader),-    ReaderT,-    mapReaderT,-    runReaderT,-  )-import Control.Monad.State (MonadState)-import Control.Monad.Trans (MonadIO, MonadTrans, lift)-import Control.Monad.Writer (MonadWriter)-import Data.Default (Default (def))-import Data.Either (partitionEithers)-import Data.Function (on)-import Data.List (intercalate, sortBy)-import Data.Maybe (catMaybes, fromMaybe)-import Data.Proxy (Proxy (Proxy))-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Typeable (TypeRep, Typeable, cast, typeRep)-import GHC.Stack-import Test.HMock.Internal.ExpectSet-import Test.HMock.Internal.Expectable-import Test.HMock.Internal.Mockable-import Test.HMock.Internal.Util (Located (..), locate, withLoc)-import UnliftIO (MonadUnliftIO, newMVar, putMVar, readMVar, takeMVar)--#if !MIN_VERSION_base(4, 13, 0)-import Control.Monad.Fail (MonadFail)-#endif--data MockState m = MockState-  { mockExpectSet :: ExpectSet (Step m),-    mockDefaults :: [Step m],-    mockClasses :: Set TypeRep-  }--initMockState :: MockState m-initMockState =-  MockState-    { mockExpectSet = ExpectNothing,-      mockDefaults = [],-      mockClasses = Set.empty-    }---- | Monad transformer for running mocks.-newtype MockT m a where-  MockT :: {unMockT :: ReaderT (MVar (MockState m)) m a} -> MockT m a-  deriving-    ( Functor,-      Applicative,-      Monad,-      MonadFail,-      MonadIO,-      MonadState s,-      MonadWriter w,-      MonadRWS r w s,-      MonadError e,-      MonadCont,-      MonadBase b,-      MonadCatch,-      MonadMask,-      MonadThrow,-      MonadUnliftIO-    )--instance MonadTrans MockT where-  lift = MockT . lift--mapMockT :: (m a -> m b) -> MockT m a -> MockT m b-mapMockT f = MockT . mapReaderT f . unMockT--initClassIfNeeded ::-  forall cls m proxy.-  (Mockable cls, Typeable m, MonadIO m) =>-  proxy cls ->-  MockT m ()-initClassIfNeeded proxy =-  do-    stateVar <- MockT ask-    mockState <- takeMVar stateVar-    let newMockClasses = Set.insert t (mockClasses mockState)-    putMVar stateVar (mockState {mockClasses = newMockClasses})-    unless (t `Set.member` mockClasses mockState) $ do-      setupMockable (Proxy :: Proxy cls)-  where-    t = typeRep proxy--initClassesAsNeeded :: MonadIO m => ExpectSet (Step m) -> MockT m ()-initClassesAsNeeded es = forM_ (getSteps es) $-  \(Step (_ :: Located (SingleRule cls name m r))) ->-    initClassIfNeeded (Proxy :: Proxy cls)--instance MonadReader r m => MonadReader r (MockT m) where-  ask = lift ask-  local = mapMockT . local-  reader = lift . reader--instance ExpectContext MockT where-  fromExpectSet e = do-    initClassesAsNeeded e-    stateVar <- MockT ask-    mockState <- takeMVar stateVar-    let newExpectSet = e `ExpectInterleave` mockExpectSet mockState-    putMVar stateVar (mockState {mockExpectSet = newExpectSet})---- | Runs a test in the 'MockT' monad, handling all of the mocks.-runMockT :: forall m a. MonadIO m => MockT m a -> m a-runMockT test = withMockT constTest-  where-    constTest :: (forall b. MockT m b -> m b) -> MockT m a-    constTest _inMockT = test---- | Runs a test in the 'MockT' monad.  The test can unlift other MockT pieces--- to the base monad while still acting on the same set of expectations.  This--- can be useful for testing concurrency or similar mechanisms.------ @--- test = 'withMockT' '$' \inMockT -> do---    'expect' '$' ...------    'liftIO' '$' 'forkIO' '$' inMockT firstThread---    'liftIO' '$' 'forkIO' '$' inMockT secondThread--- @------ This is a low-level primitive.  Consider using the @unliftio@ package for--- higher level implementations of multithreading and other primitives.-withMockT ::-  forall m b. MonadIO m => ((forall a. MockT m a -> m a) -> MockT m b) -> m b-withMockT test = do-  stateVar <- newMVar initMockState-  let inMockT :: forall a. MockT m a -> m a-      inMockT m = runReaderT (unMockT m) stateVar-  flip runReaderT stateVar $-    unMockT $ do-      a <- test inMockT-      verifyExpectations-      return a---- | Fetches a 'String' that describes the current set of outstanding--- expectations.  This is sometimes useful for debugging test code.  The exact--- format is not specified.-describeExpectations :: MonadIO m => MockT m String-describeExpectations =-  formatExpectSet <$> (MockT ask >>= fmap mockExpectSet . readMVar)---- | Verifies that all mock expectations are satisfied.  You normally don't need--- to do this, because it happens automatically at the end of your test in--- 'runMockT'.  However, it's occasionally useful to check expectations in the--- middle of a test, such as before going on to the next stage.------ Use of 'verifyExpectations' might signify that you are doing too much in a--- single test.  Consider splitting large tests into a separate test for each--- case.-verifyExpectations :: MonadIO m => MockT m ()-verifyExpectations = do-  expectSet <- MockT ask >>= fmap mockExpectSet . readMVar-  unless (satisfied expectSet) $ do-    case excess expectSet of-      ExpectNothing -> return ()-      missing -> error $ "Unmet expectations:\n" ++ formatExpectSet missing---- | Changes the default response for matching actions.------ Without 'byDefault', actions with no explicit response will return the--- 'Default' value for the type, or 'undefined' if the return type isn't an--- instance of 'Default'.  'byDefault' replaces that with a new default--- response, also overriding any previous defaults. The rule passed in must have--- exactly one response.-byDefault ::-  forall cls name m r.-  (MonadIO m, MockableMethod cls name m r) =>-  Rule cls name m r ->-  MockT m ()-byDefault (m :=> [r]) = do-  initClassIfNeeded (Proxy :: Proxy cls)-  stateVar <- MockT ask-  mockState <- takeMVar stateVar-  let newDefaults =-        Step (locate callStack (m :-> Just r)) : mockDefaults mockState-  putMVar stateVar (mockState {mockDefaults = newDefaults})-byDefault _ = error "Defaults must have exactly one response."--mockMethodImpl ::-  forall cls name m r.-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r-  ) =>-  r ->-  Action cls name m r ->-  MockT m r-mockMethodImpl surrogate action =-  do-    initClassIfNeeded (Proxy :: Proxy cls)-    stateVar <- MockT ask-    mockState <- takeMVar stateVar-    let (newExpectSet, response) =-          decideAction (mockExpectSet mockState) (mockDefaults mockState)-    putMVar stateVar mockState {mockExpectSet = newExpectSet}-    response-  where-    decideAction expectSet defaults =-      let (partial, full) = partitionEithers (tryMatch <$> liveSteps expectSet)-          orderedPartial = snd <$> sortBy (compare `on` fst) (catMaybes partial)-       in case (full, findDefault defaults, surrogate, orderedPartial) of-            ((e, Just response) : _, _, _, _) -> (e, response)-            ((e, Nothing) : _, d, s, _) -> (e, fromMaybe (return s) d)-            ([], _, _, []) -> error $ noMatchError action-            ([], _, _, _) -> error $ partialMatchError action orderedPartial-    tryMatch ::-      (Step m, ExpectSet (Step m)) ->-      Either (Maybe (Int, String)) (ExpectSet (Step m), Maybe (MockT m r))-    tryMatch (Step expected, e)-      | Just lrule@(Loc _ (m :-> impl)) <- cast expected =-        case matchAction m action of-          NoMatch n ->-            Left (Just (n, withLoc (showMatcher (Just action) m <$ lrule)))-          Match ->-            Right (e, ($ action) <$> impl)-      | otherwise = Left Nothing--    findDefault :: [Step m] -> Maybe (MockT m r)-    findDefault [] = Nothing-    findDefault (Step expected : _)-      | Just (Loc _ (m :-> Just r)) <- cast expected,-        Match <- matchAction m action =-        Just (r action)-    findDefault (_ : steps) = findDefault steps---- | 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 ::-  forall cls name m r.-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r,-    Default r-  ) =>-  Action cls name m r ->-  MockT m r-mockMethod action =-  withFrozenCallStack $ mockMethodImpl def 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 ::-  forall cls name m r.-  ( HasCallStack,-    MonadIO m,-    MockableMethod cls name m r-  ) =>-  Action cls name m r ->-  MockT m r-mockDefaultlessMethod action =-  withFrozenCallStack $ mockMethodImpl undefined action---- An error for an action that matches no expectations at all.-noMatchError ::-  (HasCallStack, Mockable cls) =>-  -- | The action that was received.-  Action cls name m a ->-  String-noMatchError a =-  "Unexpected action: " ++ showAction a---- An error for an action that doesn't match the argument predicates for any--- of the method's expectations.-partialMatchError ::-  (HasCallStack, Mockable cls) =>-  -- | The action that was received.-  Action cls name m a ->-  -- | Descriptions of the matchers that most closely matched, closest first.-  [String] ->-  String-partialMatchError a partials =-  "Wrong arguments: "-    ++ showAction a-    ++ "\n\nClosest matches:\n - "-    ++ intercalate "\n - " (take 5 partials)

@@ -1,12 +0,0 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RoleAnnotations #-}--module Test.HMock.Internal.MockT where--import Data.Kind (Type)--type role MockT nominal nominal--data MockT (m :: Type -> Type) (a :: Type)--instance Monad m => Monad (MockT m)

@@ -1,55 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Test.HMock.Internal.Mockable where--import Control.Monad.Trans (MonadIO)-import Data.Kind (Constraint, Type)-import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)-import {-# SOURCE #-} Test.HMock.Internal.MockT (MockT)---- | The result of matching a @'Matcher' a@ with an @'Action' b@.  Because the--- types should already guarantee that the methods match, all that's left is to--- match arguments.-data MatchResult where-  -- | No match.  The int is the number of arguments that don't match.-  NoMatch :: Int -> MatchResult-  -- | Match. Stores a witness to the equality of return types.-  Match :: MatchResult---- | A base class for 'Monad' subclasses whose methods can be mocked.  You--- usually want to generate this instance using 'Test.HMock.TH.makeMockable',--- 'Test.HMock.TH.makeMockableBase', 'Test.HMock.TH.deriveMockable', or--- 'Test.HMock.TH.deriveMockableBase'.  It's just boilerplate.-class (Typeable cls) => MockableBase (cls :: (Type -> Type) -> Constraint) where-  -- | An action that is performed.  This data type will have one constructor-  -- for each method.-  data Action cls :: Symbol -> (Type -> Type) -> Type -> Type--  -- | A specification for matching actions.  The actual arguments should be-  -- replaced with predicates.-  data Matcher cls :: Symbol -> (Type -> Type) -> Type -> Type--  -- | Gets a text description of an 'Action', for use in error messages.-  showAction :: Action cls name m a -> String--  -- | Gets a text description of a 'Matcher', for use in error messages.-  showMatcher :: Maybe (Action cls name m a) -> Matcher cls name m b -> String--  -- | Attempts to match an 'Action' with a 'Matcher'.-  matchAction :: Matcher cls name m a -> Action cls name m a -> MatchResult---- | A class for 'Monad' subclasses whose methods can be mocked.  This class--- augments 'MockableBase' with a setup method that is run before HMock touches--- the 'Monad' subclass for the first time.  The default implementation does--- nothing, but you can derive your own instances that add setup behavior.-class MockableBase cls => Mockable (cls :: (Type -> Type) -> Constraint) where-  -- An action to run and set up defaults for this class.  The action will be-  -- run before HMock touches the class, either to add expectations or to-  -- delegate a method.-  setupMockable :: (MonadIO m, Typeable m) => proxy cls -> MockT m ()-  setupMockable _ = return ()

@@ -1,153 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Test.HMock.Internal.Multiplicity where---- | An acceptable range of number of times for something to happen.------ A multiplicity can have a lower and an upper bound.-data Multiplicity = Multiplicity Int (Maybe Int) deriving (Eq)--instance Show Multiplicity where-  show m | not (feasible m) = "infeasible"-  show (Multiplicity 0 (Just 0)) = "never"-  show (Multiplicity 1 (Just 1)) = "once"-  show (Multiplicity 2 (Just 2)) = "twice"-  show (Multiplicity 0 Nothing) = "any number of times"-  show (Multiplicity 1 Nothing) = "at least once"-  show (Multiplicity 2 Nothing) = "at least twice"-  show (Multiplicity n Nothing) = "at least " ++ show n ++ " times"-  show (Multiplicity 0 (Just 1)) = "at most once"-  show (Multiplicity 0 (Just 2)) = "at most twice"-  show (Multiplicity 0 (Just n)) = "at most " ++ show n ++ " times"-  show (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-infeasible = Multiplicity 0 (Just (-1))---- | This is an incomplete instance, provided for convenience.------ >>> meetsMultiplicity 5 4--- False--- >>> meetsMultiplicity 5 5--- True--- >>> between 4 6 - between 1 2--- 2 to 5 times-instance Num Multiplicity where-  fromInteger n-    | n < 0 = infeasible-    | otherwise =-      normalize $-        Multiplicity (fromInteger n) (Just (fromInteger n))--  m1@(Multiplicity a b) + m2@(Multiplicity c d)-    | feasible m1 && feasible m2 =-      normalize $ Multiplicity (a + c) ((+) <$> b <*> d)-    | otherwise = infeasible--  m1@(Multiplicity a b) - m2@(Multiplicity c d)-    | feasible m1 && feasible m2 =-      normalize $ Multiplicity (maybe 0 (a -) d) (subtract c <$> b)-    | otherwise = infeasible--  (*) = error "Multiplicities are not closed under multiplication"--  abs = id--  signum (Multiplicity 0 (Just 0)) = 0-  signum _ = 1--normalize :: Multiplicity -> Multiplicity-normalize (Multiplicity a b) = Multiplicity (max a 0) b---- | Checks whether a certain number satisfies the 'Multiplicity'.-meetsMultiplicity :: Multiplicity -> Int -> Bool-meetsMultiplicity (Multiplicity lo mbhi) n-  | n < lo = False-  | Just hi <- mbhi, n > hi = False-  | otherwise = True---- | A 'Multiplicity' that means exactly once.------ >>> meetsMultiplicity once 0--- False--- >>> meetsMultiplicity once 1--- True--- >>> meetsMultiplicity once 2--- False-once :: Multiplicity-once = 1---- | A 'Multiplicity' that means any number of times.--- >>> meetsMultiplicity anyMultiplicity 0--- True--- >>> meetsMultiplicity anyMultiplicity 1--- True--- >>> meetsMultiplicity anyMultiplicity 10--- True-anyMultiplicity :: Multiplicity-anyMultiplicity = atLeast 0---- | A 'Multiplicity' that means at least this many times.------ >>> meetsMultiplicity (atLeast 2) 1--- False--- >>> meetsMultiplicity (atLeast 2) 2--- True--- >>> meetsMultiplicity (atLeast 2) 3--- True-atLeast :: Multiplicity -> Multiplicity-atLeast (Multiplicity n _) = Multiplicity n Nothing---- | A 'Multiplicity' that means at most this many times.------ >>> meetsMultiplicity (atMost 2) 1--- True--- >>> meetsMultiplicity (atMost 2) 2--- True--- >>> meetsMultiplicity (atMost 2) 3--- False-atMost :: Multiplicity -> Multiplicity-atMost (Multiplicity _ n) = 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--- @'between' n n@ is equivalent to @n@.------ >>> meetsMultiplicity (between 2 3) 1--- False--- >>> meetsMultiplicity (between 2 3) 2--- True--- >>> meetsMultiplicity (between 2 3) 3--- True--- >>> meetsMultiplicity (between 2 3) 4--- False-between :: Multiplicity -> Multiplicity -> Multiplicity-between (Multiplicity m _) (Multiplicity _ n) = Multiplicity m n---- | Checks whether a 'Multiplicity' includes zero in its range.------ >>> exhaustable anyMultiplicity--- True--- >>> exhaustable (atLeast 2)--- False--- >>> exhaustable (atMost 3)--- True--- >>> exhaustable (between 0 2)--- True-exhaustable :: Multiplicity -> Bool-exhaustable m@(Multiplicity lo _) = feasible m && lo == 0---- | Checks whether a 'Multiplicity' is capable of matching any number at all.------ >>> feasible once--- True--- >>> feasible 0--- True--- >>> feasible (once - 2)--- False-feasible :: Multiplicity -> Bool-feasible (Multiplicity a b) = maybe True (>= a) b

@@ -1,944 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Test.HMock.Internal.Predicates where--import Data.Char (toUpper)-import Data.Maybe (isJust)-import Data.MonoTraversable-import qualified Data.Sequences as Seq-import Data.Typeable (Proxy (..), Typeable, cast, typeRep)-import GHC.Exts (IsList (Item, toList))-import GHC.Stack (HasCallStack, callStack)-import Language.Haskell.TH (ExpQ, PatQ, pprint)-import Language.Haskell.TH.Syntax (lift)-import Test.HMock.Internal.TH.Util (removeModNames)-import Test.HMock.Internal.Util (choices, locate, isSubsequenceOf, withLoc)-import Text.Regex.TDFA hiding (match)---- $setup--- >>> :set -XTemplateHaskell--- >>> :set -XTypeApplications--- >>> :set -Wno-type-defaults---- | A predicate, which tests values and either accepts or rejects them.  This--- is similar to @a -> 'Bool'@, but also has a 'Show' instance to describe what--- it is checking.------ Predicates are used to define which arguments a general matcher should--- accept.-data Predicate a = Predicate-  { showPredicate :: String,-    accept :: a -> Bool-  }--instance Show (Predicate a) where show = showPredicate---- | A 'Predicate' that accepts anything at all.------ >>> accept anything "foo"--- True--- >>> accept anything undefined--- True-anything :: Predicate a-anything =-  Predicate-    { showPredicate = "anything",-      accept = const True-    }---- | A 'Predicate' that accepts only the given value.------ >>> accept (eq "foo") "foo"--- True--- >>> accept (eq "foo") "bar"--- False-eq :: (Show a, Eq a) => a -> Predicate a-eq x =-  Predicate-    { showPredicate = show x,-      accept = (== x)-    }---- | A 'Predicate' that accepts anything but the given value.------ >>> accept (neq "foo") "foo"--- False--- >>> accept (neq "foo") "bar"--- True-neq :: (Show a, Eq a) => a -> Predicate a-neq x =-  Predicate-    { showPredicate = "≠ " ++ show x,-      accept = (/= x)-    }---- | A 'Predicate' that accepts anything greater than the given value.------ >>> accept (gt 5) 4--- False--- >>> accept (gt 5) 5--- False--- >>> accept (gt 5) 6--- True-gt :: (Show a, Ord a) => a -> Predicate a-gt x =-  Predicate-    { showPredicate = "> " ++ show x,-      accept = (> x)-    }---- | A 'Predicate' that accepts anything greater than or equal to the given--- value.------ >>> accept (geq 5) 4--- False--- >>> accept (geq 5) 5--- True--- >>> accept (geq 5) 6--- True-geq :: (Show a, Ord a) => a -> Predicate a-geq x =-  Predicate-    { showPredicate = "≥ " ++ show x,-      accept = (>= x)-    }---- | A 'Predicate' that accepts anything less than the given value.------ >>> accept (lt 5) 4--- True--- >>> accept (lt 5) 5--- False--- >>> accept (lt 5) 6--- False-lt :: (Show a, Ord a) => a -> Predicate a-lt x =-  Predicate-    { showPredicate = "< " ++ show x,-      accept = (< x)-    }---- | A 'Predicate' that accepts anything less than or equal to the given value.------ >>> accept (leq 5) 4--- True--- >>> accept (leq 5) 5--- True--- >>> accept (leq 5) 6--- False-leq :: (Show a, Ord a) => a -> Predicate a-leq x =-  Predicate-    { showPredicate = "≤ " ++ show x,-      accept = (<= x)-    }---- | A 'Predicate' that matches 'True' values.------ >>> accept true True--- True--- >>> accept true False--- False-true :: Predicate Bool-true = eq True---- | A 'Predicate' that matches 'False' values.------ >>> accept false True--- False--- >>> accept false False--- True-false :: Predicate Bool-false = eq False---- | A 'Predicate' that accepts 'Maybe' values of @'Just' x@, where @x@ matches--- the given child 'Predicate'.------ >>> accept (just (eq "value")) Nothing--- False--- >>> accept (just (eq "value")) (Just "value")--- True--- >>> accept (just (eq "value")) (Just "wrong value")--- False-just :: Predicate a -> Predicate (Maybe a)-just p =-  Predicate-    { showPredicate = "Just (" ++ showPredicate p ++ ")",-      accept = \case Just x -> accept p x; _ -> False-    }---- | A 'Predicate' that accepts an 'Either' value of @'Left' x@, where @x@--- matches the given child 'Predicate'.------ >>> accept (left (eq "value")) (Left "value")--- True--- >>> accept (left (eq "value")) (Right "value")--- False--- >>> accept (left (eq "value")) (Left "wrong value")--- False-left :: Predicate a -> Predicate (Either a b)-left p =-  Predicate-    { showPredicate = "Left (" ++ showPredicate p ++ ")",-      accept = \case Left x -> accept p x; _ -> False-    }---- | A 'Predicate' that accepts an 'Either' value of @'Right' x@, where @x@--- matches the given child 'Predicate'.------ >>> accept (right (eq "value")) (Right "value")--- True--- >>> accept (right (eq "value")) (Right "wrong value")--- False--- >>> accept (right (eq "value")) (Left "value")--- False-right :: Predicate b -> Predicate (Either a b)-right p =-  Predicate-    { showPredicate = "Right (" ++ showPredicate p ++ ")",-      accept = \case Right x -> accept p x; _ -> False-    }---- | A 'Predicate' that accepts pairs whose elements satisfy the corresponding--- child 'Predicates'.------ >>> accept (zipP (eq "foo") (eq "bar")) ("foo", "bar")--- True--- >>> accept (zipP (eq "foo") (eq "bar")) ("bar", "foo")--- False-zipP :: Predicate a -> Predicate b -> Predicate (a, b)-zipP p q =-  Predicate-    { showPredicate = show (p, q),-      accept = \(x, y) -> accept p x && accept q y-    }---- | A 'Predicate' that accepts 3-tuples whose elements satisfy the--- corresponding child 'Predicate's.------ >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux")--- True--- >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo")--- False-zip3P :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)-zip3P p1 p2 p3 =-  Predicate-    { showPredicate = show (p1, p2, p3),-      accept = \(x1, x2, x3) -> accept p1 x1 && accept p2 x2 && accept p3 x3-    }---- | A 'Predicate' that accepts 3-tuples whose elements satisfy the--- corresponding child 'Predicates'.------ >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4)--- True--- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1)--- False-zip4P ::-  Predicate a ->-  Predicate b ->-  Predicate c ->-  Predicate d ->-  Predicate (a, b, c, d)-zip4P p1 p2 p3 p4 =-  Predicate-    { showPredicate = show (p1, p2, p3, p4),-      accept = \(x1, x2, x3, x4) ->-        accept p1 x1 && accept p2 x2 && accept p3 x3 && accept p4 x4-    }---- | A 'Predicate' that accepts 3-tuples whose elements satisfy the--- corresponding child 'Predicates'.------ >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5)--- True--- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1)--- False-zip5P ::-  Predicate a ->-  Predicate b ->-  Predicate c ->-  Predicate d ->-  Predicate e ->-  Predicate (a, b, c, d, e)-zip5P p1 p2 p3 p4 p5 =-  Predicate-    { showPredicate = show (p1, p2, p3, p4, p5),-      accept = \(x1, x2, x3, x4, x5) ->-        accept p1 x1 && accept p2 x2 && accept p3 x3 && accept p4 x4-          && accept p5 x5-    }---- | A 'Predicate' that accepts anything accepted by both of its children.------ >>> accept (lt "foo" `andP` gt "bar") "eta"--- True--- >>> accept (lt "foo" `andP` gt "bar") "quz"--- False--- >>> accept (lt "foo" `andP` gt "bar") "alpha"--- False-andP :: Predicate a -> Predicate a -> Predicate a-p `andP` q =-  Predicate-    { showPredicate = showPredicate p ++ " and " ++ showPredicate q,-      accept = \x -> accept p x && accept q x-    }---- | A 'Predicate' that accepts anything accepted by either of its children.------ >>> accept (lt "bar" `orP` gt "foo") "eta"--- False--- >>> accept (lt "bar" `orP` gt "foo") "quz"--- True--- >>> accept (lt "bar" `orP` gt "foo") "alpha"--- True-orP :: Predicate a -> Predicate a -> Predicate a-p `orP` q =-  Predicate-    { showPredicate = showPredicate p ++ " or " ++ showPredicate q,-      accept = \x -> accept p x || accept q x-    }---- | A 'Predicate' that inverts another 'Predicate', accepting whatever its--- child rejects, and rejecting whatever its child accepts.------ >>> accept (notP (eq "negative")) "positive"--- True--- >>> accept (notP (eq "negative")) "negative"--- False-notP :: Predicate a -> Predicate a-notP p =-  Predicate-    { showPredicate = "not " ++ showPredicate p,-      accept = not . accept p-    }---- | A 'Predicate' that accepts sequences that start with the given prefix.------ >>> accept (startsWith "fun") "fungible"--- True--- >>> accept (startsWith "gib") "fungible"--- False-startsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t-startsWith pfx =-  Predicate-    { showPredicate = "starts with " ++ show pfx,-      accept = (pfx `Seq.isPrefixOf`)-    }---- | A 'Predicate' that accepts sequences that end with the given suffix.------ >>> accept (endsWith "ow") "crossbow"--- True--- >>> accept (endsWith "ow") "trebuchet"--- False-endsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t-endsWith sfx =-  Predicate-    { showPredicate = "ends with " ++ show sfx,-      accept = (sfx `Seq.isSuffixOf`)-    }---- | A 'Predicate' that accepts sequences that contain the given (consecutive)--- substring.------ >>> accept (hasSubstr "i") "team"--- False--- >>> accept (hasSubstr "i") "partnership"--- True-hasSubstr :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t-hasSubstr s =-  Predicate-    { showPredicate = "has substring " ++ show s,-      accept = (s `Seq.isInfixOf`)-    }---- | A 'Predicate' that accepts sequences that contain the given (not--- necessarily consecutive) subsequence.------ >>> accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5]--- True--- >>> accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0]--- True--- >>> accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11]--- False-hasSubsequence :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t-hasSubsequence s =-  Predicate-    { showPredicate = "has subsequence " ++ show s,-      accept = (s `isSubsequenceOf`)-    }---- | Transforms a 'Predicate' on 'String's or string-like types to match without--- regard to case.------ >>> accept (caseInsensitive startsWith "foo") "FOOTBALL!"--- True--- >>> accept (caseInsensitive endsWith "ball") "soccer"--- False--- >>> accept (caseInsensitive eq "time") "TIME"--- True--- >>> accept (caseInsensitive gt "NOTHING") "everything"--- False-caseInsensitive ::-  ( MonoFunctor t,-    MonoFunctor a,-    Element t ~ Char,-    Element a ~ Char-  ) =>-  (t -> Predicate a) ->-  (t -> Predicate a)-caseInsensitive p s =-  Predicate-    { showPredicate = "(case insensitive) " ++ show (p s),-      accept = accept capP . omap toUpper-    }-  where-    capP = p (omap toUpper s)---- | A 'Predicate' that accepts 'String's or string-like values matching a--- regular expression.  The expression must match the entire argument.------ You should not use @'caseInsensitive' 'matchesRegex'@, because regular--- expression syntax itself is still case-sensitive even when the text you are--- matching is not.  Instead, use 'matchesCaseInsensitiveRegex'.------ >>> accept (matchesRegex "x{2,5}y?") "xxxy"--- True--- >>> accept (matchesRegex "x{2,5}y?") "xyy"--- False--- >>> accept (matchesRegex "x{2,5}y?") "wxxxyz"--- False-matchesRegex :: (RegexLike Regex a, Eq a) => String -> Predicate a-matchesRegex s =-  Predicate-    { showPredicate = "/" ++ init (tail $ show s) ++ "/",-      accept = \x -> case matchOnceText r x of-        Just (a, _, b) -> a == empty && b == empty-        Nothing -> False-    }-  where-    r = makeRegexOpts comp exec s :: Regex-    comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True}-    exec = defaultExecOpt {captureGroups = False}---- | A 'Predicate' that accepts 'String's or string-like values matching a--- regular expression in a case-insensitive way.  The expression must match the--- entire argument.------ You should use this instead of @'caseInsensitive' 'matchesRegex'@, because--- regular expression syntax itself is still case-sensitive even when the text--- you are matching is not.------ >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY"--- True--- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY"--- False--- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ"--- False-matchesCaseInsensitiveRegex ::-  (RegexLike Regex a, Eq a) => String -> Predicate a-matchesCaseInsensitiveRegex s =-  Predicate-    { showPredicate = "/" ++ init (tail $ show s) ++ "/i",-      accept = \x -> case matchOnceText r x of-        Just (a, _, b) -> a == empty && b == empty-        Nothing -> False-    }-  where-    r = makeRegexOpts comp exec s :: Regex-    comp =-      defaultCompOpt-        { newSyntax = True,-          lastStarGreedy = True,-          caseSensitive = False-        }-    exec = defaultExecOpt {captureGroups = False}---- | A 'Predicate' that accepts 'String's or string-like values containing a--- match for a regular expression.  The expression need not match the entire--- argument.------ You should not use @'caseInsensitive' 'containsRegex'@, because regular--- expression syntax itself is still case-sensitive even when the text you are--- matching is not.  Instead, use 'containsCaseInsensitiveRegex'.------ >>> accept (containsRegex "x{2,5}y?") "xxxy"--- True--- >>> accept (containsRegex "x{2,5}y?") "xyy"--- False--- >>> accept (containsRegex "x{2,5}y?") "wxxxyz"--- True-containsRegex :: (RegexLike Regex a, Eq a) => String -> Predicate a-containsRegex s =-  Predicate-    { showPredicate = "contains /" ++ init (tail $ show s) ++ "/",-      accept = isJust . matchOnce r-    }-  where-    r = makeRegexOpts comp exec s :: Regex-    comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True}-    exec = defaultExecOpt {captureGroups = False}---- | A 'Predicate' that accepts 'String's or string-like values containing a--- match for a regular expression in a case-insensitive way.  The expression--- need match the entire argument.------ You should use this instead of @'caseInsensitive' 'containsRegex'@, because--- regular expression syntax itself is still case-sensitive even when the text--- you are matching is not.------ >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY"--- True--- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY"--- False--- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ"--- True-containsCaseInsensitiveRegex ::-  (RegexLike Regex a, Eq a) => String -> Predicate a-containsCaseInsensitiveRegex s =-  Predicate-    { showPredicate = "contains /" ++ init (tail $ show s) ++ "/i",-      accept = isJust . matchOnce r-    }-  where-    r = makeRegexOpts comp exec s :: Regex-    comp =-      defaultCompOpt-        { newSyntax = True,-          lastStarGreedy = True,-          caseSensitive = False-        }-    exec = defaultExecOpt {captureGroups = False}---- | A 'Predicate' that accepts empty data structures.------ >>> accept isEmpty []--- True--- >>> accept isEmpty [1, 2, 3]--- False--- >>> accept isEmpty ""--- True--- >>> accept isEmpty "gas tank"--- False-isEmpty :: MonoFoldable t => Predicate t-isEmpty =-  Predicate-    { showPredicate = "empty",-      accept = onull-    }---- | A 'Predicate' that accepts non-empty data structures.------ >>> accept nonEmpty []--- False--- >>> accept nonEmpty [1, 2, 3]--- True--- >>> accept nonEmpty ""--- False--- >>> accept nonEmpty "gas tank"--- True-nonEmpty :: MonoFoldable t => Predicate t-nonEmpty =-  Predicate-    { showPredicate = "nonempty",-      accept = not . onull-    }---- | A 'Predicate' that accepts data structures whose number of elements match--- the child 'Predicate'.------ >>> accept (sizeIs (lt 3)) ['a' .. 'f']--- False--- >>> accept (sizeIs (lt 3)) ['a' .. 'b']--- True-sizeIs :: MonoFoldable t => Predicate Int -> Predicate t-sizeIs p =-  Predicate-    { showPredicate = "size " ++ showPredicate p,-      accept = accept p . olength-    }---- | A 'Predicate' that accepts data structures whose contents each match the--- corresponding 'Predicate' in the given list, in the same order.------ >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4]--- True--- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5]--- False--- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4]--- False-elemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t-elemsAre ps =-  Predicate-    { showPredicate = show ps,-      accept = \xs ->-        olength xs == olength ps-          && and (zipWith accept ps (otoList xs))-    }---- | A 'Predicate' that accepts data structures whose contents each match the--- corresponding 'Predicate' in the given list, in any order.------ >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3]--- True--- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1]--- True--- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4]--- False--- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3]--- False-unorderedElemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t-unorderedElemsAre ps =-  Predicate-    { showPredicate =-        "(any order) " ++ show ps,-      accept = matches ps . otoList-    }-  where-    matches (q : qs) xs = or [matches qs ys | (y, ys) <- choices xs, accept q y]-    matches [] xs = null xs---- | A 'Predicate' that accepts data structures whose elements each match the--- child 'Predicate'.------ >>> accept (each (gt 5)) [4, 5, 6]--- False--- >>> accept (each (gt 5)) [6, 7, 8]--- True--- >>> accept (each (gt 5)) []--- True-each :: MonoFoldable t => Predicate (Element t) -> Predicate t-each p =-  Predicate-    { showPredicate = "each (" ++ showPredicate p ++ ")",-      accept = oall (accept p)-    }---- | A 'Predicate' that accepts data structures which contain at least one--- element matching the child 'Predicate'.------ >>> accept (contains (gt 5)) [3, 4, 5]--- False--- >>> accept (contains (gt 5)) [4, 5, 6]--- True--- >>> accept (contains (gt 5)) []--- False-contains :: MonoFoldable t => Predicate (Element t) -> Predicate t-contains p =-  Predicate-    { showPredicate = "contains (" ++ showPredicate p ++ ")",-      accept = oany (accept p)-    }---- | A 'Predicate' that accepts data structures which contain an element--- satisfying each of the child predicates.  @'containsAll' [p1, p2, ..., pn]@--- is equivalent to @'contains' p1 `'andP'` 'contains' p2 `'andP'` ... `'andP'`--- 'contains' pn@.------ >>> accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"]--- True--- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo"]--- False--- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"]--- True-containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t-containsAll ps =-  Predicate-    { showPredicate = "contains all of " ++ show ps,-      accept = \xs -> all (flip oany xs . accept) ps-    }---- | A 'Predicate' that accepts data structures whose elements all satisfy at--- least one of the child predicates.  @'containsOnly' [p1, p2, ..., pn]@ is--- equivalent to @'each' (p1 `'orP'` p2 `'orP'` ... `'orP'` pn)@.------ >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]--- True--- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]--- True--- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]--- False-containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t-containsOnly ps =-  Predicate-    { showPredicate = "contains only " ++ show ps,-      accept = oall (\x -> any (`accept` x) ps)-    }---- | A 'Predicate' that accepts map-like structures which contain a key matching--- the child 'Predicate'.------ >>> accept (containsKey (eq "foo")) [("foo", 1), ("bar", 2)]--- True--- >>> accept (containsKey (eq "foo")) [("bar", 1), ("qux", 2)]--- False-containsKey :: (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate t-containsKey p =-  Predicate-    { showPredicate = "contains key " ++ show p,-      accept = \m -> any (accept p) (fst <$> toList m)-    }---- | A 'Predicate' that accepts map-like structures which contain a key/value--- pair matched by the given child 'Predicate's (one for the key, and one for--- the value).------ >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 12), ("bar", 5)]--- True--- >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 5), ("bar", 12)]--- False--- >>> accept (containsEntry (eq "foo") (gt 10)) [("bar", 12)]--- False-containsEntry ::-  (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate v -> Predicate t-containsEntry p q =-  Predicate-    { showPredicate = "contains entry " ++ show (p, q),-      accept = any (\(x, y) -> accept p x && accept q y) . toList-    }---- | A 'Predicate' that accepts map-like structures whose keys are exactly those--- matched by the given list of 'Predicates', in any order.------ >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("b", 2), ("c", 3)]--- True--- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("c", 1), ("b", 2), ("a", 3)]--- True--- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("c", 3)]--- False--- >>> accept (keysAre [eq "a", eq "b"]) [("a", 1), ("b", 2), ("c", 3)]--- False-keysAre ::-  (IsList t, Item t ~ (k, v)) => [Predicate k] -> Predicate t-keysAre ps =-  Predicate-    { showPredicate = "keys are " ++ show ps,-      accept = matches ps . map fst . toList-    }-  where-    matches (q : qs) xs = or [matches qs ys | (y, ys) <- choices xs, accept q y]-    matches [] xs = null xs---- | A 'Predicate' that accepts map-like structures whose entries are exactly--- those matched by the given list of 'Predicate' pairs, in any order.------ >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4)]--- True--- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(3, 4), (1, 2)]--- True--- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 4), (3, 2)]--- False--- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4), (5, 6)]--- False-entriesAre ::-  (IsList t, Item t ~ (k, v)) => [(Predicate k, Predicate v)] -> Predicate t-entriesAre ps =-  Predicate-    { showPredicate = "entries are " ++ show ps,-      accept = matches ps . toList-    }-  where-    matches ((p, q) : pqs) xs =-      or [matches pqs ys | ((k, v), ys) <- choices xs, accept p k, accept q v]-    matches [] xs = null xs---- | A 'Predicate' that accepts values of 'RealFloat' types that are close to--- the given number.  The expected precision is scaled based on the target--- value, so that reasonable rounding error is accepted but grossly inaccurate--- results are not.------ The following naive use of 'eq' fails due to rounding:------ >>> accept (eq 1.0) (sum (replicate 100 0.01))--- False------ The solution is to use 'approxEq', which accounts for rounding error.--- However, 'approxEq' doesn't accept results that are far enough off that they--- likely arise from incorrect calculations instead of rounding error.------ >>> accept (approxEq 1.0) (sum (replicate 100 0.01))--- True--- >>> accept (approxEq 1.0) (sum (replicate 100 0.009999))--- False-approxEq :: (RealFloat a, Show a) => a -> Predicate a-approxEq x =-  Predicate-    { showPredicate = "≈ " ++ show x,-      accept = \y -> abs (x - y) < diff-    }-  where-    diff = encodeFloat 1 (snd (decodeFloat x) + floatDigits x `div` 2)---- | A 'Predicate' that accepts finite numbers of any 'RealFloat' type.------ >>> accept finite 1.0--- True--- >>> accept finite (0 / 0)--- False--- >>> accept finite (1 / 0)--- False-finite :: RealFloat a => Predicate a-finite =-  Predicate-    { showPredicate = "finite",-      accept = \x -> not (isInfinite x) && not (isNaN x)-    }---- | A 'Predicate' that accepts infinite numbers of any 'RealFloat' type.------ >>> accept infinite 1.0--- False--- >>> accept infinite (0 / 0)--- False--- >>> accept infinite (1 / 0)--- True-infinite :: RealFloat a => Predicate a-infinite =-  Predicate-    { showPredicate = "infinite",-      accept = isInfinite-    }---- | A 'Predicate' that accepts NaN values of any 'RealFloat' type.------ >>> accept nAn 1.0--- False--- >>> accept nAn (0 / 0)--- True--- >>> accept nAn (1 / 0)--- False-nAn :: RealFloat a => Predicate a-nAn =-  Predicate-    { showPredicate = "NaN",-      accept = isNaN-    }---- | A conversion from @a -> 'Bool'@ to 'Predicate'.  This is a fallback that--- can be used to build a 'Predicate' that checks anything at all.  However, its--- description will be less helpful than standard 'Predicate's.------ >>> accept (is even) 3--- False--- >>> accept (is even) 4--- True-is :: HasCallStack => (a -> Bool) -> Predicate a-is f =-  Predicate-    { showPredicate = withLoc (locate callStack "custom predicate"),-      accept = f-    }---- | A Template Haskell splice that acts like 'is', but receives a quoted--- expression at compile time and has a more helpful description for error--- messages.------ >>> accept $(qIs [| even |]) 3--- False--- >>> accept $(qIs [| even |]) 4--- True------ >>> show $(qIs [| even |])--- "even"-qIs :: HasCallStack => ExpQ -> ExpQ-qIs f =-  [|-    Predicate-      { showPredicate = $(lift . pprint . removeModNames =<< f),-        accept = $f-      }-    |]---- | A combinator to lift a 'Predicate' to work on a property or computed value--- of the original value.------ >>> accept (with abs (gt 5)) (-6)--- True--- >>> accept (with abs (gt 5)) (-5)--- False--- >>> accept (with reverse (eq "olleh")) "hello"--- True--- >>> accept (with reverse (eq "olleh")) "goodbye"--- False-with :: HasCallStack => (a -> b) -> Predicate b -> Predicate a-with f p =-  Predicate-    { showPredicate =-        withLoc (locate callStack "property") ++ ": " ++ show p,-      accept = accept p . f-    }---- | A Template Haskell splice that acts like 'is', but receives a quoted typed--- expression at compile time and has a more helpful description for error--- messages.------ >>> accept ($(qWith [| abs |]) (gt 5)) (-6)--- True--- >>> accept ($(qWith [| abs |]) (gt 5)) (-5)--- False--- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "hello"--- True--- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye"--- False------ >>> show ($(qWith [| abs |]) (gt 5))--- "abs: > 5"-qWith :: ExpQ -> ExpQ-qWith f =-  [|-    \p ->-      Predicate-        { showPredicate =-            $(lift . pprint . removeModNames =<< f) ++ ": " ++ show p,-          accept = accept p . $f-        }-    |]---- | A Template Haskell splice that turns a quoted pattern into a predicate that--- accepts values that match the pattern.------ >>> accept $(qMatch [p| Just (Left _) |]) Nothing--- False--- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Left 5))--- True--- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Right 5))--- False------ >>> show $(qMatch [p| Just (Left _) |])--- "Just (Left _)"-qMatch :: PatQ -> ExpQ-qMatch qpat =-  [|-    Predicate-      { showPredicate = $(lift . pprint . removeModNames =<< qpat),-        accept = \case-          $(qpat) -> True-          _ -> False-      }-    |]---- | Converts a 'Predicate' to a new type.  Typically used with visible type--- application, as in the examples below.------ >>> accept (typed @String anything) "foo"--- True--- >>> accept (typed @String (sizeIs (gt 5))) "foo"--- False--- >>> accept (typed @String anything) (42 :: Int)--- False-typed :: forall a b. (Typeable a, Typeable b) => Predicate a -> Predicate b-typed p =-  Predicate-    { showPredicate =-        showPredicate p ++ " :: " ++ show (typeRep (Proxy :: Proxy a)),-      accept = \x -> case cast x of-        Nothing -> False-        Just y -> accept p y-    }

@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++-- | Internal module to define 'Rule', so that its constructor can be visible+-- to other implementation code.+module Test.HMock.Internal.Rule where++import Data.Kind (Constraint, Type)+import GHC.TypeLits (Symbol)+import {-# SOURCE #-} Test.HMock.Internal.State (MockT)+import Test.HMock.Mockable (MockableBase (..))++-- | 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,+-- or a 'Matcher'.  Exact matching is only available when all method arguments+--+-- A 'Rule' may have zero or more responses, which are attached using+-- 'Test.HMock.Rule.|->' and 'Test.HMock.Rule.|=>'.  If there are no responses+-- for a 'Rule', then there must be a default response for that action, and it+-- is used.  If more than one response is added, the rule will perform the+-- responses in order, repeating the last response if there are additional+-- matches.+--+-- Example:+--+-- @+-- 'Test.HMock.ExpectContext.expect' $+--   GetLine_ 'Test.HMock.anything'+--     'Test.HMock.Rule.|->' "hello"+--     'Test.HMock.Rule.|=>' \(GetLine prompt) -> "The prompt was " ++ prompt+--     'Test.HMock.Rule.|->' "quit"+-- @+data+  Rule+    (cls :: (Type -> Type) -> Constraint)+    (name :: Symbol)+    (m :: Type -> Type)+    (r :: Type)+  where+  (:=>) ::+    Matcher cls name m r ->+    [Action cls name m r -> MockT m r] ->+    Rule cls name m r

@@ -0,0 +1,193 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module contains MockT and SetupMockT state functions.+module Test.HMock.Internal.State where++import Control.Monad (forM_, unless, (<=<))+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Except (MonadError)+import Control.Monad.Extra (maybeM)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.Reader (MonadReader (..), ReaderT, mapReaderT, runReaderT)+import Control.Monad.State (MonadState)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Writer (MonadWriter)+import Data.Proxy (Proxy (Proxy))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable (TypeRep, Typeable, typeRep)+import GHC.Stack (withFrozenCallStack)+import Test.HMock.ExpectContext (ExpectContext (..))+import Test.HMock.Internal.ExpectSet (ExpectSet (..), getSteps)+import Test.HMock.Internal.Step (SingleRule, Step (..), unwrapExpected)+import Test.HMock.Internal.Util (Located)+import Test.HMock.Mockable (Mockable (..))+import UnliftIO+  ( MonadIO,+    MonadUnliftIO,+    STM,+    TVar,+    atomically,+    modifyTVar,+    newTVarIO,+    readTVar,+    readTVarIO,+  )++#if !MIN_VERSION_base(4, 13, 0)+import Control.Monad.Fail (MonadFail)+#endif++-- | Full state of a mock.+data MockState m = MockState+  { mockExpectSet :: TVar (ExpectSet (Step m)),+    mockDefaults :: TVar [(Bool, Step m)],+    mockCheckAmbiguity :: TVar Bool,+    mockClasses :: TVar (Set TypeRep),+    mockParent :: Maybe (MockState m)+  }++-- | Initializes a new 'MockState' with the given parent.  If the parent is+-- 'Nothing', then a new root state is made.+initMockState :: MonadIO m => Maybe (MockState m) -> m (MockState m)+initMockState parent =+  MockState+    <$> newTVarIO ExpectNothing+    <*> newTVarIO []+    <*> maybeM+      (newTVarIO False)+      (newTVarIO <=< readTVarIO . mockCheckAmbiguity)+      (return parent)+    <*> maybe (newTVarIO Set.empty) (return . mockClasses) parent+    <*> pure parent++-- | Gets a list of all states, starting with the innermost.+allStates :: MockState m -> [MockState m]+allStates s+  | Just s' <- mockParent s = s : allStates s'+  | otherwise = [s]++-- | Gets the root state.+rootState :: MockState m -> MockState m+rootState = last . allStates++-- | Monad for setting up a mockable class.  Note that even though the type+-- looks that way, this is *not* a monad transformer.  It's a very restricted+-- environment that can only be used to set up defaults for a class.+newtype MockSetup m a where+  MockSetup :: {unMockSetup :: ReaderT (MockState m) STM a} -> MockSetup m a+  deriving (Functor, Applicative, Monad)++-- | Runs a setup action with the root state, rather than the current one.+runInRootState :: MockSetup m a -> MockSetup m a+runInRootState = MockSetup . local rootState . unMockSetup++-- | Run an STM action in 'MockSetup'+mockSetupSTM :: STM a -> MockSetup m a+mockSetupSTM m = MockSetup (lift m)++-- | Runs class initialization for a 'Mockable' class, if it hasn't been run+-- yet.+initClassIfNeeded ::+  forall cls m proxy.+  (Mockable cls, Typeable m, MonadIO m) =>+  proxy cls ->+  MockSetup m ()+initClassIfNeeded proxy = runInRootState $ do+  state <- MockSetup ask+  classes <- mockSetupSTM $ readTVar (mockClasses state)+  unless (Set.member t classes) $ do+    mockSetupSTM $ modifyTVar (mockClasses state) (Set.insert t)+    setupMockable (Proxy :: Proxy cls)+  where+    t = typeRep proxy++-- | Runs class initialization for all uninitialized 'Mockable' classes in the+-- given 'ExpectSet'.+initClassesAsNeeded :: MonadIO m => ExpectSet (Step m) -> MockSetup m ()+initClassesAsNeeded es = runInRootState $+  forM_ (getSteps es) $+    \(Step (_ :: Located (SingleRule cls name m r))) ->+      initClassIfNeeded (Proxy :: Proxy cls)++-- | Monad transformer for running mocks.+newtype MockT m a where+  MockT :: {unMockT :: ReaderT (MockState m) m a} -> MockT m a+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadFail,+      MonadIO,+      MonadState s,+      MonadWriter w,+      MonadRWS r w s,+      MonadError e,+      MonadCont,+      MonadBase b,+      MonadCatch,+      MonadMask,+      MonadThrow,+      MonadUnliftIO+    )++instance MonadTrans MockT where+  lift = MockT . lift++-- | Applies a function to the base monad of 'MockT'.+mapMockT :: (m a -> m b) -> MockT m a -> MockT m b+mapMockT f = MockT . mapReaderT f . unMockT++instance MonadReader r m => MonadReader r (MockT m) where+  ask = lift ask+  local = mapMockT . local+  reader = lift . reader++-- | This type class defines a shared API between the 'MockT' and 'MockSetup'+-- monads.+class MockContext ctx where+  -- | Runs a 'MockSetup' action in this monad.+  fromMockSetup :: MonadIO m => MockSetup m a -> ctx m a++instance MockContext MockSetup where+  fromMockSetup = id++instance MockContext MockT where+  fromMockSetup m = do+    state <- MockT ask+    atomically $ runReaderT (unMockSetup m) state++-- | Adds an expectation to the 'MockState' for the given 'ExpectSet',+-- interleaved with any existing expectations.+expectThisSet :: MonadIO m => ExpectSet (Step m) -> MockT m ()+expectThisSet e = fromMockSetup $ do+  initClassesAsNeeded e+  state <- MockSetup ask+  mockSetupSTM $ modifyTVar (mockExpectSet state) (e `ExpectInterleave`)++instance ExpectContext MockT where+  expect e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expect e+  expectN mult e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectN mult e+  expectAny e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectAny e+  inSequence es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ inSequence es+  inAnyOrder es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ inAnyOrder es+  anyOf es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ anyOf es+  times mult es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ times mult es+  consecutiveTimes mult es =+    withFrozenCallStack $+      expectThisSet $ unwrapExpected $ consecutiveTimes mult es

@@ -0,0 +1,18 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}++module Test.HMock.Internal.State where++import Data.Kind (Type)++type role MockT nominal nominal++data MockT (m :: Type -> Type) (a :: Type)++instance Monad m => Monad (MockT m)++type role MockSetup nominal nominal++data MockSetup (m :: Type -> Type) (a :: Type)++instance Monad (MockSetup m)

@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++-- | This module defines the desugaring from multi-response 'Rule's into+-- multiple steps.+module Test.HMock.Internal.Step where++import Data.Kind (Constraint, Type)+import Data.Maybe (listToMaybe)+import GHC.Stack (CallStack, callStack)+import GHC.TypeLits (Symbol)+import Test.HMock.ExpectContext (ExpectContext (..), MockableMethod)+import Test.HMock.Internal.ExpectSet (ExpectSet (..))+import Test.HMock.Internal.Rule (Rule (..))+import {-# SOURCE #-} Test.HMock.Internal.State (MockT)+import Test.HMock.Internal.Util (Located (..), locate, withLoc)+import Test.HMock.Mockable (MockableBase (..))+import Test.HMock.Multiplicity+  ( Multiplicity,+    anyMultiplicity,+    feasible,+    meetsMultiplicity,+  )+import Test.HMock.Rule (Expectable (toRule))++-- | A Rule that contains only a single response.  This is the target for+-- desugaring the multi-response rule format.+data+  SingleRule+    (cls :: (Type -> Type) -> Constraint)+    (name :: Symbol)+    (m :: Type -> Type)+    (r :: Type)+  where+  (:->) ::+    Matcher cls name m r ->+    Maybe (Action cls name m r -> MockT m r) ->+    SingleRule cls name m r++-- | A single step of an expectation.+data Step m where+  Step ::+    MockableMethod cls name m r =>+    Located (SingleRule cls name m r) ->+    Step m++instance Show (Step m) where+  show (Step l@(Loc _ (m :-> _))) =+    withLoc (showMatcher 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.+expandRule ::+  MockableMethod cls name m r =>+  CallStack ->+  Rule cls name m r ->+  ExpectSet (Step m)+expandRule callstack (m :=> []) =+  ExpectStep (Step (locate callstack (m :-> Nothing)))+expandRule callstack (m :=> rs) =+  foldr1+    ExpectSequence+    (map (ExpectStep . Step . locate callstack . (m :->) . Just) rs)++-- | Expands a Rule into an expectation, given a target multiplicity.  It is an+-- error if there are too many responses for the multiplicity.  If there are+-- too few responses, the last response will be repeated.+expandRepeatRule ::+  MockableMethod cls name m r =>+  Multiplicity ->+  CallStack ->+  Rule cls name m r ->+  ExpectSet (Step m)+expandRepeatRule mult _ (_ :=> rs)+  | not (feasible (mult - fromIntegral (length rs))) =+    error $+      show (length rs)+        ++ " responses is too many for multiplicity "+        ++ show mult+expandRepeatRule mult callstack (m :=> (r1 : r2 : rs))+  | meetsMultiplicity mult 0 = ExpectEither ExpectNothing body+  | otherwise = body+  where+    body =+      ExpectSequence+        (ExpectStep (Step (locate callstack (m :-> Just r1))))+        (expandRepeatRule (mult - 1) callstack (m :=> (r2 : rs)))+expandRepeatRule mult callstack (m :=> rs) =+  ExpectConsecutive+    mult+    (ExpectStep (Step (locate callstack (m :-> listToMaybe rs))))++-- | Newtype wrapper to make the type of ExpectSet conform to the ExpectContext+-- class.  The "return type" a is a phantom.+newtype Expected m a = Expected {unwrapExpected :: ExpectSet (Step m)}++instance ExpectContext Expected where+  expect e = Expected (expandRule callStack (toRule e))+  expectN mult e = Expected (expandRepeatRule mult callStack (toRule e))+  expectAny e =+    Expected (expandRepeatRule anyMultiplicity callStack (toRule e))+  inSequence es = Expected (foldr1 ExpectSequence (map unwrapExpected es))+  inAnyOrder es = Expected (foldr1 ExpectInterleave (map unwrapExpected es))+  anyOf es = Expected (foldr1 ExpectEither (map unwrapExpected es))+  times mult e = Expected (ExpectMulti mult (unwrapExpected e))+  consecutiveTimes mult e =+    Expected (ExpectConsecutive mult (unwrapExpected e))

@@ -1,697 +1,235 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +-- | Template Haskell utilities used to implement HMock. module Test.HMock.Internal.TH-  ( MockableOptions (..),-    makeMockable,-    makeMockableType,-    makeMockableWithOptions,-    makeMockableTypeWithOptions,-    makeMockableBase,-    makeMockableBaseType,-    makeMockableBaseWithOptions,-    makeMockableBaseTypeWithOptions,-    deriveMockable,-    deriveMockableType,-    deriveMockableWithOptions,-    deriveMockableTypeWithOptions,-    deriveMockableBase,-    deriveMockableBaseType,-    deriveMockableBaseWithOptions,-    deriveMockableBaseTypeWithOptions,-    deriveForMockT,-    deriveTypeForMockT,-    deriveForMockTWithOptions,-    deriveTypeForMockTWithOptions,+  ( unappliedName,+    tvName,+    bindVar,+    substTypeVar,+    substTypeVars,+    splitType,+    freeTypeVars,+    relevantContext,+    constrainVars,+    unifyTypes,+    removeModNames,+    hasPolyType,+    hasNestedPolyType,+    resolveInstance,+    simplifyContext,+    localizeMember,   ) where -import Control.Monad (replicateM, unless, when, zipWithM)-import Control.Monad.Extra (concatMapM)-import Control.Monad.Trans (MonadIO)-import Data.Bool (bool)-import Data.Char (toUpper)-import Data.Default (Default (..))-import Data.Either (partitionEithers)-import qualified Data.Kind-import Data.List (foldl', (\\))-import Data.Typeable (Typeable)-import GHC.Stack (HasCallStack)-import GHC.TypeLits (Symbol)-import Language.Haskell.TH hiding (Match, match)-import Language.Haskell.TH.Syntax (Lift (lift))-import Test.HMock-import Test.HMock.Internal.TH.Util---- | Custom options for deriving a 'Mockable' class.-data MockableOptions = MockableOptions-  { -- | Suffix to add to 'Action' and 'Matcher' names.  Defaults to @""@.-    mockSuffix :: String,-    -- | Whether to warn about limitations of the generated mocks.  This is-    -- mostly useful temporarily for finding out why generated code doesn't-    -- match your expectations.  Defaults to @'False'@.-    mockVerbose :: Bool-  }--instance Default MockableOptions where-  def = MockableOptions {mockSuffix = "", mockVerbose = False}---- | Define all instances necessary to use HMock with the given class.--- Equivalent to both 'deriveMockable' and 'deriveForMockT'.------ If @MyClass@ is a class and @myMethod@ is one of its methods, then--- @'makeMockable' MyClass@ generates all of the following:------ If @MyClass@ is a class and @myMethod@ is one of its methods, then--- @'makeMockable' MyClass@ generates everything generated by--- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.-makeMockable :: Name -> Q [Dec]-makeMockable = makeMockableType . conT---- | Define all instances necessary to use HMock with the given constraint type,--- which should be a class applied to zero or more type arguments.  Equivalent--- to both 'deriveMockableType' and 'deriveTypeForMockT'.------ See 'makeMockable' for a list of what is generated by this splice.-makeMockableType :: Q Type -> Q [Dec]-makeMockableType = makeMockableTypeWithOptions def---- | Define all instances necessary to use HMock with the given class.  This is--- like 'makeMockable', but with the ability to specify custom options.------ See 'makeMockable' for a list of what is generated by this splice.-makeMockableWithOptions :: MockableOptions -> Name -> Q [Dec]-makeMockableWithOptions options = makeMockableTypeWithOptions options . conT---- | Define all instances necessary to use HMock with the given constraint type,--- which should be a class applied to zero or more type arguments.  This is--- like 'makeMockableType', but with the ability to specify custom options.------ See 'makeMockable' for a list of what is generated by this splice.-makeMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]-makeMockableTypeWithOptions options qt =-  (++) <$> deriveMockableTypeWithOptions options qt-    <*> deriveTypeForMockTWithOptions options qt---- | Defines almost all instances necessary to use HMock with the given class.--- Equivalent to both 'deriveMockableBase' and 'deriveForMockT'.-makeMockableBase :: Name -> Q [Dec]-makeMockableBase = makeMockableBaseType . conT---- | Defines almost all instances necessary to use HMock with the given--- constraint type, which should be a class applied to zero or more type--- arguments.  Equivalent to both 'deriveMockableBaseType' and--- 'deriveTypeForMockT'.-makeMockableBaseType :: Q Type -> Q [Dec]-makeMockableBaseType = makeMockableBaseTypeWithOptions def---- | Defines almost all instances necessary to use HMock with the given class.--- This is like 'makeMockable', but with the ability to specify custom options.-makeMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]-makeMockableBaseWithOptions options =-  makeMockableBaseTypeWithOptions options . conT---- | Defines almost all instances necessary to use HMock with the given--- constraint type, which should be a class applied to zero or more type--- arguments.  This is like 'makeMockableType', but with the ability to specify--- custom options.-makeMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]-makeMockableBaseTypeWithOptions options qt =-  (++) <$> deriveMockableBaseTypeWithOptions options qt-    <*> deriveTypeForMockTWithOptions options qt---- | Defines the 'Mockable' instance for the given class.------ If @MyClass@ is a class and @myMethod@ is one of its methods, then--- @'deriveMockable' MyClass@ generates everything generated by--- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.-deriveMockable :: Name -> Q [Dec]-deriveMockable = deriveMockableType . conT---- | Defines the 'Mockable' instance for the given constraint type, which should--- be a class applied to zero or more type arguments.------ See 'deriveMockable' for a list of what is generated by this splice.-deriveMockableType :: Q Type -> Q [Dec]-deriveMockableType = deriveMockableTypeWithOptions def---- | Defines the 'Mockable' instance for the given class.  This is like--- 'deriveMockable', but with the ability to specify custom options.------ See 'deriveMockable' for a list of what is generated by this splice.-deriveMockableWithOptions :: MockableOptions -> Name -> Q [Dec]-deriveMockableWithOptions options = deriveMockableTypeWithOptions options . conT---- | Defines the 'Mockable' instance for the given constraint type, which should--- be a class applied to zero or more type arguments.  This is like--- 'deriveMockableType', but with the ability to specify custom options.------ See 'deriveMockable' for a list of what is generated by this splice.-deriveMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]-deriveMockableTypeWithOptions = deriveMockableImpl False---- | Defines the 'MockableBase' instance for the given class.------ If @MyClass@ is a class and @myMethod@ is one of its methods, then--- @'deriveMockableBase' MyClass@ generates all of the following:------ * A @'MockableBase' MyClass@ instance.--- * An associated type @'Action' MyClass@, with a constructor @MyMethod@.--- * An associated type @'Matcher' MyClass@, with a constructor @MyMethod_@.--- * An 'Expectable' instance for @'Action' MyClass@ which matches an exact set---   of arguments, if and only if all of @myMethod@'s arguments have 'Eq' and---   'Show' instances.-deriveMockableBase :: Name -> Q [Dec]-deriveMockableBase = deriveMockableBaseType . conT---- | Defines the 'MockableBase' instance for the given constraint type, which--- should be a class applied to zero or more type arguments.------ See 'deriveMockableBase' for a list of what is generated by this splice.-deriveMockableBaseType :: Q Type -> Q [Dec]-deriveMockableBaseType = deriveMockableBaseTypeWithOptions def---- | Defines the 'MockableBase' instance for the given class.  This is like--- 'deriveMockableBase', but with the ability to specify custom options.------ See 'deriveMockableBase' for a list of what is generated by this splice.-deriveMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]-deriveMockableBaseWithOptions options =-  deriveMockableBaseTypeWithOptions options . conT---- | Defines the 'MockableBase' instance for the given constraint type, which--- should be a class applied to zero or more type arguments.  This is like--- 'deriveMockableBaseType', but with the ability to specify custom options.------ See 'deriveMockableBase' for a list of what is generated by this splice.-deriveMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]-deriveMockableBaseTypeWithOptions = deriveMockableImpl True---- | Defines an instance of the given class for @'MockT' m@, delegating all of--- its methods to 'mockMethod' to be handled by HMock.------ This may only be used if all members of the class are mockable methods.  If--- the class contains some unmockable methods, associated types, or other--- members, you will need to define this instance yourself, delegating the--- mockable methods as follows:------ @--- instance MyClass ('MockT' m) where---   myMethod x y = 'mockMethod' (MyMethod x y)---   ...--- @-deriveForMockT :: Name -> Q [Dec]-deriveForMockT = deriveTypeForMockT . conT---- | Defines an instance of the given constraint type for @'MockT' m@,--- delegating all of its methods to 'mockMethod' to be handled by HMock.--- The type should be a class applied to zero or more type arguments.------ See 'deriveForMockT' for restrictions on the use of this splice.-deriveTypeForMockT :: Q Type -> Q [Dec]-deriveTypeForMockT = deriveTypeForMockTWithOptions def---- | Defines an instance of the given class for @'MockT' m@, delegating all of--- its methods to 'mockMethod' to be handled by HMock.  This is like--- 'deriveForMockT', but with the ability to specify custom options.------ See 'deriveForMockT' for restrictions on the use of this splice.-deriveForMockTWithOptions :: MockableOptions -> Name -> Q [Dec]-deriveForMockTWithOptions options = deriveTypeForMockTWithOptions options . conT---- | Defines an instance of the given constraint type for @'MockT' m@,--- delegating all of its methods to 'mockMethod' to be handled by HMock.--- The type should be a class applied to zero or more type arguments.  This is--- like 'deriveTypeForMockT', but with the ability to specify custom options.------ See 'deriveForMockT' for restrictions on the use of this splice.-deriveTypeForMockTWithOptions :: MockableOptions -> Q Type -> Q [Dec]-deriveTypeForMockTWithOptions = deriveForMockTImpl--data Instance = Instance-  { instType :: Type,-    instRequiredContext :: Cxt,-    instGeneralParams :: [Name],-    instMonadVar :: Name,-    instMethods :: [Method],-    instExtraMembers :: [Dec]-  }-  deriving (Show)--data Method = Method-  { methodName :: Name,-    methodTyVars :: [Name],-    methodCxt :: Cxt,-    methodArgs :: [Type],-    methodResult :: Type-  }-  deriving (Show)--withClass :: Type -> (Dec -> Q a) -> Q a-withClass t f = do-  case unappliedName t of-    Just cls -> do-      info <- reify cls-      case info of-        ClassI dec@ClassD {} _ -> f dec-        _ -> fail $ "Expected " ++ show cls ++ " to be a class, but it wasn't."-    _ -> fail "Expected a class, but got something else."--getInstance :: MockableOptions -> Type -> Q Instance-getInstance options ty = withClass ty go-  where-    go (ClassD _ className [] _ _) =-      fail $ "Class " ++ nameBase className ++ " has no type parameters."-    go (ClassD cx _ params _ members) = matchVars ty [] (tvName <$> params)-      where-        matchVars :: Type -> [Type] -> [Name] -> Q Instance-        matchVars _ _ [] = internalError-        matchVars (AppT _ _) _ [_] =-          fail $ pprint ty ++ " is applied to too many arguments."-        matchVars (AppT a b) ts (_ : ps) =-          checkExt FlexibleInstances >> matchVars a (b : ts) ps-        matchVars _ ts ps = do-          let t = foldl' (\t' v -> AppT t' (VarT v)) ty (init ps)-          let tbl = zip (tvName <$> params) ts-          let cx' = substTypeVars tbl <$> cx-          makeInstance options t cx' tbl (init ps) (last ps) members-    go _ = internalError--makeInstance ::-  MockableOptions ->-  Type ->-  Cxt ->-  [(Name, Type)] ->-  [Name] ->-  Name ->-  [Dec] ->-  Q Instance-makeInstance options ty cx tbl ps m members = do-  processedMembers <- mapM (getMethod ty m tbl) members-  (extraMembers, methods) <--    partitionEithers <$> zipWithM memberOrMethod members processedMembers-  return $-    Instance-      { instType = ty,-        instRequiredContext = cx,-        instGeneralParams = ps,-        instMonadVar = m,-        instMethods = methods,-        instExtraMembers = extraMembers-      }-  where-    memberOrMethod :: Dec -> Either String Method -> Q (Either Dec Method)-    memberOrMethod dec (Left warning) = do-      when (mockVerbose options) $ reportWarning warning-      return (Left dec)-    memberOrMethod _ (Right method) = return (Right 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)-  return $ do-    let (tvs, cx, argsAndReturn) = splitType simpleTy-    (m', result) <- case last argsAndReturn of-      AppT (VarT m') result -> return (m', result)-      _ ->-        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)-    when (any hasNestedPolyType argTypes) $-      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-        }-getMethod _ _ _ _ = return (Left "A non-value member cannot be mocked.")--isKnownType :: Method -> Type -> Bool-isKnownType method ty = null tyVars && null cx-  where-    (tyVars, cx) =-      relevantContext ty (methodTyVars method, methodCxt method)+import Control.Monad.Extra (mapMaybeM)+import Data.Generics+import Data.List ((\\))+import Data.Maybe (catMaybes, fromMaybe)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (NameFlavour (..))+import Test.HMock.Internal.Util (choices) -withMethodParams :: Instance -> Method -> TypeQ -> TypeQ-withMethodParams inst method t =-  [t|-    $t-      $(pure (instType inst))-      $(litT (strTyLit (nameBase (methodName method))))-      $(varT (instMonadVar inst))-      $(pure (methodResult method))-    |]+#if MIN_VERSION_template_haskell(2,17,0) -deriveMockableImpl :: Bool -> MockableOptions -> Q Type -> Q [Dec]-deriveMockableImpl baseOnly options qt = do-  checkExt DataKinds-  checkExt FlexibleInstances-  checkExt GADTs-  checkExt MultiParamTypeClasses-  checkExt TypeFamilies+-- | Fetches the 'Name' of a 'TyVarBndr'.+tvName :: TyVarBndr flag -> Name+tvName (PlainTV name _) = name+tvName (KindedTV name _ _) = name -  inst <- getInstance options =<< qt+-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.+bindVar :: Name -> TyVarBndr Specificity+bindVar n = PlainTV n SpecifiedSpec -  when (null (instMethods inst)) $ do-    fail $-      "Cannot derive Mockable because " ++ pprint (instType inst)-        ++ " has no mockable methods."+#else -  typeableCxts <- constrainVars [conT ''Typeable] (instGeneralParams inst)+-- | Fetches the 'Name' of a 'TyVarBndr'.+tvName :: TyVarBndr -> Name+tvName (PlainTV name) = name+tvName (KindedTV name _) = name -  mockableBase <--    instanceD-      (pure typeableCxts)-      [t|MockableBase $(pure (instType inst))|]-      [ defineActionType options inst,-        defineMatcherType options inst,-        defineShowAction options (instMethods inst),-        defineShowMatcher options (instMethods inst),-        defineMatchAction options (instMethods inst)-      ]-  mockable <--    if baseOnly-      then return []-      else-        (: [])-          <$> instanceD-            (pure typeableCxts)-            [t|Mockable $(pure (instType inst))|]-            []-  expectables <- defineExpectableActions options inst+-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.+bindVar :: Name -> TyVarBndr+bindVar = PlainTV -  return $ mockableBase : mockable ++ expectables+#endif -defineActionType :: MockableOptions -> Instance -> DecQ-defineActionType options inst = do-  kind <--    [t|-      Symbol ->-      (Data.Kind.Type -> Data.Kind.Type) ->-      Data.Kind.Type ->-      Data.Kind.Type-      |]-  let cons = actionConstructor options inst <$> instMethods inst-  dataInstD (pure []) ''Action [pure (instType inst)] (Just kind) cons []+-- | Gets the unapplied top-level name from a type application.+unappliedName :: Type -> Maybe Name+unappliedName (AppT a _) = unappliedName a+unappliedName (ConT a) = Just a+unappliedName _ = Nothing -actionConstructor :: MockableOptions -> Instance -> Method -> ConQ-actionConstructor options inst method = do-  forallC [] (return (methodCxt method)) $-    gadtC-      [getActionName options method]-      [ return (Bang NoSourceUnpackedness NoSourceStrictness, argTy)-        | argTy <- methodArgs method-      ]-      (withMethodParams inst method [t|Action|])+-- | Substitutes a 'Type' for all occurrences of the given 'Name'.+substTypeVar :: Name -> Type -> Type -> Type+substTypeVar n t = substTypeVars [(n, t)] -getActionName :: MockableOptions -> Method -> Name-getActionName options method =-  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options)+-- | Makes variable substitutions from the given table.+substTypeVars :: [(Name, Type)] -> Type -> Type+substTypeVars classVars = everywhere (mkT subst)   where-    name = nameBase (methodName method)--defineMatcherType :: MockableOptions -> Instance -> Q Dec-defineMatcherType options inst = do-  kind <--    [t|-      Symbol ->-      (Data.Kind.Type -> Data.Kind.Type) ->-      Data.Kind.Type ->-      Data.Kind.Type-      |]-  let cons = matcherConstructor options inst <$> instMethods inst-  dataInstD (pure []) ''Matcher [pure (instType inst)] (Just kind) cons []+    subst (VarT x) | Just t <- lookup x classVars = t+    subst t = t -matcherConstructor :: MockableOptions -> Instance -> Method -> ConQ-matcherConstructor options inst method = do-  gadtC-    [getMatcherName options method]-    [ (Bang NoSourceUnpackedness NoSourceStrictness,) <$> mkPredicate argTy-      | argTy <- methodArgs method-    ]-    (withMethodParams inst method [t|Matcher|])-  where-    mkPredicate argTy-      | hasPolyType argTy = do-        checkExt RankNTypes-        v <- newName "t"-        forallT [bindVar v] (pure []) [t|Predicate $(varT v)|]-      | null tyVars && null cx = [t|Predicate $(pure argTy)|]-      | otherwise = do-        checkExt RankNTypes-        forallT (bindVar <$> tyVars) (pure cx) [t|Predicate $(pure argTy)|]-      where-        (tyVars, cx) =-          relevantContext argTy (methodTyVars method, methodCxt method)+-- | 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])+splitType (ForallT tv cx b) =+  let (tvs, cxs, parts) = splitType b+   in (map tvName tv ++ tvs, cx ++ cxs, parts)+splitType (AppT (AppT ArrowT a) b) =+  let (tvs, cx, parts) = splitType b in (tvs, cx, a : parts)+splitType r = ([], [], [r]) -getMatcherName :: MockableOptions -> Method -> Name-getMatcherName options method =-  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options ++ "_")+-- | Gets all free type variable 'Name's in the given 'Type'.+freeTypeVars :: Type -> [Name]+freeTypeVars = everythingWithContext [] (++) (mkQ ([],) go)   where-    name = nameBase (methodName method)+    go (VarT v) bound+      | v `elem` bound = ([], bound)+      | otherwise = ([v], bound)+    go (ForallT vs _ _) bound = ([], map tvName vs ++ bound)+    go _ bound = ([], bound) -defineShowAction :: MockableOptions -> [Method] -> Q Dec-defineShowAction options methods =-  funD 'showAction (showActionClause options <$> methods)+-- | Produces a 'CxtQ' that gives all given variable 'Name's all of the given+-- class 'Type's.+constrainVars :: [TypeQ] -> [Name] -> CxtQ+constrainVars cs vs = sequence [appT c (varT v) | c <- cs, v <- vs] -showActionClause :: MockableOptions -> Method -> Q Clause-showActionClause options method = do-  argVars <- replicateM (length (methodArgs method)) (newName "a")-  clause-    [ conP-        (getActionName options method)-        (zipWith argPattern (methodArgs method) argVars)-    ]-    ( normalB-        [|-          unwords-            ( $(lift (nameBase (methodName method))) :-              $(listE (zipWith showArg (methodArgs method) argVars))-            )-          |]-    )-    []+-- | Culls the given binders and constraints to choose only those that apply to+-- free variables in the given type.+relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt)+relevantContext ty (tvs, cx) = (filter needsTv tvs, filteredCx)   where-    canShow ty-      | not (null (freeTypeVars ty)) = return False-      | otherwise = isInstance ''Show [ty]-    argPattern ty v = canShow ty >>= bool wildP (varP v)-    showArg ty var =-      canShow ty-        >>= bool-          (lift ("(_ :: " ++ pprint (removeModNames ty) ++ ")"))-          [|showsPrec 11 $(varE var) ""|]--defineShowMatcher :: MockableOptions -> [Method] -> Q Dec-defineShowMatcher options methods = do-  clauses <- concatMapM (showMatcherClauses options) methods-  funD 'showMatcher clauses+    filteredCx = filter (any (`elem` freeTypeVars ty) . freeTypeVars) cx+    needsTv v = any ((v `elem`) . freeTypeVars) (ty : filteredCx) -showMatcherClauses :: MockableOptions -> Method -> Q [ClauseQ]-showMatcherClauses options method = do-  argTVars <- replicateM (length (methodArgs method)) (newName "t")-  predVars <- replicateM (length (methodArgs method)) (newName "p")-  let actionArgs = zipWith actionArg argTVars (methodArgs method)-  let matcherArgs = varP <$> predVars-  let printedArgs = zipWith3 printedArg predVars argTVars (methodArgs method)-  let polyMatcherArgs = zipWith matcherArg predVars (methodArgs method)-  let printedPolyArgs = zipWith printedPolyArg predVars (methodArgs method)-  let body name args = normalB [|unwords ($(lift name) : $(listE args))|]-  return-    [ clause-        [ conP 'Just [conP (getActionName options method) actionArgs],-          conP (getMatcherName options method) matcherArgs-        ]-        (body (nameBase (methodName method)) printedArgs)-        [],-      clause-        [ conP 'Nothing [],-          conP (getMatcherName options method) polyMatcherArgs-        ]-        (body (nameBase (methodName method)) printedPolyArgs)-        []-    ]+-- | Attempts to unify the given types by constructing a table of substitutions+-- for the variables of the left type that obtain the right one.+unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])+unifyTypes = unifyTypesWith []   where-    actionArg t ty-      | isKnownType method ty = wildP-      | otherwise = checkExt ScopedTypeVariables >> sigP wildP (varT t)+    unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])+    unifyTypesWith tbl (VarT v) t2+      | Just t1 <- lookup v tbl = unifyTypesWith tbl t1 t2+      | otherwise = return (Just ((v, t2) : tbl))+    unifyTypesWith tbl (ConT a) (ConT b) | a == b = return (Just tbl)+    unifyTypesWith tbl a b = do+      mbA <- replaceSyn a+      mbB <- replaceSyn b+      case (mbA, mbB) of+        (Nothing, Nothing) -> unifyGen tbl a b+        _ -> unifyTypesWith tbl (fromMaybe a mbA) (fromMaybe b mbB) -    matcherArg p ty-      | isKnownType method ty = varP p-      | otherwise = wildP+    replaceSyn :: Type -> Q (Maybe Type)+    replaceSyn (ConT n) = do+      info <- reify n+      case info of+        TyConI (TySynD _ [] t) -> return (Just t)+        _ -> return Nothing+    replaceSyn _ = return Nothing -    printedArg p t ty-      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]-      | otherwise =-        [|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|]+    unifyGen ::+      (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])+    unifyGen tbl a b+      | toConstr a == toConstr b =+        compose (gzipWithQ (\a' b' tbl' -> unify tbl' a' b') a b) tbl+      | otherwise = return Nothing -    printedPolyArg p ty-      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]-      | otherwise = [|"«polymorphic»"|]+    unify ::+      (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])+    unify tbl a b = do+      case (cast a, cast b) of+        (Just a', Just b') -> unifyTypesWith tbl a' b'+        _ -> unifyGen tbl a b -defineMatchAction :: MockableOptions -> [Method] -> Q Dec-defineMatchAction options methods =-  funD 'matchAction (matchActionClause options <$> methods)+    compose :: Monad m => [t -> m (Maybe t)] -> t -> m (Maybe t)+    compose [] x = return (Just x)+    compose (f : fs) x = do+      y <- f x+      case y of+        Just y' -> compose fs y'+        _ -> return Nothing -matchActionClause :: MockableOptions -> Method -> Q Clause-matchActionClause options method = do-  argVars <--    replicateM-      (length (methodArgs method))-      ((,) <$> newName "p" <*> newName "a")-  mmVar <- newName "mismatches"-  clause-    [ conP-        (getMatcherName options method)-        (varP . fst <$> argVars),-      conP (getActionName options method) (varP . snd <$> argVars)-    ]-    ( guardedB-        [ (,) <$> normalG [|$(varE mmVar) == 0|] <*> [|Match|],-          (,) <$> normalG [|otherwise|] <*> [|NoMatch $(varE mmVar)|]-        ]-    )-    [ valD-        (varP mmVar)-        (normalB [|length (filter not $(listE (mkAccept <$> argVars)))|])-        []-    ]+-- | Removes all module names from 'Name's in the given value, so that it will+-- pretty-print more cleanly.+removeModNames :: Data a => a -> a+removeModNames = everywhere (mkT unMod)   where-    mkAccept (p, a) = [|accept $(return (VarE p)) $(return (VarE a))|]+    unMod NameG {} = NameS+    unMod other = other -defineExpectableActions :: MockableOptions -> Instance -> Q [Dec]-defineExpectableActions options inst =-  concatMapM (defineExpectableAction options inst) (instMethods inst)+-- | Determines if there is a polytype nested anywhere in the given type.+-- Top-level quantification doesn't count.+hasNestedPolyType :: Type -> Bool+hasNestedPolyType (ForallT _ _ t) = hasPolyType t+hasNestedPolyType t = hasPolyType t -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 []+-- | Determines if this is a polytype, including top-level quantification.+hasPolyType :: Type -> Bool+hasPolyType = everything (||) (mkQ False isPolyType)   where-    makeBody [] e = e-    makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|]--    wholeCxt :: [Type] -> Q (Maybe Cxt)-    wholeCxt (ty : ts) = do-      thisCxt <- argCxt ty-      otherCxt <- wholeCxt ts-      return ((++) <$> thisCxt <*> otherCxt)-    wholeCxt [] = return (Just [])--    argCxt :: Type -> Q (Maybe Cxt)-    argCxt argTy-      | not (isKnownType method argTy) = return Nothing-      | VarT v <- argTy =-        Just <$> sequence [[t|Eq $(varT v)|], [t|Show $(varT v)|]]-      | otherwise = do-        eqCxt <- resolveInstance ''Eq argTy-        showCxt <- resolveInstance ''Show argTy-        return ((++) <$> eqCxt <*> showCxt)--deriveForMockTImpl :: MockableOptions -> Q Type -> Q [Dec]-deriveForMockTImpl options qt = do-  inst <- getInstance options =<< qt--  unless (null (instExtraMembers inst)) $-    fail $-      "Cannot derive MockT because " ++ pprint (instType inst)-        ++ " has unmockable methods."--  m <- newName "m"-  let decs = map (implementMethod options) (instMethods inst)--  let cx =-        instRequiredContext inst-          \\ [ AppT (ConT ''Typeable) (VarT (instMonadVar inst)),-               AppT (ConT ''Functor) (VarT (instMonadVar inst)),-               AppT (ConT ''Applicative) (VarT (instMonadVar inst)),-               AppT (ConT ''Monad) (VarT (instMonadVar inst)),-               AppT (ConT ''MonadIO) (VarT (instMonadVar inst))-             ]--  simplifyContext-    (substTypeVar (instMonadVar inst) (AppT (ConT ''MockT) (VarT m)) <$> cx)-    >>= \case-      Just cxMockT ->-        (: [])-          <$> instanceD-            ( concat-                <$> sequence-                  [ return cxMockT,-                    constrainVars [[t|Typeable|]] (instGeneralParams inst),-                    constrainVars [[t|Typeable|], [t|MonadIO|]] [m]-                  ]-            )-            [t|$(pure (instType inst)) (MockT $(varT m))|]-            decs-      Nothing -> fail "Missing MockT instance for a superclass."+    isPolyType (ForallT tvs _ _) = not (null tvs)+    isPolyType _ = False -implementMethod :: MockableOptions -> Method -> Q Dec-implementMethod options method = do-  argVars <- replicateM (length (methodArgs method)) (newName "a")-  funD-    (methodName method)-    [clause (varP <$> argVars) (normalB (body argVars)) []]+-- | Attempts to produce sufficient constraints for the given 'Type' to be an+-- instance of the given class 'Name'.+resolveInstance :: Name -> Type -> Q (Maybe Cxt)+resolveInstance cls t@(VarT _) = return (Just [AppT (ConT cls) t])+resolveInstance cls t = do+  decs <- reifyInstances cls [t]+  result <- traverse (tryInstance t) decs+  case catMaybes result of+    [cx] -> return (Just (filter (not . null . freeTypeVars) cx))+    _ -> return Nothing   where-    actionExp [] e = e-    actionExp (v : vs) e = actionExp vs [|$e $(varE v)|]+    tryInstance :: Type -> InstanceDec -> Q (Maybe Cxt)+    tryInstance actualTy (InstanceD _ cx (AppT (ConT cls') genTy) _)+      | cls' == cls =+        unifyTypes genTy actualTy >>= \case+          Just tbl ->+            let cx' = substTypeVars tbl <$> cx+             in fmap concat . sequence <$> mapM resolveInstanceType cx'+          Nothing -> return Nothing+    tryInstance _ _ = return Nothing -    body argVars = do-      defaultCxt <- resolveInstance ''Default (methodResult method)-      let someMockMethod = case defaultCxt of-            Just [] -> [|mockMethod|]-            _ -> [|mockDefaultlessMethod|]-      [|-        $someMockMethod-          $(actionExp argVars (conE (getActionName options method)))-        |]+    resolveInstanceType :: Type -> Q (Maybe Cxt)+    resolveInstanceType (AppT (ConT cls') t') = resolveInstance cls' t'+    resolveInstanceType _ = return Nothing -checkExt :: Extension -> Q ()-checkExt e = do-  enabled <- isExtEnabled e-  unless enabled $-    fail $ "Please enable " ++ show e ++ " to generate this mock."+-- | Simplifies a context with complex types (requiring FlexibleContexts) to try+-- to obtain one with all constraints applied to variables.+simplifyContext :: Cxt -> Q (Maybe Cxt)+simplifyContext (AppT (ConT cls) t : preds) = resolveInstance cls t >>= \case+  Just cxt' -> fmap (cxt' ++) <$> simplifyContext preds+  Nothing -> return Nothing+simplifyContext (otherPred : preds) = fmap (otherPred :) <$> simplifyContext preds+simplifyContext [] = return (Just []) -internalError :: HasCallStack => Q a-internalError = error "Internal error in HMock.  Please report this as a bug."+-- | Remove instance context from a method.+--+-- Some GHC versions report class members including the instance context (for+-- example, @show :: Show a => a -> String@, instead of @show :: a -> String@).+-- This looks for the instance context, and substitutes if needed to eliminate+-- it.+localizeMember :: Type -> Name -> Type -> Q Type+localizeMember instTy m t@(ForallT tvs cx ty) = do+  let fullConstraint = AppT instTy (VarT m)+  let unifyLeft (c, cs) = fmap (,cs) <$> unifyTypes c fullConstraint+  results <- mapMaybeM unifyLeft (choices cx)+  case results of+    ((tbl, remainingCx) : _) -> do+      let cx' = substTypeVars tbl <$> remainingCx+          ty' = substTypeVars tbl ty+          (tvs', cx'') =+            relevantContext+              ty'+              ((tvName <$> tvs) \\ (fst <$> tbl), cx')+          t'+            | null tvs' && null cx'' = ty'+            | otherwise = ForallT (bindVar <$> tvs') cx'' ty'+      return t'+    _ -> return t+localizeMember _ _ t = return t

@@ -1,208 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}--module Test.HMock.Internal.TH.Util-  ( unappliedName,-    tvName,-    bindVar,-    substTypeVar,-    substTypeVars,-    splitType,-    freeTypeVars,-    relevantContext,-    constrainVars,-    unifyTypes,-    removeModNames,-    hasPolyType,-    hasNestedPolyType,-    resolveInstance,-    simplifyContext,-    localizeMember,-  )-where--import Control.Monad.Extra (mapMaybeM)-import Data.Generics-import Data.List ((\\))-import Data.Maybe (catMaybes, fromMaybe)-import Language.Haskell.TH-import Language.Haskell.TH.Syntax (NameFlavour (..))-import Test.HMock.Internal.Util (choices)--#if MIN_VERSION_template_haskell(2,17,0)--tvName :: TyVarBndr flag -> Name-tvName (PlainTV name _) = name-tvName (KindedTV name _ _) = name--bindVar :: Name -> TyVarBndr Specificity-bindVar n = PlainTV n SpecifiedSpec--#else--tvName :: TyVarBndr -> Name-tvName (PlainTV name) = name-tvName (KindedTV name _) = name--bindVar :: Name -> TyVarBndr-bindVar = PlainTV--#endif--unappliedName :: Type -> Maybe Name-unappliedName (AppT a _) = unappliedName a-unappliedName (ConT a) = Just a-unappliedName _ = Nothing--substTypeVar :: Name -> Type -> Type -> Type-substTypeVar n t = substTypeVars [(n, t)]--substTypeVars :: [(Name, Type)] -> Type -> Type-substTypeVars classVars = everywhere (mkT subst)-  where-    subst (VarT x) | Just t <- lookup x classVars = t-    subst t = t--splitType :: Type -> ([Name], Cxt, [Type])-splitType (ForallT tv cx b) =-  let (tvs, cxs, parts) = splitType b-   in (map tvName tv ++ tvs, cx ++ cxs, parts)-splitType (AppT (AppT ArrowT a) b) =-  let (tvs, cx, parts) = splitType b in (tvs, cx, a : parts)-splitType r = ([], [], [r])--freeTypeVars :: Type -> [Name]-freeTypeVars = everythingWithContext [] (++) (mkQ ([],) go)-  where-    go (VarT v) bound-      | v `elem` bound = ([], bound)-      | otherwise = ([v], bound)-    go (ForallT vs _ _) bound = ([], map tvName vs ++ bound)-    go _ bound = ([], bound)--constrainVars :: [TypeQ] -> [Name] -> CxtQ-constrainVars cs vs = sequence [appT c (varT v) | c <- cs, v <- vs]--relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt)-relevantContext ty (tvs, cx) = (filter needsTv tvs, filteredCx)-  where-    filteredCx = filter (any (`elem` freeTypeVars ty) . freeTypeVars) cx-    needsTv v = any ((v `elem`) . freeTypeVars) (ty : filteredCx)--unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])-unifyTypes = unifyTypesWith []--unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])-unifyTypesWith tbl (VarT v) t2-  | Just t1 <- lookup v tbl = unifyTypesWith tbl t1 t2-  | otherwise = return (Just ((v, t2) : tbl))-unifyTypesWith tbl (ConT a) (ConT b) | a == b = return (Just tbl)-unifyTypesWith tbl a b = do-  mbA <- replaceSyn a-  mbB <- replaceSyn b-  case (mbA, mbB) of-    (Nothing, Nothing) -> unifyGen tbl a b-    _ -> unifyTypesWith tbl (fromMaybe a mbA) (fromMaybe b mbB)--replaceSyn :: Type -> Q (Maybe Type)-replaceSyn (ConT n) = do-  info <- reify n-  case info of-    TyConI (TySynD _ [] t) -> return (Just t)-    _ -> return Nothing-replaceSyn _ = return Nothing--unifyGen ::-  (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])-unifyGen tbl a b-  | toConstr a == toConstr b =-    compose (gzipWithQ (\a' b' tbl' -> unify tbl' a' b') a b) tbl-  | otherwise = return Nothing--unify ::-  (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])-unify tbl a b = do-  case (cast a, cast b) of-    (Just a', Just b') -> unifyTypesWith tbl a' b'-    _ -> unifyGen tbl a b--compose :: Monad m => [t -> m (Maybe t)] -> t -> m (Maybe t)-compose [] x = return (Just x)-compose (f : fs) x = do-  y <- f x-  case y of-    Just y' -> compose fs y'-    _ -> return Nothing--removeModNames :: Data a => a -> a-removeModNames = everywhere (mkT unMod)-  where-    unMod NameG {} = NameS-    unMod other = other--hasNestedPolyType :: Type -> Bool-hasNestedPolyType (ForallT _ _ t) = hasPolyType t-hasNestedPolyType t = hasPolyType t--hasPolyType :: Type -> Bool-hasPolyType = everything (||) (mkQ False isPolyType)-  where-    isPolyType (ForallT tvs _ _) = not (null tvs)-    isPolyType _ = False--resolveInstance :: Name -> Type -> Q (Maybe Cxt)-resolveInstance cls t@(VarT _) = return (Just [AppT (ConT cls) t])-resolveInstance cls t = do-  decs <- reifyInstances cls [t]-  result <- traverse (tryInstance t) decs-  case catMaybes result of-    [cx] -> return (Just (filter (not . null . freeTypeVars) cx))-    _ -> return Nothing-  where-    tryInstance :: Type -> InstanceDec -> Q (Maybe Cxt)-    tryInstance actualTy (InstanceD _ cx (AppT (ConT cls') genTy) _)-      | cls' == cls =-        unifyTypes genTy actualTy >>= \case-          Just tbl ->-            let cx' = substTypeVars tbl <$> cx-             in fmap concat . sequence <$> mapM resolveInstanceType cx'-          Nothing -> return Nothing-    tryInstance _ _ = return Nothing--    resolveInstanceType :: Type -> Q (Maybe Cxt)-    resolveInstanceType (AppT (ConT cls') t') = resolveInstance cls' t'-    resolveInstanceType _ = return Nothing--simplifyContext :: Cxt -> Q (Maybe Cxt)-simplifyContext (AppT (ConT cls) t : preds) = resolveInstance cls t >>= \case-  Just cxt' -> fmap (cxt' ++) <$> simplifyContext preds-  Nothing -> return Nothing-simplifyContext (otherPred : preds) = fmap (otherPred :) <$> simplifyContext preds-simplifyContext [] = return (Just [])---- | Remove instance context from a method.------ Some GHC versions report class members including the instance context (for--- example, @show :: Show a => a -> String@, instead of @show :: a -> String@).--- This looks for the instance context, and substitutes if needed to eliminate--- it.-localizeMember :: Type -> Name -> Type -> Q Type-localizeMember instTy m t@(ForallT tvs cx ty) = do-  let fullConstraint = AppT instTy (VarT m)-  let unifyLeft (c, cs) = fmap (,cs) <$> unifyTypes c fullConstraint-  results <- mapMaybeM unifyLeft (choices cx)-  case results of-    ((tbl, remainingCx) : _) -> do-      let cx' = substTypeVars tbl <$> remainingCx-          ty' = substTypeVars tbl ty-          (tvs', cx'') =-            relevantContext-              ty'-              ((tvName <$> tvs) \\ (fst <$> tbl), cx')-          t'-            | null tvs' && null cx'' = ty'-            | otherwise = ForallT (bindVar <$> tvs') cx'' ty'-      return t'-    _ -> return t-localizeMember _ _ t = return t

@@ -1,27 +1,34 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +-- | Internal utilities used for HMock implementation. module Test.HMock.Internal.Util where  import Data.MonoTraversable (Element) import qualified Data.Sequences as Seq import GHC.Stack (CallStack, getCallStack, prettySrcLoc) +-- | A value together with its source location. data Located a = Loc (Maybe String) a deriving (Eq, Ord, Functor) +-- | Annotates a value with its source location from the call stack. locate :: CallStack -> a -> Located a locate stack = case map snd (getCallStack stack) of   (loc : _) -> Loc (Just (prettySrcLoc loc))   _ -> Loc Nothing +-- | Formats a 'Located' 'String' to include its source location. withLoc :: Located String -> String withLoc (Loc Nothing s) = s withLoc (Loc (Just loc) s) = s ++ " at " ++ loc +-- | Returns all ways to choose one element from a list, and the corresponding+-- remaining list. choices :: [a] -> [(a, [a])] choices [] = [] choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs) +-- | Checks if one sequence is a subsequence of another. isSubsequenceOf :: (Seq.IsSequence t, Eq (Element t)) => t -> t -> Bool xs `isSubsequenceOf` ys = case Seq.uncons xs of   Nothing -> True

@@ -0,0 +1,181 @@+{-# 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 surrogate action = join $+  fromMockSetup $ do+    initClassIfNeeded (Proxy :: Proxy cls)+    states <- allStates <$> MockSetup ask+    (partial, full) <- fmap (bimap concat concat . unzip) $+      forM states $ \state -> do+        expectSet <- mockSetupSTM $ readTVar (mockExpectSet state)+        return $+          partitionEithers+            (tryMatch (mockExpectSet state) <$> liveSteps expectSet)+    let orderedPartial = snd <$> sortBy (compare `on` fst) (catMaybes partial)+    defaults <- concatMapM (mockSetupSTM . readTVar . mockDefaults) states+    checkAmbig <- mockSetupSTM $ readTVar . mockCheckAmbiguity . head $ states+    case (full, orderedPartial, 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)+  where+    tryMatch ::+      TVar (ExpectSet (Step m)) ->+      (Step m, ExpectSet (Step m)) ->+      Either+        (Maybe (Int, String))+        (String, MockSetup m (), Maybe (MockT m r))+    tryMatch tvar (Step expected, e)+      | Just lrule@(Loc _ (m :-> impl)) <- cast expected =+        case matchAction m action of+          NoMatch n ->+            Left (Just (n, withLoc (showMatcher (Just action) m <$ lrule)))+          Match ->+            Right+              ( withLoc (lrule $> showMatcher (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)++-- | 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 =+  withFrozenCallStack $ mockMethodImpl def 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 =+  withFrozenCallStack $ mockMethodImpl undefined 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 a = do+  fullExpectations <- describeExpectations+  error $+    "Unexpected action: " ++ showAction a+      ++ "\n\nFull expectations:\n"+      ++ 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 a partials = do+  fullExpectations <- describeExpectations+  error $+    "Wrong arguments: "+      ++ showAction a+      ++ "\n\nClosest matches:\n - "+      ++ intercalate "\n - " (take 5 partials)+      ++ "\n\nFull expectations:\n"+      ++ 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 a choices = do+  fullExpectations <- describeExpectations+  error $+    "Ambiguous action matched multiple expectations: "+      ++ showAction a+      ++ "\n\nMatches:\n - "+      ++ intercalate "\n - " choices+      ++ "\n\nFull expectations:\n"+      ++ fullExpectations

@@ -0,0 +1,206 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module defines monads for working with mocks.  HMock tests run in the+-- 'MockT' monad transformer.  A more limited monad, 'MockSetup', is used for+-- setting up defaults for each class.  Both are instances of the 'MockContext'+-- monad, which defines a shared API.+module Test.HMock.MockT+  ( MockT,+    runMockT,+    withMockT,+    nestMockT,+    withNestedMockT,+    setAmbiguityCheck,+    describeExpectations,+    verifyExpectations,+    MockSetup,+    MockContext,+    allowUnexpected,+    byDefault,+  )+where++import Control.Monad.Reader+  ( MonadReader (..),+    runReaderT,+  )+import Control.Monad.Trans (lift)+import Data.List (intercalate)+import Data.Proxy (Proxy (Proxy))+import GHC.Stack (callStack)+import Test.HMock.ExpectContext (MockableMethod)+import Test.HMock.Internal.ExpectSet+import Test.HMock.Internal.Rule (Rule ((:=>)))+import Test.HMock.Internal.State+import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step))+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+runMockT test = withMockT constTest+  where+    constTest :: (forall b. MockT m b -> m b) -> MockT m a+    constTest _inMockT = test++-- | Runs a test in the 'MockT' monad.  The test can unlift other MockT pieces+-- to the base monad while still acting on the same set of expectations.  This+-- can be useful for testing concurrency or similar mechanisms.+--+-- @+-- test = 'withMockT' '$' \inMockT -> do+--    'Test.HMock.Expectable.expect' '$' ...+--+--    'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT firstThread+--    'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT secondThread+-- @+--+-- This is a low-level primitive.  Consider using the @unliftio@ package for+-- higher level implementations of multithreading and other primitives.+withMockT ::+  forall m b. MonadIO m => ((forall a. MockT m a -> m a) -> MockT m b) -> m b+withMockT test = do+  state <- initMockState Nothing+  let inMockT :: forall a. MockT m a -> m a+      inMockT m = runReaderT (unMockT m) state+  flip runReaderT state $+    unMockT $ do+      a <- test inMockT+      verifyExpectations+      return a++-- | Starts a nested block within 'MockT'.  The nested block has its own set of+-- expectations, which must be fulfilled before the end of the block.+--+-- Beware: use of 'nestMockT' might signify that you are doing too much in a+-- single test.  Consider splitting large tests into a separate test for each+-- case.+nestMockT :: forall m a. MonadIO m => MockT m a -> MockT m a+nestMockT nest = withNestedMockT constNest+  where+    constNest :: (forall b. MockT m b -> m b) -> MockT m a+    constNest _inMockT = nest++-- | Starts a nested block within 'MockT'.  The nested block has its own set of+-- expectations, which must be fulfilled before the end of the block.  It can+-- unlift other MockT pieces to the base monad while still acting on the same+-- set of expectations.  This can be useful for testing concurrency or similar+-- mechanisms.+--+-- Beware: use of 'nestMockT' might signify that you are doing too much in a+-- single test.  Consider splitting large tests into a separate test for each+-- case.+withNestedMockT ::+  forall m b.+  MonadIO m =>+  ((forall a. MockT m a -> m a) -> MockT m b) ->+  MockT m b+withNestedMockT nest = do+  parent <- MockT ask+  state <- lift $ initMockState (Just parent)+  withState state $ do+    a <- nest (flip runReaderT state . unMockT)+    verifyExpectations+    return a+  where+    withState state = MockT . local (const state) . unMockT++-- | Sets whether to check for ambiguous actions.  If 'True', then actions that+-- match expectations in more than one way will fail.  If 'False', then the+-- most recently added action will take precedence.  This defaults to 'False'.+setAmbiguityCheck :: MonadIO m => Bool -> MockT m ()+setAmbiguityCheck flag = fromMockSetup $ do+  state <- MockSetup ask+  mockSetupSTM $ writeTVar (mockCheckAmbiguity state) flag++-- | Fetches a 'String' that describes the current set of outstanding+-- expectations.  This is sometimes useful for debugging test code.  The exact+-- format is not specified.+describeExpectations :: MonadIO m => MockT m String+describeExpectations = fromMockSetup $ do+  states <- allStates <$> MockSetup ask+  expectSets <- mapM (mockSetupSTM . readTVar . mockExpectSet) states+  return $+    intercalate "\n----- (next layer) -----\n" $+      formatExpectSet <$> expectSets++-- | Verifies that all mock expectations are satisfied.  If there is a nested+-- block in effect, only the expectations of that nested block are verified+-- You normally don't need to do this, because it happens automatically at the+-- end of your test or nested block.  However, it's occasionally useful to check+-- expectations early.+--+-- Beware: use of 'verifyExpectations' might signify that you are doing too much+-- in a single test.  Consider splitting large tests into a separate test for+-- each case.+verifyExpectations :: MonadIO m => MockT m ()+verifyExpectations = do+  fromMockSetup $ do+    expectSet <- MockSetup ask >>= mockSetupSTM . readTVar . mockExpectSet+    case excess expectSet of+      ExpectNothing -> return ()+      missing -> error $ "Unmet expectations:\n" ++ formatExpectSet missing++-- | Adds a handler for unexpected actions.  Matching calls will not fail, but+-- will use a default response instead.  The rule passed in must have zero or+-- one responses: if there is a response, @'allowUnexpected' (m+-- 'Test.HMock.Rule.|=>' r)@ is equivalent to @'allowUnexpected' m >>+-- 'byDefault' (m 'Test.HMock.Rule.|=>' r)@.+--+-- The difference between 'Test.HMock.Expectable.expectAny' and+-- 'allowUnexpected' is subtle, but comes down to ambiguity:+--+-- * 'allowUnexpected' is not an expectation, so it cannot be ambiguous.  It+--   only has an effect if no true expectation matches, regardless of when the+--   expectations were added.+-- * 'Test.HMock.Expectable.expectAny' adds an expectation, so if another+--   expectation is in effect at the same time, a call to the method is+--   ambiguous.  If ambiguity checking is enabled, the method will throw an+--   error; otherwise, the more recently added of the two expectations is used.+allowUnexpected ::+  forall cls name m r rule ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    Expectable cls name m r rule,+    MockContext ctx+  ) =>+  rule ->+  ctx m ()+allowUnexpected e = fromMockSetup $ case toRule e of+  _ :=> (_ : _ : _) -> error "allowUnexpected may not have multiple responses."+  m :=> r -> do+    initClassIfNeeded (Proxy :: Proxy cls)+    state <- MockSetup ask+    mockSetupSTM $+      modifyTVar'+        (mockDefaults state)+        ((True, 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+-- response.  The rule passed in must have exactly one response.+byDefault ::+  forall cls name m r ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    MockContext ctx+  ) =>+  Rule cls name m r ->+  ctx m ()+byDefault (m :=> [r]) = fromMockSetup $ do+  initClassIfNeeded (Proxy :: Proxy cls)+  state <- MockSetup ask+  mockSetupSTM $+    modifyTVar'+      (mockDefaults state)+      ((False, Step (locate callStack (m :-> Just r))) :)+byDefault _ = error "Defaults must have exactly one response."

@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module defines the 'MockableBase' and 'Mockable' classes that are+-- needed to use an MTL-style type class with 'Test.HMock.MockT.MockT'.  You+-- will typically derive 'MockableBase' with Template Haskell, since it's mostly+-- boilerplate.  The 'Mockable' class adds a customizable setup method which you+-- can define yourself to add the right defaults for methods in the mocked+-- class.+module Test.HMock.Mockable+  ( Mockable (..),+    MockableBase (..),+    MatchResult (..),+  )+where++import Control.Monad.Trans (MonadIO)+import Data.Kind (Constraint, Type)+import Data.Typeable (Typeable)+import GHC.TypeLits (Symbol)+import {-# SOURCE #-} Test.HMock.Internal.State (MockSetup)++-- | The result of matching a @'Matcher' a@ with an @'Action' b@.  Because the+-- types should already guarantee that the methods match, all that's left is to+-- match arguments.+data MatchResult where+  -- | No match.  The int is the number of arguments that don't match.+  NoMatch :: Int -> MatchResult+  -- | Match. Stores a witness to the equality of return types.+  Match :: MatchResult++-- | A base class for 'Monad' subclasses whose methods can be mocked.  You+-- usually want to generate this instance using 'Test.HMock.TH.makeMockable',+-- 'Test.HMock.TH.makeMockableBase', 'Test.HMock.TH.deriveMockable', or+-- 'Test.HMock.TH.deriveMockableBase'.  It's just boilerplate.+class (Typeable cls) => MockableBase (cls :: (Type -> Type) -> Constraint) where+  -- | An action that is performed.  This data type will have one constructor+  -- for each method.+  data Action cls :: Symbol -> (Type -> Type) -> Type -> Type++  -- | A specification for matching actions.  The actual arguments should be+  -- replaced with predicates.+  data Matcher cls :: Symbol -> (Type -> Type) -> Type -> Type++  -- | Gets a text description of an 'Action', for use in error messages.+  showAction :: Action cls name m a -> String++  -- | Gets a text description of a 'Matcher', for use in error messages.+  showMatcher :: Maybe (Action cls name m a) -> Matcher cls name m b -> String++  -- | Attempts to match an 'Action' with a 'Matcher'.+  matchAction :: Matcher cls name m a -> Action cls name m a -> MatchResult++-- | A class for 'Monad' subclasses whose methods can be mocked.  This class+-- augments 'MockableBase' with a setup method that is run before HMock touches+-- the 'Monad' subclass for the first time.  The default implementation does+-- nothing, but you can derive your own instances that add setup behavior.+class MockableBase cls => Mockable (cls :: (Type -> Type) -> Constraint) where+  -- An action to run and set up defaults for this class.  The action will be+  -- run before HMock touches the class, either to add expectations or to+  -- delegate a method.+  --+  -- By default, unexpected actions throw errors, and actions with no explicit+  -- default always return the default value of their return type, or+  -- 'undefined' if there is none.  You can change this on a per-class or+  -- per-test basis.+  --+  -- * To change defaults on a per-class basis, you should use+  --   'Test.HMock.MockT.allowUnexpected' and/or 'Test.HMock.MockT.byDefault'+  --   to perform the setup you need here.+  -- * To change defaults on a per-test basis, you should use+  --   'Test.HMock.MockT.allowUnexpected' and/or 'Test.HMock.MockT.byDefault'+  --   directly from the test.+  setupMockable :: (MonadIO m, Typeable m) => proxy cls -> MockSetup m ()+  setupMockable _ = return ()

@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | This module provides the basic vocabulary for talking about multiplicity,+-- which is the number of times something is allowed to happen.  Multiplicities+-- can be any range of natural numbers, with or without an upper bound.+module Test.HMock.Multiplicity+  ( Multiplicity,+    meetsMultiplicity,+    feasible,+    once,+    anyMultiplicity,+    atLeast,+    atMost,+    between,+  )+where++-- | An acceptable range of number of times for something to happen.+--+-- A multiplicity can have a lower and an upper bound.+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"++-- | A 'Multiplicity' value representing inconsistent expectations.+infeasible :: Multiplicity+infeasible = Multiplicity 0 (Just (-1))++-- | This is an incomplete instance, provided for convenience.+--+-- >>> meetsMultiplicity 5 4+-- False+-- >>> meetsMultiplicity 5 5+-- True+-- >>> between 4 6 - between 1 2+-- 2 to 5 times+instance Num Multiplicity where+  fromInteger n+    | n < 0 = infeasible+    | otherwise =+      normalize $+        Multiplicity (fromInteger n) (Just (fromInteger n))++  m1@(Multiplicity a b) + m2@(Multiplicity c d)+    | feasible m1 && feasible m2 =+      normalize $ Multiplicity (a + c) ((+) <$> b <*> d)+    | otherwise = infeasible++  m1@(Multiplicity a b) - m2@(Multiplicity c d)+    | feasible m1 && feasible m2 =+      normalize $ Multiplicity (maybe 0 (a -) d) (subtract c <$> b)+    | otherwise = infeasible++  (*) = error "Multiplicities are not closed under multiplication"++  abs = id++  signum (Multiplicity 0 (Just 0)) = 0+  signum _ = 1++normalize :: Multiplicity -> Multiplicity+normalize (Multiplicity a b) = Multiplicity (max a 0) b++-- | Checks whether a certain number satisfies the 'Multiplicity'.+meetsMultiplicity :: Multiplicity -> Int -> Bool+meetsMultiplicity (Multiplicity lo mbhi) n+  | n < lo = False+  | Just hi <- mbhi, n > hi = False+  | otherwise = True++-- | A 'Multiplicity' that means exactly once.+--+-- >>> meetsMultiplicity once 0+-- False+-- >>> meetsMultiplicity once 1+-- True+-- >>> meetsMultiplicity once 2+-- False+once :: Multiplicity+once = 1++-- | A 'Multiplicity' that means any number of times.+-- >>> meetsMultiplicity anyMultiplicity 0+-- True+-- >>> meetsMultiplicity anyMultiplicity 1+-- True+-- >>> meetsMultiplicity anyMultiplicity 10+-- True+anyMultiplicity :: Multiplicity+anyMultiplicity = atLeast 0++-- | A 'Multiplicity' that means at least this many times.+--+-- >>> meetsMultiplicity (atLeast 2) 1+-- False+-- >>> meetsMultiplicity (atLeast 2) 2+-- True+-- >>> meetsMultiplicity (atLeast 2) 3+-- True+atLeast :: Multiplicity -> Multiplicity+atLeast (Multiplicity n _) = Multiplicity n Nothing++-- | A 'Multiplicity' that means at most this many times.+--+-- >>> meetsMultiplicity (atMost 2) 1+-- True+-- >>> meetsMultiplicity (atMost 2) 2+-- True+-- >>> meetsMultiplicity (atMost 2) 3+-- False+atMost :: Multiplicity -> Multiplicity+atMost (Multiplicity _ n) = 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+-- @'between' n n@ is equivalent to @n@.+--+-- >>> meetsMultiplicity (between 2 3) 1+-- False+-- >>> meetsMultiplicity (between 2 3) 2+-- True+-- >>> meetsMultiplicity (between 2 3) 3+-- True+-- >>> meetsMultiplicity (between 2 3) 4+-- False+between :: Multiplicity -> Multiplicity -> Multiplicity+between (Multiplicity m _) (Multiplicity _ n) = Multiplicity m n++-- | Checks whether a 'Multiplicity' is capable of matching any number at all.+--+-- >>> feasible once+-- True+-- >>> feasible 0+-- True+-- >>> feasible (once - 2)+-- False+feasible :: Multiplicity -> Bool+feasible (Multiplicity a b) = maybe True (>= a) b

@@ -0,0 +1,980 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module defines 'Predicate's which you can use to match the arguments of+-- a method in your execution plan.+module Test.HMock.Predicates+  ( Predicate (..),+    anything,+    eq,+    neq,+    gt,+    geq,+    lt,+    leq,+    just,+    left,+    right,+    zipP,+    zip3P,+    zip4P,+    zip5P,+    andP,+    orP,+    notP,+    startsWith,+    endsWith,+    hasSubstr,+    hasSubsequence,+    caseInsensitive,+    matchesRegex,+    matchesCaseInsensitiveRegex,+    containsRegex,+    containsCaseInsensitiveRegex,+    isEmpty,+    nonEmpty,+    sizeIs,+    elemsAre,+    unorderedElemsAre,+    each,+    contains,+    containsAll,+    containsOnly,+    containsKey,+    containsEntry,+    keysAre,+    entriesAre,+    approxEq,+    finite,+    infinite,+    nAn,+    is,+    qIs,+    with,+    qWith,+    qMatch,+    typed,+  )+where++import Data.Char (toUpper)+import Data.Maybe (isJust)+import Data.MonoTraversable+import qualified Data.Sequences as Seq+import Data.Typeable (Proxy (..), Typeable, cast, typeRep)+import GHC.Exts (IsList (Item, toList))+import GHC.Stack (HasCallStack, callStack)+import Language.Haskell.TH (ExpQ, PatQ, pprint)+import Language.Haskell.TH.Syntax (lift)+import Test.HMock.Internal.TH (removeModNames)+import Test.HMock.Internal.Util (choices, isSubsequenceOf, locate, withLoc)+import Text.Regex.TDFA hiding (match)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XTypeApplications+-- >>> :set -Wno-type-defaults++-- | A predicate, which tests values and either accepts or rejects them.  This+-- is similar to @a -> 'Bool'@, but also has a 'Show' instance to describe what+-- it is checking.+--+-- 'Predicate's are used to define which arguments a general matcher should+-- accept.+data Predicate a = Predicate+  { showPredicate :: String,+    accept :: a -> Bool+  }++instance Show (Predicate a) where show = showPredicate++-- | A 'Predicate' that accepts anything at all.+--+-- >>> accept anything "foo"+-- True+-- >>> accept anything undefined+-- True+anything :: Predicate a+anything =+  Predicate+    { showPredicate = "anything",+      accept = const True+    }++-- | A 'Predicate' that accepts only the given value.+--+-- >>> accept (eq "foo") "foo"+-- True+-- >>> accept (eq "foo") "bar"+-- False+eq :: (Show a, Eq a) => a -> Predicate a+eq x =+  Predicate+    { showPredicate = show x,+      accept = (== x)+    }++-- | A 'Predicate' that accepts anything but the given value.+--+-- >>> accept (neq "foo") "foo"+-- False+-- >>> accept (neq "foo") "bar"+-- True+neq :: (Show a, Eq a) => a -> Predicate a+neq x =+  Predicate+    { showPredicate = "≠ " ++ show x,+      accept = (/= x)+    }++-- | A 'Predicate' that accepts anything greater than the given value.+--+-- >>> accept (gt 5) 4+-- False+-- >>> accept (gt 5) 5+-- False+-- >>> accept (gt 5) 6+-- True+gt :: (Show a, Ord a) => a -> Predicate a+gt x =+  Predicate+    { showPredicate = "> " ++ show x,+      accept = (> x)+    }++-- | A 'Predicate' that accepts anything greater than or equal to the given+-- value.+--+-- >>> accept (geq 5) 4+-- False+-- >>> accept (geq 5) 5+-- True+-- >>> accept (geq 5) 6+-- True+geq :: (Show a, Ord a) => a -> Predicate a+geq x =+  Predicate+    { showPredicate = "≥ " ++ show x,+      accept = (>= x)+    }++-- | A 'Predicate' that accepts anything less than the given value.+--+-- >>> accept (lt 5) 4+-- True+-- >>> accept (lt 5) 5+-- False+-- >>> accept (lt 5) 6+-- False+lt :: (Show a, Ord a) => a -> Predicate a+lt x =+  Predicate+    { showPredicate = "< " ++ show x,+      accept = (< x)+    }++-- | A 'Predicate' that accepts anything less than or equal to the given value.+--+-- >>> accept (leq 5) 4+-- True+-- >>> accept (leq 5) 5+-- True+-- >>> accept (leq 5) 6+-- False+leq :: (Show a, Ord a) => a -> Predicate a+leq x =+  Predicate+    { showPredicate = "≤ " ++ show x,+      accept = (<= x)+    }++-- | A 'Predicate' that accepts 'Maybe' values of @'Just' x@, where @x@ matches+-- the given child 'Predicate'.+--+-- >>> accept (just (eq "value")) Nothing+-- False+-- >>> accept (just (eq "value")) (Just "value")+-- True+-- >>> accept (just (eq "value")) (Just "wrong value")+-- False+just :: Predicate a -> Predicate (Maybe a)+just p =+  Predicate+    { showPredicate = "Just (" ++ showPredicate p ++ ")",+      accept = \case Just x -> accept p x; _ -> False+    }++-- | A 'Predicate' that accepts an 'Either' value of @'Left' x@, where @x@+-- matches the given child 'Predicate'.+--+-- >>> accept (left (eq "value")) (Left "value")+-- True+-- >>> accept (left (eq "value")) (Right "value")+-- False+-- >>> accept (left (eq "value")) (Left "wrong value")+-- False+left :: Predicate a -> Predicate (Either a b)+left p =+  Predicate+    { showPredicate = "Left (" ++ showPredicate p ++ ")",+      accept = \case Left x -> accept p x; _ -> False+    }++-- | A 'Predicate' that accepts an 'Either' value of @'Right' x@, where @x@+-- matches the given child 'Predicate'.+--+-- >>> accept (right (eq "value")) (Right "value")+-- True+-- >>> accept (right (eq "value")) (Right "wrong value")+-- False+-- >>> accept (right (eq "value")) (Left "value")+-- False+right :: Predicate b -> Predicate (Either a b)+right p =+  Predicate+    { showPredicate = "Right (" ++ showPredicate p ++ ")",+      accept = \case Right x -> accept p x; _ -> False+    }++-- | A 'Predicate' that accepts pairs whose elements satisfy the corresponding+-- child 'Predicate's.+--+-- >>> accept (zipP (eq "foo") (eq "bar")) ("foo", "bar")+-- True+-- >>> accept (zipP (eq "foo") (eq "bar")) ("bar", "foo")+-- False+zipP :: Predicate a -> Predicate b -> Predicate (a, b)+zipP p q =+  Predicate+    { showPredicate = show (p, q),+      accept = \(x, y) -> accept p x && accept q y+    }++-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the+-- corresponding child 'Predicate's.+--+-- >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux")+-- True+-- >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo")+-- False+zip3P :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)+zip3P p1 p2 p3 =+  Predicate+    { showPredicate = show (p1, p2, p3),+      accept = \(x1, x2, x3) -> accept p1 x1 && accept p2 x2 && accept p3 x3+    }++-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the+-- corresponding child 'Predicate's.+--+-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4)+-- True+-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1)+-- False+zip4P ::+  Predicate a ->+  Predicate b ->+  Predicate c ->+  Predicate d ->+  Predicate (a, b, c, d)+zip4P p1 p2 p3 p4 =+  Predicate+    { showPredicate = show (p1, p2, p3, p4),+      accept = \(x1, x2, x3, x4) ->+        accept p1 x1 && accept p2 x2 && accept p3 x3 && accept p4 x4+    }++-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the+-- corresponding child 'Predicate's.+--+-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5)+-- True+-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1)+-- False+zip5P ::+  Predicate a ->+  Predicate b ->+  Predicate c ->+  Predicate d ->+  Predicate e ->+  Predicate (a, b, c, d, e)+zip5P p1 p2 p3 p4 p5 =+  Predicate+    { showPredicate = show (p1, p2, p3, p4, p5),+      accept = \(x1, x2, x3, x4, x5) ->+        accept p1 x1 && accept p2 x2 && accept p3 x3 && accept p4 x4+          && accept p5 x5+    }++-- | A 'Predicate' that accepts anything accepted by both of its children.+--+-- >>> accept (lt "foo" `andP` gt "bar") "eta"+-- True+-- >>> accept (lt "foo" `andP` gt "bar") "quz"+-- False+-- >>> accept (lt "foo" `andP` gt "bar") "alpha"+-- False+andP :: Predicate a -> Predicate a -> Predicate a+p `andP` q =+  Predicate+    { showPredicate = showPredicate p ++ " and " ++ showPredicate q,+      accept = \x -> accept p x && accept q x+    }++-- | A 'Predicate' that accepts anything accepted by either of its children.+--+-- >>> accept (lt "bar" `orP` gt "foo") "eta"+-- False+-- >>> accept (lt "bar" `orP` gt "foo") "quz"+-- True+-- >>> accept (lt "bar" `orP` gt "foo") "alpha"+-- True+orP :: Predicate a -> Predicate a -> Predicate a+p `orP` q =+  Predicate+    { showPredicate = showPredicate p ++ " or " ++ showPredicate q,+      accept = \x -> accept p x || accept q x+    }++-- | A 'Predicate' that inverts another 'Predicate', accepting whatever its+-- child rejects, and rejecting whatever its child accepts.+--+-- >>> accept (notP (eq "negative")) "positive"+-- True+-- >>> accept (notP (eq "negative")) "negative"+-- False+notP :: Predicate a -> Predicate a+notP p =+  Predicate+    { showPredicate = "not " ++ showPredicate p,+      accept = not . accept p+    }++-- | A 'Predicate' that accepts sequences that start with the given prefix.+--+-- >>> accept (startsWith "fun") "fungible"+-- True+-- >>> accept (startsWith "gib") "fungible"+-- False+startsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t+startsWith pfx =+  Predicate+    { showPredicate = "starts with " ++ show pfx,+      accept = (pfx `Seq.isPrefixOf`)+    }++-- | A 'Predicate' that accepts sequences that end with the given suffix.+--+-- >>> accept (endsWith "ow") "crossbow"+-- True+-- >>> accept (endsWith "ow") "trebuchet"+-- False+endsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t+endsWith sfx =+  Predicate+    { showPredicate = "ends with " ++ show sfx,+      accept = (sfx `Seq.isSuffixOf`)+    }++-- | A 'Predicate' that accepts sequences that contain the given (consecutive)+-- substring.+--+-- >>> accept (hasSubstr "i") "team"+-- False+-- >>> accept (hasSubstr "i") "partnership"+-- True+hasSubstr :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t+hasSubstr s =+  Predicate+    { showPredicate = "has substring " ++ show s,+      accept = (s `Seq.isInfixOf`)+    }++-- | A 'Predicate' that accepts sequences that contain the given (not+-- necessarily consecutive) subsequence.+--+-- >>> accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5]+-- True+-- >>> accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0]+-- True+-- >>> accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11]+-- False+hasSubsequence :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t+hasSubsequence s =+  Predicate+    { showPredicate = "has subsequence " ++ show s,+      accept = (s `isSubsequenceOf`)+    }++-- | Transforms a 'Predicate' on 'String's or string-like types to match without+-- regard to case.+--+-- >>> accept (caseInsensitive startsWith "foo") "FOOTBALL!"+-- True+-- >>> accept (caseInsensitive endsWith "ball") "soccer"+-- False+-- >>> accept (caseInsensitive eq "time") "TIME"+-- True+-- >>> accept (caseInsensitive gt "NOTHING") "everything"+-- False+caseInsensitive ::+  ( MonoFunctor t,+    MonoFunctor a,+    Element t ~ Char,+    Element a ~ Char+  ) =>+  (t -> Predicate a) ->+  (t -> Predicate a)+caseInsensitive p s =+  Predicate+    { showPredicate = "(case insensitive) " ++ show (p s),+      accept = accept capP . omap toUpper+    }+  where+    capP = p (omap toUpper s)++-- | A 'Predicate' that accepts 'String's or string-like values matching a+-- regular expression.  The expression must match the entire argument.+--+-- You should not use @'caseInsensitive' 'matchesRegex'@, because regular+-- expression syntax itself is still case-sensitive even when the text you are+-- matching is not.  Instead, use 'matchesCaseInsensitiveRegex'.+--+-- >>> accept (matchesRegex "x{2,5}y?") "xxxy"+-- True+-- >>> accept (matchesRegex "x{2,5}y?") "xyy"+-- False+-- >>> accept (matchesRegex "x{2,5}y?") "wxxxyz"+-- False+matchesRegex :: (RegexLike Regex a, Eq a) => String -> Predicate a+matchesRegex s =+  Predicate+    { showPredicate = "/" ++ init (tail $ show s) ++ "/",+      accept = \x -> case matchOnceText r x of+        Just (a, _, b) -> a == empty && b == empty+        Nothing -> False+    }+  where+    r = makeRegexOpts comp exec s :: Regex+    comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True}+    exec = defaultExecOpt {captureGroups = False}++-- | A 'Predicate' that accepts 'String's or string-like values matching a+-- regular expression in a case-insensitive way.  The expression must match the+-- entire argument.+--+-- You should use this instead of @'caseInsensitive' 'matchesRegex'@, because+-- regular expression syntax itself is still case-sensitive even when the text+-- you are matching is not.+--+-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY"+-- True+-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY"+-- False+-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ"+-- False+matchesCaseInsensitiveRegex ::+  (RegexLike Regex a, Eq a) => String -> Predicate a+matchesCaseInsensitiveRegex s =+  Predicate+    { showPredicate = "/" ++ init (tail $ show s) ++ "/i",+      accept = \x -> case matchOnceText r x of+        Just (a, _, b) -> a == empty && b == empty+        Nothing -> False+    }+  where+    r = makeRegexOpts comp exec s :: Regex+    comp =+      defaultCompOpt+        { newSyntax = True,+          lastStarGreedy = True,+          caseSensitive = False+        }+    exec = defaultExecOpt {captureGroups = False}++-- | A 'Predicate' that accepts 'String's or string-like values containing a+-- match for a regular expression.  The expression need not match the entire+-- argument.+--+-- You should not use @'caseInsensitive' 'containsRegex'@, because regular+-- expression syntax itself is still case-sensitive even when the text you are+-- matching is not.  Instead, use 'containsCaseInsensitiveRegex'.+--+-- >>> accept (containsRegex "x{2,5}y?") "xxxy"+-- True+-- >>> accept (containsRegex "x{2,5}y?") "xyy"+-- False+-- >>> accept (containsRegex "x{2,5}y?") "wxxxyz"+-- True+containsRegex :: (RegexLike Regex a, Eq a) => String -> Predicate a+containsRegex s =+  Predicate+    { showPredicate = "contains /" ++ init (tail $ show s) ++ "/",+      accept = isJust . matchOnce r+    }+  where+    r = makeRegexOpts comp exec s :: Regex+    comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True}+    exec = defaultExecOpt {captureGroups = False}++-- | A 'Predicate' that accepts 'String's or string-like values containing a+-- match for a regular expression in a case-insensitive way.  The expression+-- need match the entire argument.+--+-- You should use this instead of @'caseInsensitive' 'containsRegex'@, because+-- regular expression syntax itself is still case-sensitive even when the text+-- you are matching is not.+--+-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY"+-- True+-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY"+-- False+-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ"+-- True+containsCaseInsensitiveRegex ::+  (RegexLike Regex a, Eq a) => String -> Predicate a+containsCaseInsensitiveRegex s =+  Predicate+    { showPredicate = "contains /" ++ init (tail $ show s) ++ "/i",+      accept = isJust . matchOnce r+    }+  where+    r = makeRegexOpts comp exec s :: Regex+    comp =+      defaultCompOpt+        { newSyntax = True,+          lastStarGreedy = True,+          caseSensitive = False+        }+    exec = defaultExecOpt {captureGroups = False}++-- | A 'Predicate' that accepts empty data structures.+--+-- >>> accept isEmpty []+-- True+-- >>> accept isEmpty [1, 2, 3]+-- False+-- >>> accept isEmpty ""+-- True+-- >>> accept isEmpty "gas tank"+-- False+isEmpty :: MonoFoldable t => Predicate t+isEmpty =+  Predicate+    { showPredicate = "empty",+      accept = onull+    }++-- | A 'Predicate' that accepts non-empty data structures.+--+-- >>> accept nonEmpty []+-- False+-- >>> accept nonEmpty [1, 2, 3]+-- True+-- >>> accept nonEmpty ""+-- False+-- >>> accept nonEmpty "gas tank"+-- True+nonEmpty :: MonoFoldable t => Predicate t+nonEmpty =+  Predicate+    { showPredicate = "nonempty",+      accept = not . onull+    }++-- | A 'Predicate' that accepts data structures whose number of elements match+-- the child 'Predicate'.+--+-- >>> accept (sizeIs (lt 3)) ['a' .. 'f']+-- False+-- >>> accept (sizeIs (lt 3)) ['a' .. 'b']+-- True+sizeIs :: MonoFoldable t => Predicate Int -> Predicate t+sizeIs p =+  Predicate+    { showPredicate = "size " ++ showPredicate p,+      accept = accept p . olength+    }++-- | A 'Predicate' that accepts data structures whose contents each match the+-- corresponding 'Predicate' in the given list, in the same order.+--+-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4]+-- True+-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5]+-- False+-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4]+-- False+elemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+elemsAre ps =+  Predicate+    { showPredicate = show ps,+      accept = \xs ->+        olength xs == olength ps+          && and (zipWith accept ps (otoList xs))+    }++-- | A 'Predicate' that accepts data structures whose contents each match the+-- corresponding 'Predicate' in the given list, in any order.+--+-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3]+-- True+-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1]+-- True+-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4]+-- False+-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3]+-- False+unorderedElemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+unorderedElemsAre ps =+  Predicate+    { showPredicate =+        "(any order) " ++ show ps,+      accept = matches ps . otoList+    }+  where+    matches (q : qs) xs = or [matches qs ys | (y, ys) <- choices xs, accept q y]+    matches [] xs = null xs++-- | A 'Predicate' that accepts data structures whose elements each match the+-- child 'Predicate'.+--+-- >>> accept (each (gt 5)) [4, 5, 6]+-- False+-- >>> accept (each (gt 5)) [6, 7, 8]+-- True+-- >>> accept (each (gt 5)) []+-- True+each :: MonoFoldable t => Predicate (Element t) -> Predicate t+each p =+  Predicate+    { showPredicate = "each (" ++ showPredicate p ++ ")",+      accept = oall (accept p)+    }++-- | A 'Predicate' that accepts data structures which contain at least one+-- element matching the child 'Predicate'.+--+-- >>> accept (contains (gt 5)) [3, 4, 5]+-- False+-- >>> accept (contains (gt 5)) [4, 5, 6]+-- True+-- >>> accept (contains (gt 5)) []+-- False+contains :: MonoFoldable t => Predicate (Element t) -> Predicate t+contains p =+  Predicate+    { showPredicate = "contains (" ++ showPredicate p ++ ")",+      accept = oany (accept p)+    }++-- | A 'Predicate' that accepts data structures which contain an element+-- satisfying each of the child 'Predicate's.  @'containsAll' [p1, p2, ..., pn]@+-- is equivalent to @'contains' p1 `'andP'` 'contains' p2 `'andP'` ... `'andP'`+-- 'contains' pn@.+--+-- >>> accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"]+-- True+-- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo"]+-- False+-- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"]+-- True+containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+containsAll ps =+  Predicate+    { showPredicate = "contains all of " ++ show ps,+      accept = \xs -> all (flip oany xs . accept) ps+    }++-- | A 'Predicate' that accepts data structures whose elements all satisfy at+-- least one of the child 'Predicate's.  @'containsOnly' [p1, p2, ..., pn]@ is+-- equivalent to @'each' (p1 `'orP'` p2 `'orP'` ... `'orP'` pn)@.+--+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]+-- True+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]+-- True+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]+-- False+containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+containsOnly ps =+  Predicate+    { showPredicate = "contains only " ++ show ps,+      accept = oall (\x -> any (`accept` x) ps)+    }++-- | A 'Predicate' that accepts map-like structures which contain a key matching+-- the child 'Predicate'.+--+-- >>> accept (containsKey (eq "foo")) [("foo", 1), ("bar", 2)]+-- True+-- >>> accept (containsKey (eq "foo")) [("bar", 1), ("qux", 2)]+-- False+containsKey :: (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate t+containsKey p =+  Predicate+    { showPredicate = "contains key " ++ show p,+      accept = \m -> any (accept p) (fst <$> toList m)+    }++-- | A 'Predicate' that accepts map-like structures which contain a key/value+-- pair matched by the given child 'Predicate's (one for the key, and one for+-- the value).+--+-- >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 12), ("bar", 5)]+-- True+-- >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 5), ("bar", 12)]+-- False+-- >>> accept (containsEntry (eq "foo") (gt 10)) [("bar", 12)]+-- False+containsEntry ::+  (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate v -> Predicate t+containsEntry p q =+  Predicate+    { showPredicate = "contains entry " ++ show (p, q),+      accept = any (\(x, y) -> accept p x && accept q y) . toList+    }++-- | A 'Predicate' that accepts map-like structures whose keys are exactly those+-- matched by the given list of 'Predicate's, in any order.+--+-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("b", 2), ("c", 3)]+-- True+-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("c", 1), ("b", 2), ("a", 3)]+-- True+-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("c", 3)]+-- False+-- >>> accept (keysAre [eq "a", eq "b"]) [("a", 1), ("b", 2), ("c", 3)]+-- False+keysAre ::+  (IsList t, Item t ~ (k, v)) => [Predicate k] -> Predicate t+keysAre ps =+  Predicate+    { showPredicate = "keys are " ++ show ps,+      accept = matches ps . map fst . toList+    }+  where+    matches (q : qs) xs = or [matches qs ys | (y, ys) <- choices xs, accept q y]+    matches [] xs = null xs++-- | A 'Predicate' that accepts map-like structures whose entries are exactly+-- those matched by the given list of 'Predicate' pairs, in any order.+--+-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4)]+-- True+-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(3, 4), (1, 2)]+-- True+-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 4), (3, 2)]+-- False+-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4), (5, 6)]+-- False+entriesAre ::+  (IsList t, Item t ~ (k, v)) => [(Predicate k, Predicate v)] -> Predicate t+entriesAre ps =+  Predicate+    { showPredicate = "entries are " ++ show ps,+      accept = matches ps . toList+    }+  where+    matches ((p, q) : pqs) xs =+      or [matches pqs ys | ((k, v), ys) <- choices xs, accept p k, accept q v]+    matches [] xs = null xs++-- | A 'Predicate' that accepts values of 'RealFloat' types that are close to+-- the given number.  The expected precision is scaled based on the target+-- value, so that reasonable rounding error is accepted but grossly inaccurate+-- results are not.+--+-- The following naive use of 'eq' fails due to rounding:+--+-- >>> accept (eq 1.0) (sum (replicate 100 0.01))+-- False+--+-- The solution is to use 'approxEq', which accounts for rounding error.+-- However, 'approxEq' doesn't accept results that are far enough off that they+-- likely arise from incorrect calculations instead of rounding error.+--+-- >>> accept (approxEq 1.0) (sum (replicate 100 0.01))+-- True+-- >>> accept (approxEq 1.0) (sum (replicate 100 0.009999))+-- False+approxEq :: (RealFloat a, Show a) => a -> Predicate a+approxEq x =+  Predicate+    { showPredicate = "≈ " ++ show x,+      accept = \y -> abs (x - y) < diff+    }+  where+    diff = encodeFloat 1 (snd (decodeFloat x) + floatDigits x `div` 2)++-- | A 'Predicate' that accepts finite numbers of any 'RealFloat' type.+--+-- >>> accept finite 1.0+-- True+-- >>> accept finite (0 / 0)+-- False+-- >>> accept finite (1 / 0)+-- False+finite :: RealFloat a => Predicate a+finite =+  Predicate+    { showPredicate = "finite",+      accept = \x -> not (isInfinite x) && not (isNaN x)+    }++-- | A 'Predicate' that accepts infinite numbers of any 'RealFloat' type.+--+-- >>> accept infinite 1.0+-- False+-- >>> accept infinite (0 / 0)+-- False+-- >>> accept infinite (1 / 0)+-- True+infinite :: RealFloat a => Predicate a+infinite =+  Predicate+    { showPredicate = "infinite",+      accept = isInfinite+    }++-- | A 'Predicate' that accepts NaN values of any 'RealFloat' type.+--+-- >>> accept nAn 1.0+-- False+-- >>> accept nAn (0 / 0)+-- True+-- >>> accept nAn (1 / 0)+-- False+nAn :: RealFloat a => Predicate a+nAn =+  Predicate+    { showPredicate = "NaN",+      accept = isNaN+    }++-- | A conversion from @a -> 'Bool'@ to 'Predicate'.  This is a fallback that+-- can be used to build a 'Predicate' that checks anything at all.  However, its+-- description will be less helpful than standard 'Predicate's.+--+-- >>> accept (is even) 3+-- False+-- >>> accept (is even) 4+-- True+is :: HasCallStack => (a -> Bool) -> Predicate a+is f =+  Predicate+    { showPredicate = withLoc (locate callStack "custom predicate"),+      accept = f+    }++-- | A Template Haskell splice that acts like 'is', but receives a quoted+-- expression at compile time and has a more helpful description for error+-- messages.+--+-- >>> accept $(qIs [| even |]) 3+-- False+-- >>> accept $(qIs [| even |]) 4+-- True+--+-- >>> show $(qIs [| even |])+-- "even"+qIs :: HasCallStack => ExpQ -> ExpQ+qIs f =+  [|+    Predicate+      { showPredicate = $(lift . pprint . removeModNames =<< f),+        accept = $f+      }+    |]++-- | A combinator to lift a 'Predicate' to work on a property or computed value+-- of the original value.+--+-- >>> accept (with abs (gt 5)) (-6)+-- True+-- >>> accept (with abs (gt 5)) (-5)+-- False+-- >>> accept (with reverse (eq "olleh")) "hello"+-- True+-- >>> accept (with reverse (eq "olleh")) "goodbye"+-- False+with :: HasCallStack => (a -> b) -> Predicate b -> Predicate a+with f p =+  Predicate+    { showPredicate =+        withLoc (locate callStack "property") ++ ": " ++ show p,+      accept = accept p . f+    }++-- | A Template Haskell splice that acts like 'is', but receives a quoted typed+-- expression at compile time and has a more helpful description for error+-- messages.+--+-- >>> accept ($(qWith [| abs |]) (gt 5)) (-6)+-- True+-- >>> accept ($(qWith [| abs |]) (gt 5)) (-5)+-- False+-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "hello"+-- True+-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye"+-- False+--+-- >>> show ($(qWith [| abs |]) (gt 5))+-- "abs: > 5"+qWith :: ExpQ -> ExpQ+qWith f =+  [|+    \p ->+      Predicate+        { showPredicate =+            $(lift . pprint . removeModNames =<< f) ++ ": " ++ show p,+          accept = accept p . $f+        }+    |]++-- | A Template Haskell splice that turns a quoted pattern into a predicate that+-- accepts values that match the pattern.+--+-- >>> accept $(qMatch [p| Just (Left _) |]) Nothing+-- False+-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Left 5))+-- True+-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Right 5))+-- False+--+-- >>> show $(qMatch [p| Just (Left _) |])+-- "Just (Left _)"+qMatch :: PatQ -> ExpQ+qMatch qpat =+  [|+    Predicate+      { showPredicate = $(lift . pprint . removeModNames =<< qpat),+        accept = \case+          $(qpat) -> True+          _ -> False+      }+    |]++-- | Converts a 'Predicate' to a new type.  Typically used with visible type+-- application, as in the examples below.+--+-- >>> accept (typed @String anything) "foo"+-- True+-- >>> accept (typed @String (sizeIs (gt 5))) "foo"+-- False+-- >>> accept (typed @String anything) (42 :: Int)+-- False+typed :: forall a b. (Typeable a, Typeable b) => Predicate a -> Predicate b+typed p =+  Predicate+    { showPredicate =+        showPredicate p ++ " :: " ++ show (typeRep (Proxy :: Proxy a)),+      accept = \x -> case cast x of+        Nothing -> False+        Just y -> accept p y+    }

@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | This module defines the 'Rule' type, which describes a matcher for methods+-- and a possibly-empty list of responses to use for successive calls to+-- 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++import Test.HMock.Internal.Rule (Rule (..))+import {-# SOURCE #-} Test.HMock.Internal.State (MockT)+import Test.HMock.Mockable (MockableBase (Action, Matcher))++-- | Class for things that can be expected.  This is includes 'Rule's, but also+-- bare 'Matcher's and 'Action's with no explicit response.+class Expectable cls name m r ex | ex -> cls name m r where+  -- | Converts an expectable to a Rule that means the same thing.+  toRule :: ex -> Rule cls name m r++-- | Attaches a response to an expectation.  This is a flexible response,+-- which can look at arguments, do things in the base monad, set up more+-- expectations, etc.  A matching 'Action' is passed to the response.+(|=>) ::+  Expectable cls name m r ex =>+  ex ->+  (Action cls name m r -> MockT m r) ->+  Rule cls name m r+e |=> r = m :=> (rs ++ [r]) where m :=> rs = toRule e++infixl 1 |=>++-- | Attaches a return value to an expectation.  This is more convenient than+-- '|=>' in the common case where you just want to return a known result.+-- @e '|->' r@ means the same thing as @e '|=>' 'const' ('return' r)@.+(|->) ::+  (Monad m, Expectable cls name m r ex) =>+  ex ->+  r ->+  Rule cls name m r+m |-> r = m |=> const (return r)++infixl 1 |->++instance Expectable cls name m r (Rule cls name m r) where+  toRule = id++instance Expectable cls name m r (Matcher cls name m r) where+  toRule m = m :=> []

@@ -1,40 +1,714 @@-{- |--This module provides Template Haskell splices that can be used to derive-boilerplate instances for HMock.--There are 12 splices described here, based on all combinations of three choices:--* Whether to generate a 'Test.HMock.Mockable' instance, an instance for-  'Test.HMock.MockT', or both.-* Whether the argument is a class name, or a type which may be partially applied-  to concrete arguments.-* Whether options are passed to customize the behavior.--}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} +-- | This module provides Template Haskell splices that can be used to derive+-- boilerplate instances for HMock.+--+-- There are 20 splices described here, based on combinations of four+-- choices:+--+-- * Whether to generate a 'Test.HMock.MockableBase', an instance for+--   'Test.HMock.MockT', or both.+-- * When generating 'Test.HMock.MockableBase', whether to also generate a+--   'Test.HMock.Mockable' instance with an empty setup.+-- * Whether the argument is a class name, or a type which may be partially+--   applied to concrete arguments.+-- * Whether options are passed to customize the behavior. module Test.HMock.TH-  ( makeMockable,-    makeMockableWithOptions,-    makeMockableBase,-    makeMockableBaseWithOptions,-    deriveMockable,-    deriveMockableWithOptions,-    deriveMockableBase,-    deriveMockableBaseWithOptions,-    deriveForMockT,-    deriveForMockTWithOptions,+  ( MockableOptions (..),+    makeMockable,     makeMockableType,+    makeMockableWithOptions,     makeMockableTypeWithOptions,+    makeMockableBase,     makeMockableBaseType,+    makeMockableBaseWithOptions,     makeMockableBaseTypeWithOptions,+    deriveMockable,     deriveMockableType,+    deriveMockableWithOptions,     deriveMockableTypeWithOptions,+    deriveMockableBase,     deriveMockableBaseType,+    deriveMockableBaseWithOptions,     deriveMockableBaseTypeWithOptions,+    deriveForMockT,     deriveTypeForMockT,+    deriveForMockTWithOptions,     deriveTypeForMockTWithOptions,-    MockableOptions (..),   ) where +import Control.Monad (replicateM, unless, when, zipWithM)+import Control.Monad.Extra (concatMapM)+import Control.Monad.Trans (MonadIO)+import Data.Bool (bool)+import Data.Char (toUpper)+import Data.Default (Default (..))+import Data.Either (partitionEithers)+import qualified Data.Kind+import Data.List (foldl', (\\))+import Data.Typeable (Typeable)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (Symbol)+import Language.Haskell.TH hiding (Match, match)+import Language.Haskell.TH.Syntax (Lift (lift)) import Test.HMock.Internal.TH+import Test.HMock.MockT (MockT)+import Test.HMock.MockMethod (mockMethod, mockDefaultlessMethod)+import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..))+import Test.HMock.Predicates (Predicate (..), eq)+import Test.HMock.Rule (Expectable (..))++-- | Custom options for deriving a 'Mockable' class.+data MockableOptions = MockableOptions+  { -- | Suffix to add to 'Action' and 'Matcher' names.  Defaults to @""@.+    mockSuffix :: String,+    -- | Whether to warn about limitations of the generated mocks.  This is+    -- mostly useful temporarily for finding out why generated code doesn't+    -- match your expectations.  Defaults to @'False'@.+    mockVerbose :: Bool+  }++instance Default MockableOptions where+  def = MockableOptions {mockSuffix = "", mockVerbose = False}++-- | Define all instances necessary to use HMock with the given class.+-- Equivalent to both 'deriveMockable' and 'deriveForMockT'.+--+-- If @MyClass@ is a class and @myMethod@ is one of its methods, then+-- @'makeMockable' MyClass@ generates all of the following:+--+-- If @MyClass@ is a class and @myMethod@ is one of its methods, then+-- @'makeMockable' MyClass@ generates everything generated by+-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.+makeMockable :: Name -> Q [Dec]+makeMockable = makeMockableType . conT++-- | Define all instances necessary to use HMock with the given constraint type,+-- which should be a class applied to zero or more type arguments.  Equivalent+-- to both 'deriveMockableType' and 'deriveTypeForMockT'.+--+-- See 'makeMockable' for a list of what is generated by this splice.+makeMockableType :: Q Type -> Q [Dec]+makeMockableType = makeMockableTypeWithOptions def++-- | Define all instances necessary to use HMock with the given class.  This is+-- like 'makeMockable', but with the ability to specify custom options.+--+-- See 'makeMockable' for a list of what is generated by this splice.+makeMockableWithOptions :: MockableOptions -> Name -> Q [Dec]+makeMockableWithOptions options = makeMockableTypeWithOptions options . conT++-- | Define all instances necessary to use HMock with the given constraint type,+-- which should be a class applied to zero or more type arguments.  This is+-- like 'makeMockableType', but with the ability to specify custom options.+--+-- See 'makeMockable' for a list of what is generated by this splice.+makeMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]+makeMockableTypeWithOptions options qt =+  (++) <$> deriveMockableTypeWithOptions options qt+    <*> deriveTypeForMockTWithOptions options qt++-- | Defines almost all instances necessary to use HMock with the given class.+-- Equivalent to both 'deriveMockableBase' and 'deriveForMockT'.+makeMockableBase :: Name -> Q [Dec]+makeMockableBase = makeMockableBaseType . conT++-- | Defines almost all instances necessary to use HMock with the given+-- constraint type, which should be a class applied to zero or more type+-- arguments.  Equivalent to both 'deriveMockableBaseType' and+-- 'deriveTypeForMockT'.+makeMockableBaseType :: Q Type -> Q [Dec]+makeMockableBaseType = makeMockableBaseTypeWithOptions def++-- | Defines almost all instances necessary to use HMock with the given class.+-- This is like 'makeMockable', but with the ability to specify custom options.+makeMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]+makeMockableBaseWithOptions options =+  makeMockableBaseTypeWithOptions options . conT++-- | Defines almost all instances necessary to use HMock with the given+-- constraint type, which should be a class applied to zero or more type+-- arguments.  This is like 'makeMockableType', but with the ability to specify+-- custom options.+makeMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]+makeMockableBaseTypeWithOptions options qt =+  (++) <$> deriveMockableBaseTypeWithOptions options qt+    <*> deriveTypeForMockTWithOptions options qt++-- | Defines the 'Mockable' instance for the given class.+--+-- If @MyClass@ is a class and @myMethod@ is one of its methods, then+-- @'deriveMockable' MyClass@ generates everything generated by+-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.+deriveMockable :: Name -> Q [Dec]+deriveMockable = deriveMockableType . conT++-- | Defines the 'Mockable' instance for the given constraint type, which should+-- be a class applied to zero or more type arguments.+--+-- See 'deriveMockable' for a list of what is generated by this splice.+deriveMockableType :: Q Type -> Q [Dec]+deriveMockableType = deriveMockableTypeWithOptions def++-- | Defines the 'Mockable' instance for the given class.  This is like+-- 'deriveMockable', but with the ability to specify custom options.+--+-- See 'deriveMockable' for a list of what is generated by this splice.+deriveMockableWithOptions :: MockableOptions -> Name -> Q [Dec]+deriveMockableWithOptions options = deriveMockableTypeWithOptions options . conT++-- | Defines the 'Mockable' instance for the given constraint type, which should+-- be a class applied to zero or more type arguments.  This is like+-- 'deriveMockableType', but with the ability to specify custom options.+--+-- See 'deriveMockable' for a list of what is generated by this splice.+deriveMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]+deriveMockableTypeWithOptions = deriveMockableImpl False++-- | Defines the 'MockableBase' instance for the given class.+--+-- If @MyClass@ is a class and @myMethod@ is one of its methods, then+-- @'deriveMockableBase' MyClass@ generates all of the following:+--+-- * A @'MockableBase' MyClass@ instance.+-- * An associated type @'Action' MyClass@, with a constructor @MyMethod@.+-- * An associated type @'Matcher' MyClass@, with a constructor @MyMethod_@.+-- * An 'Expectable' instance for @'Action' MyClass@ which matches an exact set+--   of arguments, if and only if all of @myMethod@'s arguments have 'Eq' and+--   'Show' instances.+deriveMockableBase :: Name -> Q [Dec]+deriveMockableBase = deriveMockableBaseType . conT++-- | Defines the 'MockableBase' instance for the given constraint type, which+-- should be a class applied to zero or more type arguments.+--+-- See 'deriveMockableBase' for a list of what is generated by this splice.+deriveMockableBaseType :: Q Type -> Q [Dec]+deriveMockableBaseType = deriveMockableBaseTypeWithOptions def++-- | Defines the 'MockableBase' instance for the given class.  This is like+-- 'deriveMockableBase', but with the ability to specify custom options.+--+-- See 'deriveMockableBase' for a list of what is generated by this splice.+deriveMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]+deriveMockableBaseWithOptions options =+  deriveMockableBaseTypeWithOptions options . conT++-- | Defines the 'MockableBase' instance for the given constraint type, which+-- should be a class applied to zero or more type arguments.  This is like+-- 'deriveMockableBaseType', but with the ability to specify custom options.+--+-- See 'deriveMockableBase' for a list of what is generated by this splice.+deriveMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]+deriveMockableBaseTypeWithOptions = deriveMockableImpl True++-- | Defines an instance of the given class for @'MockT' m@, delegating all of+-- its methods to 'mockMethod' to be handled by HMock.+--+-- This may only be used if all members of the class are mockable methods.  If+-- the class contains some unmockable methods, associated types, or other+-- members, you will need to define this instance yourself, delegating the+-- mockable methods as follows:+--+-- @+-- instance MyClass ('MockT' m) where+--   myMethod x y = 'mockMethod' (MyMethod x y)+--   ...+-- @+deriveForMockT :: Name -> Q [Dec]+deriveForMockT = deriveTypeForMockT . conT++-- | Defines an instance of the given constraint type for @'MockT' m@,+-- delegating all of its methods to 'mockMethod' to be handled by HMock.+-- The type should be a class applied to zero or more type arguments.+--+-- See 'deriveForMockT' for restrictions on the use of this splice.+deriveTypeForMockT :: Q Type -> Q [Dec]+deriveTypeForMockT = deriveTypeForMockTWithOptions def++-- | Defines an instance of the given class for @'MockT' m@, delegating all of+-- its methods to 'mockMethod' to be handled by HMock.  This is like+-- 'deriveForMockT', but with the ability to specify custom options.+--+-- See 'deriveForMockT' for restrictions on the use of this splice.+deriveForMockTWithOptions :: MockableOptions -> Name -> Q [Dec]+deriveForMockTWithOptions options = deriveTypeForMockTWithOptions options . conT++-- | Defines an instance of the given constraint type for @'MockT' m@,+-- delegating all of its methods to 'mockMethod' to be handled by HMock.+-- The type should be a class applied to zero or more type arguments.  This is+-- like 'deriveTypeForMockT', but with the ability to specify custom options.+--+-- See 'deriveForMockT' for restrictions on the use of this splice.+deriveTypeForMockTWithOptions :: MockableOptions -> Q Type -> Q [Dec]+deriveTypeForMockTWithOptions = deriveForMockTImpl++data Instance = Instance+  { instType :: Type,+    instRequiredContext :: Cxt,+    instGeneralParams :: [Name],+    instMonadVar :: Name,+    instMethods :: [Method],+    instExtraMembers :: [Dec]+  }+  deriving (Show)++data Method = Method+  { methodName :: Name,+    methodTyVars :: [Name],+    methodCxt :: Cxt,+    methodArgs :: [Type],+    methodResult :: Type+  }+  deriving (Show)++withClass :: Type -> (Dec -> Q a) -> Q a+withClass t f = do+  case unappliedName t of+    Just cls -> do+      info <- reify cls+      case info of+        ClassI dec@ClassD {} _ -> f dec+        _ -> fail $ "Expected " ++ show cls ++ " to be a class, but it wasn't."+    _ -> fail "Expected a class, but got something else."++getInstance :: MockableOptions -> Type -> Q Instance+getInstance options ty = withClass ty go+  where+    go (ClassD _ className [] _ _) =+      fail $ "Class " ++ nameBase className ++ " has no type parameters."+    go (ClassD cx _ params _ members) = matchVars ty [] (tvName <$> params)+      where+        matchVars :: Type -> [Type] -> [Name] -> Q Instance+        matchVars _ _ [] = internalError+        matchVars (AppT _ _) _ [_] =+          fail $ pprint ty ++ " is applied to too many arguments."+        matchVars (AppT a b) ts (_ : ps) =+          checkExt FlexibleInstances >> matchVars a (b : ts) ps+        matchVars _ ts ps = do+          let t = foldl' (\t' v -> AppT t' (VarT v)) ty (init ps)+          let tbl = zip (tvName <$> params) ts+          let cx' = substTypeVars tbl <$> cx+          makeInstance options t cx' tbl (init ps) (last ps) members+    go _ = internalError++makeInstance ::+  MockableOptions ->+  Type ->+  Cxt ->+  [(Name, Type)] ->+  [Name] ->+  Name ->+  [Dec] ->+  Q Instance+makeInstance options ty cx tbl ps m members = do+  processedMembers <- mapM (getMethod ty m tbl) members+  (extraMembers, methods) <-+    partitionEithers <$> zipWithM memberOrMethod members processedMembers+  return $+    Instance+      { instType = ty,+        instRequiredContext = cx,+        instGeneralParams = ps,+        instMonadVar = m,+        instMethods = methods,+        instExtraMembers = extraMembers+      }+  where+    memberOrMethod :: Dec -> Either String Method -> Q (Either Dec Method)+    memberOrMethod dec (Left warning) = do+      when (mockVerbose options) $ reportWarning warning+      return (Left dec)+    memberOrMethod _ (Right method) = return (Right 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)+  return $ do+    let (tvs, cx, argsAndReturn) = splitType simpleTy+    (m', result) <- case last argsAndReturn of+      AppT (VarT m') result -> return (m', result)+      _ ->+        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)+    when (any hasNestedPolyType argTypes) $+      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+        }+getMethod _ _ _ _ = return (Left "A non-value member cannot be mocked.")++isKnownType :: Method -> Type -> Bool+isKnownType method ty = null tyVars && null cx+  where+    (tyVars, cx) =+      relevantContext ty (methodTyVars method, methodCxt method)++withMethodParams :: Instance -> Method -> TypeQ -> TypeQ+withMethodParams inst method t =+  [t|+    $t+      $(pure (instType inst))+      $(litT (strTyLit (nameBase (methodName method))))+      $(varT (instMonadVar inst))+      $(pure (methodResult method))+    |]++deriveMockableImpl :: Bool -> MockableOptions -> Q Type -> Q [Dec]+deriveMockableImpl baseOnly options qt = do+  checkExt DataKinds+  checkExt FlexibleInstances+  checkExt GADTs+  checkExt MultiParamTypeClasses+  checkExt TypeFamilies++  inst <- getInstance options =<< qt++  when (null (instMethods inst)) $ do+    fail $+      "Cannot derive Mockable because " ++ pprint (instType inst)+        ++ " has no mockable methods."++  typeableCxts <- constrainVars [conT ''Typeable] (instGeneralParams inst)++  mockableBase <-+    instanceD+      (pure typeableCxts)+      [t|MockableBase $(pure (instType inst))|]+      [ defineActionType options inst,+        defineMatcherType options inst,+        defineShowAction options (instMethods inst),+        defineShowMatcher options (instMethods inst),+        defineMatchAction options (instMethods inst)+      ]+  mockable <-+    if baseOnly+      then return []+      else+        (: [])+          <$> instanceD+            (pure typeableCxts)+            [t|Mockable $(pure (instType inst))|]+            []+  expectables <- defineExpectableActions options inst++  return $ mockableBase : mockable ++ expectables++defineActionType :: MockableOptions -> Instance -> DecQ+defineActionType options inst = do+  kind <-+    [t|+      Symbol ->+      (Data.Kind.Type -> Data.Kind.Type) ->+      Data.Kind.Type ->+      Data.Kind.Type+      |]+  let cons = actionConstructor options inst <$> instMethods inst+  dataInstD (pure []) ''Action [pure (instType inst)] (Just kind) cons []++actionConstructor :: MockableOptions -> Instance -> Method -> ConQ+actionConstructor options inst method = do+  forallC [] (return (methodCxt method)) $+    gadtC+      [getActionName options method]+      [ return (Bang NoSourceUnpackedness NoSourceStrictness, argTy)+        | argTy <- methodArgs method+      ]+      (withMethodParams inst method [t|Action|])++getActionName :: MockableOptions -> Method -> Name+getActionName options method =+  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options)+  where+    name = nameBase (methodName method)++defineMatcherType :: MockableOptions -> Instance -> Q Dec+defineMatcherType options inst = do+  kind <-+    [t|+      Symbol ->+      (Data.Kind.Type -> Data.Kind.Type) ->+      Data.Kind.Type ->+      Data.Kind.Type+      |]+  let cons = matcherConstructor options inst <$> instMethods inst+  dataInstD (pure []) ''Matcher [pure (instType inst)] (Just kind) cons []++matcherConstructor :: MockableOptions -> Instance -> Method -> ConQ+matcherConstructor options inst method = do+  gadtC+    [getMatcherName options method]+    [ (Bang NoSourceUnpackedness NoSourceStrictness,) <$> mkPredicate argTy+      | argTy <- methodArgs method+    ]+    (withMethodParams inst method [t|Matcher|])+  where+    mkPredicate argTy+      | hasPolyType argTy = do+        checkExt RankNTypes+        v <- newName "t"+        forallT [bindVar v] (pure []) [t|Predicate $(varT v)|]+      | null tyVars && null cx = [t|Predicate $(pure argTy)|]+      | otherwise = do+        checkExt RankNTypes+        forallT (bindVar <$> tyVars) (pure cx) [t|Predicate $(pure argTy)|]+      where+        (tyVars, cx) =+          relevantContext argTy (methodTyVars method, methodCxt method)++getMatcherName :: MockableOptions -> Method -> Name+getMatcherName options method =+  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options ++ "_")+  where+    name = nameBase (methodName method)++defineShowAction :: MockableOptions -> [Method] -> Q Dec+defineShowAction options methods =+  funD 'showAction (showActionClause options <$> methods)++showActionClause :: MockableOptions -> Method -> Q Clause+showActionClause options method = do+  argVars <- replicateM (length (methodArgs method)) (newName "a")+  clause+    [ conP+        (getActionName options method)+        (zipWith argPattern (methodArgs method) argVars)+    ]+    ( normalB+        [|+          unwords+            ( $(lift (nameBase (methodName method))) :+              $(listE (zipWith showArg (methodArgs method) argVars))+            )+          |]+    )+    []+  where+    canShow ty+      | not (null (freeTypeVars ty)) = return False+      | otherwise = isInstance ''Show [ty]+    argPattern ty v = canShow ty >>= bool wildP (varP v)+    showArg ty var =+      canShow ty+        >>= bool+          (lift ("(_ :: " ++ pprint (removeModNames ty) ++ ")"))+          [|showsPrec 11 $(varE var) ""|]++defineShowMatcher :: MockableOptions -> [Method] -> Q Dec+defineShowMatcher options methods = do+  clauses <- concatMapM (showMatcherClauses options) methods+  funD 'showMatcher clauses++showMatcherClauses :: MockableOptions -> Method -> Q [ClauseQ]+showMatcherClauses options method = do+  argTVars <- replicateM (length (methodArgs method)) (newName "t")+  predVars <- replicateM (length (methodArgs method)) (newName "p")+  let actionArgs = zipWith actionArg argTVars (methodArgs method)+  let matcherArgs = varP <$> predVars+  let printedArgs = zipWith3 printedArg predVars argTVars (methodArgs method)+  let polyMatcherArgs = zipWith matcherArg predVars (methodArgs method)+  let printedPolyArgs = zipWith printedPolyArg predVars (methodArgs method)+  let body name args = normalB [|unwords ($(lift name) : $(listE args))|]+  return+    [ clause+        [ conP 'Just [conP (getActionName options method) actionArgs],+          conP (getMatcherName options method) matcherArgs+        ]+        (body (nameBase (methodName method)) printedArgs)+        [],+      clause+        [ conP 'Nothing [],+          conP (getMatcherName options method) polyMatcherArgs+        ]+        (body (nameBase (methodName method)) printedPolyArgs)+        []+    ]+  where+    actionArg t ty+      | isKnownType method ty = wildP+      | otherwise = checkExt ScopedTypeVariables >> sigP wildP (varT t)++    matcherArg p ty+      | isKnownType method ty = varP p+      | otherwise = wildP++    printedArg p t ty+      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]+      | otherwise =+        [|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|]++    printedPolyArg p ty+      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]+      | otherwise = [|"«polymorphic»"|]++defineMatchAction :: MockableOptions -> [Method] -> Q Dec+defineMatchAction options methods =+  funD 'matchAction (matchActionClause options <$> methods)++matchActionClause :: MockableOptions -> Method -> Q Clause+matchActionClause options method = do+  argVars <-+    replicateM+      (length (methodArgs method))+      ((,) <$> newName "p" <*> newName "a")+  mmVar <- newName "mismatches"+  clause+    [ conP+        (getMatcherName options method)+        (varP . fst <$> argVars),+      conP (getActionName options method) (varP . snd <$> argVars)+    ]+    ( guardedB+        [ (,) <$> normalG [|$(varE mmVar) == 0|] <*> [|Match|],+          (,) <$> normalG [|otherwise|] <*> [|NoMatch $(varE mmVar)|]+        ]+    )+    [ valD+        (varP mmVar)+        (normalB [|length (filter not $(listE (mkAccept <$> argVars)))|])+        []+    ]+  where+    mkAccept (p, a) = [|accept $(return (VarE p)) $(return (VarE a))|]++defineExpectableActions :: MockableOptions -> Instance -> Q [Dec]+defineExpectableActions options inst =+  concatMapM (defineExpectableAction options inst) (instMethods inst)++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 []+  where+    makeBody [] e = e+    makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|]++    wholeCxt :: [Type] -> Q (Maybe Cxt)+    wholeCxt (ty : ts) = do+      thisCxt <- argCxt ty+      otherCxt <- wholeCxt ts+      return ((++) <$> thisCxt <*> otherCxt)+    wholeCxt [] = return (Just [])++    argCxt :: Type -> Q (Maybe Cxt)+    argCxt argTy+      | not (isKnownType method argTy) = return Nothing+      | VarT v <- argTy =+        Just <$> sequence [[t|Eq $(varT v)|], [t|Show $(varT v)|]]+      | otherwise = do+        eqCxt <- resolveInstance ''Eq argTy+        showCxt <- resolveInstance ''Show argTy+        return ((++) <$> eqCxt <*> showCxt)++deriveForMockTImpl :: MockableOptions -> Q Type -> Q [Dec]+deriveForMockTImpl options qt = do+  inst <- getInstance options =<< qt++  unless (null (instExtraMembers inst)) $+    fail $+      "Cannot derive MockT because " ++ pprint (instType inst)+        ++ " has unmockable methods."++  m <- newName "m"+  let decs = map (implementMethod options) (instMethods inst)++  let cx =+        instRequiredContext inst+          \\ [ AppT (ConT ''Typeable) (VarT (instMonadVar inst)),+               AppT (ConT ''Functor) (VarT (instMonadVar inst)),+               AppT (ConT ''Applicative) (VarT (instMonadVar inst)),+               AppT (ConT ''Monad) (VarT (instMonadVar inst)),+               AppT (ConT ''MonadIO) (VarT (instMonadVar inst))+             ]++  simplifyContext+    (substTypeVar (instMonadVar inst) (AppT (ConT ''MockT) (VarT m)) <$> cx)+    >>= \case+      Just cxMockT ->+        (: [])+          <$> instanceD+            ( concat+                <$> sequence+                  [ return cxMockT,+                    constrainVars [[t|Typeable|]] (instGeneralParams inst),+                    constrainVars [[t|Typeable|], [t|MonadIO|]] [m]+                  ]+            )+            [t|$(pure (instType inst)) (MockT $(varT m))|]+            decs+      Nothing -> fail "Missing MockT instance for a superclass."++implementMethod :: MockableOptions -> Method -> Q Dec+implementMethod options method = do+  argVars <- replicateM (length (methodArgs method)) (newName "a")+  funD+    (methodName method)+    [clause (varP <$> argVars) (normalB (body argVars)) []]+  where+    actionExp [] e = e+    actionExp (v : vs) e = actionExp vs [|$e $(varE v)|]++    body argVars = do+      defaultCxt <- resolveInstance ''Default (methodResult method)+      let someMockMethod = case defaultCxt of+            Just [] -> [|mockMethod|]+            _ -> [|mockDefaultlessMethod|]+      [|+        $someMockMethod+          $(actionExp argVars (conE (getActionName options method)))+        |]++checkExt :: Extension -> Q ()+checkExt e = do+  enabled <- isExtEnabled e+  unless enabled $+    fail $ "Please enable " ++ show e ++ " to generate this mock."++internalError :: HasCallStack => Q a+internalError = error "Internal error in HMock.  Please report this as a bug."

@@ -23,15 +23,10 @@ import Data.Dynamic (Typeable) import Data.Kind (Type) import Language.Haskell.TH.Syntax hiding (Type)-import QuasiMock (Action (..), Matcher (..))+import QuasiMock import Test.HMock-import Test.HMock.TH import Test.Hspec-import Util.TH (deriveRecursive, reifyInstancesStatic, reifyStatic)--#if !MIN_VERSION_base(4, 13, 0)-import Control.Monad.Fail (MonadFail)-#endif+import Util.DeriveRecursive (deriveRecursive)  #if MIN_VERSION_template_haskell(2, 16, 0) -- Pre-define low-level instance to prevent deriveRecursive from trying.@@ -50,14 +45,13 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)-+        $(onReify [|expectAny|] ''MonadSimple)         runQ (makeMockable ''MonadSimple)       evaluate (rnf decs)    it "doesn't require unnecessary extensions for simple cases" $     example . runMockT $ do-      expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)+      $(onReify [|expectAny|] ''MonadSimple)       expectAny $ QIsExtEnabled ScopedTypeVariables |-> False       expectAny $ QIsExtEnabled RankNTypes |-> False @@ -68,7 +62,7 @@     example $ do       let missingGADTs = runMockT $ do             expectAny $ QIsExtEnabled GADTs |-> False-            expect $ QReport_ anything (hasSubstr "Please enable GADTs") |-> ()+            expect $ QReport_ anything (hasSubstr "Please enable GADTs")              _ <- runQ (makeMockable ''MonadSimple)             return ()@@ -79,8 +73,7 @@     example $ do       let missingTypeFamilies = runMockT $ do             expectAny $ QIsExtEnabled TypeFamilies |-> False-            expect $-              QReport_ anything (hasSubstr "Please enable TypeFamilies") |-> ()+            expect $ QReport_ anything (hasSubstr "Please enable TypeFamilies")              _ <- runQ (makeMockable ''MonadSimple)             return ()@@ -91,8 +84,7 @@     example $ do       let missingDataKinds = runMockT $ do             expectAny $ QIsExtEnabled DataKinds |-> False-            expect $-              QReport_ anything (hasSubstr "Please enable DataKinds") |-> ()+            expect $ QReport_ anything (hasSubstr "Please enable DataKinds")              _ <- runQ (makeMockable ''MonadSimple)             return ()@@ -105,7 +97,6 @@             expectAny $ QIsExtEnabled FlexibleInstances |-> False             expect $               QReport_ anything (hasSubstr "Please enable FlexibleInstances")-                |-> ()              _ <- runQ (makeMockable ''MonadSimple)             return ()@@ -120,7 +111,6 @@               QReport_                 anything                 (hasSubstr "Please enable MultiParamTypeClasses")-                |-> ()              _ <- runQ (makeMockable ''MonadSimple)             return ()@@ -130,10 +120,9 @@   it "fails when too many params are given" $     example $ do       let tooManyParams = runMockT $ do-            expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)+            $(onReify [|expectAny|] ''MonadSimple)             expect $               QReport_ anything (hasSubstr "is applied to too many arguments")-                |-> ()              _ <- runQ (makeMockableType [t|MonadSimple IO|])             return ()@@ -143,11 +132,11 @@   it "is mockable" $     example $ do       let success = runMockT $ do-            expect $ Simple "foo" |-> ()+            expect $ Simple "foo"             simple "foo"            failure = runMockT $ do-            expect $ Simple "foo" |-> ()+            expect $ Simple "foo"             simple "bar"        success@@ -163,19 +152,18 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadSuffix |-> $(reifyStatic ''MonadSuffix)-+        $(onReify [|expectAny|] ''MonadSuffix)         runQ (makeMockableWithOptions def {mockSuffix = "Blah"} ''MonadSuffix)       evaluate (rnf decs)    it "is mockable" $     example $ do       let success = runMockT $ do-            expect $ SuffixBlah "foo" |-> ()+            expect $ SuffixBlah "foo"             suffix "foo"            failure = runMockT $ do-            expect $ SuffixBlah "foo" |-> ()+            expect $ SuffixBlah "foo"             suffix "bar"        success@@ -188,15 +176,14 @@  instance Mockable MonadWithSetup where   setupMockable _ = do-    byDefault $ WithSetup |-> "custom default"+    allowUnexpected $ WithSetup |-> "custom default"  setupTests :: SpecWith () setupTests = describe "MonadWithSetup" $ do   it "generates mock impl" $ do     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadWithSetup |-> $(reifyStatic ''MonadWithSetup)-+        $(onReify [|expectAny|] ''MonadWithSetup)         runQ (makeMockableBase ''MonadWithSetup)       evaluate (rnf decs) @@ -208,6 +195,23 @@         result <- withSetup         liftIO (result `shouldBe` "custom default") +  it "uses default in a nested context" $ do+    example $+      runMockT $ do+        nestMockT $ do+          result <- withSetup+          liftIO (result `shouldBe` "custom default")++  it "retains default when initialized in nested context" $ do+    example $+      runMockT $ do+        nestMockT $ do+          _ <- withSetup+          return ()+        result <- withSetup++        liftIO (result `shouldBe` "custom default")+ class SuperClass (m :: Type -> Type)  instance SuperClass m@@ -222,16 +226,14 @@   it "generated mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadSuper |-> $(reifyStatic ''MonadSuper)+        $(onReify [|expectAny|] ''MonadSuper)         expectAny $           QReifyInstances_             (eq ''SuperClass)             $(qMatch [p|[AppT (ConT (Name (OccName "MockT") _)) (VarT _)]|])-            |-> $( do-                     v <- runQ (newName "m")-                     reifyInstancesStatic-                       ''SuperClass-                       [AppT (ConT ''MockT) (VarT v)]+            |-> $( reifyInstancesStatic+                     ''SuperClass+                     [AppT (ConT ''MockT) (VarT (mkName "v"))]                  )          runQ (makeMockable ''MonadSuper)@@ -240,7 +242,7 @@   it "is mockable" $     example $ do       let success = runMockT $ do-            expect $ WithSuper |-> ()+            expect WithSuper             withSuper            failure = runMockT withSuper@@ -259,19 +261,18 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadMPTC |-> $(reifyStatic ''MonadMPTC)-+        $(onReify [|expectAny|] ''MonadMPTC)         runQ (makeMockable ''MonadMPTC)       evaluate (rnf decs)    it "is mockable" $     example $ do       let success = runMockT $ do-            expect $ Mptc "foo" |-> ()+            expect $ Mptc "foo"             mptc "foo"            failure = runMockT $ do-            expect $ Mptc "foo" |-> ()+            expect $ Mptc "foo"             mptc "bar"        success@@ -287,10 +288,7 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $-          QReify ''MonadFDSpecialized-            |-> $(reifyStatic ''MonadFDSpecialized)-+        $(onReify [|expectAny|] ''MonadFDSpecialized)         runQ (makeMockableType [t|MonadFDSpecialized String|])       evaluate (rnf decs) @@ -327,8 +325,7 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadFDGeneral |-> $(reifyStatic ''MonadFDGeneral)-+        $(onReify [|expectAny|] ''MonadFDGeneral)         runQ (deriveMockable ''MonadFDGeneral)       evaluate (rnf decs) @@ -356,7 +353,7 @@ fdMixedTests = describe "MonadFDMixed" $ do   it "generates mock impl" $     example . runMockT $ do-      expectAny $ QReify ''MonadFDMixed |-> $(reifyStatic ''MonadFDMixed)+      $(onReify [|expectAny|] ''MonadFDMixed)        decs1 <- runQ (deriveMockableType [t|MonadFDMixed String Int|])       decs2 <-@@ -389,20 +386,17 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)-+        $(onReify [|expectAny|] ''MonadPolyArg)         runQ (makeMockable ''MonadPolyArg)       evaluate (rnf decs)    it "fails without ScopedTypeVariables" $     example $ do       let missingScopedTypeVariables = runMockT $ do-            expectAny $-              QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)+            $(onReify [|expectAny|] ''MonadPolyArg)             expectAny $ QIsExtEnabled ScopedTypeVariables |-> False             expect $               QReport_ anything (hasSubstr "Please enable ScopedTypeVariables")-                |-> ()              _ <- runQ (makeMockable ''MonadPolyArg)             return ()@@ -412,10 +406,10 @@   it "fails without RankNTypes" $     example $ do       let missingRankNTypes = runMockT $ do-            expectAny $ QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)+            $(onReify [|expectAny|] ''MonadPolyArg)             expectAny $ QIsExtEnabled RankNTypes |-> False             expect $-              QReport_ anything (hasSubstr "Please enable RankNTypes") |-> ()+              QReport_ anything (hasSubstr "Please enable RankNTypes")              _ <- runQ (makeMockable ''MonadPolyArg)             return ()@@ -426,12 +420,12 @@     example $ do       let success = runMyBase . runMockT $ do             expect $-              PolyArg_ (eq "foo") (with fromEnum (eq 1)) anything |-> ()+              PolyArg_ (eq "foo") (with fromEnum (eq 1)) anything             polyArg "foo" (toEnum 1 :: Bool) "hello"            failure = runMyBase . runMockT $ do             expect $-              PolyArg_ (eq "foo") (with fromEnum (eq 1)) anything |-> ()+              PolyArg_ (eq "foo") (with fromEnum (eq 1)) anything             polyArg "foo" (toEnum 2 :: Bool) "hello"        success@@ -447,20 +441,18 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $-          QReify ''MonadUnshowableArg |-> $(reifyStatic ''MonadUnshowableArg)-+        $(onReify [|expectAny|] ''MonadUnshowableArg)         runQ (makeMockable ''MonadUnshowableArg)       evaluate (rnf decs)    it "is mockable" $     example $ do       let success = runMyBase . runMockT $ do-            expect $ UnshowableArg_ anything |-> ()+            expect $ UnshowableArg_ anything             unshowableArg (+ 1)            failure = runMyBase . runMockT $ do-            expect $ UnshowableArg_ anything |-> ()+            expect $ UnshowableArg_ anything              unshowableArg (+ 1)             unshowableArg (+ 1)@@ -478,19 +470,18 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadInArg |-> $(reifyStatic ''MonadInArg)-+        $(onReify [|expectAny|] ''MonadInArg)         runQ (makeMockable ''MonadInArg)       evaluate (rnf decs)    it "is mockable" $     example $ do       let success = runMyBase . runMockT $ do-            expect $ MonadInArg_ anything |-> ()+            expect $ MonadInArg_ anything             monadInArg (const (return ()))            failure = runMyBase . runMockT $ do-            expect $ UnshowableArg_ anything |-> ()+            expect $ UnshowableArg_ anything              monadInArg (const (return ()))             monadInArg (const (return ()))@@ -523,36 +514,27 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $-          QReify ''MonadExtraneousMembers-            |-> $(reifyStatic ''MonadExtraneousMembers)-+        $(onReify [|expectAny|] ''MonadExtraneousMembers)         runQ (deriveMockable ''MonadExtraneousMembers)       evaluate (rnf decs)    it "warns about non-methods" $     example $ do       decs <- runMockT $ do-        expectAny $-          QReify ''MonadExtraneousMembers-            |-> $(reifyStatic ''MonadExtraneousMembers)-        expect $ QReport False "A non-value member cannot be mocked." |-> ()+        $(onReify [|expectAny|] ''MonadExtraneousMembers)+        expect $ QReport False "A non-value member cannot be mocked."         expect $           QReport False "favoriteNumber can't be mocked: non-monadic result."-            |-> ()         expect $           QReport             False             "wrongMonad can't be mocked: return value in wrong monad."-            |-> ()         expect $           QReport False "polyResult can't be mocked: polymorphic return value."-            |-> ()         expect $           QReport             False             "nestedRankN can't be mocked: rank-n types nested in arguments."-            |-> ()          runQ           ( deriveMockableWithOptions@@ -564,11 +546,9 @@   it "fails to derive MockT when class has extra methods" $     example $ do       let unmockableMethods = runMockT $ do-            expectAny $-              QReify ''MonadExtraneousMembers-                |-> $(reifyStatic ''MonadExtraneousMembers)+            $(onReify [|expectAny|] ''MonadExtraneousMembers)             expect $-              QReport_ anything (hasSubstr "has unmockable methods") |-> ()+              QReport_ anything (hasSubstr "has unmockable methods")              _ <- runQ (makeMockable ''MonadExtraneousMembers)             return ()@@ -578,11 +558,11 @@   it "is mockable" $     example $ do       let success = runMyBase . runMockT $ do-            expect $ MockableMethod 42 |-> ()+            expect $ MockableMethod 42             mockableMethod (favoriteNumber (SomeCon @(MockT IO)))            failure = runMyBase . runMockT $ do-            expect $ MockableMethod 42 |-> ()+            expect $ MockableMethod 42             mockableMethod 12        success@@ -598,19 +578,18 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $ QReify ''MonadRankN |-> $(reifyStatic ''MonadRankN)-+        $(onReify [|expectAny|] ''MonadRankN)         runQ (deriveMockable ''MonadRankN)       evaluate (rnf decs)    it "is mockable" $     example $ do       let success = runMockT $ do-            expect $ RankN_ anything (eq True) |-> ()+            expect $ RankN_ anything (eq True)             rankN (const True) True            failure = runMockT $ do-            expect $ RankN_ anything (eq True) |-> ()+            expect $ RankN_ anything (eq True)             rankN (const True) False        success@@ -634,11 +613,8 @@     it "generates mock impl" $       example $ do         decs <- runMockT $ do-          expectAny $-            QReify ''MonadManyReturns |-> $(reifyStatic ''MonadManyReturns)-          expectAny $-            QReifyInstances ''Default [ConT ''NoDefault]-              |-> $(reifyInstancesStatic ''Default [ConT ''NoDefault])+          $(onReify [|expectAny|] ''MonadManyReturns)+          $(onReifyInstances [|expectAny|] ''Default [ConT ''NoDefault])            runQ (makeMockable ''MonadManyReturns)         evaluate (rnf decs)@@ -692,19 +668,11 @@   it "generates mock impl" $     example $ do       decs <- runMockT $ do-        expectAny $-          QReify ''MonadNestedNoDef |-> $(reifyStatic ''MonadNestedNoDef)-        expectAny $-          QReifyInstances-            ''Default-            [AppT (AppT (TupleT 2) (ConT ''NoDefault)) (ConT ''String)]-            |-> $( reifyInstancesStatic-                     ''Default-                     [AppT (AppT (TupleT 2) (ConT ''NoDefault)) (ConT ''String)]-                 )-        expectAny $-          QReifyInstances ''Default [ConT ''NoDefault]-            |-> $(reifyInstancesStatic ''Default [ConT ''NoDefault])+        $(onReify [|expectAny|] ''MonadNestedNoDef)+        $( [t|(NoDefault, String)|]+             >>= onReifyInstances [|expectAny|] ''Default . (: [])+         )+        $(onReifyInstances [|expectAny|] ''Default [ConT ''NoDefault])          runQ (makeMockable ''MonadNestedNoDef)       evaluate (rnf decs)@@ -722,7 +690,6 @@               QReport_                 anything                 (hasSubstr "Expected GHC.Types.Int to be a class")-                |-> ()              _ <- runQ (makeMockable ''Int)             return ()@@ -732,7 +699,7 @@   it "fails when given an unexpected type construct" $     example $ do       let notClass = runMockT $ do-            expect $ QReport_ anything (hasSubstr "Expected a class") |-> ()+            expect $ QReport_ anything (hasSubstr "Expected a class")              _ <- runQ (makeMockableType [t|(Int, String)|])             return ()@@ -742,13 +709,11 @@   it "fails when class has no params" $     example $ do       let tooManyParams = runMockT $ do-            expectAny $-              QReify ''ClassWithNoParams |-> $(reifyStatic ''ClassWithNoParams)+            $(onReify [|expectAny|] ''ClassWithNoParams)             expect $               QReport_                 anything                 (hasSubstr "ClassWithNoParams has no type parameters")-                |-> ()              _ <- runQ (makeMockable ''ClassWithNoParams)             return ()@@ -758,10 +723,8 @@   it "fails when class has no mockable methods" $     example $ do       let noMockableMethods = runMockT $ do-            expectAny $ QReify ''Show |-> $(reifyStatic ''Show)-            expect $-              QReport_ anything (hasSubstr "has no mockable methods") |-> ()-+            $(onReify [|expectAny|] ''Show)+            expect $ QReport_ anything (hasSubstr "has no mockable methods")             _ <- runQ (deriveMockable ''Show)             return () 

@@ -17,7 +17,6 @@ import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (isInfixOf, isPrefixOf) import Test.HMock-import Test.HMock.TH (makeMockable) import Test.Hspec import qualified UnliftIO.Concurrent as UnliftIO import Prelude hiding (readFile, writeFile)@@ -493,6 +492,8 @@               <*> readFile "foo.txt"           liftIO $ result `shouldBe` ("A", "B", "A", "B") +    it "repeats response sequences during consecutive repetition" $+      example $ do         runMockT $ do           consecutiveTimes 2 $ expect $ ReadFile "foo.txt" |-> "A" |-> "B" @@ -593,7 +594,7 @@          test `shouldThrow` anyException -    it "allows the user to override a default" $+    it "allows the user to override a default with byDefault" $       example $         runMockT $ do           expectAny $ ReadFile_ anything@@ -607,6 +608,108 @@           liftIO (r1 `shouldBe` "")           liftIO (r2 `shouldBe` "foo")           liftIO (r3 `shouldBe` "")++    it "adopts lax behavior for allowUnexpected" $+      example $+        runMockT $ do+          allowUnexpected $ ReadFile "foo.txt" |-> "foo"+          r <- readFile "foo.txt"+          liftIO (r `shouldBe` "foo")++    it "prefers expect over allowUnexpected" $+      example $+        runMockT $ do+          expectAny $ ReadFile_ anything |-> "bar"+          allowUnexpected $ ReadFile "foo.txt" |-> "foo"+          r <- readFile "foo.txt"+          liftIO (r `shouldBe` "bar")++    it "uses defaults when allowUnexpected is not explicit" $+      example $ do+        runMockT $ do+          byDefault $ ReadFile "foo.txt" |-> "foo" -- added before allow+          allowUnexpected $ ReadFile_ anything+          byDefault $ ReadFile "bar.txt" |-> "bar" -- added after allow+          result <-+            (,,)+              <$> readFile "foo.txt"+              <*> readFile "bar.txt"+              <*> readFile "baz.txt"+          liftIO (result `shouldBe` ("foo", "bar", ""))++    it "doesn't adopt lax behavior for byDefault" $+      example $ do+        let test = runMockT $ do+              byDefault $ ReadFile "foo.txt" |-> "foo"+              readFile "foo.txt"+        liftIO (test `shouldThrow` anyException)++    it "checks ambiguity when asked" $+      example $ do+        let setExpectations = do+              expect $ ReadFile_ anything+              expect $ ReadFile "foo.txt"+              setAmbiguityCheck True++            failure = runMockT $ do+              setExpectations+              _ <- readFile "foo.txt"+              _ <- readFile "bar.txt"+              return ()++            success = runMockT $ do+              setExpectations+              _ <- readFile "bar.txt"+              _ <- readFile "foo.txt"+              return ()++        success+        failure `shouldThrow` errorWith ("Ambiguous action" `isInfixOf`)++    describe "nestMockT" $ do+      it "checks nested context early" $ do+        example $ do+          let success = runMockT $ do+                expect $ WriteFile "final.txt" "final"+                nestMockT $ do+                  expect $ WriteFile "foo.txt" "foo"+                  writeFile "foo.txt" "foo"+                writeFile "final.txt" "final"++              failure = runMockT $ do+                nestMockT $ do+                  expect $ WriteFile "foo.txt" "foo"+                writeFile "foo.txt" "foo"++          success+          failure `shouldThrow` anyException++      it "updates the right context when nesting" $+        example $+          runMockT $ do+            expect $ ReadFile "foo.txt" |-> "foo #1" |-> "foo #2"+            result <- nestMockT $ do+              expect $ ReadFile "bar.txt" |-> "bar #1" |-> "bar #2"+              (,,,)+                <$> readFile "foo.txt"+                <*> readFile "bar.txt"+                <*> readFile "foo.txt"+                <*> readFile "bar.txt"+            liftIO (result `shouldBe` ("foo #1", "bar #1", "foo #2", "bar #2"))++      it "inherits defaults correctly" $+        example $+          runMockT $ do+            allowUnexpected $ ReadFile "foo.txt" |-> "foo"+            allowUnexpected $ ReadFile "bar.txt" |-> "bar"+            result <- nestMockT $ do+              allowUnexpected $ ReadFile "foo.txt" |-> "foo #2"+              (,) <$> readFile "foo.txt" <*> readFile "bar.txt"++            liftIO (result `shouldBe` ("foo #2", "bar"))++            result2 <- readFile "foo.txt"+            liftIO (result2 `shouldBe` "foo")  errorWith :: (String -> Bool) -> SomeException -> Bool errorWith p e = p (show e)

@@ -19,13 +19,15 @@ import Test.HMock   ( Mockable (..),     anything,+    allowUnexpected,     expect,     expectAny,+    makeMockable,+    makeMockableBase,     runMockT,     (|->),     (|=>),   )-import Test.HMock.TH (makeMockable, makeMockableBase) import Test.Hspec (SpecWith, describe, example, it) import Prelude hiding (appendFile, readFile, writeFile) @@ -156,7 +158,7 @@   setupMockable _ = do     -- Ensure that when the chatbot logs in with the right username and     -- password.-    expectAny $+    allowUnexpected $       Login "HMockBot" "secretish"         |=> \_ -> do           -- Every login should be accompanied by a logout@@ -164,13 +166,13 @@      -- By default, assume that the bot has all permissions.  Individual tests     -- can override this assumption.-    expectAny $ HasPermission_ anything |-> True+    allowUnexpected $ HasPermission_ anything |-> True  makeMockableBase ''MonadChat  instance Mockable MonadChat where   setupMockable _ = do-    expectAny $+    allowUnexpected $       JoinRoom_ anything         |=> \(JoinRoom room) -> do           -- The bot should leave every room it joins.@@ -179,7 +181,7 @@      -- Our tests aren't generally concerned with what the bot says.  Individual     -- tests can add expectations to check for specific messages.-    expectAny $ SendChat_ anything anything+    allowUnexpected $ SendChat_ anything anything |-> ()  ------------------------------------------------------------------------------- -- PART 4: TESTS@@ -229,7 +231,7 @@          chatbot "#haskell" -  it "doesn't ban people for using four-letter words in big reports" $ do+  it "doesn't ban people for using four-letter words in bug reports" $ do     example $       runMockT $ do         -- A four letter word is used in a bug report.  This is understandable,

@@ -1,12 +1,12 @@ -- Do not edit! Automatically created with doctest-extract. module DocTests.All where -import qualified DocTests.Test.HMock.Internal.Predicates-import qualified DocTests.Test.HMock.Internal.Multiplicity+import qualified DocTests.Test.HMock.Predicates+import qualified DocTests.Test.HMock.Multiplicity  import qualified Test.DocTest.Driver as DocTest  main :: DocTest.T () main = do-    DocTests.Test.HMock.Internal.Predicates.test-    DocTests.Test.HMock.Internal.Multiplicity.test+    DocTests.Test.HMock.Predicates.test+    DocTests.Test.HMock.Multiplicity.test

@@ -1,166 +0,0 @@--- Do not edit! Automatically created with doctest-extract from src/Test/HMock/Internal/Multiplicity.hs-module DocTests.Test.HMock.Internal.Multiplicity where--import Test.HMock.Internal.Multiplicity-import Test.DocTest.Base-import qualified Test.DocTest.Driver as DocTest---test :: DocTest.T ()-test = do- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:33: "-{-# LINE 33 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 33 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity 5 4)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:35: "-{-# LINE 35 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 35 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity 5 5)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:37: "-{-# LINE 37 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 37 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (between 4 6 - between 1 2)-  [ExpectedLine [LineChunk "2 to 5 times"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:75: "-{-# LINE 75 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 75 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity once 0)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:77: "-{-# LINE 77 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 77 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity once 1)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:79: "-{-# LINE 79 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 79 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity once 2)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:85: "-{-# LINE 85 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 85 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity anyMultiplicity 0)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:87: "-{-# LINE 87 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 87 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity anyMultiplicity 1)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:89: "-{-# LINE 89 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 89 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity anyMultiplicity 10)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:96: "-{-# LINE 96 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 96 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atLeast 2) 1)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:98: "-{-# LINE 98 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 98 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atLeast 2) 2)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:100: "-{-# LINE 100 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 100 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atLeast 2) 3)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:107: "-{-# LINE 107 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 107 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atMost 2) 1)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:109: "-{-# LINE 109 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 109 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atMost 2) 2)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:111: "-{-# LINE 111 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 111 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (atMost 2) 3)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:120: "-{-# LINE 120 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 120 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (between 2 3) 1)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:122: "-{-# LINE 122 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 122 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (between 2 3) 2)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:124: "-{-# LINE 124 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 124 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (between 2 3) 3)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:126: "-{-# LINE 126 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 126 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (meetsMultiplicity (between 2 3) 4)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:133: "-{-# LINE 133 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 133 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (exhaustable anyMultiplicity)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:135: "-{-# LINE 135 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 135 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (exhaustable (atLeast 2))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:137: "-{-# LINE 137 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 137 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (exhaustable (atMost 3))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:139: "-{-# LINE 139 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 139 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (exhaustable (between 0 2))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:146: "-{-# LINE 146 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 146 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (feasible once)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:148: "-{-# LINE 148 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 148 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (feasible 0)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Multiplicity:150: "-{-# LINE 150 "src/Test/HMock/Internal/Multiplicity.hs" #-}- DocTest.example-{-# LINE 150 "src/Test/HMock/Internal/Multiplicity.hs" #-}-      (feasible (once - 2))-  [ExpectedLine [LineChunk "False"]]

@@ -1,898 +0,0 @@--- Do not edit! Automatically created with doctest-extract from src/Test/HMock/Internal/Predicates.hs-{-# LINE 24 "src/Test/HMock/Internal/Predicates.hs" #-}--{-# OPTIONS_GHC -XTemplateHaskell #-}-{-# OPTIONS_GHC -XTypeApplications #-}-{-# OPTIONS_GHC -Wno-type-defaults #-}-module DocTests.Test.HMock.Internal.Predicates where--import Test.HMock.Internal.Predicates-import Test.DocTest.Base-import qualified Test.DocTest.Driver as DocTest--{-# LINE 28 "src/Test/HMock/Internal/Predicates.hs" #-}--test :: DocTest.T ()-test = do- DocTest.printPrefix "Test.HMock.Internal.Predicates:44: "-{-# LINE 44 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 44 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept anything "foo")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:46: "-{-# LINE 46 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 46 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept anything undefined)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:57: "-{-# LINE 57 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 57 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (eq "foo") "foo")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:59: "-{-# LINE 59 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 59 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (eq "foo") "bar")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:70: "-{-# LINE 70 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 70 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (neq "foo") "foo")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:72: "-{-# LINE 72 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 72 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (neq "foo") "bar")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:83: "-{-# LINE 83 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 83 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (gt 5) 4)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:85: "-{-# LINE 85 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 85 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (gt 5) 5)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:87: "-{-# LINE 87 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 87 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (gt 5) 6)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:99: "-{-# LINE 99 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 99 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (geq 5) 4)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:101: "-{-# LINE 101 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 101 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (geq 5) 5)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:103: "-{-# LINE 103 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 103 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (geq 5) 6)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:114: "-{-# LINE 114 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 114 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt 5) 4)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:116: "-{-# LINE 116 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 116 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt 5) 5)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:118: "-{-# LINE 118 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 118 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt 5) 6)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:129: "-{-# LINE 129 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 129 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (leq 5) 4)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:131: "-{-# LINE 131 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 131 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (leq 5) 5)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:133: "-{-# LINE 133 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 133 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (leq 5) 6)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:144: "-{-# LINE 144 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 144 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept true True)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:146: "-{-# LINE 146 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 146 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept true False)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:153: "-{-# LINE 153 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 153 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept false True)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:155: "-{-# LINE 155 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 155 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept false False)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:163: "-{-# LINE 163 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 163 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (just (eq "value")) Nothing)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:165: "-{-# LINE 165 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 165 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (just (eq "value")) (Just "value"))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:167: "-{-# LINE 167 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 167 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (just (eq "value")) (Just "wrong value"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:179: "-{-# LINE 179 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 179 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (left (eq "value")) (Left "value"))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:181: "-{-# LINE 181 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 181 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (left (eq "value")) (Right "value"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:183: "-{-# LINE 183 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 183 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (left (eq "value")) (Left "wrong value"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:195: "-{-# LINE 195 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 195 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (right (eq "value")) (Right "value"))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:197: "-{-# LINE 197 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 197 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (right (eq "value")) (Right "wrong value"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:199: "-{-# LINE 199 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 199 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (right (eq "value")) (Left "value"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:211: "-{-# LINE 211 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 211 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zipP (eq "foo") (eq "bar")) ("foo", "bar"))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:213: "-{-# LINE 213 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 213 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zipP (eq "foo") (eq "bar")) ("bar", "foo"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:225: "-{-# LINE 225 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 225 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux"))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:227: "-{-# LINE 227 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 227 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo"))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:239: "-{-# LINE 239 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 239 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:241: "-{-# LINE 241 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 241 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:259: "-{-# LINE 259 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 259 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:261: "-{-# LINE 261 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 261 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:280: "-{-# LINE 280 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 280 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "foo" `andP` gt "bar") "eta")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:282: "-{-# LINE 282 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 282 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "foo" `andP` gt "bar") "quz")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:284: "-{-# LINE 284 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 284 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "foo" `andP` gt "bar") "alpha")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:295: "-{-# LINE 295 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 295 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "bar" `orP` gt "foo") "eta")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:297: "-{-# LINE 297 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 297 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "bar" `orP` gt "foo") "quz")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:299: "-{-# LINE 299 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 299 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (lt "bar" `orP` gt "foo") "alpha")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:311: "-{-# LINE 311 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 311 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (notP (eq "negative")) "positive")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:313: "-{-# LINE 313 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 313 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (notP (eq "negative")) "negative")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:324: "-{-# LINE 324 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 324 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (startsWith "fun") "fungible")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:326: "-{-# LINE 326 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 326 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (startsWith "gib") "fungible")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:337: "-{-# LINE 337 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 337 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (endsWith "ow") "crossbow")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:339: "-{-# LINE 339 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 339 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (endsWith "ow") "trebuchet")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:351: "-{-# LINE 351 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 351 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (hasSubstr "i") "team")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:353: "-{-# LINE 353 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 353 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (hasSubstr "i") "partnership")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:365: "-{-# LINE 365 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 365 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:367: "-{-# LINE 367 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 367 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:369: "-{-# LINE 369 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 369 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:381: "-{-# LINE 381 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 381 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (caseInsensitive startsWith "foo") "FOOTBALL!")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:383: "-{-# LINE 383 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 383 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (caseInsensitive endsWith "ball") "soccer")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:385: "-{-# LINE 385 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 385 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (caseInsensitive eq "time") "TIME")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:387: "-{-# LINE 387 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 387 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (caseInsensitive gt "NOTHING") "everything")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:412: "-{-# LINE 412 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 412 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesRegex "x{2,5}y?") "xxxy")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:414: "-{-# LINE 414 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 414 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesRegex "x{2,5}y?") "xyy")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:416: "-{-# LINE 416 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 416 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesRegex "x{2,5}y?") "wxxxyz")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:439: "-{-# LINE 439 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 439 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:441: "-{-# LINE 441 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 441 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:443: "-{-# LINE 443 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 443 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:472: "-{-# LINE 472 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 472 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsRegex "x{2,5}y?") "xxxy")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:474: "-{-# LINE 474 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 474 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsRegex "x{2,5}y?") "xyy")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:476: "-{-# LINE 476 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 476 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsRegex "x{2,5}y?") "wxxxyz")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:497: "-{-# LINE 497 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 497 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:499: "-{-# LINE 499 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 499 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:501: "-{-# LINE 501 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 501 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:522: "-{-# LINE 522 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 522 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept isEmpty [])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:524: "-{-# LINE 524 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 524 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept isEmpty [1, 2, 3])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:526: "-{-# LINE 526 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 526 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept isEmpty "")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:528: "-{-# LINE 528 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 528 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept isEmpty "gas tank")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:539: "-{-# LINE 539 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 539 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nonEmpty [])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:541: "-{-# LINE 541 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 541 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nonEmpty [1, 2, 3])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:543: "-{-# LINE 543 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 543 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nonEmpty "")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:545: "-{-# LINE 545 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 545 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nonEmpty "gas tank")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:557: "-{-# LINE 557 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 557 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (sizeIs (lt 3)) ['a' .. 'f'])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:559: "-{-# LINE 559 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 559 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (sizeIs (lt 3)) ['a' .. 'b'])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:571: "-{-# LINE 571 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 571 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:573: "-{-# LINE 573 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 573 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:575: "-{-# LINE 575 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 575 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:589: "-{-# LINE 589 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 589 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:591: "-{-# LINE 591 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 591 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:593: "-{-# LINE 593 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 593 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:595: "-{-# LINE 595 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 595 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:611: "-{-# LINE 611 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 611 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (each (gt 5)) [4, 5, 6])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:613: "-{-# LINE 613 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 613 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (each (gt 5)) [6, 7, 8])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:615: "-{-# LINE 615 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 615 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (each (gt 5)) [])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:627: "-{-# LINE 627 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 627 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (contains (gt 5)) [3, 4, 5])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:629: "-{-# LINE 629 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 629 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (contains (gt 5)) [4, 5, 6])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:631: "-{-# LINE 631 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 631 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (contains (gt 5)) [])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:645: "-{-# LINE 645 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 645 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:647: "-{-# LINE 647 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 647 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsAll [eq "foo", eq "bar"]) ["foo"])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:649: "-{-# LINE 649 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 649 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:662: "-{-# LINE 662 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 662 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:664: "-{-# LINE 664 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 664 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:666: "-{-# LINE 666 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 666 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:678: "-{-# LINE 678 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 678 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsKey (eq "foo")) [("foo", 1), ("bar", 2)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:680: "-{-# LINE 680 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 680 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsKey (eq "foo")) [("bar", 1), ("qux", 2)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:693: "-{-# LINE 693 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 693 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsEntry (eq "foo") (gt 10)) [("foo", 12), ("bar", 5)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:695: "-{-# LINE 695 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 695 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsEntry (eq "foo") (gt 10)) [("foo", 5), ("bar", 12)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:697: "-{-# LINE 697 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 697 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (containsEntry (eq "foo") (gt 10)) [("bar", 12)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:710: "-{-# LINE 710 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 710 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("b", 2), ("c", 3)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:712: "-{-# LINE 712 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 712 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (keysAre [eq "a", eq "b", eq "c"]) [("c", 1), ("b", 2), ("a", 3)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:714: "-{-# LINE 714 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 714 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("c", 3)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:716: "-{-# LINE 716 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 716 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (keysAre [eq "a", eq "b"]) [("a", 1), ("b", 2), ("c", 3)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:732: "-{-# LINE 732 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 732 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:734: "-{-# LINE 734 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 734 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(3, 4), (1, 2)])-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:736: "-{-# LINE 736 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 736 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 4), (3, 2)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:738: "-{-# LINE 738 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 738 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4), (5, 6)])-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:759: "-{-# LINE 759 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 759 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (eq 1.0) (sum (replicate 100 0.01)))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:766: "-{-# LINE 766 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 766 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (approxEq 1.0) (sum (replicate 100 0.01)))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:768: "-{-# LINE 768 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 768 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (approxEq 1.0) (sum (replicate 100 0.009999)))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:781: "-{-# LINE 781 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 781 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept finite 1.0)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:783: "-{-# LINE 783 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 783 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept finite (0 / 0))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:785: "-{-# LINE 785 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 785 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept finite (1 / 0))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:796: "-{-# LINE 796 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 796 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept infinite 1.0)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:798: "-{-# LINE 798 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 798 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept infinite (0 / 0))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:800: "-{-# LINE 800 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 800 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept infinite (1 / 0))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:811: "-{-# LINE 811 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 811 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nAn 1.0)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:813: "-{-# LINE 813 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 813 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nAn (0 / 0))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:815: "-{-# LINE 815 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 815 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept nAn (1 / 0))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:828: "-{-# LINE 828 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 828 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (is even) 3)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:830: "-{-# LINE 830 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 830 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (is even) 4)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:843: "-{-# LINE 843 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 843 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept $(qIs [| even |]) 3)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:845: "-{-# LINE 845 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 845 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept $(qIs [| even |]) 4)-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:848: "-{-# LINE 848 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 848 "src/Test/HMock/Internal/Predicates.hs" #-}-      (show $(qIs [| even |]))-  [ExpectedLine [LineChunk "\"even\""]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:862: "-{-# LINE 862 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 862 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (with abs (gt 5)) (-6))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:864: "-{-# LINE 864 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 864 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (with abs (gt 5)) (-5))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:866: "-{-# LINE 866 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 866 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (with reverse (eq "olleh")) "hello")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:868: "-{-# LINE 868 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 868 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (with reverse (eq "olleh")) "goodbye")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:882: "-{-# LINE 882 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 882 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept ($(qWith [| abs |]) (gt 5)) (-6))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:884: "-{-# LINE 884 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 884 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept ($(qWith [| abs |]) (gt 5)) (-5))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:886: "-{-# LINE 886 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 886 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept ($(qWith [| reverse |]) (eq "olleh")) "hello")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:888: "-{-# LINE 888 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 888 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:891: "-{-# LINE 891 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 891 "src/Test/HMock/Internal/Predicates.hs" #-}-      (show ($(qWith [| abs |]) (gt 5)))-  [ExpectedLine [LineChunk "\"abs: > 5\""]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:907: "-{-# LINE 907 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 907 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept $(qMatch [p| Just (Left _) |]) Nothing)-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:909: "-{-# LINE 909 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 909 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept $(qMatch [p| Just (Left _) |]) (Just (Left 5)))-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:911: "-{-# LINE 911 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 911 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept $(qMatch [p| Just (Left _) |]) (Just (Right 5)))-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:914: "-{-# LINE 914 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 914 "src/Test/HMock/Internal/Predicates.hs" #-}-      (show $(qMatch [p| Just (Left _) |]))-  [ExpectedLine [LineChunk "\"Just (Left _)\""]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:930: "-{-# LINE 930 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 930 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (typed @String anything) "foo")-  [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:932: "-{-# LINE 932 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 932 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (typed @String (sizeIs (gt 5))) "foo")-  [ExpectedLine [LineChunk "False"]]- DocTest.printPrefix "Test.HMock.Internal.Predicates:934: "-{-# LINE 934 "src/Test/HMock/Internal/Predicates.hs" #-}- DocTest.example-{-# LINE 934 "src/Test/HMock/Internal/Predicates.hs" #-}-      (accept (typed @String anything) (42 :: Int))-  [ExpectedLine [LineChunk "False"]]