diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/HMock.cabal b/HMock.cabal --- a/HMock.cabal +++ b/HMock.cabal @@ -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, diff --git a/src/Test/HMock.hs b/src/Test/HMock.hs --- a/src/Test/HMock.hs +++ b/src/Test/HMock.hs @@ -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 diff --git a/src/Test/HMock/ExpectContext.hs b/src/Test/HMock/ExpectContext.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/ExpectContext.hs @@ -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 () diff --git a/src/Test/HMock/Internal/ExpectSet.hs b/src/Test/HMock/Internal/ExpectSet.hs --- a/src/Test/HMock/Internal/ExpectSet.hs +++ b/src/Test/HMock/Internal/ExpectSet.hs @@ -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 diff --git a/src/Test/HMock/Internal/Expectable.hs b/src/Test/HMock/Internal/Expectable.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/Expectable.hs +++ /dev/null @@ -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)) diff --git a/src/Test/HMock/Internal/MockT.hs b/src/Test/HMock/Internal/MockT.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/MockT.hs +++ /dev/null @@ -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) diff --git a/src/Test/HMock/Internal/MockT.hs-boot b/src/Test/HMock/Internal/MockT.hs-boot deleted file mode 100644 --- a/src/Test/HMock/Internal/MockT.hs-boot +++ /dev/null @@ -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) diff --git a/src/Test/HMock/Internal/Mockable.hs b/src/Test/HMock/Internal/Mockable.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/Mockable.hs +++ /dev/null @@ -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 () diff --git a/src/Test/HMock/Internal/Multiplicity.hs b/src/Test/HMock/Internal/Multiplicity.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/Multiplicity.hs +++ /dev/null @@ -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 diff --git a/src/Test/HMock/Internal/Predicates.hs b/src/Test/HMock/Internal/Predicates.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/Predicates.hs +++ /dev/null @@ -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 - } diff --git a/src/Test/HMock/Internal/Rule.hs b/src/Test/HMock/Internal/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Internal/Rule.hs @@ -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 diff --git a/src/Test/HMock/Internal/State.hs b/src/Test/HMock/Internal/State.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Internal/State.hs @@ -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 diff --git a/src/Test/HMock/Internal/State.hs-boot b/src/Test/HMock/Internal/State.hs-boot new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Internal/State.hs-boot @@ -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) diff --git a/src/Test/HMock/Internal/Step.hs b/src/Test/HMock/Internal/Step.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Internal/Step.hs @@ -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)) diff --git a/src/Test/HMock/Internal/TH.hs b/src/Test/HMock/Internal/TH.hs --- a/src/Test/HMock/Internal/TH.hs +++ b/src/Test/HMock/Internal/TH.hs @@ -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 diff --git a/src/Test/HMock/Internal/TH/Util.hs b/src/Test/HMock/Internal/TH/Util.hs deleted file mode 100644 --- a/src/Test/HMock/Internal/TH/Util.hs +++ /dev/null @@ -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 diff --git a/src/Test/HMock/Internal/Util.hs b/src/Test/HMock/Internal/Util.hs --- a/src/Test/HMock/Internal/Util.hs +++ b/src/Test/HMock/Internal/Util.hs @@ -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 diff --git a/src/Test/HMock/MockMethod.hs b/src/Test/HMock/MockMethod.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/MockMethod.hs @@ -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 diff --git a/src/Test/HMock/MockT.hs b/src/Test/HMock/MockT.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/MockT.hs @@ -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." diff --git a/src/Test/HMock/Mockable.hs b/src/Test/HMock/Mockable.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Mockable.hs @@ -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 () diff --git a/src/Test/HMock/Multiplicity.hs b/src/Test/HMock/Multiplicity.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Multiplicity.hs @@ -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 diff --git a/src/Test/HMock/Predicates.hs b/src/Test/HMock/Predicates.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Predicates.hs @@ -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 + } diff --git a/src/Test/HMock/Rule.hs b/src/Test/HMock/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Test/HMock/Rule.hs @@ -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 :=> [] diff --git a/src/Test/HMock/TH.hs b/src/Test/HMock/TH.hs --- a/src/Test/HMock/TH.hs +++ b/src/Test/HMock/TH.hs @@ -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." diff --git a/test/Classes.hs b/test/Classes.hs --- a/test/Classes.hs +++ b/test/Classes.hs @@ -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 () diff --git a/test/Core.hs b/test/Core.hs --- a/test/Core.hs +++ b/test/Core.hs @@ -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) diff --git a/test/Demo.hs b/test/Demo.hs --- a/test/Demo.hs +++ b/test/Demo.hs @@ -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, diff --git a/test/DocTests/All.hs b/test/DocTests/All.hs --- a/test/DocTests/All.hs +++ b/test/DocTests/All.hs @@ -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 diff --git a/test/DocTests/Test/HMock/Internal/Multiplicity.hs b/test/DocTests/Test/HMock/Internal/Multiplicity.hs deleted file mode 100644 --- a/test/DocTests/Test/HMock/Internal/Multiplicity.hs +++ /dev/null @@ -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"]] diff --git a/test/DocTests/Test/HMock/Internal/Predicates.hs b/test/DocTests/Test/HMock/Internal/Predicates.hs deleted file mode 100644 --- a/test/DocTests/Test/HMock/Internal/Predicates.hs +++ /dev/null @@ -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"]] diff --git a/test/DocTests/Test/HMock/Multiplicity.hs b/test/DocTests/Test/HMock/Multiplicity.hs new file mode 100644 --- /dev/null +++ b/test/DocTests/Test/HMock/Multiplicity.hs @@ -0,0 +1,142 @@ +-- Do not edit! Automatically created with doctest-extract from src/Test/HMock/Multiplicity.hs +module DocTests.Test.HMock.Multiplicity where + +import Test.HMock.Multiplicity +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + + +test :: DocTest.T () +test = do + DocTest.printPrefix "Test.HMock.Multiplicity:47: " +{-# LINE 47 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 47 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity 5 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:49: " +{-# LINE 49 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 49 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity 5 5) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:51: " +{-# LINE 51 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 51 "src/Test/HMock/Multiplicity.hs" #-} + (between 4 6 - between 1 2) + [ExpectedLine [LineChunk "2 to 5 times"]] + DocTest.printPrefix "Test.HMock.Multiplicity:89: " +{-# LINE 89 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 89 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity once 0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:91: " +{-# LINE 91 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 91 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity once 1) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:93: " +{-# LINE 93 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 93 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity once 2) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:99: " +{-# LINE 99 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 99 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity anyMultiplicity 0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:101: " +{-# LINE 101 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 101 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity anyMultiplicity 1) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:103: " +{-# LINE 103 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 103 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity anyMultiplicity 10) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:110: " +{-# LINE 110 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 110 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atLeast 2) 1) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:112: " +{-# LINE 112 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 112 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atLeast 2) 2) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:114: " +{-# LINE 114 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 114 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atLeast 2) 3) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:121: " +{-# LINE 121 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 121 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atMost 2) 1) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:123: " +{-# LINE 123 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 123 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atMost 2) 2) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:125: " +{-# LINE 125 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 125 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (atMost 2) 3) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:134: " +{-# LINE 134 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 134 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (between 2 3) 1) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:136: " +{-# LINE 136 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 136 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (between 2 3) 2) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:138: " +{-# LINE 138 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 138 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (between 2 3) 3) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:140: " +{-# LINE 140 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 140 "src/Test/HMock/Multiplicity.hs" #-} + (meetsMultiplicity (between 2 3) 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Multiplicity:147: " +{-# LINE 147 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 147 "src/Test/HMock/Multiplicity.hs" #-} + (feasible once) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:149: " +{-# LINE 149 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 149 "src/Test/HMock/Multiplicity.hs" #-} + (feasible 0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Multiplicity:151: " +{-# LINE 151 "src/Test/HMock/Multiplicity.hs" #-} + DocTest.example +{-# LINE 151 "src/Test/HMock/Multiplicity.hs" #-} + (feasible (once - 2)) + [ExpectedLine [LineChunk "False"]] diff --git a/test/DocTests/Test/HMock/Predicates.hs b/test/DocTests/Test/HMock/Predicates.hs new file mode 100644 --- /dev/null +++ b/test/DocTests/Test/HMock/Predicates.hs @@ -0,0 +1,874 @@ +-- Do not edit! Automatically created with doctest-extract from src/Test/HMock/Predicates.hs +{-# LINE 78 "src/Test/HMock/Predicates.hs" #-} + +{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# OPTIONS_GHC -XTypeApplications #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +module DocTests.Test.HMock.Predicates where + +import Test.HMock.Predicates +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 82 "src/Test/HMock/Predicates.hs" #-} + +test :: DocTest.T () +test = do + DocTest.printPrefix "Test.HMock.Predicates:98: " +{-# LINE 98 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 98 "src/Test/HMock/Predicates.hs" #-} + (accept anything "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:100: " +{-# LINE 100 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 100 "src/Test/HMock/Predicates.hs" #-} + (accept anything undefined) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:111: " +{-# LINE 111 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 111 "src/Test/HMock/Predicates.hs" #-} + (accept (eq "foo") "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:113: " +{-# LINE 113 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 113 "src/Test/HMock/Predicates.hs" #-} + (accept (eq "foo") "bar") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:124: " +{-# LINE 124 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 124 "src/Test/HMock/Predicates.hs" #-} + (accept (neq "foo") "foo") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:126: " +{-# LINE 126 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 126 "src/Test/HMock/Predicates.hs" #-} + (accept (neq "foo") "bar") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:137: " +{-# LINE 137 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 137 "src/Test/HMock/Predicates.hs" #-} + (accept (gt 5) 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:139: " +{-# LINE 139 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 139 "src/Test/HMock/Predicates.hs" #-} + (accept (gt 5) 5) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:141: " +{-# LINE 141 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 141 "src/Test/HMock/Predicates.hs" #-} + (accept (gt 5) 6) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:153: " +{-# LINE 153 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 153 "src/Test/HMock/Predicates.hs" #-} + (accept (geq 5) 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:155: " +{-# LINE 155 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 155 "src/Test/HMock/Predicates.hs" #-} + (accept (geq 5) 5) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:157: " +{-# LINE 157 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 157 "src/Test/HMock/Predicates.hs" #-} + (accept (geq 5) 6) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:168: " +{-# LINE 168 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 168 "src/Test/HMock/Predicates.hs" #-} + (accept (lt 5) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:170: " +{-# LINE 170 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 170 "src/Test/HMock/Predicates.hs" #-} + (accept (lt 5) 5) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:172: " +{-# LINE 172 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 172 "src/Test/HMock/Predicates.hs" #-} + (accept (lt 5) 6) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:183: " +{-# LINE 183 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 183 "src/Test/HMock/Predicates.hs" #-} + (accept (leq 5) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:185: " +{-# LINE 185 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 185 "src/Test/HMock/Predicates.hs" #-} + (accept (leq 5) 5) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:187: " +{-# LINE 187 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 187 "src/Test/HMock/Predicates.hs" #-} + (accept (leq 5) 6) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:199: " +{-# LINE 199 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 199 "src/Test/HMock/Predicates.hs" #-} + (accept (just (eq "value")) Nothing) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:201: " +{-# LINE 201 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 201 "src/Test/HMock/Predicates.hs" #-} + (accept (just (eq "value")) (Just "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:203: " +{-# LINE 203 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 203 "src/Test/HMock/Predicates.hs" #-} + (accept (just (eq "value")) (Just "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:215: " +{-# LINE 215 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 215 "src/Test/HMock/Predicates.hs" #-} + (accept (left (eq "value")) (Left "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:217: " +{-# LINE 217 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 217 "src/Test/HMock/Predicates.hs" #-} + (accept (left (eq "value")) (Right "value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:219: " +{-# LINE 219 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 219 "src/Test/HMock/Predicates.hs" #-} + (accept (left (eq "value")) (Left "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:231: " +{-# LINE 231 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 231 "src/Test/HMock/Predicates.hs" #-} + (accept (right (eq "value")) (Right "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:233: " +{-# LINE 233 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 233 "src/Test/HMock/Predicates.hs" #-} + (accept (right (eq "value")) (Right "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:235: " +{-# LINE 235 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 235 "src/Test/HMock/Predicates.hs" #-} + (accept (right (eq "value")) (Left "value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:247: " +{-# LINE 247 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 247 "src/Test/HMock/Predicates.hs" #-} + (accept (zipP (eq "foo") (eq "bar")) ("foo", "bar")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:249: " +{-# LINE 249 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 249 "src/Test/HMock/Predicates.hs" #-} + (accept (zipP (eq "foo") (eq "bar")) ("bar", "foo")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:261: " +{-# LINE 261 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 261 "src/Test/HMock/Predicates.hs" #-} + (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:263: " +{-# LINE 263 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 263 "src/Test/HMock/Predicates.hs" #-} + (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:275: " +{-# LINE 275 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 275 "src/Test/HMock/Predicates.hs" #-} + (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:277: " +{-# LINE 277 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 277 "src/Test/HMock/Predicates.hs" #-} + (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:295: " +{-# LINE 295 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 295 "src/Test/HMock/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.Predicates:297: " +{-# LINE 297 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 297 "src/Test/HMock/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.Predicates:316: " +{-# LINE 316 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 316 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "eta") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:318: " +{-# LINE 318 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 318 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "quz") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:320: " +{-# LINE 320 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 320 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "alpha") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:331: " +{-# LINE 331 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 331 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "eta") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:333: " +{-# LINE 333 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 333 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "quz") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:335: " +{-# LINE 335 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 335 "src/Test/HMock/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "alpha") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:347: " +{-# LINE 347 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 347 "src/Test/HMock/Predicates.hs" #-} + (accept (notP (eq "negative")) "positive") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:349: " +{-# LINE 349 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 349 "src/Test/HMock/Predicates.hs" #-} + (accept (notP (eq "negative")) "negative") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:360: " +{-# LINE 360 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 360 "src/Test/HMock/Predicates.hs" #-} + (accept (startsWith "fun") "fungible") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:362: " +{-# LINE 362 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 362 "src/Test/HMock/Predicates.hs" #-} + (accept (startsWith "gib") "fungible") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:373: " +{-# LINE 373 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 373 "src/Test/HMock/Predicates.hs" #-} + (accept (endsWith "ow") "crossbow") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:375: " +{-# LINE 375 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 375 "src/Test/HMock/Predicates.hs" #-} + (accept (endsWith "ow") "trebuchet") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:387: " +{-# LINE 387 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 387 "src/Test/HMock/Predicates.hs" #-} + (accept (hasSubstr "i") "team") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:389: " +{-# LINE 389 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 389 "src/Test/HMock/Predicates.hs" #-} + (accept (hasSubstr "i") "partnership") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:401: " +{-# LINE 401 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 401 "src/Test/HMock/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:403: " +{-# LINE 403 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 403 "src/Test/HMock/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:405: " +{-# LINE 405 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 405 "src/Test/HMock/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:417: " +{-# LINE 417 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 417 "src/Test/HMock/Predicates.hs" #-} + (accept (caseInsensitive startsWith "foo") "FOOTBALL!") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:419: " +{-# LINE 419 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 419 "src/Test/HMock/Predicates.hs" #-} + (accept (caseInsensitive endsWith "ball") "soccer") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:421: " +{-# LINE 421 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 421 "src/Test/HMock/Predicates.hs" #-} + (accept (caseInsensitive eq "time") "TIME") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:423: " +{-# LINE 423 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 423 "src/Test/HMock/Predicates.hs" #-} + (accept (caseInsensitive gt "NOTHING") "everything") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:448: " +{-# LINE 448 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 448 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "xxxy") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:450: " +{-# LINE 450 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 450 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "xyy") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:452: " +{-# LINE 452 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 452 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "wxxxyz") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:475: " +{-# LINE 475 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 475 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:477: " +{-# LINE 477 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 477 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:479: " +{-# LINE 479 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 479 "src/Test/HMock/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:508: " +{-# LINE 508 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 508 "src/Test/HMock/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "xxxy") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:510: " +{-# LINE 510 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 510 "src/Test/HMock/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "xyy") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:512: " +{-# LINE 512 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 512 "src/Test/HMock/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "wxxxyz") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:533: " +{-# LINE 533 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 533 "src/Test/HMock/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:535: " +{-# LINE 535 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 535 "src/Test/HMock/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:537: " +{-# LINE 537 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 537 "src/Test/HMock/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:558: " +{-# LINE 558 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 558 "src/Test/HMock/Predicates.hs" #-} + (accept isEmpty []) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:560: " +{-# LINE 560 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 560 "src/Test/HMock/Predicates.hs" #-} + (accept isEmpty [1, 2, 3]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:562: " +{-# LINE 562 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 562 "src/Test/HMock/Predicates.hs" #-} + (accept isEmpty "") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:564: " +{-# LINE 564 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 564 "src/Test/HMock/Predicates.hs" #-} + (accept isEmpty "gas tank") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:575: " +{-# LINE 575 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 575 "src/Test/HMock/Predicates.hs" #-} + (accept nonEmpty []) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:577: " +{-# LINE 577 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 577 "src/Test/HMock/Predicates.hs" #-} + (accept nonEmpty [1, 2, 3]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:579: " +{-# LINE 579 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 579 "src/Test/HMock/Predicates.hs" #-} + (accept nonEmpty "") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:581: " +{-# LINE 581 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 581 "src/Test/HMock/Predicates.hs" #-} + (accept nonEmpty "gas tank") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:593: " +{-# LINE 593 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 593 "src/Test/HMock/Predicates.hs" #-} + (accept (sizeIs (lt 3)) ['a' .. 'f']) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:595: " +{-# LINE 595 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 595 "src/Test/HMock/Predicates.hs" #-} + (accept (sizeIs (lt 3)) ['a' .. 'b']) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:607: " +{-# LINE 607 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 607 "src/Test/HMock/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:609: " +{-# LINE 609 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 609 "src/Test/HMock/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:611: " +{-# LINE 611 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 611 "src/Test/HMock/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:625: " +{-# LINE 625 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 625 "src/Test/HMock/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:627: " +{-# LINE 627 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 627 "src/Test/HMock/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:629: " +{-# LINE 629 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 629 "src/Test/HMock/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:631: " +{-# LINE 631 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 631 "src/Test/HMock/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:647: " +{-# LINE 647 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 647 "src/Test/HMock/Predicates.hs" #-} + (accept (each (gt 5)) [4, 5, 6]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:649: " +{-# LINE 649 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 649 "src/Test/HMock/Predicates.hs" #-} + (accept (each (gt 5)) [6, 7, 8]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:651: " +{-# LINE 651 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 651 "src/Test/HMock/Predicates.hs" #-} + (accept (each (gt 5)) []) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:663: " +{-# LINE 663 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 663 "src/Test/HMock/Predicates.hs" #-} + (accept (contains (gt 5)) [3, 4, 5]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:665: " +{-# LINE 665 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 665 "src/Test/HMock/Predicates.hs" #-} + (accept (contains (gt 5)) [4, 5, 6]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:667: " +{-# LINE 667 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 667 "src/Test/HMock/Predicates.hs" #-} + (accept (contains (gt 5)) []) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:681: " +{-# LINE 681 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 681 "src/Test/HMock/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:683: " +{-# LINE 683 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 683 "src/Test/HMock/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["foo"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:685: " +{-# LINE 685 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 685 "src/Test/HMock/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:698: " +{-# LINE 698 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 698 "src/Test/HMock/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:700: " +{-# LINE 700 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 700 "src/Test/HMock/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:702: " +{-# LINE 702 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 702 "src/Test/HMock/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:714: " +{-# LINE 714 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 714 "src/Test/HMock/Predicates.hs" #-} + (accept (containsKey (eq "foo")) [("foo", 1), ("bar", 2)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:716: " +{-# LINE 716 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 716 "src/Test/HMock/Predicates.hs" #-} + (accept (containsKey (eq "foo")) [("bar", 1), ("qux", 2)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:729: " +{-# LINE 729 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 729 "src/Test/HMock/Predicates.hs" #-} + (accept (containsEntry (eq "foo") (gt 10)) [("foo", 12), ("bar", 5)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:731: " +{-# LINE 731 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 731 "src/Test/HMock/Predicates.hs" #-} + (accept (containsEntry (eq "foo") (gt 10)) [("foo", 5), ("bar", 12)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:733: " +{-# LINE 733 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 733 "src/Test/HMock/Predicates.hs" #-} + (accept (containsEntry (eq "foo") (gt 10)) [("bar", 12)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:746: " +{-# LINE 746 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 746 "src/Test/HMock/Predicates.hs" #-} + (accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("b", 2), ("c", 3)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:748: " +{-# LINE 748 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 748 "src/Test/HMock/Predicates.hs" #-} + (accept (keysAre [eq "a", eq "b", eq "c"]) [("c", 1), ("b", 2), ("a", 3)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:750: " +{-# LINE 750 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 750 "src/Test/HMock/Predicates.hs" #-} + (accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("c", 3)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:752: " +{-# LINE 752 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 752 "src/Test/HMock/Predicates.hs" #-} + (accept (keysAre [eq "a", eq "b"]) [("a", 1), ("b", 2), ("c", 3)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:768: " +{-# LINE 768 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 768 "src/Test/HMock/Predicates.hs" #-} + (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:770: " +{-# LINE 770 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 770 "src/Test/HMock/Predicates.hs" #-} + (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(3, 4), (1, 2)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:772: " +{-# LINE 772 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 772 "src/Test/HMock/Predicates.hs" #-} + (accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 4), (3, 2)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:774: " +{-# LINE 774 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 774 "src/Test/HMock/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.Predicates:795: " +{-# LINE 795 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 795 "src/Test/HMock/Predicates.hs" #-} + (accept (eq 1.0) (sum (replicate 100 0.01))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:802: " +{-# LINE 802 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 802 "src/Test/HMock/Predicates.hs" #-} + (accept (approxEq 1.0) (sum (replicate 100 0.01))) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:804: " +{-# LINE 804 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 804 "src/Test/HMock/Predicates.hs" #-} + (accept (approxEq 1.0) (sum (replicate 100 0.009999))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:817: " +{-# LINE 817 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 817 "src/Test/HMock/Predicates.hs" #-} + (accept finite 1.0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:819: " +{-# LINE 819 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 819 "src/Test/HMock/Predicates.hs" #-} + (accept finite (0 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:821: " +{-# LINE 821 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 821 "src/Test/HMock/Predicates.hs" #-} + (accept finite (1 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:832: " +{-# LINE 832 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 832 "src/Test/HMock/Predicates.hs" #-} + (accept infinite 1.0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:834: " +{-# LINE 834 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 834 "src/Test/HMock/Predicates.hs" #-} + (accept infinite (0 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:836: " +{-# LINE 836 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 836 "src/Test/HMock/Predicates.hs" #-} + (accept infinite (1 / 0)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:847: " +{-# LINE 847 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 847 "src/Test/HMock/Predicates.hs" #-} + (accept nAn 1.0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:849: " +{-# LINE 849 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 849 "src/Test/HMock/Predicates.hs" #-} + (accept nAn (0 / 0)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:851: " +{-# LINE 851 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 851 "src/Test/HMock/Predicates.hs" #-} + (accept nAn (1 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:864: " +{-# LINE 864 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 864 "src/Test/HMock/Predicates.hs" #-} + (accept (is even) 3) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:866: " +{-# LINE 866 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 866 "src/Test/HMock/Predicates.hs" #-} + (accept (is even) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:879: " +{-# LINE 879 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 879 "src/Test/HMock/Predicates.hs" #-} + (accept $(qIs [| even |]) 3) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:881: " +{-# LINE 881 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 881 "src/Test/HMock/Predicates.hs" #-} + (accept $(qIs [| even |]) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:884: " +{-# LINE 884 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 884 "src/Test/HMock/Predicates.hs" #-} + (show $(qIs [| even |])) + [ExpectedLine [LineChunk "\"even\""]] + DocTest.printPrefix "Test.HMock.Predicates:898: " +{-# LINE 898 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 898 "src/Test/HMock/Predicates.hs" #-} + (accept (with abs (gt 5)) (-6)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:900: " +{-# LINE 900 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 900 "src/Test/HMock/Predicates.hs" #-} + (accept (with abs (gt 5)) (-5)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:902: " +{-# LINE 902 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 902 "src/Test/HMock/Predicates.hs" #-} + (accept (with reverse (eq "olleh")) "hello") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:904: " +{-# LINE 904 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 904 "src/Test/HMock/Predicates.hs" #-} + (accept (with reverse (eq "olleh")) "goodbye") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:918: " +{-# LINE 918 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 918 "src/Test/HMock/Predicates.hs" #-} + (accept ($(qWith [| abs |]) (gt 5)) (-6)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:920: " +{-# LINE 920 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 920 "src/Test/HMock/Predicates.hs" #-} + (accept ($(qWith [| abs |]) (gt 5)) (-5)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:922: " +{-# LINE 922 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 922 "src/Test/HMock/Predicates.hs" #-} + (accept ($(qWith [| reverse |]) (eq "olleh")) "hello") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:924: " +{-# LINE 924 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 924 "src/Test/HMock/Predicates.hs" #-} + (accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:927: " +{-# LINE 927 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 927 "src/Test/HMock/Predicates.hs" #-} + (show ($(qWith [| abs |]) (gt 5))) + [ExpectedLine [LineChunk "\"abs: > 5\""]] + DocTest.printPrefix "Test.HMock.Predicates:943: " +{-# LINE 943 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 943 "src/Test/HMock/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) Nothing) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:945: " +{-# LINE 945 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 945 "src/Test/HMock/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) (Just (Left 5))) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:947: " +{-# LINE 947 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 947 "src/Test/HMock/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) (Just (Right 5))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:950: " +{-# LINE 950 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 950 "src/Test/HMock/Predicates.hs" #-} + (show $(qMatch [p| Just (Left _) |])) + [ExpectedLine [LineChunk "\"Just (Left _)\""]] + DocTest.printPrefix "Test.HMock.Predicates:966: " +{-# LINE 966 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 966 "src/Test/HMock/Predicates.hs" #-} + (accept (typed @String anything) "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.HMock.Predicates:968: " +{-# LINE 968 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 968 "src/Test/HMock/Predicates.hs" #-} + (accept (typed @String (sizeIs (gt 5))) "foo") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.HMock.Predicates:970: " +{-# LINE 970 "src/Test/HMock/Predicates.hs" #-} + DocTest.example +{-# LINE 970 "src/Test/HMock/Predicates.hs" #-} + (accept (typed @String anything) (42 :: Int)) + [ExpectedLine [LineChunk "False"]] diff --git a/test/ExpectSet.hs b/test/ExpectSet.hs --- a/test/ExpectSet.hs +++ b/test/ExpectSet.hs @@ -6,7 +6,7 @@ import Control.Arrow (second) import Data.List (foldl') import Test.HMock.Internal.ExpectSet -import Test.HMock.Internal.Multiplicity +import Test.HMock.Multiplicity import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -48,7 +48,10 @@ ++ [e] instance Arbitrary Multiplicity where - arbitrary = normalize <$> (Multiplicity <$> arbitrary <*> arbitrary) + arbitrary = + between + <$> (fromInteger <$> arbitrary) + <*> (fromInteger . getNonNegative <$> arbitrary) liveSteps' :: ExpectSet step -> [(step, ExpectSet step)] liveSteps' = map (second simplify) . liveSteps diff --git a/test/Extras.hs b/test/Extras.hs --- a/test/Extras.hs +++ b/test/Extras.hs @@ -6,12 +6,14 @@ import Data.List (isPrefixOf) import Data.Typeable (Typeable) import Test.HMock -import Test.HMock.Internal.Multiplicity import Test.Hspec import Test.QuickCheck hiding (once) instance Arbitrary Multiplicity where - arbitrary = normalize <$> (Multiplicity <$> arbitrary <*> arbitrary) + arbitrary = + between + <$> (fromInteger <$> arbitrary) + <*> (fromInteger . getNonNegative <$> arbitrary) multiplicityTests :: SpecWith () multiplicityTests = do diff --git a/test/QuasiMock.hs b/test/QuasiMock.hs --- a/test/QuasiMock.hs +++ b/test/QuasiMock.hs @@ -1,32 +1,20 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module QuasiMock where +module QuasiMock (module QuasiMock, module QuasiMockBase) where import Control.Monad.Trans (MonadIO, liftIO) import Data.Default (Default (..)) import Data.Generics (Typeable, everything, mkQ) import Language.Haskell.TH hiding (Match) import Language.Haskell.TH.Syntax hiding (Match) +import QuasiMockBase import Test.HMock -import Test.HMock.TH (deriveMockableBase) -import Util.TH (reifyInstancesStatic, reifyStatic) #if !MIN_VERSION_base(4, 13, 0) import Control.Monad.Fail (MonadFail) #endif -deriveMockableBase ''Quasi - -- Because not all methods of Quasi are mockable, the instance must be written -- by hand. instance (Typeable m, MonadFail m, MonadIO m) => Quasi (MockT m) where @@ -75,58 +63,42 @@ instance Mockable Quasi where setupMockable _ = do - expectAny $ QIsExtEnabled_ anything |-> True + allowUnexpected $ QIsExtEnabled_ anything |-> True - expectAny $ QReify ''String |-> $(reifyStatic ''String) - expectAny $ QReify ''Char |-> $(reifyStatic ''Char) - expectAny $ QReify ''Int |-> $(reifyStatic ''Int) - expectAny $ QReify ''Bool |-> $(reifyStatic ''Bool) - expectAny $ QReify ''Enum |-> $(reifyStatic ''Enum) - expectAny $ QReify ''Monad |-> $(reifyStatic ''Monad) - expectAny $ - QReifyInstances ''Show [ConT ''String] - |-> $(reifyInstancesStatic ''Show [ConT ''String]) - expectAny $ - QReifyInstances ''Eq [ConT ''String] - |-> $(reifyInstancesStatic ''Eq [ConT ''String]) - expectAny $ - QReifyInstances ''Show [ConT ''Char] - |-> $(reifyInstancesStatic ''Show [ConT ''Char]) - expectAny $ - QReifyInstances ''Eq [ConT ''Char] - |-> $(reifyInstancesStatic ''Eq [ConT ''Char]) - expectAny $ - QReifyInstances ''Show [ConT ''Int] - |-> $(reifyInstancesStatic ''Show [ConT ''Int]) - expectAny $ - QReifyInstances ''Eq [ConT ''Int] - |-> $(reifyInstancesStatic ''Eq [ConT ''Int]) - expectAny $ - QReifyInstances ''Show [ConT ''Bool] - |-> $(reifyInstancesStatic ''Show [ConT ''Bool]) - expectAny $ - QReifyInstances ''Eq [ConT ''Bool] - |-> $(reifyInstancesStatic ''Eq [ConT ''Bool]) - expectAny $ - QReifyInstances ''Default [TupleT 0] - |-> $(reifyInstancesStatic ''Default [TupleT 0]) - expectAny $ - QReifyInstances ''Default [ConT ''String] - |-> $(reifyInstancesStatic ''Default [ConT ''String]) - expectAny $ - QReifyInstances ''Default [ConT ''Int] - |-> $(reifyInstancesStatic ''Default [ConT ''Int]) - expectAny $ - QReifyInstances ''Default [AppT (ConT ''Maybe) (ConT ''Bool)] - |-> $(reifyInstancesStatic ''Default [AppT (ConT ''Maybe) (ConT ''Bool)]) - expectAny $ - QReifyInstances_ (eq ''Show) (is functionType) |-> [] - expectAny $ - QReifyInstances_ (eq ''Eq) (is functionType) |-> [] + $(onReify [|allowUnexpected|] ''String) + $(onReify [|allowUnexpected|] ''Char) + $(onReify [|allowUnexpected|] ''Int) + $(onReify [|allowUnexpected|] ''Bool) + $(onReify [|allowUnexpected|] ''Enum) + $(onReify [|allowUnexpected|] ''Monad) - expectAny $ - QReifyInstances_ (eq ''Show) (elemsAre [$(qMatch [p|AppT ListT (VarT _)|])]) - |-> $(reifyInstancesStatic ''Show [AppT ListT (VarT (mkName "a_0"))]) - expectAny $ - QReifyInstances_ (eq ''Eq) (elemsAre [$(qMatch [p|AppT ListT (VarT _)|])]) - |-> $(reifyInstancesStatic ''Eq [AppT ListT (VarT (mkName "a_0"))]) + $(onReifyInstances [|allowUnexpected|] ''Show [ConT ''String]) + $(onReifyInstances [|allowUnexpected|] ''Eq [ConT ''String]) + $(onReifyInstances [|allowUnexpected|] ''Show [ConT ''Char]) + $(onReifyInstances [|allowUnexpected|] ''Eq [ConT ''Char]) + $(onReifyInstances [|allowUnexpected|] ''Show [ConT ''Int]) + $(onReifyInstances [|allowUnexpected|] ''Eq [ConT ''Int]) + $(onReifyInstances [|allowUnexpected|] ''Show [ConT ''Bool]) + $(onReifyInstances [|allowUnexpected|] ''Eq [ConT ''Bool]) + $(onReifyInstances [|allowUnexpected|] ''Default [TupleT 0]) + $(onReifyInstances [|allowUnexpected|] ''Default [ConT ''String]) + $(onReifyInstances [|allowUnexpected|] ''Default [ConT ''Int]) + $( onReifyInstances + [|allowUnexpected|] + ''Default + [AppT (ConT ''Maybe) (ConT ''Bool)] + ) + + allowUnexpected $ QReifyInstances_ (eq ''Show) (is functionType) |-> [] + allowUnexpected $ QReifyInstances_ (eq ''Eq) (is functionType) |-> [] + + allowUnexpected $ + QReifyInstances_ + (eq ''Show) + (elemsAre [$(qMatch [p|AppT ListT (VarT _)|])]) + |-> $(reifyInstancesStatic ''Show [AppT ListT (VarT (mkName "a"))]) + allowUnexpected $ + QReifyInstances_ + (eq ''Eq) + (elemsAre [$(qMatch [p|AppT ListT (VarT _)|])]) + |-> $(reifyInstancesStatic ''Eq [AppT ListT (VarT (mkName "a"))]) diff --git a/test/QuasiMockBase.hs b/test/QuasiMockBase.hs new file mode 100644 --- /dev/null +++ b/test/QuasiMockBase.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module QuasiMockBase where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Test.HMock.TH (deriveMockableBase) +import Util.DeriveRecursive (deriveRecursive) + +#if MIN_VERSION_template_haskell(2, 16, 0) +-- Pre-define low-level instance to prevent deriveRecursive from trying. +instance Lift Bytes where lift = undefined; liftTyped = undefined +#endif + +deriveRecursive Nothing ''Lift ''Info + +deriveMockableBase ''Quasi + +reifyStatic :: Name -> Q Exp +reifyStatic n = reify n >>= lift + +onReify :: Q Exp -> Name -> Q Exp +onReify handler n = do + result <- reify n + [| $handler (QReify $(lift n) |-> $(lift result))|] + +deriveRecursive Nothing ''Lift ''InstanceDec + +reifyInstancesStatic :: Name -> [Type] -> Q Exp +reifyInstancesStatic n ts = reifyInstances n ts >>= lift + +onReifyInstances :: Q Exp -> Name -> [Type] -> Q Exp +onReifyInstances handler n ts = do + result <- reifyInstances n ts + [|$handler (QReifyInstances $(lift n) $(lift ts) |-> $(lift result))|] diff --git a/test/TH.hs b/test/TH.hs --- a/test/TH.hs +++ b/test/TH.hs @@ -8,9 +8,8 @@ import Language.Haskell.TH import QuasiMock import Test.HMock -import Test.HMock.Internal.TH.Util (resolveInstance, unifyTypes) +import Test.HMock.Internal.TH (resolveInstance, unifyTypes) import Test.Hspec -import Util.TH (reifyInstancesStatic, reifyStatic) data NotShowable @@ -66,21 +65,11 @@ it "recognizes when a nested type lacks instance" $ example $ runMockT $ do - expectAny $ QReify ''NotShowable |-> $(reifyStatic ''NotShowable) - expectAny $ - QReifyInstances ''Show [ConT ''NotShowable] - |-> $(reifyInstancesStatic ''Show [ConT ''NotShowable]) - expectAny $ - QReifyInstances - ''Show - [AppT (AppT (TupleT 2) (ConT ''Int)) (ConT ''NotShowable)] - |-> $( reifyInstancesStatic - ''Show - [ AppT - (AppT (TupleT 2) (ConT ''Int)) - (ConT ''NotShowable) - ] - ) + $(onReify [|expectAny|] ''NotShowable) + $(onReifyInstances [|expectAny|] ''Show [ConT ''NotShowable]) + $( [t|(Int, NotShowable)|] + >>= onReifyInstances [|expectAny|] ''Show . (: []) + ) t <- runQ [t|(Int, NotShowable)|] result <- runQ $ resolveInstance ''Show t diff --git a/test/Util/TH.hs b/test/Util/TH.hs deleted file mode 100644 --- a/test/Util/TH.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module Util.TH (deriveRecursive, reifyStatic, reifyInstancesStatic) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Util.DeriveRecursive (deriveRecursive) - -#if MIN_VERSION_template_haskell(2, 16, 0) --- Pre-define low-level instance to prevent deriveRecursive from trying. -instance Lift Bytes where lift = undefined; liftTyped = undefined -#endif - -deriveRecursive Nothing ''Lift ''Info - -reifyStatic :: Name -> Q Exp -reifyStatic n = reify n >>= lift - -deriveRecursive Nothing ''Lift ''InstanceDec - -reifyInstancesStatic :: Name -> [Type] -> Q Exp -reifyInstancesStatic n ts = reifyInstances n ts >>= lift