HMock (empty) → 0.1.0.0
raw patch · 29 files changed
+6669/−0 lines, 29 filesdep +HMockdep +QuickCheckdep +base
Dependencies added: HMock, QuickCheck, base, constraints, containers, data-default, deepseq, directory, doctest-exitcode-stdio, doctest-lib, exceptions, extra, hspec, monad-control, mono-traversable, mtl, polysemy, polysemy-plugin, regex-tdfa, syb, template-haskell, transformers-base, unliftio
Files
- CHANGELOG.md +5/−0
- HMock.cabal +96/−0
- LICENSE +30/−0
- src/Test/HMock.hs +150/−0
- src/Test/HMock/Internal/ExpectSet.hs +204/−0
- src/Test/HMock/Internal/Expectable.hs +342/−0
- src/Test/HMock/Internal/MockT.hs +301/−0
- src/Test/HMock/Internal/MockT.hs-boot +12/−0
- src/Test/HMock/Internal/Mockable.hs +55/−0
- src/Test/HMock/Internal/Multiplicity.hs +153/−0
- src/Test/HMock/Internal/Predicates.hs +944/−0
- src/Test/HMock/Internal/TH.hs +697/−0
- src/Test/HMock/Internal/TH/Util.hs +208/−0
- src/Test/HMock/Internal/Util.hs +30/−0
- src/Test/HMock/TH.hs +40/−0
- test/Classes.hs +787/−0
- test/Core.hs +615/−0
- test/Demo.hs +244/−0
- test/DocTests/All.hs +12/−0
- test/DocTests/Test/HMock/Internal/Multiplicity.hs +166/−0
- test/DocTests/Test/HMock/Internal/Predicates.hs +898/−0
- test/ExpectSet.hs +127/−0
- test/Extras.hs +165/−0
- test/Main.hs +21/−0
- test/PolysemyTest.hs +65/−0
- test/QuasiMock.hs +132/−0
- test/TH.hs +87/−0
- test/Util/DeriveRecursive.hs +58/−0
- test/Util/TH.hs +25/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hmock++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ HMock.cabal view
@@ -0,0 +1,96 @@+cabal-version: 2.4+name: HMock+version: 0.1.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+ actions that can or should be performed and their results,+ and then verify those expectations when the test is+ complete.+ .+ For more information, see the module documentation for+ "Test.HMock".+category: Testing+homepage: https://github.com/cdsmith/HMock+bug-reports: https://github.com/cdsmith/HMock/issues+license: BSD-3-Clause+license-file: LICENSE++author: Chris Smith <cdsmith@gmail.com>+maintainer: Chris Smith <cdsmith@gmail.com>++extra-source-files: CHANGELOG.md++tested-with: GHC == 8.4.4 || == 8.6.5 || == 8.8.4 || == 8.10.4 || == 9.0.1++source-repository head+ type: git+ location: git://github.com/cdsmith/HMock.git++library+ exposed-modules: Test.HMock,+ 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.TH,+ Test.HMock.Internal.TH.Util,+ Test.HMock.Internal.Util+ build-depends: base >=4.11.0 && < 4.16,+ constraints >= 0.13 && < 0.14,+ containers >= 0.6.2 && < 0.7,+ data-default >= 0.7.1 && < 0.8,+ exceptions >= 0.10.4 && < 0.11,+ extra >= 1.7.9 && < 1.8,+ monad-control >= 1.0.2 && < 1.1,+ mono-traversable >= 1.0.15 && < 1.1,+ mtl >= 2.2.2 && < 2.3,+ regex-tdfa >= 1.3.1 && < 1.4,+ syb >= 0.7.2 && < 0.8,+ template-haskell >= 2.13.0 && < 2.18,+ transformers-base >= 0.4.5 && < 0.5,+ unliftio >= 0.2.18 && < 0.3,+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Classes,+ Core,+ Demo,+ DocTests.All,+ DocTests.Test.HMock.Internal.Multiplicity,+ DocTests.Test.HMock.Internal.Predicates,+ ExpectSet,+ Extras,+ PolysemyTest,+ QuasiMock,+ TH,+ Util.DeriveRecursive,+ Util.TH+ build-depends: HMock,+ QuickCheck,+ base,+ containers,+ data-default,+ deepseq,+ directory,+ doctest-exitcode-stdio,+ doctest-lib,+ exceptions,+ extra,+ hspec,+ mtl,+ polysemy,+ polysemy-plugin,+ syb,+ template-haskell,+ unliftio+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall -Wcompat -Wincomplete-uni-patterns -Wno-orphans
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Chris Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Chris Smith nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ src/Test/HMock.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+--+-- This module provides a monad transformer, 'MockT', which can be used to test+-- with mocks of Haskell @mtl@-style type classes. To use a mock, you define+-- the expected actions and their results, and then run the code you are+-- testing. The framework verifies that the behavior of the code matched your+-- expectations.+--+-- For an introduction to the idea of mocks, see+-- <https://martinfowler.com/articles/mocksArentStubs.html Mocks Aren't Stubs>,+-- by Martin Fowler.+--+-- WARNING: Hmock's API is likely to change soon. Please ensure you use an+-- upper bound on the version number. The current API works fine for mocking+-- with MTL-style classes. I want HMock to also work with effect systems,+-- servant, haxl, and more. To accomplish this, I'll need to make breaking+-- changes to the API.+--+-- Suppose you have a @MonadFilesystem@ typeclass, which is instantiated by+-- monads that implement filesystem operations:+--+-- @+-- class 'Monad' m => MonadFilesystem m where+-- readFile :: 'FilePath' -> m 'String'+-- writeFile :: 'FilePath' -> 'String' -> m ()+-- @+--+-- You can use HMock to test code using @MonadFilesystem@ like this:+--+-- @+-- copyFile :: MonadFilesystem m => 'FilePath' -> 'FilePath' -> m ()+-- copyFile a b = readFile a >>= writeFile b+--+-- 'Test.HMock.TH.makeMockable' ''MonadFilesystem+--+-- spec = describe "copyFile" '$'+-- it "reads a file and writes its contents to another file" '$'+-- 'runMockT' '$' do+-- 'expect' '$' ReadFile "foo.txt" '|->' "contents"+-- 'expect' '$' WriteFile "bar.txt" "contents" '|->' ()+-- copyFile "foo.txt" "bar.txt"+-- @+--+-- The Template Haskell splice, 'Test.HMock.TH.makeMockable', generates the+-- boilerplate needed to use @MonadFilesystem@ with HMock. You then use+-- '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,++ -- * Setting expectations+ MockableMethod,+ Expectable (..),+ Rule,+ (|=>),+ (|->),+ ExpectContext,+ expect,+ expectN,+ expectAny,+ inSequence,+ inAnyOrder,+ anyOf,+ times,+ consecutiveTimes,++ -- * 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,++ -- * Multiplicity+ Multiplicity,+ meetsMultiplicity,+ once,+ anyMultiplicity,+ atLeast,+ atMost,+ between,++ -- * Implementing mocks+ MockableBase (..),+ Mockable (..),+ MatchResult (..),+ mockMethod,+ mockDefaultlessMethod,+ )+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
+ src/Test/HMock/Internal/ExpectSet.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.HMock.Internal.ExpectSet where++import Test.HMock.Internal.Multiplicity+ ( Multiplicity,+ between,+ exhaustable,+ feasible,+ normalize,+ )++-- | A set of expected steps and their responses. This is the "core" language+-- of expectations for HMock. It's based roughly on Svenningsson, Svensson,+-- Smallbone, Arts, Norell, and Hughes' Expressive Semantics of Mocking.+-- However, there are a few small adjustments. We have two repetition operators+-- which respectively represent general repetition with interleaving, and+-- consecutive repetition. We also attach arbitrary multiplicities to+-- repetition.+data ExpectSet step where+ ExpectStep :: step -> ExpectSet step+ ExpectNothing :: ExpectSet step+ ExpectSequence :: ExpectSet step -> ExpectSet step -> ExpectSet step+ ExpectInterleave :: ExpectSet step -> ExpectSet step -> ExpectSet step+ ExpectEither :: ExpectSet step -> ExpectSet step -> ExpectSet step+ ExpectMulti :: Multiplicity -> ExpectSet step -> ExpectSet step+ ExpectConsecutive :: Multiplicity -> ExpectSet step -> ExpectSet step+ deriving (Show, Eq)++-- | Checks whether an ExpectSet is in an "accepting" state. In other words, is+-- it okay for the test to end here? If False, then there are still+-- expectations that must be satisfied before the test can succeed.+satisfied :: ExpectSet step -> Bool+satisfied (ExpectStep _) = False+satisfied ExpectNothing = True+satisfied (ExpectSequence e f) = satisfied e && satisfied f+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)+satisfied (ExpectConsecutive mult e) =+ feasible mult && (exhaustable mult || 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+-- each case?+liveSteps :: ExpectSet step -> [(step, ExpectSet step)]+liveSteps (ExpectStep step) = [(step, ExpectNothing)]+liveSteps ExpectNothing = []+liveSteps (ExpectSequence e f) =+ (fmap (`ExpectSequence` f) <$> liveSteps e)+ ++ if satisfied e then liveSteps f else []+liveSteps (ExpectInterleave e f) =+ (fmap (`ExpectInterleave` f) <$> liveSteps e)+ ++ (fmap (ExpectInterleave e) <$> liveSteps f)+liveSteps (ExpectEither e f) = liveSteps e ++ liveSteps f+liveSteps (ExpectMulti mult e)+ | feasible (mult - 1) =+ [ (step, ExpectInterleave f (ExpectMulti (mult - 1) e))+ | (step, f) <- liveSteps e+ ]+ | otherwise = []+liveSteps (ExpectConsecutive mult e)+ | feasible (mult - 1) =+ [ (step, ExpectSequence f (ExpectConsecutive (mult - 1) e))+ | (step, f) <- liveSteps e+ ]+ | otherwise = []++-- | Performs a complete simplification of the ExpectSet. This could be slow,+-- but we intend to do it only for error messages, so it need not be very fast.+simplify :: ExpectSet step -> ExpectSet step+simplify (ExpectSequence e f)+ | ExpectNothing <- e' = f'+ | ExpectNothing <- f' = e'+ | ExpectSequence e1 e2 <- e' =+ simplify (ExpectSequence e1 (ExpectSequence e2 f'))+ | otherwise = ExpectSequence e' f'+ where+ e' = simplify e+ f' = simplify f+simplify (ExpectInterleave e f)+ | ExpectNothing <- e' = f'+ | ExpectNothing <- f' = e'+ | ExpectInterleave e1 e2 <- e' =+ simplify (ExpectInterleave e1 (ExpectInterleave e2 f'))+ | otherwise = ExpectInterleave e' f'+ where+ e' = simplify e+ f' = simplify f+simplify (ExpectEither e f)+ | ExpectNothing <- e', ExpectNothing <- f' = ExpectNothing+ | ExpectNothing <- e' = simplify (ExpectEither f' ExpectNothing)+ | ExpectEither e1 e2 <- e' =+ simplify (ExpectEither e1 (ExpectEither e2 f'))+ | ExpectNothing <- f', satisfied e' = e'+ | ExpectNothing <- f' = simplify (ExpectMulti (between 0 1) e')+ | otherwise = ExpectEither e' f'+ where+ e' = simplify e+ f' = simplify f+simplify (ExpectMulti m e)+ | not (feasible m) = ExpectMulti m ExpectNothing + | ExpectNothing <- e' = ExpectNothing+ | m == 0 = ExpectNothing+ | m == 1 = e'+ | otherwise = ExpectMulti (normalize m) e'+ where+ e' = simplify e+simplify (ExpectConsecutive m e)+ | not (feasible m) = ExpectConsecutive m ExpectNothing + | ExpectNothing <- e' = ExpectNothing+ | m == 0 = ExpectNothing+ | m == 1 = e'+ | otherwise = ExpectConsecutive (normalize m) e'+ where+ e' = simplify e+simplify other = other++-- | Get a list of all steps mentioned by an 'ExpectSet'. This is used to+-- determine which classes need to be initialized before adding an expectation.+getSteps :: ExpectSet step -> [step]+getSteps ExpectNothing = []+getSteps (ExpectStep step) = [step]+getSteps (ExpectInterleave e f) = getSteps e ++ getSteps f+getSteps (ExpectSequence e f) = getSteps e ++ getSteps f+getSteps (ExpectEither e f) = getSteps e ++ getSteps f+getSteps (ExpectMulti _ e) = getSteps e+getSteps (ExpectConsecutive _ e) = getSteps e++-- | A higher-level intermediate form of an ExpectSet suitable for communication+-- with the user. Chains of binary operators are collected into sequences to+-- be displayed in lists rather than arbitrary nesting.+data CollectedSet step where+ CollectedStep :: step -> CollectedSet step+ CollectedNothing :: CollectedSet step+ CollectedSequence :: [CollectedSet step] -> CollectedSet step+ CollectedInterleave :: [CollectedSet step] -> CollectedSet step+ CollectedChoice :: [CollectedSet step] -> CollectedSet step+ CollectedMulti :: Multiplicity -> CollectedSet step -> CollectedSet step+ CollectedConsecutive :: Multiplicity -> CollectedSet step -> CollectedSet step++-- | Collects an ExpectSet into the intermediate form for display. It's assumed+-- that the expression was simplified before this operation.+collect :: ExpectSet step -> CollectedSet step+collect (ExpectStep s) = CollectedStep s+collect ExpectNothing = CollectedNothing+collect (ExpectSequence e f) = CollectedSequence (collect e : fs)+ where+ fs = case collect f of+ CollectedSequence f' -> f'+ f' -> [f']+collect (ExpectInterleave e f) = CollectedInterleave (collect e : fs)+ where+ fs = case collect f of+ CollectedInterleave f' -> f'+ f' -> [f']+collect (ExpectEither e f) = CollectedChoice (collect e : fs)+ where+ fs = case collect f of+ CollectedChoice f' -> f'+ f' -> [f']+collect (ExpectMulti m e) = CollectedMulti m (collect e)+collect (ExpectConsecutive m e) = CollectedConsecutive m (collect e)++-- | Converts a set of expectations into a string that summarizes them, with+-- the given prefix (used to indent).+formatExpectSet :: (Show step) => ExpectSet step -> String+formatExpectSet = go "" . collect . simplify+ where+ go prefix CollectedNothing = prefix ++ "* nothing"+ go prefix (CollectedStep step) = prefix ++ "* " ++ show step+ go prefix (CollectedSequence cs) =+ prefix ++ "* in sequence:\n" ++ unlines (map (go (" " ++ prefix)) cs)+ go prefix (CollectedInterleave cs) =+ prefix ++ "* in any order:\n" ++ unlines (map (go (" " ++ prefix)) cs)+ go prefix (CollectedChoice cs) =+ prefix ++ "* any of:\n" ++ unlines (map (go (" " ++ prefix)) cs)+ go prefix (CollectedMulti m e) =+ prefix ++ "* " ++ show m ++ ":\n" ++ go (" " ++ prefix) e+ go prefix (CollectedConsecutive m e) =+ prefix ++ "* " ++ show m ++ " consecutively:\n" ++ go (" " ++ prefix) e++-- | Reduces a set of expectations to the minimum steps that would be required+-- to satisfy the entire set. This weeds out unnecessary information before+-- reporting that there were unmet expectations at the end of the test.+excess :: ExpectSet step -> ExpectSet step+excess = simplify . go+ where+ go (ExpectSequence e f) = ExpectSequence (go e) (go f)+ go (ExpectInterleave e f) = ExpectInterleave (go e) (go f)+ go (ExpectEither e f)+ | satisfied e || satisfied f = ExpectNothing+ | otherwise = ExpectEither (go e) (go f)+ go (ExpectMulti m e)+ | exhaustable m = ExpectNothing+ | otherwise = ExpectMulti m (go e)+ go (ExpectConsecutive m e)+ | exhaustable m = ExpectNothing+ | otherwise = ExpectConsecutive m (go e)+ go other = other
+ src/Test/HMock/Internal/Expectable.hs view
@@ -0,0 +1,342 @@+{-# 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))
+ src/Test/HMock/Internal/MockT.hs view
@@ -0,0 +1,301 @@+{-# 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)
+ src/Test/HMock/Internal/MockT.hs-boot view
@@ -0,0 +1,12 @@+{-# 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)
+ src/Test/HMock/Internal/Mockable.hs view
@@ -0,0 +1,55 @@+{-# 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 ()
+ src/Test/HMock/Internal/Multiplicity.hs view
@@ -0,0 +1,153 @@+{-# 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
+ src/Test/HMock/Internal/Predicates.hs view
@@ -0,0 +1,944 @@+{-# 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+ }
+ src/Test/HMock/Internal/TH.hs view
@@ -0,0 +1,697 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++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,+ )+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)++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."
+ src/Test/HMock/Internal/TH/Util.hs view
@@ -0,0 +1,208 @@+{-# 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
+ src/Test/HMock/Internal/Util.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}++module Test.HMock.Internal.Util where++import Data.MonoTraversable (Element)+import qualified Data.Sequences as Seq+import GHC.Stack (CallStack, getCallStack, prettySrcLoc)++data Located a = Loc (Maybe String) a deriving (Eq, Ord, Functor)++locate :: CallStack -> a -> Located a+locate stack = case map snd (getCallStack stack) of+ (loc : _) -> Loc (Just (prettySrcLoc loc))+ _ -> Loc Nothing++withLoc :: Located String -> String+withLoc (Loc Nothing s) = s+withLoc (Loc (Just loc) s) = s ++ " at " ++ loc++choices :: [a] -> [(a, [a])]+choices [] = []+choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs)++isSubsequenceOf :: (Seq.IsSequence t, Eq (Element t)) => t -> t -> Bool+xs `isSubsequenceOf` ys = case Seq.uncons xs of+ Nothing -> True+ Just (x, xs') -> case Seq.uncons (snd (Seq.break (== x) ys)) of+ Nothing -> False+ Just (_, ys') -> xs' `isSubsequenceOf` ys'
+ src/Test/HMock/TH.hs view
@@ -0,0 +1,40 @@+{- |++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.+-}++module Test.HMock.TH+ ( makeMockable,+ makeMockableWithOptions,+ makeMockableBase,+ makeMockableBaseWithOptions,+ deriveMockable,+ deriveMockableWithOptions,+ deriveMockableBase,+ deriveMockableBaseWithOptions,+ deriveForMockT,+ deriveForMockTWithOptions,+ makeMockableType,+ makeMockableTypeWithOptions,+ makeMockableBaseType,+ makeMockableBaseTypeWithOptions,+ deriveMockableType,+ deriveMockableTypeWithOptions,+ deriveMockableBaseType,+ deriveMockableBaseTypeWithOptions,+ deriveTypeForMockT,+ deriveTypeForMockTWithOptions,+ MockableOptions (..),+ )+where++import Test.HMock.Internal.TH
+ test/Classes.hs view
@@ -0,0 +1,787 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Classes where++import Control.DeepSeq (NFData (rnf))+import Control.Exception (evaluate)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Default (Default (def))+import Data.Dynamic (Typeable)+import Data.Kind (Type)+import Language.Haskell.TH.Syntax hiding (Type)+import QuasiMock (Action (..), Matcher (..))+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++#if MIN_VERSION_template_haskell(2, 16, 0)+-- Pre-define low-level instance to prevent deriveRecursive from trying.+instance NFData Bytes where rnf = undefined+#endif++deriveRecursive (Just AnyclassStrategy) ''NFData ''Dec++class MonadSimple m where+ simple :: String -> m ()++makeMockable ''MonadSimple++simpleTests :: SpecWith ()+simpleTests = describe "MonadSimple" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)++ runQ (makeMockable ''MonadSimple)+ evaluate (rnf decs)++ it "doesn't require unnecessary extensions for simple cases" $+ example . runMockT $ do+ expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)+ expectAny $ QIsExtEnabled ScopedTypeVariables |-> False+ expectAny $ QIsExtEnabled RankNTypes |-> False++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ it "fails when GADTs is disabled" $+ example $ do+ let missingGADTs = runMockT $ do+ expectAny $ QIsExtEnabled GADTs |-> False+ expect $ QReport_ anything (hasSubstr "Please enable GADTs") |-> ()++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ missingGADTs `shouldThrow` anyIOException++ it "fails when TypeFamilies is disabled" $+ example $ do+ let missingTypeFamilies = runMockT $ do+ expectAny $ QIsExtEnabled TypeFamilies |-> False+ expect $+ QReport_ anything (hasSubstr "Please enable TypeFamilies") |-> ()++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ missingTypeFamilies `shouldThrow` anyIOException++ it "fails when DataKinds is disabled" $+ example $ do+ let missingDataKinds = runMockT $ do+ expectAny $ QIsExtEnabled DataKinds |-> False+ expect $+ QReport_ anything (hasSubstr "Please enable DataKinds") |-> ()++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ missingDataKinds `shouldThrow` anyIOException++ it "fails when FlexibleInstances is disabled" $+ example $ do+ let missingDataKinds = runMockT $ do+ expectAny $ QIsExtEnabled FlexibleInstances |-> False+ expect $+ QReport_ anything (hasSubstr "Please enable FlexibleInstances")+ |-> ()++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ missingDataKinds `shouldThrow` anyIOException++ it "fails when MultiParamTypeClasses is disabled" $+ example $ do+ let missingDataKinds = runMockT $ do+ expectAny $ QIsExtEnabled MultiParamTypeClasses |-> False+ expect $+ QReport_+ anything+ (hasSubstr "Please enable MultiParamTypeClasses")+ |-> ()++ _ <- runQ (makeMockable ''MonadSimple)+ return ()++ missingDataKinds `shouldThrow` anyIOException++ it "fails when too many params are given" $+ example $ do+ let tooManyParams = runMockT $ do+ expectAny $ QReify ''MonadSimple |-> $(reifyStatic ''MonadSimple)+ expect $+ QReport_ anything (hasSubstr "is applied to too many arguments")+ |-> ()++ _ <- runQ (makeMockableType [t|MonadSimple IO|])+ return ()++ tooManyParams `shouldThrow` anyIOException++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ Simple "foo" |-> ()+ simple "foo"++ failure = runMockT $ do+ expect $ Simple "foo" |-> ()+ simple "bar"++ success+ failure `shouldThrow` anyException++class MonadSuffix m where+ suffix :: String -> m ()++makeMockableWithOptions def {mockSuffix = "Blah"} ''MonadSuffix++suffixTests :: SpecWith ()+suffixTests = describe "MonadSuffix" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadSuffix |-> $(reifyStatic ''MonadSuffix)++ runQ (makeMockableWithOptions def {mockSuffix = "Blah"} ''MonadSuffix)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ SuffixBlah "foo" |-> ()+ suffix "foo"++ failure = runMockT $ do+ expect $ SuffixBlah "foo" |-> ()+ suffix "bar"++ success+ failure `shouldThrow` anyException++class MonadWithSetup m where+ withSetup :: m String++makeMockableBase ''MonadWithSetup++instance Mockable MonadWithSetup where+ setupMockable _ = do+ byDefault $ WithSetup |-> "custom default"++setupTests :: SpecWith ()+setupTests = describe "MonadWithSetup" $ do+ it "generates mock impl" $ do+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadWithSetup |-> $(reifyStatic ''MonadWithSetup)++ runQ (makeMockableBase ''MonadWithSetup)+ evaluate (rnf decs)++ it "returns the customized default value" $ do+ example $+ runMockT $ do+ expectAny WithSetup++ result <- withSetup+ liftIO (result `shouldBe` "custom default")++class SuperClass (m :: Type -> Type)++instance SuperClass m++class (SuperClass m, Monad m, Typeable m) => MonadSuper m where+ withSuper :: m ()++makeMockable ''MonadSuper++superTests :: SpecWith ()+superTests = describe "MonadSuper" $ do+ it "generated mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadSuper |-> $(reifyStatic ''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)]+ )++ runQ (makeMockable ''MonadSuper)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ WithSuper |-> ()+ withSuper++ failure = runMockT withSuper++ success+ failure `shouldThrow` anyException++class MonadMPTC a m where+ mptc :: a -> m ()+ mptcList :: [a] -> m ()++makeMockable ''MonadMPTC++mptcTests :: SpecWith ()+mptcTests = describe "MonadMPTC" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadMPTC |-> $(reifyStatic ''MonadMPTC)++ runQ (makeMockable ''MonadMPTC)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ Mptc "foo" |-> ()+ mptc "foo"++ failure = runMockT $ do+ expect $ Mptc "foo" |-> ()+ mptc "bar"++ success+ failure `shouldThrow` anyException++class MonadFDSpecialized a m | m -> a where+ fdSpecialized :: a -> m a++makeMockableType [t|MonadFDSpecialized String|]++fdSpecializedTests :: SpecWith ()+fdSpecializedTests = describe "MonadFDSpecialized" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $+ QReify ''MonadFDSpecialized+ |-> $(reifyStatic ''MonadFDSpecialized)++ runQ (makeMockableType [t|MonadFDSpecialized String|])+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ FdSpecialized "foo" |-> "bar"+ r <- fdSpecialized "foo"+ liftIO $ r `shouldBe` "bar"++ failure = runMockT $ do+ expect $ FdSpecialized "foo" |-> "bar"+ fdSpecialized "bar"++ success+ failure `shouldThrow` anyException++class MonadFDGeneral a m | m -> a where+ fdGeneral :: a -> m a++deriveMockable ''MonadFDGeneral++newtype MyBase m a = MyBase {runMyBase :: m a}+ deriving newtype (Functor, Applicative, Monad, MonadIO)++instance+ (MonadIO m, Typeable m) =>+ MonadFDGeneral String (MockT (MyBase m))+ where+ fdGeneral x = mockMethod (FdGeneral x)++fdGeneralTests :: SpecWith ()+fdGeneralTests = describe "MonadFDGeneral" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadFDGeneral |-> $(reifyStatic ''MonadFDGeneral)++ runQ (deriveMockable ''MonadFDGeneral)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMyBase . runMockT $ do+ expect $ FdGeneral "foo" |-> "bar"+ r <- fdGeneral "foo"+ liftIO $ r `shouldBe` "bar"++ failure = runMyBase . runMockT $ do+ expect $ FdGeneral "foo" |-> "bar"+ fdGeneral "bar"++ success+ failure `shouldThrow` anyException++class MonadFDMixed a b c d m | m -> a b c d where+ fdMixed :: a -> b -> c -> m d++deriveMockableType [t|MonadFDMixed String Int|]+deriveTypeForMockT [t|MonadFDMixed String Int String String|]++fdMixedTests :: SpecWith ()+fdMixedTests = describe "MonadFDMixed" $ do+ it "generates mock impl" $+ example . runMockT $ do+ expectAny $ QReify ''MonadFDMixed |-> $(reifyStatic ''MonadFDMixed)++ decs1 <- runQ (deriveMockableType [t|MonadFDMixed String Int|])+ decs2 <-+ runQ (deriveTypeForMockT [t|MonadFDMixed String Int String Int|])+ _ <- liftIO $ evaluate (rnf (decs1 ++ decs2))+ return ()++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ FdMixed "foo" 1 "bar" |-> "qux"+ r <- fdMixed "foo" 1 "bar"+ liftIO $ r `shouldBe` "qux"++ failure = runMockT $ do+ expect $ FdMixed "foo" 1 "bar" |-> "qux"+ _ <- fdMixed "bar" 1 "foo"+ return ()++ success+ failure `shouldThrow` anyException++class MonadPolyArg m where+ polyArg :: Enum a => String -> a -> b -> m ()++makeMockable ''MonadPolyArg++polyArgTests :: SpecWith ()+polyArgTests = describe "MonadPolyArg" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)++ runQ (makeMockable ''MonadPolyArg)+ evaluate (rnf decs)++ it "fails without ScopedTypeVariables" $+ example $ do+ let missingScopedTypeVariables = runMockT $ do+ expectAny $+ QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)+ expectAny $ QIsExtEnabled ScopedTypeVariables |-> False+ expect $+ QReport_ anything (hasSubstr "Please enable ScopedTypeVariables")+ |-> ()++ _ <- runQ (makeMockable ''MonadPolyArg)+ return ()++ missingScopedTypeVariables `shouldThrow` anyException++ it "fails without RankNTypes" $+ example $ do+ let missingRankNTypes = runMockT $ do+ expectAny $ QReify ''MonadPolyArg |-> $(reifyStatic ''MonadPolyArg)+ expectAny $ QIsExtEnabled RankNTypes |-> False+ expect $+ QReport_ anything (hasSubstr "Please enable RankNTypes") |-> ()++ _ <- runQ (makeMockable ''MonadPolyArg)+ return ()++ missingRankNTypes `shouldThrow` anyException++ it "is mockable" $+ example $ do+ let success = runMyBase . runMockT $ do+ expect $+ 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 "foo" (toEnum 2 :: Bool) "hello"++ success+ failure `shouldThrow` anyException++class MonadUnshowableArg m where+ unshowableArg :: (Int -> Int) -> m ()++makeMockable ''MonadUnshowableArg++unshowableArgTests :: SpecWith ()+unshowableArgTests = describe "MonadUnshowableArg" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $+ QReify ''MonadUnshowableArg |-> $(reifyStatic ''MonadUnshowableArg)++ runQ (makeMockable ''MonadUnshowableArg)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMyBase . runMockT $ do+ expect $ UnshowableArg_ anything |-> ()+ unshowableArg (+ 1)++ failure = runMyBase . runMockT $ do+ expect $ UnshowableArg_ anything |-> ()++ unshowableArg (+ 1)+ unshowableArg (+ 1)++ success+ failure `shouldThrow` anyException++class MonadInArg m where+ monadInArg :: (Int -> m ()) -> m ()++makeMockable ''MonadInArg++monadInArgTests :: SpecWith ()+monadInArgTests = describe "MonadInArg" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadInArg |-> $(reifyStatic ''MonadInArg)++ runQ (makeMockable ''MonadInArg)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMyBase . runMockT $ do+ expect $ MonadInArg_ anything |-> ()+ monadInArg (const (return ()))++ failure = runMyBase . runMockT $ do+ expect $ UnshowableArg_ anything |-> ()++ monadInArg (const (return ()))+ monadInArg (const (return ()))++ success+ failure `shouldThrow` anyException++class MonadExtraneousMembers m where+ data SomeDataType m+ favoriteNumber :: SomeDataType m -> Int+ wrongMonad :: Monad n => m Int -> n Int+ polyResult :: a -> m a+ nestedRankN :: ((forall a. a -> Bool) -> Bool) -> m ()++ mockableMethod :: Int -> m ()++deriveMockable ''MonadExtraneousMembers++instance (Typeable m, MonadIO m) => MonadExtraneousMembers (MockT m) where+ data SomeDataType (MockT m) = SomeCon+ favoriteNumber SomeCon = 42+ wrongMonad _ = return 42+ polyResult = return+ nestedRankN _ = return ()++ mockableMethod a = mockMethod (MockableMethod a)++extraneousMembersTests :: SpecWith ()+extraneousMembersTests = describe "MonadExtraneousMembers" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $+ QReify ''MonadExtraneousMembers+ |-> $(reifyStatic ''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." |-> ()+ 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+ def {mockVerbose = True}+ ''MonadExtraneousMembers+ )+ evaluate (rnf decs)++ it "fails to derive MockT when class has extra methods" $+ example $ do+ let unmockableMethods = runMockT $ do+ expectAny $+ QReify ''MonadExtraneousMembers+ |-> $(reifyStatic ''MonadExtraneousMembers)+ expect $+ QReport_ anything (hasSubstr "has unmockable methods") |-> ()++ _ <- runQ (makeMockable ''MonadExtraneousMembers)+ return ()++ unmockableMethods `shouldThrow` anyIOException++ it "is mockable" $+ example $ do+ let success = runMyBase . runMockT $ do+ expect $ MockableMethod 42 |-> ()+ mockableMethod (favoriteNumber (SomeCon @(MockT IO)))++ failure = runMyBase . runMockT $ do+ expect $ MockableMethod 42 |-> ()+ mockableMethod 12++ success+ failure `shouldThrow` anyException++class MonadRankN m where+ rankN :: (forall a. a -> Bool) -> Bool -> m ()++makeMockable ''MonadRankN++rankNTests :: SpecWith ()+rankNTests = describe "MonadRankN" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $ QReify ''MonadRankN |-> $(reifyStatic ''MonadRankN)++ runQ (deriveMockable ''MonadRankN)+ evaluate (rnf decs)++ it "is mockable" $+ example $ do+ let success = runMockT $ do+ expect $ RankN_ anything (eq True) |-> ()+ rankN (const True) True++ failure = runMockT $ do+ expect $ RankN_ anything (eq True) |-> ()+ rankN (const True) False++ success+ failure `shouldThrow` anyException++-- | Type with no Default instance.+data NoDefault = NoDefault++class MonadManyReturns m where+ returnsUnit :: m ()+ returnsInt :: m Int+ returnsString :: m String+ returnsMaybe :: m (Maybe Bool)+ returnsNoDefault :: m NoDefault++makeMockable ''MonadManyReturns++defaultReturnTests :: SpecWith ()+defaultReturnTests = do+ describe "MonadManyReturns" $ do+ it "generates mock impl" $+ example $ do+ decs <- runMockT $ do+ expectAny $+ QReify ''MonadManyReturns |-> $(reifyStatic ''MonadManyReturns)+ expectAny $+ QReifyInstances ''Default [ConT ''NoDefault]+ |-> $(reifyInstancesStatic ''Default [ConT ''NoDefault])++ runQ (makeMockable ''MonadManyReturns)+ evaluate (rnf decs)++ it "fails when there's an unexpected method" $+ example $ runMockT returnsUnit `shouldThrow` anyException++ it "succeeds when there's an expected method with default response" $+ example $ do+ result <- runMockT $ do+ expect ReturnsUnit+ expect ReturnsInt+ expect ReturnsString+ expect ReturnsMaybe++ (,,,)+ <$> returnsUnit+ <*> returnsInt+ <*> returnsString+ <*> returnsMaybe++ result `shouldBe` ((), 0, "", Nothing)++ it "overrides default when response is specified" $+ example $ do+ result <- runMockT $ do+ expect ReturnsInt+ expect $ ReturnsString |-> "non-default"++ (,)+ <$> returnsInt+ <*> returnsString++ result `shouldBe` (0, "non-default")++ it "returns undefined when response isn't given for defaultless method" $+ example $ do+ let test = runMockT $ do+ expect ReturnsNoDefault+ returnsNoDefault+ _ <- test+ (test >>= evaluate) `shouldThrow` anyException++class MonadNestedNoDef m where+ nestedNoDef :: m (NoDefault, String)++$(return []) -- Hack to get types into the TH environment.++nestedNoDefTests :: SpecWith ()+nestedNoDefTests = describe "MonadNestedNoDef" $ do+ 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])++ runQ (makeMockable ''MonadNestedNoDef)+ evaluate (rnf decs)++class ClassWithNoParams++$(return []) -- Hack to get types into the TH environment.++errorTests :: SpecWith ()+errorTests = describe "errors" $ do+ it "fails when given a type instead of a class" $+ example $ do+ let wrongKind = runMockT $ do+ expect $+ QReport_+ anything+ (hasSubstr "Expected GHC.Types.Int to be a class")+ |-> ()++ _ <- runQ (makeMockable ''Int)+ return ()++ wrongKind `shouldThrow` anyIOException++ it "fails when given an unexpected type construct" $+ example $ do+ let notClass = runMockT $ do+ expect $ QReport_ anything (hasSubstr "Expected a class") |-> ()++ _ <- runQ (makeMockableType [t|(Int, String)|])+ return ()++ notClass `shouldThrow` anyIOException++ it "fails when class has no params" $+ example $ do+ let tooManyParams = runMockT $ do+ expectAny $+ QReify ''ClassWithNoParams |-> $(reifyStatic ''ClassWithNoParams)+ expect $+ QReport_+ anything+ (hasSubstr "ClassWithNoParams has no type parameters")+ |-> ()++ _ <- runQ (makeMockable ''ClassWithNoParams)+ return ()++ tooManyParams `shouldThrow` anyIOException++ 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") |-> ()++ _ <- runQ (deriveMockable ''Show)+ return ()++ noMockableMethods `shouldThrow` anyIOException++classTests :: SpecWith ()+classTests = describe "makeMockable" $ do+ simpleTests+ suffixTests+ setupTests+ superTests+ mptcTests+ fdSpecializedTests+ fdGeneralTests+ fdMixedTests+ polyArgTests+ unshowableArgTests+ monadInArgTests+ extraneousMembersTests+ rankNTests+ defaultReturnTests+ nestedNoDefTests+ errorTests
+ test/Core.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Core where++import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.DeepSeq (rnf)+import Control.Exception (SomeException, evaluate)+import Control.Monad (replicateM_)+import Control.Monad.Reader (MonadReader (local), ask, runReaderT)+import Control.Monad.State (execStateT, modify)+import Control.Monad.Trans (liftIO)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.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)+import qualified Prelude++class Monad m => MonadFilesystem m where+ readFile :: FilePath -> m String+ writeFile :: FilePath -> String -> m ()++-- | This is not used by tests. It's just an illustration of how you'd use+-- 'MonadFilesystem' in production.+instance MonadFilesystem IO where+ readFile = Prelude.readFile+ writeFile = Prelude.writeFile++makeMockable ''MonadFilesystem++newtype SocketHandle = Handle Int deriving (Eq, Show)++class Monad m => MonadSocket m where+ openSocket :: Int -> m SocketHandle+ closeSocket :: SocketHandle -> m ()++makeMockable ''MonadSocket++coreTests :: SpecWith ()+coreTests = do+ describe "HMock core" $ do+ it "verifies a file copy" $+ example $ do+ let copyFile :: MonadFilesystem m => FilePath -> FilePath -> m ()+ copyFile a b = readFile a >>= writeFile b++ runMockT $ do+ expect $ ReadFile "foo.txt" |-> "lorem ipsum"+ expect $ WriteFile "bar.txt" "lorem ipsum"++ copyFile "foo.txt" "bar.txt"++ it "rejects an incorrect file copy" $+ example $ do+ let badCopyFile :: MonadFilesystem m => FilePath -> FilePath -> m ()+ badCopyFile a b = readFile b >>= writeFile a++ failure = runMockT $ do+ expect $ ReadFile "foo.txt" |-> "lorem ipsum"+ expect $ WriteFile "bar.txt" "lorem ipsum"++ badCopyFile "foo.txt" "bar.txt"++ failure `shouldThrow` anyException++ it "uses default responses when no explicit response given" $+ example $ do+ let test = runMockT $ do+ expect $ WriteFile "file.txt" "contents"+ expect $ ReadFile "file.txt"+ writeFile "file.txt" "contents"+ readFile "file.txt"++ test `shouldReturn` ""++ it "shares expectations using withMockT" $+ example $+ withMockT $ \inMockT -> do+ expect $ ReadFile "foo.txt" |-> "lorem ipsum"+ expect $ WriteFile "bar.txt" "lorem ipsum"++ var <- liftIO newEmptyMVar++ _ <-+ liftIO $+ forkIO $ inMockT $ readFile "foo.txt" >>= liftIO . putMVar var+ writeFile "bar.txt" =<< liftIO (takeMVar var)++ it "shares expectations across threads using MonadUnliftIO" $+ example $+ runMockT $ do+ expect $ ReadFile "foo.txt" |-> "lorem ipsum"+ expect $ WriteFile "bar.txt" "lorem ipsum"++ var <- liftIO newEmptyMVar+ _ <- UnliftIO.forkIO $ readFile "foo.txt" >>= liftIO . putMVar var+ writeFile "bar.txt" =<< liftIO (takeMVar var)++ it "tracks expectations across multiple classes" $+ example $ do+ let setExpectations =+ inSequence+ [ expect $ ReadFile "code.txt" |-> "alpha",+ expect $ OpenSocket 80 |-> Handle 80,+ expect $ WriteFile "code.txt" "alpha+",+ expect $ CloseSocket (Handle 80)+ ]++ success = runMockT $ do+ setExpectations++ code <- readFile "code.txt"+ h <- openSocket 80+ writeFile "code.txt" (code ++ "+")+ closeSocket h++ failure = runMockT $ do+ setExpectations++ h <- openSocket 80+ code <- readFile "code.txt"+ closeSocket h+ writeFile "code.txt" (code ++ "+")++ success++ failure+ `shouldThrow` errorWith ("Unexpected action: openSocket" `isInfixOf`)++ it "returns multiple responses" $+ example $ do+ let test = runMockT $ do+ expect $+ ReadFile "foo.txt"+ |-> "a"+ |-> "b"+ |-> "c"+ (,,)+ <$> readFile "foo.txt"+ <*> readFile "foo.txt"+ <*> readFile "foo.txt"++ test `shouldReturn` ("a", "b", "c")++ it "catches expectN with too many expectations" $+ example $ do+ let test = runMockT $ do+ expectN once $+ ReadFile "foo.txt"+ |-> "a"+ |-> "b"++ test `shouldThrow` errorWith ("2 responses is too many" `isInfixOf`)++ it "catches unmet expectations" $+ example $ do+ let test = runMockT $ do+ expect $ WriteFile "bar.txt" "bar"++ -- Don't write the file.+ return ()++ test+ `shouldThrow` errorWith+ (("Unmet expectations" `isInfixOf`) <&&> ("Core.hs:" `isInfixOf`))++ it "catches partially unmet expectations" $+ example $ do+ let test = runMockT $ do+ expect $ WriteFile "foo.txt" "foo"+ expect $ WriteFile "bar.txt" "bar"++ writeFile "foo.txt" "foo"++ test `shouldThrow` errorWith ("Unmet expectations" `isInfixOf`)++ it "catches partially unmet sequences" $+ example $ do+ let test = runMockT $ do+ inSequence+ [ expect $ WriteFile "foo.txt" "foo",+ expect $ WriteFile "bar.txt" "bar",+ expect $ WriteFile "baz.txt" "baz"+ ]++ writeFile "foo.txt" "foo"++ test `shouldThrow` errorWith ("Unmet expectations" `isInfixOf`)++ it "catches unexpected actions" $+ example $+ runMockT (writeFile "bar.txt" "bar")+ `shouldThrow` errorWith ("Unexpected action: writeFile" `isInfixOf`)++ it "catches incorrect arguments" $+ example $ do+ let test = runMockT $ do+ expect $ WriteFile "bar.txt" "bar"+ writeFile "bar.txt" "incorrect"++ test+ `shouldThrow` errorWith+ (("Wrong arguments" `isInfixOf`) <&&> ("Core.hs:" `isInfixOf`))++ it "matches with imprecise predicates" $+ example . runMockT $ do+ expect $ WriteFile_ (hasSubstr "bar") anything+ writeFile "bar.txt" "unknown contents"++ it "stores source location in suchThat predicate" $+ example $ do+ let test = runMockT $ do+ expect $ ReadFile_ (is ("foo" `isPrefixOf`)) |-> "foo"+ readFile "bar.txt"++ test `shouldThrow` errorWith ("Core.hs" `isInfixOf`)++ it "prefers most recent method match" $+ example . runMockT $ do+ expectAny $ ReadFile "foo.txt" |-> "a"+ expectAny $ ReadFile "foo.txt" |-> "b"+ expect $ ReadFile "foo.txt" |-> "c"+ expect $ ReadFile "foo.txt" |-> "d"++ r1 <- readFile "foo.txt"+ r2 <- readFile "foo.txt"+ r3 <- readFile "foo.txt"+ r4 <- readFile "foo.txt"++ liftIO $ r1 `shouldBe` "d"+ liftIO $ r2 `shouldBe` "c"+ liftIO $ r3 `shouldBe` "b"+ liftIO $ r4 `shouldBe` "b"++ it "matches flexible multiplicity" $+ example $ do+ let setExpectations = do+ expectN (atLeast 3) $ ReadFile "foo.txt" |-> "foo"+ expectN (atMost 2) $ ReadFile "bar.txt" |-> "bar"+ expectAny $ ReadFile "baz.txt" |-> "baz"++ success1 = runMockT $ do+ setExpectations+ replicateM_ 3 $ readFile "foo.txt"++ success2 = runMockT $ do+ setExpectations+ replicateM_ 4 $ readFile "foo.txt"++ success3 = runMockT $ do+ setExpectations+ replicateM_ 3 $ readFile "foo.txt"+ replicateM_ 2 $ readFile "bar.txt"++ success4 = runMockT $ do+ setExpectations+ replicateM_ 3 $ readFile "foo.txt"+ replicateM_ 2 $ readFile "bar.txt"+ replicateM_ 5 $ readFile "baz.txt"++ failure1 = runMockT $ do+ setExpectations+ replicateM_ 1 $ readFile "foo.txt"++ failure2 = runMockT $ do+ setExpectations+ replicateM_ 3 $ readFile "foo.txt"+ replicateM_ 3 $ readFile "bar.txt"++ success1+ success2+ success3+ success4+ failure1 `shouldThrow` anyException+ failure2 `shouldThrow` anyException++ it "enforces nested sequences" $+ example $ do+ let setExpectations =+ inSequence+ [ inAnyOrder+ [ expect $ ReadFile "1.txt" |-> "1",+ expect $ ReadFile "2.txt" |-> "2"+ ],+ expect $ ReadFile "3.txt" |-> "3"+ ]++ success1 = runMockT $ do+ setExpectations+ _ <- readFile "1.txt"+ _ <- readFile "2.txt"+ _ <- readFile "3.txt"+ return ()++ success2 = runMockT $ do+ setExpectations+ _ <- readFile "2.txt"+ _ <- readFile "1.txt"+ _ <- readFile "3.txt"+ return ()++ failure = runMockT $ do+ setExpectations+ _ <- readFile "2.txt"+ _ <- readFile "3.txt"+ _ <- readFile "1.txt"+ return ()++ success1+ success2+ failure `shouldThrow` anyException++ it "handles nested sequences" $+ example . runMockT $ do+ inSequence+ [ inSequence+ [ expect $ ReadFile "a" |-> "a",+ expect $ ReadFile "b" |-> "b"+ ],+ expect $ ReadFile "c" |-> "c"+ ]++ _ <- readFile "a"+ _ <- readFile "b"+ _ <- readFile "c"+ return ()++ it "consumes optional calls in sequences" $+ example $ do+ let setExpectations =+ inSequence+ [ expectAny $ WriteFile "foo.txt" "foo",+ expectAny $ WriteFile "foo.txt" "bar"+ ]++ success = runMockT $ do+ setExpectations+ writeFile "foo.txt" "foo"+ writeFile "foo.txt" "bar"++ failure = runMockT $ do+ setExpectations+ writeFile "foo.txt" "foo"+ writeFile "foo.txt" "bar"+ writeFile "foo.txt" "foo"++ success+ failure `shouldThrow` errorWith ("Wrong arguments:" `isInfixOf`)++ it "implements choice" $+ example $ do+ let setExpectations =+ anyOf+ [ expect $ WriteFile "status.txt" "all systems go",+ expect $ WriteFile "status.txt" "we have a problem"+ ]++ success1 = runMockT $ do+ setExpectations+ writeFile "status.txt" "all systems go"++ success2 = runMockT $ do+ setExpectations+ writeFile "status.txt" "we have a problem"++ failure1 = runMockT $ do+ setExpectations+ return ()++ failure2 = runMockT $ do+ setExpectations+ writeFile "status.txt" "not sure"++ success1+ success2+ failure1 `shouldThrow` anyException+ failure2 `shouldThrow` anyException++ it "implements interleaved repetition" $+ example $ do+ let setExpectations =+ times (atLeast 2) $+ inAnyOrder+ [ expect $ WriteFile "foo.txt" "a",+ expect $ WriteFile "bar.txt" "b"+ ]++ success1 = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "bar.txt" "b"+ writeFile "foo.txt" "a"++ success2 = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "foo.txt" "a"++ writeFile "bar.txt" "b"+ writeFile "bar.txt" "b"++ tooFew = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ incomplete = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "foo.txt" "a"++ success1+ success2+ tooFew `shouldThrow` anyException+ incomplete `shouldThrow` anyException++ it "implements consecutive repetition" $+ example $ do+ let setExpectations =+ consecutiveTimes (atLeast 2) $+ inAnyOrder+ [ expect $ WriteFile "foo.txt" "a",+ expect $ WriteFile "bar.txt" "b"+ ]++ success1 = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "bar.txt" "b"+ writeFile "foo.txt" "a"++ interleaved = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "foo.txt" "a"++ writeFile "bar.txt" "b"+ writeFile "bar.txt" "b"++ tooFew = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ incomplete = runMockT $ do+ setExpectations++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "foo.txt" "a"+ writeFile "bar.txt" "b"++ writeFile "foo.txt" "a"++ success1+ interleaved `shouldThrow` anyException+ tooFew `shouldThrow` anyException+ incomplete `shouldThrow` anyException++ it "repeats response sequences during repetition" $+ example $ do+ runMockT $ do+ times 2 $ expect $ ReadFile "foo.txt" |-> "A" |-> "B"++ result <-+ (,,,) <$> readFile "foo.txt"+ <*> readFile "foo.txt"+ <*> readFile "foo.txt"+ <*> readFile "foo.txt"+ liftIO $ result `shouldBe` ("A", "B", "A", "B")++ runMockT $ do+ consecutiveTimes 2 $ expect $ ReadFile "foo.txt" |-> "A" |-> "B"++ result <-+ (,,,) <$> readFile "foo.txt"+ <*> readFile "foo.txt"+ <*> readFile "foo.txt"+ <*> readFile "foo.txt"+ liftIO $ result `shouldBe` ("A", "B", "A", "B")++ it "gives access to method arguments in the response" $+ example $ do+ let test = runMockT $ do+ expect $+ ReadFile_ anything+ |=> \(ReadFile f) -> return ("contents of " ++ f)++ readFile "foo.txt"++ test `shouldReturn` "contents of foo.txt"++ it "allows responses to run in the underlying monad" $+ example $ do+ ref <- newIORef ""+ runMockT $ do+ expectAny $+ WriteFile_ (eq "foo.txt") anything+ |=> \(WriteFile _ c) -> liftIO (writeIORef ref c)+ writeFile "foo.txt" "open sesame"+ readIORef ref `shouldReturn` "open sesame"++ it "respects expectations added by a response" $+ example $ do+ let setExpectations = do+ expectAny $+ OpenSocket_ anything |=> \(OpenSocket n) -> do+ expect $ CloseSocket (Handle n)+ return (Handle n)++ success = runMockT $ do+ setExpectations++ h <- openSocket 80+ closeSocket h++ failure = runMockT $ do+ setExpectations++ _ <- openSocket 80+ return ()++ success+ failure `shouldThrow` anyException++ it "has a correct implementation of MonadReader" $+ example $ do+ flip runReaderT "read me" $+ runMockT $ do+ expectAny $ ReadFile_ anything |=> const ask++ a <- readFile ""+ liftIO (a `shouldBe` "read me")++ local (++ " too") $ do+ b <- readFile ""+ liftIO (b `shouldBe` "read me too")++ it "has a correct implementation of MonadState" $+ example $ do+ filesRead <- flip execStateT (0 :: Int) $+ runMockT $ do+ expectAny $+ ReadFile_ anything+ |=> \_ -> modify (+ 1) >> return ""++ _ <- readFile "foo.txt"+ _ <- readFile "bar.txt"+ return ()++ filesRead `shouldBe` 2++ it "describes expectations when asked" $+ example . runMockT $ do+ expectAny $ ReadFile_ anything+ expectations <- describeExpectations++ -- Format is deliberately unspecified. We're forcing it here so that+ -- test coverage doesn't flag the formatting code as untested.+ liftIO $ evaluate (rnf expectations)++ it "verifies expectations early" $+ example $ do+ let test = runMockT $ do+ expect $ ReadFile "foo.txt" |-> "lorem ipsum"+ verifyExpectations+ _ <- readFile "foo.txt"+ return ()++ test `shouldThrow` anyException++ it "allows the user to override a default" $+ example $+ runMockT $ do+ expectAny $ ReadFile_ anything++ r1 <- readFile "foo.txt"++ byDefault $ ReadFile "foo.txt" |-> "foo"+ r2 <- readFile "foo.txt"+ r3 <- readFile "bar.txt"++ liftIO (r1 `shouldBe` "")+ liftIO (r2 `shouldBe` "foo")+ liftIO (r3 `shouldBe` "")++errorWith :: (String -> Bool) -> SomeException -> Bool+errorWith p e = p (show e)++(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool+x <&&> y = (&&) <$> x <*> y
+ test/Demo.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Demo where++import Control.Exception (Exception)+import Control.Monad (unless, when)+import Control.Monad.Catch (MonadMask, catch, finally, throwM)+import Data.Char (isLetter)+import Test.HMock+ ( Mockable (..),+ anything,+ expect,+ expectAny,+ runMockT,+ (|->),+ (|=>),+ )+import Test.HMock.TH (makeMockable, makeMockableBase)+import Test.Hspec (SpecWith, describe, example, it)+import Prelude hiding (appendFile, readFile, writeFile)++-- This is an in-depth example of using HMock to test a system with dependencies+-- on external systems. The application here is a chat bot, which needs to+-- be able to talk to services for authentication, communication, and storage.++-------------------------------------------------------------------------------+-- PART 1: TYPES AND CLASSES++-- We start with some basic types.++-- | Represents a user in the system.+newtype User = User String deriving (Eq, Show)++-- | Represents a permission level. The Guest level is given to users who are+-- not logged in. NormalUser requires being logged in. Admin requires being+-- logged in with elevated permissions.+data PermLevel = Guest | NormalUser | Admin deriving (Eq, Show)++-- | Represents a chat room.+newtype Room = Room String deriving (Eq, Show)++-- HMock needs MTL-style type classes to mock. Here, we implement a number of+-- these classes.++-- | An MTL-style type class to capture authentication. This can be used in two+-- ways.+--+-- 1. Using the 'login' and 'logout' actions to start and end an authenticated+-- session. While the user is logged in, 'getUser' and 'hasPermission' will+-- return appropriate responses for that user. Remember to log out!+--+-- 2. Using the 'withLogin' action to run an action as a user. The user will+-- be logged out automatically when the action finishes.+class Monad m => MonadAuth m where+ login :: String -> String -> m ()+ logout :: m ()+ hasPermission :: PermLevel -> m Bool++-- | An MTL-style type class for sending and receiving chat messages. We can+-- start and close sessions, send messages, poll for messages (blocking for a+-- period of time if desired), and ban other users (probably only if we're an+-- admin!)+class MonadAuth m => MonadChat m where+ joinRoom :: String -> m Room+ leaveRoom :: Room -> m ()+ sendChat :: Room -> String -> m ()+ pollChat :: Room -> m (User, String)+ ban :: Room -> User -> m ()++-- | An MTL-style type class for accessing the filesystem. It wouldn't be a+-- good idea to write mock-style tests for all uses of the filesystem, but we+-- can use HMock to set up a lightweight fake.+class Monad m => MonadBugReport m where+ reportBug :: String -> m ()++-- | An exception thrown when a banned user attempts to join a room.+data BannedException = BannedException deriving (Show)++instance Exception BannedException++-------------------------------------------------------------------------------+-- PART 2: IMPLEMENTATION++-- We will now implement a simple chatbot, which joins a chat room and responds+-- to messages.++type MonadChatBot m = (MonadChat m, MonadBugReport m)++chatbot :: (MonadMask m, MonadChatBot m) => String -> m ()+chatbot roomName = do+ login "HMockBot" "secretish"+ handleRoom roomName `finally` logout++handleRoom :: (MonadMask m, MonadChatBot m) => String -> m ()+handleRoom roomName = do+ room <- joinRoom roomName+ listenAndReply room `finally` leaveRoom room++listenAndReply :: MonadChatBot m => Room -> m ()+listenAndReply room = do+ (user, msg) <- pollChat room+ finished <- case words msg of+ ["!leave"] -> return True+ ("!bug" : ws) -> reportBug (unwords ws) >> return False+ ws | any isFourLetterWord ws -> banIfAdmin room user >> return False+ _ -> return False+ unless finished (listenAndReply room)++isFourLetterWord :: [Char] -> Bool+isFourLetterWord = (== 4) . length . filter isLetter++sendBugReport :: MonadChatBot m => Room -> String -> m ()+sendBugReport room bug = do+ reportBug bug+ sendChat room "Thanks for the bug report!"++banIfAdmin :: MonadChat m => Room -> User -> m ()+banIfAdmin room user = do+ isAdmin <- hasPermission Admin+ when isAdmin $ do+ ban room user+ sendChat room "Sorry for the disturbance!"++-------------------------------------------------------------------------------+-- PART 3: MOCKS++-- Set up the mocks for the three classes. makeMockable is the first step to+-- using HMock, and defines a number of boilerplate types and instances that are+-- used by the framework and your tests.+--+-- How we do this depends on whether there is setup we want to package with the+-- class:++-- Since there is no setup for MonadBugReport, it's easiest to use makeMockable+-- to derive all instances needed to mock this class.+makeMockable ''MonadBugReport++-- For MonadAuth and MonadChat, we have default behaviors we'd like to offer+-- to all tests. So instead of makeMockable, we use makeMockableBase to derive+-- MockableBase, which contains all the boilerplate. We can then write a+-- Mockable instance with setup steps.++makeMockableBase ''MonadAuth++instance Mockable MonadAuth where+ setupMockable _ = do+ -- Ensure that when the chatbot logs in with the right username and+ -- password.+ expectAny $+ Login "HMockBot" "secretish"+ |=> \_ -> do+ -- Every login should be accompanied by a logout+ expect Logout++ -- By default, assume that the bot has all permissions. Individual tests+ -- can override this assumption.+ expectAny $ HasPermission_ anything |-> True++makeMockableBase ''MonadChat++instance Mockable MonadChat where+ setupMockable _ = do+ expectAny $+ JoinRoom_ anything+ |=> \(JoinRoom room) -> do+ -- The bot should leave every room it joins.+ expect $ LeaveRoom (Room room)+ return (Room room)++ -- 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++-------------------------------------------------------------------------------+-- PART 4: TESTS++-- We're now ready to write tests for the behavior of our chat bot. We'll just+-- write a few representative tests to see how things work. I'm using Hspec for+-- the test framework, but you can use your favorite framework.++demoSpec :: SpecWith ()+demoSpec = describe "chatbot" $ do+ it "bans users who use four-letter words" $+ example $+ runMockT $ do+ -- Set up some chat messages to be received.+ expectAny $+ PollChat_ anything+ |-> (User "A", "I love Haskell")+ |-> (User "B", "Lovin' the ass. candies")+ |-> (User "B", "!leave")++ -- User A should be banned for using a four-letter word ("love"). User+ -- B should not be banned for using an abbreviation for "assorted."+ expect $ Ban (Room "#haskell") (User "A")++ -- Finally, run the system under test.+ chatbot "#haskell"++ it "still logs out cleanly when there are errors" $ do+ example $+ runMockT $ do+ expectAny $ JoinRoom "#haskell" |=> \_ -> throwM BannedException++ -- An exception will be thrown when attempting to read chat. The bot+ -- is still expected to log out.+ chatbot "#haskell" `catch` \BannedException -> return ()++ it "doesn't ban if it doesn't have permission" $ do+ example $+ runMockT $ do+ -- Override the earlier default behavior, returning False for the Admin+ -- permission level.+ expectAny $ HasPermission Admin |-> False+ expectAny $+ PollChat_ anything+ |-> (User "A", "I love Haskell")+ |-> (User "A", "!leave")++ chatbot "#haskell"++ it "doesn't ban people for using four-letter words in big reports" $ do+ example $+ runMockT $ do+ -- A four letter word is used in a bug report. This is understandable,+ -- so the user shouldn't be banned. The bug should be reported,+ -- instead.+ expectAny $+ PollChat_ anything+ |-> (User "A", "!bug Fix the damn website!")+ |-> (User "A", "!leave")+ expect $ ReportBug "Fix the damn website!"++ chatbot "#haskell"
+ test/DocTests/All.hs view
@@ -0,0 +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 Test.DocTest.Driver as DocTest++main :: DocTest.T ()+main = do+ DocTests.Test.HMock.Internal.Predicates.test+ DocTests.Test.HMock.Internal.Multiplicity.test
+ test/DocTests/Test/HMock/Internal/Multiplicity.hs view
@@ -0,0 +1,166 @@+-- 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"]]
+ test/DocTests/Test/HMock/Internal/Predicates.hs view
@@ -0,0 +1,898 @@+-- 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"]]
+ test/ExpectSet.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ExpectSet where++import Control.Arrow (second)+import Data.List (foldl')+import Test.HMock.Internal.ExpectSet+import Test.HMock.Internal.Multiplicity+import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck++instance Arbitrary (ExpectSet Int) where+ arbitrary = do+ n <- getSize+ frequency+ [ (1, return ExpectNothing),+ (5, ExpectStep <$> choose (1, 100)),+ (n, scale (`div` 2) $ ExpectSequence <$> arbitrary <*> arbitrary),+ (n, scale (`div` 2) $ ExpectInterleave <$> arbitrary <*> arbitrary),+ (n, scale (`div` 2) $ ExpectEither <$> arbitrary <*> arbitrary),+ (n, scale (subtract 1) $ ExpectMulti <$> arbitrary <*> arbitrary),+ (n, scale (subtract 1) $ ExpectConsecutive <$> arbitrary <*> arbitrary)+ ]++ shrink ExpectNothing = []+ shrink (ExpectStep _) = [ExpectNothing]+ shrink (ExpectSequence e f) =+ [ExpectSequence e' f | e' <- shrink e]+ ++ [ExpectSequence e f' | f' <- shrink f]+ ++ [e, f]+ shrink (ExpectInterleave e f) =+ [ExpectSequence e' f | e' <- shrink e]+ ++ [ExpectSequence e f' | f' <- shrink f]+ ++ [e, f]+ shrink (ExpectEither e f) =+ [ExpectSequence e' f | e' <- shrink e]+ ++ [ExpectSequence e f' | f' <- shrink f]+ ++ [e, f]+ shrink (ExpectMulti mult e) =+ [ExpectMulti mult' e | mult' <- shrink mult]+ ++ [ExpectMulti mult e' | e' <- shrink e]+ ++ [e]+ shrink (ExpectConsecutive mult e) =+ [ExpectConsecutive mult' e | mult' <- shrink mult]+ ++ [ExpectConsecutive mult e' | e' <- shrink e]+ ++ [e]++instance Arbitrary Multiplicity where+ arbitrary = normalize <$> (Multiplicity <$> arbitrary <*> arbitrary)++liveSteps' :: ExpectSet step -> [(step, ExpectSet step)]+liveSteps' = map (second simplify) . liveSteps++expectSetSpec :: SpecWith ()+expectSetSpec = modifyMaxSuccess (const 1000) $ do+ describe "ExpectSet" $ do+ describe "satisfied" $ do+ it "agrees with excess" $+ property $+ \(es :: ExpectSet Int) ->+ if satisfied es+ then excess es === ExpectNothing+ else excess es =/= ExpectNothing++ let sameBehavior ::+ (Show a, Eq a) => Int -> ExpectSet a -> ExpectSet a -> Property+ sameBehavior 0 e f = satisfied e === satisfied f+ sameBehavior d e f =+ satisfied e === satisfied f+ .&&. foldl' (.&&.) (property True) (zipWith (===) esteps fsteps)+ .&&. foldl'+ (.&&.)+ (property True)+ (zipWith (sameBehavior (d - 1)) econts fconts)+ where+ (esteps, econts) = unzip (liveSteps e)+ (fsteps, fconts) = unzip (liveSteps f)++ describe "simplify" $ do+ it "always terminates" $+ property $+ \(es :: ExpectSet Int) ->+ -- Hack to force deep evaluation+ let es' = simplify es in formatExpectSet es' == formatExpectSet es'++ it "preserves behavior" $+ property $+ \(es :: ExpectSet Int) -> sameBehavior 3 es (simplify es)++ describe "liveSteps" $ do+ it "expects nothing" $+ example $ liveSteps' (ExpectNothing :: ExpectSet Int) `shouldBe` []++ it "expects a step" $+ example $+ liveSteps' (ExpectStep 42)+ `shouldBe` [(42 :: Int, ExpectNothing)]++ it "expects the first step in a sequence" $+ example $ do+ let input = ExpectSequence (ExpectStep 1) (ExpectStep 2)+ liveSteps' input `shouldBe` [(1 :: Int, ExpectStep 2)]++ it "skips an exhaustable first step in a sequence" $+ example $ do+ let input = ExpectSequence ExpectNothing (ExpectStep 2)+ liveSteps' input `shouldBe` [(2 :: Int, ExpectNothing)]++ it "skips an exhaustable first step in a sequence" $+ example $ do+ let input = ExpectSequence ExpectNothing (ExpectStep 2)+ liveSteps' input `shouldBe` [(2 :: Int, ExpectNothing)]++ it "expects either step in an interleave" $+ example $ do+ let input = ExpectInterleave (ExpectStep 1) (ExpectStep 2)+ liveSteps' input+ `shouldBe` [(1 :: Int, ExpectStep 2), (2, ExpectStep 1)]++ it "optional has same behavior as or-empty" $+ property $+ \(es :: ExpectSet Int) ->+ let a = ExpectEither ExpectNothing es+ b = ExpectMulti (atMost 1) es+ in sameBehavior 3 a b
+ test/Extras.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Extras where++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)++multiplicityTests :: SpecWith ()+multiplicityTests = do+ describe "Multiplicity" $ do+ it "describes itself" $+ example $ do+ show once `shouldBe` "once"+ show anyMultiplicity `shouldBe` "any number of times"+ show (2 :: Multiplicity) `shouldBe` "twice"+ show (3 :: Multiplicity) `shouldBe` "3 times"+ show (atLeast 1) `shouldBe` "at least once"+ show (atLeast 2) `shouldBe` "at least twice"+ show (atLeast 3) `shouldBe` "at least 3 times"+ show (atMost 1) `shouldBe` "at most once"+ show (atMost 2) `shouldBe` "at most twice"+ show (atMost 3) `shouldBe` "at most 3 times"+ show (between 2 3) `shouldBe` "2 or 3 times"+ show (between 2 5) `shouldBe` "2 to 5 times"++ it "correctly implements sum" $+ property $+ \m1 m2 (NonNegative n) ->+ let natSums k = [(i, k - i) | i <- [0 .. k]]+ in meetsMultiplicity (m1 + m2) n+ == any+ (\(j, k) -> meetsMultiplicity m1 j && meetsMultiplicity m2 k)+ (natSums n)++predicateTests :: SpecWith ()+predicateTests = do+ describe "Predicate" $ do+ it "describes itself" $+ example $ do+ show anything `shouldBe` "anything"+ show (eq "foo") `shouldBe` "\"foo\""+ show (neq "foo") `shouldBe` "≠ \"foo\""+ show (gt "foo") `shouldBe` "> \"foo\""+ show (geq "foo") `shouldBe` "≥ \"foo\""+ show (lt "foo") `shouldBe` "< \"foo\""+ show (leq "foo") `shouldBe` "≤ \"foo\""+ show (just (gt "foo")) `shouldBe` "Just (> \"foo\")"+ show (left (gt "foo")) `shouldBe` "Left (> \"foo\")"+ show (right (gt "foo")) `shouldBe` "Right (> \"foo\")"+ show (zipP (eq 1) (eq 2) :: Predicate (Int, Int)) `shouldBe` "(1,2)"+ show (zip3P (eq 1) (eq 2) (eq 3) :: Predicate (Int, Int, Int))+ `shouldBe` "(1,2,3)"+ show+ ( zip4P (eq 1) (eq 2) (eq 3) (eq 4) ::+ Predicate (Int, Int, Int, Int)+ )+ `shouldBe` "(1,2,3,4)"+ show+ ( zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5) ::+ Predicate (Int, Int, Int, Int, Int)+ )+ `shouldBe` "(1,2,3,4,5)"+ show (lt "foo" `andP` gt "bar")+ `shouldBe` "< \"foo\" and > \"bar\""+ show (lt "bar" `orP` gt "foo")+ `shouldBe` "< \"bar\" or > \"foo\""+ show (notP (gt "foo")) `shouldBe` "not > \"foo\""+ show (startsWith "fun") `shouldBe` "starts with \"fun\""+ show (endsWith "ing") `shouldBe` "ends with \"ing\""+ show (hasSubstr "i") `shouldBe` "has substring \"i\""+ show (hasSubsequence "abc") `shouldBe` "has subsequence \"abc\""+ show (caseInsensitive eq "foo") `shouldBe` "(case insensitive) \"foo\""+ show (caseInsensitive startsWith "foo")+ `shouldBe` "(case insensitive) starts with \"foo\""+ show (caseInsensitive endsWith "foo")+ `shouldBe` "(case insensitive) ends with \"foo\""+ show (matchesRegex "foo" :: Predicate String)+ `shouldBe` "/foo/"+ show (matchesCaseInsensitiveRegex "foo" :: Predicate String)+ `shouldBe` "/foo/i"+ show (containsRegex "foo" :: Predicate String)+ `shouldBe` "contains /foo/"+ show (containsCaseInsensitiveRegex "foo" :: Predicate String)+ `shouldBe` "contains /foo/i"+ show (isEmpty :: Predicate [()]) `shouldBe` "empty"+ show (nonEmpty :: Predicate [()]) `shouldBe` "nonempty"+ show (sizeIs (gt 5) :: Predicate [()]) `shouldBe` "size > 5"+ show (elemsAre [gt 5, eq 5] :: Predicate [Int]) `shouldBe` "[> 5,5]"+ show (unorderedElemsAre [gt 5, eq 5] :: Predicate [Int])+ `shouldBe` "(any order) [> 5,5]"+ show (each (gt 5) :: Predicate [Int]) `shouldBe` "each (> 5)"+ show (contains (gt 5) :: Predicate [Int]) `shouldBe` "contains (> 5)"+ show (containsAll [gt 5] :: Predicate [Int])+ `shouldBe` "contains all of [> 5]"+ show (containsOnly [gt 5] :: Predicate [Int])+ `shouldBe` "contains only [> 5]"+ show (containsKey (eq "foo") :: Predicate [(String, String)])+ `shouldBe` "contains key \"foo\""+ show+ ( containsEntry (eq "foo") (eq "bar") ::+ Predicate [(String, String)]+ )+ `shouldBe` "contains entry (\"foo\",\"bar\")"+ show (keysAre [eq 1, eq 2, eq 3] :: Predicate [(Int, String)])+ `shouldBe` "keys are [1,2,3]"+ show+ ( entriesAre [(eq 1, eq "one"), (eq 2, eq "two")] ::+ Predicate [(Int, String)]+ )+ `shouldBe` "entries are [(1,\"one\"),(2,\"two\")]"+ show (approxEq 1.0 :: Predicate Double) `shouldBe` "≈ 1.0"+ show (finite :: Predicate Double) `shouldBe` "finite"+ show (infinite :: Predicate Double) `shouldBe` "infinite"+ show (nAn :: Predicate Double) `shouldBe` "NaN"+ show (is even :: Predicate Int)+ `shouldSatisfy` ("custom predicate at " `isPrefixOf`)+ show ($(qIs [|even|]) :: Predicate Int) `shouldBe` "even"+ show (with length (gt 5) :: Predicate String)+ `shouldSatisfy` ("property at " `isPrefixOf`)+ show ($(qWith [|length|]) (gt 5) :: Predicate String)+ `shouldBe` "length: > 5"++ it "matches patterns" $+ example $ do+ let p = $(qMatch [p|Just (Left _)|])+ show p `shouldBe` "Just (Left _)"++ accept p (Just (Left "foo")) `shouldBe` True+ accept p (Just (Right "foo")) `shouldBe` False+ accept p Nothing `shouldBe` False++ it "checks types" $+ example $ do+ let p1 :: Typeable a => Predicate a+ p1 = typed @String anything++ p2 :: Typeable a => Predicate a+ p2 = typed @String (eq "foo")++ show (p1 :: Predicate String)+ `shouldBe` "anything :: [Char]"+ show (p1 :: Predicate Int)+ `shouldBe` "anything :: [Char]"++ accept p1 "foo" `shouldBe` True+ accept p1 "bar" `shouldBe` True+ accept p1 () `shouldBe` False+ accept p1 (5 :: Int) `shouldBe` False++ show (p2 :: Predicate String)+ `shouldBe` "\"foo\" :: [Char]"+ show (p2 :: Predicate Int)+ `shouldBe` "\"foo\" :: [Char]"++ accept p2 "foo" `shouldBe` True+ accept p2 "bar" `shouldBe` False+ accept p2 (5 :: Int) `shouldBe` False
+ test/Main.hs view
@@ -0,0 +1,21 @@+import Classes (classTests)+import Core (coreTests)+import Demo (demoSpec)+import qualified DocTests.All+import ExpectSet+import Extras (multiplicityTests, predicateTests)+import qualified Test.DocTest.Driver as DocTest+import Test.Hspec (hspec)+import TH++main :: IO ()+main = do+ hspec $ do+ multiplicityTests+ predicateTests+ expectSetSpec+ coreTests+ classTests+ thUtilSpec+ demoSpec+ DocTest.run DocTests.All.main
+ test/PolysemyTest.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}++module PolysemyTest where++import Data.Kind (Type)+import Data.Typeable (Typeable)+import Polysemy++data FileSystem (m :: Type -> Type) a where+ ReadFile :: FilePath -> FileSystem m String+ WriteFile :: FilePath -> String -> FileSystem m ()++makeSem ''FileSystem++class Mockable (eff :: Effect) where+ data Action eff :: (Type -> Type) -> Type -> Type++instance Mockable FileSystem where+ data Action FileSystem m a where+ ReadFile_ :: FilePath -> Action FileSystem m String+ WriteFile_ :: FilePath -> String -> Action FileSystem m ()++data Step (m :: Type -> Type) where+ Step ::+ (Mockable eff, Typeable eff, Typeable m, Typeable a) =>+ Action eff m a ->+ m a ->+ Step m++type ExpectSet m = [Step m]++data Mock m a where+ Expect :: ExpectSet m -> Mock m ()+ MockAction :: Mockable eff => Action eff m a -> Mock m a++makeSem ''Mock++interpretFSToMock :: Member Mock r => Sem (FileSystem ': r) a -> Sem r a+interpretFSToMock = interpret $ \case+ ReadFile f -> mockAction (ReadFile_ f)+ WriteFile f s -> mockAction (WriteFile_ f s)++{-+interpretMock :: forall r a. Sem (Mock ': r) a -> Sem r a+interpretMock = do+ (finalES, r) <- runState [] $ reinterpretH $ \case+ Expect es -> do+ es' <- get+ put (es ++ es')+ return ()+ MockAction a -> error "Unimplemented"+ unless (null finalES) $ error "Unmet expectations"+ return r+-}
+ test/QuasiMock.hs view
@@ -0,0 +1,132 @@+{-# 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++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 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+ -- Mocks+ qReport b s = mockMethod (QReport b s)+ qLookupName b s = mockMethod (QLookupName b s)+ qReify n = mockDefaultlessMethod (QReify n)+ qReifyFixity n = mockMethod (QReifyFixity n)+ qReifyInstances n ts = mockMethod (QReifyInstances n ts)+ qReifyRoles n = mockMethod (QReifyRoles n)+ qReifyModule m = mockDefaultlessMethod (QReifyModule m)+ qReifyConStrictness n = mockMethod (QReifyConStrictness n)+ qLocation = mockDefaultlessMethod QLocation+ qAddDependentFile f = mockMethod (QAddDependentFile f)+ qAddTopDecls ds = mockMethod (QAddTopDecls ds)+ qAddModFinalizer f = mockMethod (QAddModFinalizer f)+ qAddCorePlugin s = mockMethod (QAddCorePlugin s)+ qPutQ a = mockMethod (QPutQ a)+ qIsExtEnabled e = mockDefaultlessMethod (QIsExtEnabled e)+ qExtsEnabled = mockMethod QExtsEnabled++#if MIN_VERSION_template_haskell(2, 14, 0)+ qAddTempFile s = mockMethod (QAddTempFile s)+ qAddForeignFilePath l s = mockMethod (QAddForeignFilePath l s)+#else+ qAddForeignFile l s = mockMethod (QAddForeignFile l s)+#endif++#if MIN_VERSION_template_haskell(2, 16, 0)+ qReifyType n = mockDefaultlessMethod (QReifyType n)+#endif++ -- Methods delegated to IO+ qNewName s = liftIO (qNewName s)++ -- Non-mockable methods that cannot be lifted to IO+ qGetQ = error "qGetQ"+ qRecover = error "qRecover"+ qReifyAnnotations = error "qReifyAnnotations"++functionType :: [Type] -> Bool+functionType = everything (||) (mkQ False isArrow)+ where+ isArrow ArrowT = True+ isArrow _ = False++instance Mockable Quasi where+ setupMockable _ = do+ expectAny $ 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) |-> []++ 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"))])
+ test/TH.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module TH where++import Control.Monad.Trans (liftIO)+import Language.Haskell.TH+import QuasiMock+import Test.HMock+import Test.HMock.Internal.TH.Util (resolveInstance, unifyTypes)+import Test.Hspec+import Util.TH (reifyInstancesStatic, reifyStatic)++data NotShowable++$(pure [])++thUtilSpec :: SpecWith ()+thUtilSpec = do+ describe "unifyTypes" $ do+ it "accepts identical types" $+ example $+ runMockT $ do+ result <- runQ $ unifyTypes (ConT ''Bool) (ConT ''Bool)+ liftIO $ result `shouldBe` Just []++ it "rejects different types" $+ example $+ runMockT $ do+ result <- runQ $ unifyTypes (ConT ''Bool) (ConT ''Int)+ liftIO $ result `shouldBe` Nothing++ it "unifies patterns with variables" $+ example $+ runMockT $ do+ v <- runQ $ newName "a"+ t1 <- runQ [t|Maybe ($(varT v), Int)|]+ t2 <- runQ [t|Maybe (Bool, Int)|]+ result <- runQ $ unifyTypes t1 t2+ liftIO $ result `shouldBe` Just [(v, ConT ''Bool)]++ it "substitutes synonyms" $+ example $+ runMockT $ do+ v <- runQ $ newName "a"+ t1 <- runQ [t|[$(varT v)]|]+ t2 <- runQ [t|String|]+ result <- runQ $ unifyTypes t1 t2+ liftIO $ result `shouldBe` Just [(v, ConT ''Char)]++ describe "resolveInstance" $ do+ it "finds unrestricted instances" $+ example $+ runMockT $ do+ result <- runQ $ resolveInstance ''Show (ConT ''String)+ liftIO $ result `shouldBe` Just []++ it "finds context on nested vars" $+ example $+ runMockT $ do+ v <- runQ $ newName "a"+ result <- runQ $ resolveInstance ''Show (AppT ListT (VarT v))+ liftIO $ result `shouldBe` Just [AppT (ConT ''Show) (VarT v)]++ 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)+ ]+ )++ t <- runQ [t|(Int, NotShowable)|]+ result <- runQ $ resolveInstance ''Show t+ liftIO $ result `shouldBe` Nothing
+ test/Util/DeriveRecursive.hs view
@@ -0,0 +1,58 @@+module Util.DeriveRecursive where++import Control.Monad (replicateM)+import Control.Monad.Extra (concatMapM)+import Control.Monad.State (StateT, evalStateT, gets, modify)+import Control.Monad.Trans (MonadTrans (lift))+import Language.Haskell.TH+import Data.List (foldl')++deriveRecursive :: Maybe DerivStrategy -> Name -> Name -> Q [Dec]+deriveRecursive strat cls ty = evalStateT (concatMapM defineIfNeeded [ty]) []+ where+ defineIfNeeded :: Name -> StateT [Name] Q [Dec]+ defineIfNeeded t = do+ done <- gets (t `elem`)+ if done then return [] else modify (t :) >> defineInstance t++ defineInstance :: Name -> StateT [Name] Q [Dec]+ defineInstance t = do+ info <- lift (reify t)+ case info of+ TyConI (DataD _ n vs _ cons _)+ | n == t -> defineTypeAndCons t (length vs) cons+ TyConI (NewtypeD _ n vs _ con _)+ | n == t -> defineTypeAndCons t (length vs) [con]+ TyConI (TySynD _ _ t') -> concatMapM defineIfNeeded (typeToCons t')+ _ -> return []++ defineTypeAndCons :: Name -> Int -> [Con] -> StateT [Name] Q [Dec]+ defineTypeAndCons t nvars cons = do+ vs <- replicateM nvars (lift (newName "v"))+ let fullType = foldl' (\t' v -> AppT t' (VarT v)) (ConT t) vs+ let cx = AppT (ConT cls) . VarT <$> vs+ hasInstance <- lift (isInstance cls [fullType])+ if hasInstance+ then return []+ else do+ fieldDecls <-+ concatMapM defineIfNeeded $+ concatMap typeToCons $ concatMap conFieldTypes cons+ return+ ( StandaloneDerivD strat cx (AppT (ConT cls) fullType) :+ fieldDecls+ )++ conFieldTypes :: Con -> [Type]+ conFieldTypes (NormalC _ bts) = snd <$> bts+ conFieldTypes (RecC _ vbts) = (\(_, _, t) -> t) <$> vbts+ conFieldTypes (InfixC t1 _ t2) = [snd t1, snd t2]+ conFieldTypes (ForallC _ _ con) = conFieldTypes con+ conFieldTypes (GadtC _ bts _) = snd <$> bts+ conFieldTypes (RecGadtC _ vbts _) = (\(_, _, t) -> t) <$> vbts++ typeToCons :: Type -> [Name]+ typeToCons (ConT c) = [c]+ typeToCons (AppT ListT t) = typeToCons t+ typeToCons (AppT t1 t2) = typeToCons t1 ++ typeToCons t2+ typeToCons _ = []
+ test/Util/TH.hs view
@@ -0,0 +1,25 @@+{-# 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