horizontal-rule 0.6.0.0 → 0.7.0.0

raw patch · 25 files changed

+4548/−43 lines, 25 filesdep +arraydep +constraintsdep +containersdep −HMockdep ~ansi-wl-pprintdep ~basedep ~optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependencies added: array, constraints, containers, data-default, exceptions, extra, monad-control, mtl, stm, syb, template-haskell, transformers-base, unliftio

Dependencies removed: HMock

Dependency ranges changed: ansi-wl-pprint, base, optparse-applicative, tasty, tasty-hunit, terminal-size, text, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−1
• LICENSE +1/−1
• app/LibOA.hs +1/−1
• app/Main.hs +1/−1
• horizontal-rule.cabal +69/−37
• src/HR.hs +1/−1
• src/HR/Monad/Terminal.hs +1/−1
• test/Test/HMock.hs +116/−0
• test/Test/HMock/ExpectContext.hs +192/−0
• test/Test/HMock/Internal/ExpectSet.hs +203/−0
• test/Test/HMock/Internal/Rule.hs +65/−0
• test/Test/HMock/Internal/State.hs +296/−0
• test/Test/HMock/Internal/State.hs-boot +18/−0
• test/Test/HMock/Internal/Step.hs +112/−0
• test/Test/HMock/Internal/TH.hs +262/−0
• test/Test/HMock/Internal/Util.hs +27/−0
• test/Test/HMock/MockMethod.hs +259/−0
• test/Test/HMock/MockT.hs +280/−0
• test/Test/HMock/Mockable.hs +78/−0
• test/Test/HMock/Multiplicity.hs +155/−0
• test/Test/HMock/Rule.hs +59/−0
• test/Test/HMock/TH.hs +707/−0
• test/Test/Predicates.hs +1477/−0
• test/Test/Predicates/Internal/FlowMatcher.hs +95/−0
• test/Test/Predicates/Internal/Util.hs +55/−0

@@ -4,7 +4,7 @@ versions in `A.B.C.D` format.  `A` may be incremented arbitrarily for non-technical reasons, but [semantic versioning][SemVer] is otherwise followed, where `A.B` is the major version, `C` is the minor version, and `D`-is the patch version.  Initial development uses versions `0.0.0.D`, for which+is the patch version.  Initial development uses versions `0.0.C.D`, for which every version is considered breaking.  [PVP]: <https://pvp.haskell.org/>@@ -23,6 +23,23 @@ * Changes are listed in arbitrary order and present tense.  [KaC]: <https://keepachangelog.com/en/1.0.0/>++## 0.7.0.0 (2024-12-04)++### Breaking++* Remove support for GHC 8.6, constraining lower bounds+* Remove support for GHC 8.4, constraining lower bounds+* Remove support for GHC 8.2, constraining lower bounds+* Change minimal Cabal from 1.24 to 3.0++### Non-Breaking++* Bump `base` dependency version upper bound+* Bump `tasty` dependency version upper bound+* Bump `text` dependency version upper bound+* Bump `time` dependency version upper bound+* Vendor `HMock` and `explainable-predicates`  ## 0.6.0.0 (2023-05-28) 

@@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2019-2023 Travis Cardwell+Copyright (c) 2019-2024 Travis Cardwell  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -2,7 +2,7 @@ -- | -- Module      : LibOA -- Description : supplementary functions for optparse-applicative--- Copyright   : Copyright (c) 2019-2023 Travis Cardwell+-- Copyright   : Copyright (c) 2019-2024 Travis Cardwell -- License     : MIT -- -- This is a collection of functions that I often use with

@@ -2,7 +2,7 @@ -- | -- Module      : Main -- Description : hr: a horizontal rule for terminals--- Copyright   : Copyright (c) 2019-2023 Travis Cardwell+-- Copyright   : Copyright (c) 2019-2024 Travis Cardwell -- License     : MIT -- -- See the README for details.

@@ -1,36 +1,34 @@-name:           horizontal-rule-version:        0.6.0.0-category:       Utils-synopsis:       horizontal rule for the terminal+cabal-version:      3.0+name:               horizontal-rule+version:            0.7.0.0+synopsis:           horizontal rule for the terminal description:   This package provides a utility for displaying a horizontal rule in a   terminal.  Please see the README on GitHub at   <https://github.com/ExtremaIS/hr-haskell#readme>.+homepage:           https://github.com/ExtremaIS/hr-haskell#readme+bug-reports:        https://github.com/ExtremaIS/hr-haskell/issues+license:            MIT+license-file:       LICENSE+author:             Travis Cardwell <travis.cardwell@extrema.is>+maintainer:         Travis Cardwell <travis.cardwell@extrema.is>+copyright:          Copyright (c) 2019-2024 Travis Cardwell+category:           Utils+build-type:         Simple -homepage:       https://github.com/ExtremaIS/hr-haskell#readme-bug-reports:    https://github.com/ExtremaIS/hr-haskell/issues-author:         Travis Cardwell <travis.cardwell@extrema.is>-maintainer:     Travis Cardwell <travis.cardwell@extrema.is>-copyright:      Copyright (c) 2019-2023 Travis Cardwell-license:        MIT-license-file:   LICENSE+extra-doc-files:+  CHANGELOG.md+  README.md -cabal-version:  1.24-build-type:     Simple tested-with:-  GHC ==8.2.2-   || ==8.4.4-   || ==8.6.5-   || ==8.8.4+  GHC ==8.8.4    || ==8.10.7    || ==9.0.2    || ==9.2.8-   || ==9.4.5-   || ==9.6.2--extra-source-files:-  CHANGELOG.md-  README.md+   || ==9.4.8+   || ==9.6.6+   || ==9.8.4+   || ==9.10.1  source-repository head   type: git@@ -49,10 +47,12 @@     , HR.Monad.Terminal   other-modules:       Paths_horizontal_rule+  autogen-modules:+      Paths_horizontal_rule   build-depends:-      base >=4.10.1 && <4.19-    , terminal-size >=0.2 && <0.4-    , text >=1.2.3 && <2.1+      base >=4.13.0.0 && <4.21+    , terminal-size >=0.3.2.1 && <0.4+    , text >=1.2.4.0 && <2.2   default-language: Haskell2010   default-extensions:       OverloadedStrings@@ -67,15 +67,15 @@       base     , horizontal-rule     , text-    , time >=1.8.0.2 && <1.13+    , time >=1.9.3 && <1.15   if flag(optparse-applicative_ge_0_18)     build-depends:         optparse-applicative >=0.18 && <0.19       , prettyprinter >=1.7.1 && <1.8   else     build-depends:-        ansi-wl-pprint >=0.6.8 && <1.1-      , optparse-applicative >=0.13 && <0.18+        ansi-wl-pprint >=0.6.9 && <1.1+      , optparse-applicative >=0.15.1.0 && <0.18   default-language: Haskell2010   ghc-options: -Wall @@ -84,16 +84,48 @@   hs-source-dirs: test   main-is: Spec.hs   other-modules:-      HR.Test+      HR.Mock+    , HR.Test+  other-modules:+      -- vendored explainable-preducates+      Test.Predicates+    , Test.Predicates.Internal.FlowMatcher+    , Test.Predicates.Internal.Util+  other-modules:+      -- vendored HMock+      Test.HMock+    , Test.HMock.ExpectContext+    , Test.HMock.Internal.ExpectSet+    , Test.HMock.Internal.Rule+    , Test.HMock.Internal.State+    , Test.HMock.Internal.Step+    , Test.HMock.Internal.TH+    , Test.HMock.Internal.Util+    , Test.HMock.MockMethod+    , Test.HMock.MockT+    , Test.HMock.Mockable+    , Test.HMock.Multiplicity+    , Test.HMock.Rule+    , Test.HMock.TH   build-depends:       base     , horizontal-rule-    , tasty >=0.12 && <1.5-    , tasty-hunit >=0.8 && <0.11-  if impl(ghc >= 8.6.1)-    other-modules:-        HR.Mock-    build-depends:-        HMock >=0.5.1 && <0.6+    , tasty >=1.2.3 && <1.6+    , tasty-hunit >=0.10.0.3 && <0.11+  build-depends:+      -- vendored dependencies+      array >=0.5.2 && <0.6+    , constraints >=0.13 && <0.15+    , containers >=0.6.2 && <0.8+    , data-default >=0.7.1 && <0.9+    , exceptions >=0.10.4 && <0.11+    , extra >=1.7.9 && <1.9+    , monad-control >=1.0.2 && <1.1+    , mtl >=2.2.2 && <2.4+    , stm >=2.5.0 && <2.6+    , syb >=0.7.2 && <0.8+    , template-haskell >=2.14 && <2.23+    , transformers-base >=0.4.5 && <0.5+    , unliftio >=0.2.18 && <0.3   default-language: Haskell2010   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N

@@ -2,7 +2,7 @@ -- | -- Module      : HR -- Description : horizontal rule for terminals--- Copyright   : Copyright (c) 2019-2023 Travis Cardwell+-- Copyright   : Copyright (c) 2019-2024 Travis Cardwell -- License     : MIT -- -- This library is meant to be imported qualified, as follows:

@@ -2,7 +2,7 @@ -- | -- Module      : HR.Monad.Terminal -- Description : terminal output--- Copyright   : Copyright (c) 2019-2023 Travis Cardwell+-- Copyright   : Copyright (c) 2019-2024 Travis Cardwell -- License     : MIT ------------------------------------------------------------------------------ 

@@ -0,0 +1,116 @@+{-# 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' [t|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+  ( +    -- * The 'Mockable' class++    -- | HMock starts with the 'Mockable' class (most of which is actually in+    -- its superclass, 'MockableBase').  This class is implemented for each+    -- interface you want to mock, and describes which actions are possible,+    -- and how to match and compare them.  It's a lot of boilerplate, so you'll+    -- usually derive it with Template Haskell, but the instance must exist.+    module Test.HMock.Mockable,++    -- * Running mocks++    -- | Tests with mocks run in the 'MockT' monad transformer, which wraps a+    -- base monad and adds the ability to delegate methods to HMock for+    -- matching.  'runMockT' is the entry point for 'MockT'.+    --+    -- This module also defines the more restricted 'MockSetup;' monad, which+    -- is used to set up defaults for a type.+    module Test.HMock.MockT,++    -- * Rules for actions and responses++    -- | The bread and butter of mocks is matching actions and specifying+    -- responses.  Matchers and corresponding responses are combined into a+    -- 'Rule'+    module Test.HMock.Rule,++    -- * Combinators for building test plans++    -- | A complete execution plans consists of a collection of individual rules+    -- combined in various ways.  HMock defines a set of composable combinators+    -- for the execution plan.+    module Test.HMock.ExpectContext,++    -- * Multiplicity++    -- | For repeated actions in your execution plan, you often want to control+    -- the number of times somrthing is allowed to happen.  This is called a+    -- 'Multiplicity'.+    module Test.HMock.Multiplicity,++    -- * Delegating mocks++    -- | In order to run your test code with the 'MockT', you need instances of+    -- your effect classes for the 'MockT' type.  If you mock all methods of the+    -- class, this can be derived using Template Haskell.  For partial mocks,+    -- you'll need to write the instances yourself, using 'mockMethod' and its+    -- cousin 'mockDefaultlessMethod'.+    module Test.HMock.MockMethod,++    -- * Template Haskell generator++    -- | These are the Template Haskell splices which generate boilerplate for+    -- your classes to be used with HMock.+    module Test.HMock.TH,+  )+where++import Test.HMock.ExpectContext+import Test.HMock.MockT+import Test.HMock.MockMethod+import Test.HMock.Mockable+import Test.HMock.Multiplicity+import Test.HMock.Rule+import Test.HMock.TH

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

@@ -0,0 +1,203 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | The internal core language of expectations in HMock.+module Test.HMock.Internal.ExpectSet where++import Test.HMock.Multiplicity+  ( Multiplicity,+    between,+    feasible, meetsMultiplicity+  )++-- | 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 && (meetsMultiplicity mult 0 || satisfied e)+satisfied (ExpectConsecutive mult e) =+  feasible mult && (meetsMultiplicity mult 0 || satisfied e)++-- | Computes the live steps of the ExpectSet.  In other words: which individual+-- steps can be matched right now, and what are the remaining expectations in+-- 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 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 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)+      | meetsMultiplicity m 0 = ExpectNothing+      | otherwise = ExpectMulti m (go e)+    go (ExpectConsecutive m e)+      | meetsMultiplicity m 0 = ExpectNothing+      | otherwise = ExpectConsecutive m (go e)+    go other = other

@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++-- | Internal module to define 'Rule', so that its constructor can be visible+-- to other implementation code.+module Test.HMock.Internal.Rule where++import Data.Kind (Constraint, Type)+import GHC.TypeLits (Symbol)+import {-# SOURCE #-} Test.HMock.Internal.State (MockT)+import Test.HMock.Mockable (MockableBase (..))++-- | A way to match an entire action, using conditions that might depend on the+-- relationship between arguments.+data WholeMethodMatcher cls name m r where+  JustMatcher :: Matcher cls name m r -> WholeMethodMatcher cls name m r+  SuchThat ::+    Matcher cls name m r ->+    (Action cls name m r -> Bool) ->+    WholeMethodMatcher cls name m r++-- | Displays a WholeMethodMatcher.  The predicate isn't showable, but we can at+-- least indicate whether there is one present.+showWholeMatcher ::+  MockableBase cls =>+  Maybe (Action cls name m a) ->+  WholeMethodMatcher cls name m b ->+  String+showWholeMatcher a (JustMatcher m) = showMatcher a m+showWholeMatcher a (m `SuchThat` _) =+  showMatcher a m ++ " (with whole method matcher)"++-- | A rule for matching a method and responding to it when it matches.+--+-- The method may be matched by providing either an 'Action' to match exactly,+-- or a 'Matcher'.  Exact matching is only available when all method arguments+--+-- A 'Rule' may have zero or more responses, which are attached using+-- 'Test.HMock.Rule.|->' and 'Test.HMock.Rule.|=>'.  If there are no responses+-- for a 'Rule', then there must be a default response for that action, and it+-- is used.  If more than one response is added, the rule will perform the+-- responses in order, repeating the last response if there are additional+-- matches.+--+-- Example:+--+-- @+-- 'Test.HMock.ExpectContext.expect' $+--   GetLine_ 'Test.HMock.anything'+--     'Test.HMock.Rule.|->' "hello"+--     'Test.HMock.Rule.|=>' \(GetLine prompt) -> "The prompt was " ++ prompt+--     'Test.HMock.Rule.|->' "quit"+-- @+data+  Rule+    (cls :: (Type -> Type) -> Constraint)+    (name :: Symbol)+    (m :: Type -> Type)+    (r :: Type)+  where+  (:=>) ::+    WholeMethodMatcher cls name m r ->+    [Action cls name m r -> MockT m r] ->+    Rule cls name m r

@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE KindSignatures #-}++-- | This module contains MockT and SetupMockT state functions.+module Test.HMock.Internal.State where++import Control.Monad (forM_, unless, (<=<))+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Except (MonadError)+import Control.Monad.Extra (maybeM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.Reader (MonadReader (..), ReaderT, mapReaderT, runReaderT)+import Control.Monad.State (MonadState)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Writer (MonadWriter)+import Data.Proxy (Proxy (Proxy))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable (TypeRep, Typeable, typeRep)+import GHC.Stack (withFrozenCallStack, HasCallStack)+import GHC.TypeLits (KnownSymbol, symbolVal)+import System.IO (hPutStrLn, stderr)+import Test.HMock.ExpectContext (ExpectContext (..))+import Test.HMock.Internal.ExpectSet (ExpectSet (..), getSteps)+import Test.HMock.Internal.Step (SingleRule, Step (..), unwrapExpected)+import Test.HMock.Internal.Util (Located)+import Test.HMock.Mockable (Mockable (..))+import UnliftIO+  ( MonadIO,+    MonadUnliftIO(withRunInIO),+    STM,+    TVar,+    atomically,+    modifyTVar,+    newTVarIO,+    readTVar,+    readTVarIO,+  )+import Data.Kind (Type, Constraint)++#if !MIN_VERSION_base(4, 13, 0)+import Control.Monad.Fail (MonadFail)+#endif++-- | The severity for a possible problem.+data Severity+  = -- | Fail the test.+    Error+  | -- | Print a message, but continue the test.+    Warning+  | -- | Don't do anything.+    Ignore++-- | Full state of a mock.+data MockState m = MockState+  { mockExpectSet :: TVar (ExpectSet (Step m)),+    mockDefaults :: TVar [Step m],+    mockAllowUnexpected :: TVar [Step m],+    mockSideEffects :: TVar [Step m],+    mockAmbiguitySeverity :: TVar Severity,+    mockUnexpectedSeverity :: TVar Severity,+    mockUninterestingSeverity :: TVar Severity,+    mockUnmetSeverity :: TVar Severity,+    mockClasses :: TVar (Set TypeRep),+    mockInterestingMethods :: TVar (Set (TypeRep, String)),+    mockParent :: Maybe (MockState m)+  }++-- | Initializes a new 'MockState' with the given parent.  If the parent is+-- 'Nothing', then a new root state is made.+initMockState :: MonadIO m => Maybe (MockState m) -> m (MockState m)+initMockState parent =+  MockState+    <$> newTVarIO ExpectNothing+    <*> newTVarIO []+    <*> newTVarIO []+    <*> newTVarIO []+    <*> maybeM+      (newTVarIO Ignore)+      (newTVarIO <=< readTVarIO . mockAmbiguitySeverity)+      (return parent)+    <*> maybeM+      (newTVarIO Error)+      (newTVarIO <=< readTVarIO . mockUnexpectedSeverity)+      (return parent)+    <*> maybeM+      (newTVarIO Error)+      (newTVarIO <=< readTVarIO . mockUninterestingSeverity)+      (return parent)+    <*> maybeM+      (newTVarIO Error)+      (newTVarIO <=< readTVarIO . mockUnmetSeverity)+      (return parent)+    <*> maybe (newTVarIO Set.empty) (return . mockClasses) parent+    <*> maybe (newTVarIO Set.empty) (return . mockInterestingMethods) parent+    <*> pure parent++-- | Gets a list of all states, starting with the innermost.+allStates :: MockState m -> [MockState m]+allStates s+  | Just s' <- mockParent s = s : allStates s'+  | otherwise = [s]++-- | Gets the root state.+rootState :: MockState m -> MockState m+rootState = last . allStates++-- | Monad for setting up a mockable class.  Note that even though the type+-- looks that way, this is *not* a monad transformer.  It's a very restricted+-- environment that can only be used to set up defaults for a class.+newtype MockSetup m a where+  MockSetup :: {unMockSetup :: ReaderT (MockState m) STM a} -> MockSetup m a+  deriving (Functor, Applicative, Monad)++-- | Runs a setup action with the root state, rather than the current one.+runInRootState :: MockSetup m a -> MockSetup m a+runInRootState = MockSetup . local rootState . unMockSetup++-- | Run an STM action in 'MockSetup'+mockSetupSTM :: STM a -> MockSetup m a+mockSetupSTM m = MockSetup (lift m)++-- | Runs class initialization for a 'Mockable' class, if it hasn't been run+-- yet.+initClassIfNeeded ::+  forall cls m proxy.+  (Mockable cls, Typeable m, MonadIO m) =>+  proxy cls ->+  MockSetup m ()+initClassIfNeeded proxy = runInRootState $ do+  state <- MockSetup ask+  classes <- mockSetupSTM $ readTVar (mockClasses state)+  unless (Set.member t classes) $ do+    mockSetupSTM $ modifyTVar (mockClasses state) (Set.insert t)+    setupMockable (Proxy :: Proxy cls)+  where+    t = typeRep proxy++-- | Marks a method as "interesting".  This can have implications for what+-- happens to calls to that method.+markInteresting ::+  forall (cls :: (Type -> Type) -> Constraint) name m proxy1 proxy2.+  (Typeable cls, KnownSymbol name) =>+  proxy1 cls ->+  proxy2 name ->+  MockSetup m ()+markInteresting proxyCls proxyName = runInRootState $ do+  state <- MockSetup ask+  mockSetupSTM $+    modifyTVar+      (mockInterestingMethods state)+      (Set.insert (typeRep proxyCls, symbolVal proxyName))++-- | Determines whether a method is "interesting".+isInteresting :: +  forall (cls :: (Type -> Type) -> Constraint) name m proxy1 proxy2.+  (Typeable cls, KnownSymbol name) =>+  proxy1 cls ->+  proxy2 name ->+  MockSetup m Bool+isInteresting proxyCls proxyName = runInRootState $ do+  state <- MockSetup ask+  interesting <- mockSetupSTM $ readTVar (mockInterestingMethods state)+  return ((typeRep proxyCls, symbolVal proxyName) `Set.member` interesting)++-- | Runs class initialization for all uninitialized 'Mockable' classes in the+-- given 'ExpectSet'.+initClassesAsNeeded :: MonadIO m => ExpectSet (Step m) -> MockSetup m ()+initClassesAsNeeded es = runInRootState $+  forM_ (getSteps es) $+    \(Step (_ :: Located (SingleRule cls name m r))) -> do+      initClassIfNeeded (Proxy :: Proxy cls)+      markInteresting (Proxy :: Proxy cls) (Proxy :: Proxy name)++-- | Monad transformer for running mocks.+newtype MockT m a where+  MockT :: {unMockT :: ReaderT (MockState m) m a} -> MockT m a+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadFail,+      MonadIO,+      MonadState s,+      MonadWriter w,+      MonadRWS r w s,+      MonadError e,+      MonadCont,+      MonadBase b,+      MonadCatch,+      MonadMask,+      MonadThrow+    )++instance MonadTrans MockT where+  lift = MockT . lift++-- Note: The 'MonadUnliftIO' instance is implemented manually because deriving+-- it causes compilation failure in GHC 8.6 and 8.8.  (See issue #23.)+instance MonadUnliftIO m => MonadUnliftIO (MockT m) where+  withRunInIO inner = MockT $ withRunInIO $ \run -> inner (run . unMockT)++-- | Applies a function to the base monad of 'MockT'.+mapMockT :: (m a -> m b) -> MockT m a -> MockT m b+mapMockT f = MockT . mapReaderT f . unMockT++instance MonadReader r m => MonadReader r (MockT m) where+  ask = lift ask+  local = mapMockT . local+  reader = lift . reader++-- | This type class defines a shared API between the 'MockT' and 'MockSetup'+-- monads.+class MockContext ctx where+  -- | Runs a 'MockSetup' action in this monad.+  fromMockSetup :: MonadIO m => MockSetup m a -> ctx m a++instance MockContext MockSetup where+  fromMockSetup = id++instance MockContext MockT where+  fromMockSetup m = do+    state <- MockT ask+    atomically $ runReaderT (unMockSetup m) state++-- | Adds an expectation to the 'MockState' for the given 'ExpectSet',+-- interleaved with any existing expectations.+expectThisSet :: MonadIO m => ExpectSet (Step m) -> MockSetup m ()+expectThisSet e = do+  initClassesAsNeeded e+  state <- MockSetup ask+  mockSetupSTM $ modifyTVar (mockExpectSet state) (e `ExpectInterleave`)++-- | This instance allows you to add expectations from 'MockSetup' actions.+-- This is an unusual thing to do.  Consider using+-- 'Test.HMock.MockT.allowUnexpected', instead.+instance ExpectContext MockSetup where+  expect e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expect e+  expectN mult e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectN mult e+  expectAny e =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectAny e+  inSequence es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ inSequence es+  inAnyOrder es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ inAnyOrder es+  anyOf es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ anyOf es+  times mult es =+    withFrozenCallStack $ expectThisSet $ unwrapExpected $ times mult es+  consecutiveTimes mult es =+    withFrozenCallStack $+      expectThisSet $ unwrapExpected $ consecutiveTimes mult es++instance ExpectContext MockT where+  expect e =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ expect e+  expectN mult e =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ expectN mult e+  expectAny e =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ expectAny e+  inSequence es =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ inSequence es+  inAnyOrder es =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ inAnyOrder es+  anyOf es =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ anyOf es+  times mult es =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ times mult es+  consecutiveTimes mult es =+    withFrozenCallStack $+      fromMockSetup $ expectThisSet $ unwrapExpected $ consecutiveTimes mult es++-- | Reports a potential problem with the given 'Severity'.+reportFault :: (HasCallStack, MonadIO m) => Severity -> String -> MockT m ()+reportFault severity msg = case severity of+  Ignore -> return ()+  Warning -> liftIO $ hPutStrLn stderr msg+  Error -> error msg

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

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

@@ -0,0 +1,262 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++-- | Template Haskell utilities used to implement HMock.+module Test.HMock.Internal.TH+  ( unappliedName,+    tvName,+    bindVar,+    substTypeVar,+    substTypeVars,+    splitType,+    freeTypeVars,+    relevantContext,+    constrainVars,+    unifyTypes,+    removeModNames,+    hasPolyType,+    hasNestedPolyType,+    resolveInstance,+    resolveInstanceType,+    simplifyContext,+    localizeMember,+  )+where++import Control.Monad.Extra (mapMaybeM, concatMapM)+import Data.Generics+import Data.List ((\\), nub)+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)++-- | Fetches the 'Name' of a 'TyVarBndr'.+tvName :: TyVarBndr flag -> Name+tvName (PlainTV name _) = name+tvName (KindedTV name _ _) = name++-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.+bindVar :: Name -> TyVarBndr Specificity+bindVar n = PlainTV n SpecifiedSpec++#else++-- | Fetches the 'Name' of a 'TyVarBndr'.+tvName :: TyVarBndr -> Name+tvName (PlainTV name) = name+tvName (KindedTV name _) = name++-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.+bindVar :: Name -> TyVarBndr+bindVar = PlainTV++#endif++-- | Gets the unapplied top-level name from a type application.+unappliedName :: Type -> Maybe Name+unappliedName (AppT a _) = unappliedName a+unappliedName (ConT a) = Just a+unappliedName _ = Nothing++-- | Substitutes a 'Type' for all occurrences of the given 'Name'.+substTypeVar :: Name -> Type -> Type -> Type+substTypeVar n t = substTypeVars [(n, t)]++-- | Makes variable substitutions from the given table.+substTypeVars :: [(Name, Type)] -> Type -> Type+substTypeVars classVars = everywhere (mkT subst)+  where+    subst (VarT x) | Just t <- lookup x classVars = t+    subst t = t++-- | Splits a type application into a top-level constructor and a list of its+-- type arguments.+splitTypeApp :: Type -> Maybe (Name, [Type])+splitTypeApp (ConT name) = Just (name, [])+splitTypeApp (AppT a b) = fmap (++ [b]) <$> splitTypeApp a+splitTypeApp _ = Nothing++-- | Splits a function type into a list of bound type vars, context, parameter+-- types, and return value type.+splitType :: Type -> ([Name], Cxt, [Type], Type)+splitType (ForallT tv cx b) =+  let (tvs, cxs, params, retval) = splitType b+   in (map tvName tv ++ tvs, cx ++ cxs, params, retval)+splitType (AppT (AppT ArrowT a) b) =+  let (tvs, cx, params, retval) = splitType b in (tvs, cx, a : params, retval)+splitType r = ([], [], [], r)++-- | Gets all free type variable 'Name's in the given 'Type'.+freeTypeVars :: Type -> [Name]+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)++-- | Produces a 'CxtQ' that gives all given variable 'Name's all of the given+-- class 'Type's.+constrainVars :: [TypeQ] -> [Name] -> CxtQ+constrainVars cs vs = sequence [appT c (varT v) | c <- cs, v <- vs]++-- | Culls the given binders and constraints to choose only those that apply to+-- free variables in the given type.+relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt)+relevantContext ty (tvs, cx) = (filter needsTv tvs, filteredCx)+  where+    filteredCx = filter (any (`elem` freeTypeVars ty) . freeTypeVars) cx+    needsTv v = any ((v `elem`) . freeTypeVars) (ty : filteredCx)++-- | Attempts to unify the given types by constructing a table of substitutions+-- for the variables of the left type that obtain the right one.+unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])+unifyTypes = unifyTypesWith []++-- | Unify types, but starting with a table of substitutions.+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) -> unifyWithin tbl a b+    _ -> unifyTypesWith tbl (fromMaybe a mbA) (fromMaybe b mbB)+  where+    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++-- Unifies the types that occur within the arguments, starting with a table of+-- substitutions.+unifyWithin ::+  (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])+unifyWithin tbl a b+  | toConstr a == toConstr b =+    compose (gzipWithQ (\a' b' tbl' -> unify tbl' a' b') a b) tbl+  | otherwise = return Nothing+  where+    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''+        _ -> unifyWithin 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++-- | Removes all module names from 'Name's in the given value, so that it will+-- pretty-print more cleanly.+removeModNames :: Data a => a -> a+removeModNames = everywhere (mkT unMod)+  where+    unMod NameG {} = NameS+    unMod other = other++-- | Determines if there is a polytype nested anywhere in the given type.+-- Top-level quantification doesn't count.+hasNestedPolyType :: Type -> Bool+hasNestedPolyType (ForallT _ _ t) = hasPolyType t+hasNestedPolyType t = hasPolyType t++-- | Determines if this is a polytype, including top-level quantification.+hasPolyType :: Type -> Bool+hasPolyType = everything (||) (mkQ False isPolyType)+  where+    isPolyType (ForallT tvs _ _) = not (null tvs)+    isPolyType _ = False++-- | Attempts to produce sufficient constraints for the given 'Type' to be an+-- instance of the given class 'Name'.+resolveInstance :: Name -> [Type] -> Q (Maybe Cxt)+resolveInstance cls args = do+  decs <- reifyInstances cls args+  results <- catMaybes <$> traverse (tryInstance args) decs+  case results of+    [cx] -> pure (Just cx)+    _ -> return Nothing+  where+    tryInstance :: [Type] -> InstanceDec -> Q (Maybe Cxt)+    tryInstance actualArgs (InstanceD _ cx instType _) =+      case splitTypeApp instType of+        Just (cls', instArgs)+          | cls' == cls ->+            unifyWithin [] instArgs actualArgs >>= \case+              Just tbl -> simplifyContext (substTypeVars tbl <$> cx)+              Nothing -> return Nothing+        _ -> return Nothing+    tryInstance _ _ = return Nothing++-- | Attempts to produce sufficient constraints for the given 'Type' to be a+-- satisfied constraint.  The type should be a class applied to its type+-- parameters.+--+-- Unlike 'simplifyContext', this function always resolves the top-level+-- constraint, and returns 'Nothing' if it cannot do so.+resolveInstanceType :: Type -> Q (Maybe Cxt)+resolveInstanceType t =+  maybe (pure Nothing) (uncurry resolveInstance) (splitTypeApp t)++-- | Simplifies a context with complex types (requiring FlexibleContexts) to try+-- to obtain one with all constraints applied to variables.+--+-- Should return Nothing if and only if the simplified contraint is+-- unsatisfiable, which is the case if and only if it contains a component with+-- no type variables.+simplifyContext :: Cxt -> Q (Maybe Cxt)+simplifyContext preds+  | all isVarApp preds = return (Just preds)+  | otherwise = do+    let simplifyPred t = fromMaybe [t] <$> resolveInstanceType t+    components <- concatMapM simplifyPred preds+    if any (null . freeTypeVars) components+      then return Nothing+      else return (Just (nub components))+  where+    isVarApp (ConT _) = True+    isVarApp (AppT t (VarT _)) | isVarApp t = True+    isVarApp _ = False++-- | 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

@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Internal utilities used for HMock implementation.+module Test.HMock.Internal.Util where++import GHC.Stack (CallStack, getCallStack, prettySrcLoc)++-- | A value together with its source location.+data Located a = Loc (Maybe String) a deriving (Functor)++-- | Annotates a value with its source location from the call stack.+locate :: CallStack -> a -> Located a+locate stack = case map snd (getCallStack stack) of+  (loc : _) -> Loc (Just (prettySrcLoc loc))+  _ -> Loc Nothing++-- | Formats a 'Located' 'String' to include its source location.+withLoc :: Located String -> String+withLoc (Loc Nothing s) = s+withLoc (Loc (Just loc) s) = s ++ " at " ++ loc++-- | Returns all ways to choose one element from a list, and the corresponding+-- remaining list.+choices :: [a] -> [(a, [a])]+choices [] = []+choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs)

@@ -0,0 +1,259 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Functions to delegate 'Action's to HMock to match expectations.  There is+-- one delegation function that works if the return type has a 'Default'+-- instance, and another that doesn't require the 'Default' instance, but causes+-- the method to return 'undefined' by default.+module Test.HMock.MockMethod+  ( mockMethod,+    mockDefaultlessMethod,+  )+where++import Control.Concurrent.STM (TVar, readTVar, writeTVar)+import Control.Monad (forM, forM_, join, unless, void)+import Control.Monad.Extra (concatMapM)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ask)+import Data.Bifunctor (bimap)+import Data.Default (Default (def))+import Data.Either (partitionEithers)+import Data.Function (on)+import Data.Functor (($>))+import Data.List (intercalate, sortBy)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Proxy (Proxy (Proxy))+import Data.Typeable (cast)+import GHC.Stack (HasCallStack, withFrozenCallStack)+import Test.HMock.ExpectContext (MockableMethod)+import Test.HMock.Internal.ExpectSet (ExpectSet, liveSteps)+import Test.HMock.Internal.Rule (WholeMethodMatcher (..), showWholeMatcher)+import Test.HMock.Internal.State+  ( MockContext (..),+    MockSetup (..),+    MockState (..),+    MockT,+    Severity (..),+    allStates,+    initClassIfNeeded,+    isInteresting,+    mockSetupSTM,+    reportFault,+  )+import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step))+import Test.HMock.Internal.Util (Located (Loc), withLoc)+import Test.HMock.MockT (describeExpectations)+import Test.HMock.Mockable+  ( MatchResult (..),+    Mockable (..),+    MockableBase (..),+  )++matchWholeAction ::+  MockableBase cls =>+  WholeMethodMatcher cls name m a ->+  Action cls name m a ->+  MatchResult+matchWholeAction (JustMatcher m) a = matchAction m a+matchWholeAction (m `SuchThat` p) a = case matchAction m a of+  NoMatch n -> NoMatch n+  Match+    | p a -> Match+    | otherwise -> NoMatch []++-- | Implements mock delegation for actions.+mockMethodImpl ::+  forall cls name m r.+  (HasCallStack, MonadIO m, MockableMethod cls name m r) =>+  r ->+  Action cls name m r ->+  MockT m r+mockMethodImpl surrogate action = join $+  fromMockSetup $ do+    initClassIfNeeded (Proxy :: Proxy cls)+    states <- allStates <$> MockSetup ask+    (partial, full) <- fmap (bimap concat concat . unzip) $+      forM states $ \state -> do+        expectSet <- mockSetupSTM $ readTVar (mockExpectSet state)+        return $+          partitionEithers+            (tryMatch (mockExpectSet state) <$> liveSteps expectSet)+    let orderedPartial = sortBy (compare `on` (length . fst)) (catMaybes partial)+    defaults <- concatMapM (mockSetupSTM . readTVar . mockDefaults) states+    unexpected <-+      concatMapM+        (mockSetupSTM . readTVar . mockAllowUnexpected)+        states+    sideEffect <-+      getSideEffect+        <$> concatMapM (mockSetupSTM . readTVar . mockSideEffects) states+    ambigSev <- mockSetupSTM $ readTVar . mockAmbiguitySeverity . head $ states+    unintSev <-+      mockSetupSTM $ readTVar . mockUninterestingSeverity . head $ states+    unexpSev <- mockSetupSTM $ readTVar . mockUnexpectedSeverity . head $ states+    case ( full,+           orderedPartial,+           allowedUnexpected unexpected,+           findDefault defaults+         ) of+      (opts@((_, choose, response) : rest), _, _, d) -> do+        choose+        return $ do+          unless (null rest) $+            ambiguityError ambigSev action ((\(s, _, _) -> s) <$> opts)+          sideEffect+          fromMaybe d response+      ([], _, Just response, d) -> return (sideEffect >> fromMaybe d response)+      ([], [], _, d) -> do+        interesting <- isInteresting (Proxy :: Proxy cls) (Proxy :: Proxy name)+        case (interesting, unintSev) of+          (True, _) -> return (noMatchError unexpSev action >> d)+          (False, Error) -> return (noMatchError unexpSev action >> d)+          _ -> return (uninterestingError unintSev action >> d)+      ([], _, _, d) ->+        return (partialMatchError unexpSev action orderedPartial >> d)+  where+    tryMatch ::+      TVar (ExpectSet (Step m)) ->+      (Step m, ExpectSet (Step m)) ->+      Either+        (Maybe ([(Int, String)], String))+        (String, MockSetup m (), Maybe (MockT m r))+    tryMatch tvar (Step expected, e)+      | Just lrule@(Loc _ (m :-> impl)) <- cast expected =+        case matchWholeAction m action of+          NoMatch n ->+            Left (Just (n, withLoc (showWholeMatcher (Just action) m <$ lrule)))+          Match ->+            Right+              ( withLoc (lrule $> showWholeMatcher (Just action) m),+                mockSetupSTM $ writeTVar tvar e,+                ($ action) <$> impl+              )+      | otherwise = Left Nothing++    allowedUnexpected :: [Step m] -> Maybe (Maybe (MockT m r))+    allowedUnexpected [] = Nothing+    allowedUnexpected (Step unexpected : steps)+      | Just (Loc _ (m :-> impl)) <- cast unexpected,+        Match <- matchWholeAction m action =+        Just (($ action) <$> impl)+      | otherwise = allowedUnexpected steps++    findDefault :: [Step m] -> MockT m r+    findDefault [] = return surrogate+    findDefault (Step expected : steps)+      | Just (Loc _ (m :-> impl)) <- cast expected,+        Match <- matchWholeAction m action =+        maybe (findDefault steps) ($ action) impl+      | otherwise = findDefault steps++    getSideEffect :: [Step m] -> MockT m ()+    getSideEffect effects =+      forM_ effects $ \(Step expected) -> case cast expected of+        Just (Loc _ (m :-> Just impl))+          | Match <- matchWholeAction m action -> void (impl action)+        _ -> return ()++-- | Implements a method in a 'Mockable' monad by delegating to the mock+-- framework.  If the method is called unexpectedly, an exception will be+-- thrown.  However, an expected invocation without a specified response will+-- return the default value.+mockMethod ::+  ( HasCallStack,+    MonadIO m,+    MockableMethod cls name m r,+    Default r+  ) =>+  Action cls name m r ->+  MockT m r+mockMethod action =+  withFrozenCallStack $ mockMethodImpl def action++-- | Implements a method in a 'Mockable' monad by delegating to the mock+-- framework.  If the method is called unexpectedly, an exception will be+-- thrown.  However, an expected invocation without a specified response will+-- return undefined.  This can be used in place of 'mockMethod' when the return+-- type has no default.+mockDefaultlessMethod ::+  ( HasCallStack,+    MonadIO m,+    MockableMethod cls name m r+  ) =>+  Action cls name m r ->+  MockT m r+mockDefaultlessMethod action =+  withFrozenCallStack $ mockMethodImpl undefined action++-- | An error for an action that matches no expectations at all.  This is only+-- used if severity is Ignore or Warning.+uninterestingError ::+  (HasCallStack, Mockable cls, MonadIO m) =>+  Severity ->+  Action cls name m r ->+  MockT m ()+uninterestingError severity a =+  reportFault severity $ "Uninteresting action: " ++ showAction a++-- | An error for an action that matches no expectations at all.+noMatchError ::+  (HasCallStack, Mockable cls, MonadIO m) =>+  Severity ->+  Action cls name m r ->+  MockT m ()+noMatchError severity a = do+  fullExpectations <- describeExpectations+  reportFault severity $+    "Unexpected action: " ++ showAction a+      ++ "\n\nFull expectations:\n"+      ++ fullExpectations++-- | An error for an action that doesn't match the argument predicates for any+-- of the method's expectations.+partialMatchError ::+  (HasCallStack, Mockable cls, MonadIO m) =>+  Severity ->+  Action cls name m r ->+  [([(Int, String)], String)] ->+  MockT m ()+partialMatchError severity a partials = do+  fullExpectations <- describeExpectations+  reportFault severity $+    "Wrong arguments: "+      ++ showAction a+      ++ "\n\nClosest matches:\n - "+      ++ intercalate "\n - " (map formatPartial $ take 5 partials)+      ++ "\n\nFull expectations:\n"+      ++ fullExpectations+  where+    formatPartial :: ([(Int, String)], String) -> String+    formatPartial (mismatches, matcher)+      | null mismatches = matcher ++ "\n   * Failed whole-method matcher"+      | otherwise =+        matcher ++ "\n   * "+          ++ intercalate+            "\n   * "+            ( map+                ( \(i, mm) ->+                    "Arg #" ++ show i ++ ": " ++ mm+                )+                mismatches+            )++-- | An error for an 'Action' that matches more than one 'Matcher'.  This only+-- triggers an error if ambiguity checks are on.+ambiguityError ::+  (HasCallStack, Mockable cls, MonadIO m) =>+  Severity ->+  Action cls name m r ->+  [String] ->+  MockT m ()+ambiguityError severity a choices = do+  fullExpectations <- describeExpectations+  reportFault severity $+    "Ambiguous action matched multiple expectations: "+      ++ showAction a+      ++ "\n\nMatches:\n - "+      ++ intercalate "\n - " choices+      ++ "\n\nFull expectations:\n"+      ++ fullExpectations

@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module defines monads for working with mocks.  HMock tests run in the+-- 'MockT' monad transformer.  A more limited monad, 'MockSetup', is used for+-- setting up defaults for each class.  Both are instances of the 'MockContext'+-- monad, which defines a shared API.+module Test.HMock.MockT+  ( MockT,+    runMockT,+    withMockT,+    nestMockT,+    withNestedMockT,+    Severity (..),+    setAmbiguityCheck,+    setUninterestingActionCheck,+    setUnexpectedActionCheck,+    setUnmetExpectationCheck,+    describeExpectations,+    verifyExpectations,+    MockSetup,+    MockContext,+    allowUnexpected,+    byDefault,+    whenever,+  )+where++import Control.Monad (join)+import Control.Monad.Reader+  ( MonadReader (..),+    runReaderT,+  )+import Control.Monad.Trans (lift)+import Data.List (intercalate)+import Data.Maybe (listToMaybe)+import Data.Proxy (Proxy (Proxy))+import GHC.Stack (callStack)+import Test.HMock.ExpectContext (MockableMethod)+import Test.HMock.Internal.ExpectSet+import Test.HMock.Internal.Rule (Rule ((:=>)))+import Test.HMock.Internal.State+import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step))+import Test.HMock.Internal.Util (locate)+import Test.HMock.Rule (Expectable (toRule))+import UnliftIO++-- | Runs a test in the 'MockT' monad, handling all of the mocks.+runMockT :: forall m a. MonadIO m => MockT m a -> m a+runMockT test = withMockT constTest+  where+    constTest :: (forall b. MockT m b -> m b) -> MockT m a+    constTest _inMockT = test++-- | Runs a test in the 'MockT' monad.  The test can unlift other MockT pieces+-- to the base monad while still acting on the same set of expectations.  This+-- can be useful for testing concurrency or similar mechanisms.+--+-- @+-- test = 'withMockT' '$' \inMockT -> do+--    'Test.HMock.Expectable.expect' '$' ...+--+--    'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT firstThread+--    'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT secondThread+-- @+--+-- This is a low-level primitive.  Consider using the @unliftio@ package for+-- higher level implementations of multithreading and other primitives.+withMockT ::+  forall m b. MonadIO m => ((forall a. MockT m a -> m a) -> MockT m b) -> m b+withMockT test = do+  state <- initMockState Nothing+  let inMockT :: forall a. MockT m a -> m a+      inMockT m = runReaderT (unMockT m) state+  flip runReaderT state $+    unMockT $ do+      a <- test inMockT+      verifyExpectations+      return a++-- | Starts a nested block within 'MockT'.  The nested block has its own set of+-- expectations, which must be fulfilled before the end of the block.+--+-- Beware: use of 'nestMockT' might signify that you are doing too much in a+-- single test.  Consider splitting large tests into a separate test for each+-- case.+nestMockT :: forall m a. MonadIO m => MockT m a -> MockT m a+nestMockT nest = withNestedMockT constNest+  where+    constNest :: (forall b. MockT m b -> m b) -> MockT m a+    constNest _inMockT = nest++-- | Starts a nested block within 'MockT'.  The nested block has its own set of+-- expectations, which must be fulfilled before the end of the block.  It can+-- unlift other MockT pieces to the base monad while still acting on the same+-- set of expectations.  This can be useful for testing concurrency or similar+-- mechanisms.+--+-- Beware: use of 'nestMockT' might signify that you are doing too much in a+-- single test.  Consider splitting large tests into a separate test for each+-- case.+withNestedMockT ::+  forall m b.+  MonadIO m =>+  ((forall a. MockT m a -> m a) -> MockT m b) ->+  MockT m b+withNestedMockT nest = do+  parent <- MockT ask+  state <- lift $ initMockState (Just parent)+  withState state $ do+    a <- nest (flip runReaderT state . unMockT)+    verifyExpectations+    return a+  where+    withState state = MockT . local (const state) . unMockT++-- | Sets the severity for ambiguous actions.  An ambiguous action is one that+-- matches expectations in more than one way.  If this is not set to `Error`,+-- the most recently added expectation will take precedence.+--+-- This defaults to 'Ignore'.+setAmbiguityCheck :: MonadIO m => Severity -> MockT m ()+setAmbiguityCheck severity = fromMockSetup $ do+  state <- MockSetup ask+  mockSetupSTM $ writeTVar (mockAmbiguitySeverity state) severity++-- | Sets the severity for uninteresting actions.  An uninteresting action is+-- one for which no expectations or other configuration have been added that+-- mention the method at all.  If this is not set to `Error`, then uninteresting+-- methods are treated just like unexpected methods.+--+-- Before you weaken this check, consider that the labeling of methods as+-- "uninteresting" is non-compositional.  A change in one part of your test can+-- result in a formerly uninteresting action being considered interesting in a+-- different part of the test.+--+-- This defaults to 'Error'.+setUninterestingActionCheck :: MonadIO m => Severity -> MockT m ()+setUninterestingActionCheck severity = fromMockSetup $ do+  state <- MockSetup ask+  mockSetupSTM $ writeTVar (mockUninterestingSeverity state) severity++-- | Sets the severity for unexpected actions.  An unexpected action is one that+-- doesn't match any expectations *and* isn't explicitly allowed by+-- `allowUnexpected`.  If this is not set to `Error`, the action returns its+-- default response.+--+-- This defaults to 'Error'.+setUnexpectedActionCheck :: MonadIO m => Severity -> MockT m ()+setUnexpectedActionCheck severity = fromMockSetup $ do+  state <- MockSetup ask+  mockSetupSTM $ writeTVar (mockUnexpectedSeverity state) severity++-- | Sets the severity for unmet expectations.  An unmet expectation happens+-- when an expectation is added, but either the test (or nesting level) ends or+-- 'verifyExpectations' is used before a matching action takes place.+--+-- This defaults to 'Error'.+setUnmetExpectationCheck :: MonadIO m => Severity -> MockT m ()+setUnmetExpectationCheck severity = fromMockSetup $ do+  state <- MockSetup ask+  mockSetupSTM $ writeTVar (mockUnmetSeverity state) severity++-- | Fetches a 'String' that describes the current set of outstanding+-- expectations.  This is sometimes useful for debugging test code.  The exact+-- format is not specified.+describeExpectations :: MonadIO m => MockT m String+describeExpectations = fromMockSetup $ do+  states <- allStates <$> MockSetup ask+  expectSets <- mapM (mockSetupSTM . readTVar . mockExpectSet) states+  return $+    intercalate "\n----- (next layer) -----\n" $+      formatExpectSet <$> expectSets++-- | Verifies that all mock expectations are satisfied.  If there is a nested+-- block in effect, only the expectations of that nested block are verified+-- You normally don't need to do this, because it happens automatically at the+-- end of your test or nested block.  However, it's occasionally useful to check+-- expectations early.+--+-- Beware: use of 'verifyExpectations' might signify that you are doing too much+-- in a single test.  Consider splitting large tests into a separate test for+-- each case.+verifyExpectations :: MonadIO m => MockT m ()+verifyExpectations = join $ do+  fromMockSetup $ do+    states <- MockSetup ask+    expectSet <- mockSetupSTM $ readTVar $ mockExpectSet states+    missingSev <- mockSetupSTM $ readTVar $ mockUnmetSeverity states+    case excess expectSet of+      ExpectNothing -> return (return ())+      missing ->+        return $+          reportFault missingSev $+            "Unmet expectations:\n" ++ formatExpectSet missing++-- | Adds a handler for unexpected actions.  Matching calls will not fail, but+-- will use a default response instead.  The rule passed in must have zero or+-- one responses: if there is a response, @'allowUnexpected' (m+-- 'Test.HMock.Rule.|=>' r)@ is equivalent to @'allowUnexpected' m >>+-- 'byDefault' (m 'Test.HMock.Rule.|=>' r)@.+--+-- The difference between 'Test.HMock.Expectable.expectAny' and+-- 'allowUnexpected' is subtle, but comes down to ambiguity:+--+-- * 'allowUnexpected' is not an expectation, so it cannot be ambiguous.  It+--   only has an effect if no true expectation matches, regardless of when the+--   expectations were added.+-- * 'Test.HMock.Expectable.expectAny' adds an expectation, so if another+--   expectation is in effect at the same time, a call to the method is+--   ambiguous.  If ambiguity checking is enabled, the method will throw an+--   error; otherwise, the more recently added of the two expectations is used.+allowUnexpected ::+  forall cls name m r rule ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    Expectable cls name m r rule,+    MockContext ctx+  ) =>+  rule ->+  ctx m ()+allowUnexpected e = fromMockSetup $ case toRule e of+  _ :=> (_ : _ : _) -> error "allowUnexpected may not have multiple responses."+  m :=> r -> do+    initClassIfNeeded (Proxy :: Proxy cls)+    state <- MockSetup ask+    mockSetupSTM $+      modifyTVar'+        (mockAllowUnexpected state)+        (Step (locate callStack (m :-> listToMaybe r)) :)++-- | Sets a default action for *expected* matching calls.  The new default only+-- applies to calls for which an expectation exists, but it lacks an explicit+-- response.  The rule passed in must have exactly one response.+byDefault ::+  forall cls name m r ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    MockContext ctx+  ) =>+  Rule cls name m r ->+  ctx m ()+byDefault (m :=> [r]) = fromMockSetup $ do+  initClassIfNeeded (Proxy :: Proxy cls)+  state <- MockSetup ask+  mockSetupSTM $+    modifyTVar'+      (mockDefaults state)+      (Step (locate callStack (m :-> Just r)) :)+byDefault _ = error "Defaults must have exactly one response."++-- | Adds a side-effect, which happens whenever a matching call occurs, in+-- addition to the usual response.  The return value is entirely ignored.+--+-- Be warned: using side effects makes it easy to break abstraction boundaries.+-- Be aware that there may be other uses of a method besides the one which you+-- intend to intercept here.  If possible, add the desired behavior to the+-- response for the matching expectation instead.+whenever ::+  forall cls name m r ctx.+  ( MonadIO m,+    MockableMethod cls name m r,+    MockContext ctx+  ) =>+  Rule cls name m r ->+  ctx m ()+whenever (m :=> [r]) = fromMockSetup $ do+  initClassIfNeeded (Proxy :: Proxy cls)+  state <- MockSetup ask+  mockSetupSTM $+    modifyTVar'+      (mockSideEffects state)+      (Step (locate callStack (m :-> Just r)) :)+whenever _ = error "Side effects must have exactly one response."

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

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

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

@@ -0,0 +1,707 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}++-- | This module provides Template Haskell splices that can be used to derive+-- boilerplate instances for HMock.  'makeMockable' implements the common case+-- where you just want to generate everything you need to mock with a class.+-- The variant 'makeMockableWithOptions' is similar, but takes an options+-- parameter that can be used to customize the generation.+module Test.HMock.TH+  ( MakeMockableOptions (..),+    makeMockable,+    makeMockableWithOptions,+  )+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.Maybe (catMaybes, isNothing)+import Data.Proxy (Proxy)+import Data.Typeable (Typeable, typeRep)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (ErrorMessage (Text, (:$$:), (:<>:)), Symbol, TypeError)+import Language.Haskell.TH hiding (Match, match)+import Language.Haskell.TH.Syntax (Lift (lift))+import Test.HMock.Internal.State (MockT)+import Test.HMock.Internal.TH+import Test.HMock.MockMethod (mockDefaultlessMethod, mockMethod)+import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..))+import Test.HMock.Rule (Expectable (..))+import Test.Predicates (Predicate (..), eq)++-- | Custom options for deriving 'MockableBase' and related instances.+data MakeMockableOptions = MakeMockableOptions+  { -- | Whether to generate a 'Mockable' instance with an empty setup.+    -- Defaults to 'True'.+    --+    -- If this is 'False', you are responsible for providing a 'Mockable'+    -- instance as follows:+    --+    -- @+    -- instance 'Mockable' MyClass where+    --   'Test.HMock.Mockable.setupMockable' _ = ...+    -- @+    mockEmptySetup :: Bool,+    -- | Whether to derive instances of the class for 'MockT' or not.  Defaults+    -- to 'True'.+    --+    -- This option will cause a build error if some members of the class are+    -- unmockable or are not methods.  In this case, you'll need to define this+    -- instance yourself, delegating the mockable methods as follows:+    --+    -- @+    -- instance MyClass ('MockT' m) where+    --   myMethod x y = 'mockMethod' (MyMethod x y)+    --   ...+    -- @+    mockDeriveForMockT :: Bool,+    -- | 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 MakeMockableOptions where+  def =+    MakeMockableOptions+      { mockEmptySetup = True,+        mockDeriveForMockT = True,+        mockSuffix = "",+        mockVerbose = False+      }++-- | Defines all instances necessary to use HMock with the given type, using+-- default options.  The type should be a type class extending 'Monad', applied+-- to zero or more type arguments.+--+-- This defines all of the following instances, if necessary:+--+-- * 'MockableBase' and the associated 'Action' and 'Matcher' types.+-- * 'Expectable' instances for the 'Action' type.+-- * 'Mockable' with an empty setup.+-- * Instances of the provided application type class to allow unit tests to be+--   run with the 'MockT' monad transformer.+makeMockable :: Q Type -> Q [Dec]+makeMockable qtype = makeMockableWithOptions qtype def++-- | Defines all instances necessary to use HMock with the given type, using+-- the provided options.  The type should be a type class extending 'Monad',+-- applied to zero or more type arguments.+--+-- This defines the following instances, if necessary:+--+-- * 'MockableBase' and the associated 'Action' and 'Matcher' types.+-- * 'Expectable' instances for the 'Action' type.+-- * If 'mockEmptySetup' is 'True': 'Mockable' with an empty setup.+-- * If 'mockDeriveForMockT' is 'True': Instances of the provided application+--   type class to allow unit tests to be run with the 'MockT' monad+--   transformer.+makeMockableWithOptions :: Q Type -> MakeMockableOptions -> Q [Dec]+makeMockableWithOptions qtype options = makeMockableImpl options qtype++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 :: MakeMockableOptions -> 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 genVars = init ps+          let mVar = last ps+          let t = foldl' (\t' v -> AppT t' (VarT v)) ty genVars+          let tbl = zip (tvName <$> params) ts+          let cx' = substTypeVars tbl <$> cx+          makeInstance options t cx' tbl genVars mVar members+    go _ = internalError++makeInstance ::+  MakeMockableOptions ->+  Type ->+  Cxt ->+  [(Name, Type)] ->+  [Name] ->+  Name ->+  [Dec] ->+  Q Instance+makeInstance options ty cx tbl ps m members = do+  processedMembers <- mapM (getMethod ty m tbl) $ filter isRelevantMember members+  (extraMembers, methods) <-+    partitionEithers <$> zipWithM memberOrMethod members processedMembers+  return $+    Instance+      { instType = ty,+        instRequiredContext = cx,+        instGeneralParams = ps,+        instMonadVar = m,+        instMethods = methods,+        instExtraMembers = extraMembers+      }+  where+    isRelevantMember :: Dec -> Bool+    isRelevantMember DefaultSigD {} = False+    isRelevantMember _ = True++    memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)+    memberOrMethod dec (Left warnings) = do+      when (mockVerbose options) $ mapM_ reportWarning warnings+      return (Left dec)+    memberOrMethod _ (Right method) = return (Right method)++getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)+getMethod instTy m tbl (SigD name ty) = do+  simpleTy <- localizeMember instTy m (substTypeVars tbl ty)+  let (tvs, cx, args, mretval) = splitType simpleTy+  return $ do+    retval <- case mretval of+      AppT (VarT m') retval | m' == m -> return retval+      _ ->+        Left+          [ nameBase name+              ++ " can't be mocked: return value not in the expected monad."+          ]+    unless+      ( all+          (isVarTypeable cx)+          (filter (`elem` tvs) (freeTypeVars retval))+      )+      $ Left+        [ nameBase name+            ++ " can't be mocked: return value not Typeable."+        ]+    let argTypes = map (substTypeVar m (AppT (ConT ''MockT) (VarT m))) args+    when (any hasNestedPolyType argTypes) $+      Left+        [ nameBase name+            ++ " can't be mocked: rank-n types nested in arguments."+        ]++    return $+      Method+        { methodName = name,+          methodTyVars = tvs,+          methodCxt = cx,+          methodArgs = argTypes,+          methodResult = retval+        }+  where+    isVarTypeable :: Cxt -> Name -> Bool+    isVarTypeable cx v = AppT (ConT ''Typeable) (VarT v) `elem` cx+getMethod _ _ _ (DataD _ name _ _ _ _) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ (NewtypeD _ name _ _ _ _) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ (TySynD name _ _) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ (DataFamilyD name _ _) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) =+  return $+    Left [nameBase name ++ " must be defined manually in MockT instance."]+getMethod _ _ _ _ = return (Left [])++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))+    |]++makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec]+makeMockableImpl options qtype = do+  checkExt DataKinds+  checkExt FlexibleInstances+  checkExt GADTs+  checkExt MultiParamTypeClasses+  checkExt ScopedTypeVariables+  checkExt TypeFamilies++  ty <- qtype+  let generalizedTy = case unappliedName ty of+        Just cls -> ConT cls+        _ -> ty+  inst <- getInstance options generalizedTy++  when (null (instMethods inst)) $ do+    fail $+      "Cannot derive Mockable because " ++ pprint (instType inst)+        ++ " has no mockable methods."++  typeableCxt <- constrainVars [conT ''Typeable] (instGeneralParams inst)++  needsMockableBase <-+    isNothing <$> resolveInstance ''MockableBase [instType inst]+  mockableBase <-+    if needsMockableBase+      then do+        mockableBase <-+          instanceD+            (pure typeableCxt)+            [t|MockableBase $(pure (instType inst))|]+            [ defineActionType options inst,+              defineMatcherType options inst,+              defineShowAction options (instMethods inst),+              defineShowMatcher options (instMethods inst),+              defineMatchAction options (instMethods inst)+            ]+        expectables <- defineExpectableActions options inst+        return (mockableBase : expectables)+      else return []++  needsMockable <-+    if mockEmptySetup options+      then isNothing <$> resolveInstance ''Mockable [instType inst]+      else return False+  mockable <-+    if needsMockable+      then do+        t <- [t|Mockable $(pure (instType inst))|]+        return [InstanceD (Just Overlappable) typeableCxt t []]+      else return []++  mockt <- deriveForMockT options ty++  return $ mockableBase ++ mockable ++ mockt++defineActionType :: MakeMockableOptions -> 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 :: MakeMockableOptions -> 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 :: MakeMockableOptions -> Method -> Name+getActionName options method =+  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options)+  where+    name = nameBase (methodName method)++defineMatcherType :: MakeMockableOptions -> 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 :: MakeMockableOptions -> 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 :: MakeMockableOptions -> Method -> Name+getMatcherName options method =+  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options ++ "_")+  where+    name = nameBase (methodName method)++defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec+defineShowAction options methods =+  funD 'showAction (showActionClause options <$> methods)++showActionClause :: MakeMockableOptions -> 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+    isLocalPoly ty =+      not . null . fst $+        relevantContext ty (methodTyVars method, methodCxt method)++    canShow ty+      | hasPolyType ty = return False+      | isLocalPoly ty = (`elem` methodCxt method) <$> [t|Show $(pure ty)|]+      | null (freeTypeVars ty) = isInstance ''Show [ty]+      | otherwise = return False++    canType ty+      | hasPolyType ty = return False+      | isLocalPoly ty =+        (`elem` methodCxt method)+          <$> [t|Typeable $(pure ty)|]+      | otherwise = return (null (freeTypeVars ty))++    argPattern ty v = canShow ty >>= flip sigP (pure ty) . bool wildP (varP v)++    showArg ty var = do+      showable <- canShow ty+      typeable <- canType ty+      case (showable, typeable) of+        (True, _) -> [|showsPrec 11 $(varE var) ""|]+        (_, True) ->+          [|+            "(_ :: "+              ++ show (typeRep (undefined :: Proxy $(return ty)))+              ++ ")"+            |]+        _ -> lift ("(_  :: " ++ pprint (removeModNames ty) ++ ")")++defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec+defineShowMatcher options methods = do+  clauses <- concatMapM (showMatcherClauses options) methods+  funD 'showMatcher clauses++showMatcherClauses :: MakeMockableOptions -> 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 = 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 :: MakeMockableOptions -> [Method] -> Q Dec+defineMatchAction options methods =+  funD 'matchAction (matchActionClause options <$> methods)++matchActionClause :: MakeMockableOptions -> 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 [|null $(varE mmVar)|] <*> [|Match|],+          (,) <$> normalG [|otherwise|] <*> [|NoMatch $(varE mmVar)|]+        ]+    )+    [ valD+        (varP mmVar)+        ( normalB+            [|+              catMaybes $+                zipWith+                  (fmap . (,))+                  [1 ..]+                  $(listE (mkAccept <$> argVars))+              |]+        )+        []+    ]+  where+    mkAccept (p, a) =+      [|+        if accept $(return (VarE p)) $(return (VarE a))+          then Nothing+          else Just $ explain $(return (VarE p)) $(return (VarE a))+        |]++defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec]+defineExpectableActions options inst =+  mapM (defineExpectableAction options inst) (instMethods inst)++type ComplexExpectableMessage name =+  ( 'Text "Method " ':<>: 'Text name+      ':<>: 'Text " is too complex to expect with an Action."+  )+    ':$$: 'Text "Suggested fix: Use a Matcher instead of an Action."++defineExpectableAction :: MakeMockableOptions -> 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)+                )+                []+            ]+        ]+    _ -> do+      checkExt UndecidableInstances+      instanceD+        ( (: [])+            <$> [t|+              TypeError+                ( ComplexExpectableMessage+                    $(litT $ strTyLit $ nameBase $ methodName method)+                )+              |]+        )+        ( appT+            (withMethodParams inst method [t|Expectable|])+            (withMethodParams inst method [t|Action|])+        )+        [ funD+            'toRule+            [clause [] (normalB [|undefined|]) []]+        ]+  where+    makeBody [] e = e+    makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|]++    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+      | otherwise =+        simplifyContext [AppT (ConT ''Eq) argTy, AppT (ConT ''Show) argTy]++deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec]+deriveForMockT options ty = do+  inst <- getInstance options {mockVerbose = False} ty+  needsMockT <-+    if mockDeriveForMockT options+      then+        isNothing+          <$> resolveInstanceType+            ( AppT+                (instType inst)+                (AppT (ConT ''MockT) (VarT (instMonadVar inst)))+            )+      else return False++  if needsMockT+    then do+      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))+                 ]++      let mockTConstraints =+            substTypeVar+              (instMonadVar inst)+              (AppT (ConT ''MockT) (VarT m))+              <$> cx+      simplifyContext mockTConstraints+        >>= \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."+    else return []++implementMethod :: MakeMockableOptions -> 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 <- simplifyContext [AppT (ConT ''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."

@@ -0,0 +1,1477 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Explainable 'Predicate's are essentially functions from types to `Bool`+-- which can additionally describe themselves and explain why an argument does+-- or doesn't match.  They are intended to be used during unit tests to provide+-- better error messages when tests fail.+module Test.Predicates+  ( -- * The Predicate type+    Predicate (..),+    (==~),+    PredicateFailure (..),+    acceptIO,++    -- * Predicate combinators++    -- ** Basic predicates+    anything,+    eq,+    neq,+    gt,+    geq,+    lt,+    leq,+    just,+    nothing,+    left,+    right,++    -- ** Zips+    zipP,+    zip3P,+    zip4P,+    zip5P,++    -- ** Logic+    andP,+    orP,+    notP,+#ifdef REGEX+    -- ** Regular expressions+    matchesRegex,+    matchesCaseInsensitiveRegex,+    containsRegex,+    containsCaseInsensitiveRegex,+#endif++#ifdef CONTAINERS+    -- ** Strings and sequences+    startsWith,+    endsWith,+    hasSubstr,+    hasSubsequence,+    caseInsensitive,++    -- ** Containers+    isEmpty,+    nonEmpty,+    sizeIs,+    elemsAre,+    unorderedElemsAre,+    each,+    contains,+    containsAll,+    containsOnly,+    keys,+    values,+#endif++    -- ** Numerics+    approxEq,+    positive,+    negative,+    nonPositive,+    nonNegative,+    finite,+    infinite,+    nAn,++    -- ** Miscellaneous+    is,+    qIs,+    with,+    qWith,+    inBranch,+    qADT,+    qMatch,+    typed,+  )+where++import Control.Exception (Exception, throwIO)+import Control.Monad (replicateM, unless)+import Data.Functor.Contravariant (Contravariant (..))+import Data.List (intercalate)+import Data.Maybe (isNothing)+import Data.Typeable (Proxy (..), Typeable, cast, typeRep)+import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)+import Test.Predicates.Internal.Util (locate, removeModNames, withLoc)++#ifdef REGEX+import Data.Maybe (isJust)+import Text.Regex.TDFA+  ( CompOption (caseSensitive, lastStarGreedy, newSyntax),+    ExecOption (captureGroups),+    Extract (empty),+    Regex,+    RegexLike (matchOnce, matchOnceText),+    RegexMaker (makeRegexOpts),+    RegexOptions (defaultCompOpt, defaultExecOpt),+  )+#endif++#ifdef CONTAINERS+import Data.Char (toUpper)+import Data.Maybe (catMaybes)+import Data.MonoTraversable (Element, MonoFoldable (..), MonoFunctor (..))+import qualified Data.Sequences as Seq+import GHC.Exts (IsList (Item, toList))+import Test.Predicates.Internal.FlowMatcher (bipartiteMatching)+import Test.Predicates.Internal.Util (isSubsequenceOf)+#endif++-- $setup+-- >>> :set -XLambdaCase+-- >>> :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 can describe itself and explain why an+-- argument does or doesn't match.+data Predicate a = Predicate+  { showPredicate :: String,+    showNegation :: String,+    accept :: a -> Bool,+    explain :: a -> String+  }++instance Show (Predicate a) where show = showPredicate++data PredicateFailure = PredicateFailure String CallStack++instance Show PredicateFailure where+  show (PredicateFailure message cs) = message ++ "\n" ++ prettyCallStack cs+instance Exception PredicateFailure++-- | Same as 'accept', except throws a 'PredicateFailure' instead of returning a 'Bool'.+acceptIO :: HasCallStack => Predicate a -> a -> IO ()+acceptIO p x =+  unless (accept p x) $+    throwIO $ PredicateFailure (explain p x) callStack++-- | An infix synonym for 'accept'.+--+-- >>> eq 1 ==~ 1+-- True+-- >>> eq 2 ==~ 1+-- False+(==~) :: Predicate a -> a -> Bool+(==~) = accept++withDefaultExplain ::+  (a -> String) -> String -> ((a -> String) -> Predicate a) -> Predicate a+withDefaultExplain format connector mk = p+  where+    p = mk $ \x ->+      if accept p x+        then format x ++ connector ++ showPredicate p+        else format x ++ connector ++ showNegation p++-- | A 'Predicate' that accepts anything at all.+--+-- >>> accept anything "foo"+-- True+-- >>> accept anything undefined+-- True+anything :: Predicate a+anything =+  Predicate+    { showPredicate = "anything",+      showNegation = "nothing",+      accept = const True,+      explain = const "always matches"+    }++-- | 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,+      showNegation = "≠ " ++ show x,+      accept = (== x),+      explain = \y ->+        if y == x+          then show y ++ " = " ++ show x+          else show y ++ " ≠ " ++ show 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 = notP . eq++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "> " ++ show x,+      showNegation = "≤ " ++ show x,+      accept = (> x),+      explain = explainImpl+    }++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "≥ " ++ show x,+      showNegation = "< " ++ show x,+      accept = (>= x),+      explain = explainImpl+    }++-- | 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 = notP . geq++-- | 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 = notP . gt++-- | 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 ++ ")",+      showNegation = "not Just (" ++ showPredicate p ++ ")",+      accept = \case Just x -> accept p x; _ -> False,+      explain = \case Just x -> explain p x; _ -> "Nothing ≠ Just _"+    }++-- | A Predicate that accepts 'Maybe' values of @'Nothing'@.  Unlike 'eq', this+-- doesn't require 'Eq' or 'Show' instances.+--+-- >>> accept nothing Nothing+-- True+--+-- >>> accept nothing (Just "something")+-- False+nothing :: Predicate (Maybe a)+nothing =+  Predicate+    { showPredicate = "Nothing",+      showNegation = "Just anything",+      accept = isNothing,+      explain = \case Nothing -> "Nothing = Nothing"; _ -> "Just _ ≠ Nothing"+    }++-- | 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 ++ ")",+      showNegation = "not Left (" ++ showPredicate p ++ ")",+      accept = \case Left x -> accept p x; _ -> False,+      explain = \case Left x -> explain p x; _ -> "Right _ ≠ Left _"+    }++-- | 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 ++ ")",+      showNegation = "not Right (" ++ showPredicate p ++ ")",+      accept = \case Right x -> accept p x; _ -> False,+      explain = \case Right x -> explain p x; _ -> "Left _ ≠ Right _"+    }++-- | A 'Predicate' that accepts pairs whose elements satisfy the corresponding+-- child 'Predicate's.+--+-- >>> accept (zipP (eq "foo") (eq "bar")) ("foo", "bar")+-- True+-- >>> accept (zipP (eq "foo") (eq "bar")) ("bar", "foo")+-- False+zipP :: Predicate a -> Predicate b -> Predicate (a, b)+zipP p1 p2 =+  Predicate+    { showPredicate = show (p1, p2),+      showNegation = "not " ++ show (p1, p2),+      accept = all fst . acceptAndExplain,+      explain = \xs ->+        let results = acceptAndExplain xs+            significant+              | all fst results = results+              | otherwise = filter (not . fst) results+         in intercalate " and " $ map snd significant+    }+  where+    acceptAndExplain = \(x1, x2) ->+      [ (accept p1 x1, explain p1 x1),+        (accept p2 x2, explain p2 x2)+      ]++-- | 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),+      showNegation = "not " ++ show (p1, p2, p3),+      accept = all fst . acceptAndExplain,+      explain = \xs ->+        let results = acceptAndExplain xs+            significant+              | all fst results = results+              | otherwise = filter (not . fst) results+         in intercalate " and " $ map snd significant+    }+  where+    acceptAndExplain = \(x1, x2, x3) ->+      [ (accept p1 x1, explain p1 x1),+        (accept p2 x2, explain p2 x2),+        (accept p3 x3, explain p3 x3)+      ]++-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the+-- corresponding child 'Predicate's.+--+-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4)+-- True+-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1)+-- False+zip4P ::+  Predicate a ->+  Predicate b ->+  Predicate c ->+  Predicate d ->+  Predicate (a, b, c, d)+zip4P p1 p2 p3 p4 =+  Predicate+    { showPredicate = show (p1, p2, p3, p4),+      showNegation = "not " ++ show (p1, p2, p3, p4),+      accept = all fst . acceptAndExplain,+      explain = \xs ->+        let results = acceptAndExplain xs+            significant+              | all fst results = results+              | otherwise = filter (not . fst) results+         in intercalate " and " $ map snd significant+    }+  where+    acceptAndExplain = \(x1, x2, x3, x4) ->+      [ (accept p1 x1, explain p1 x1),+        (accept p2 x2, explain p2 x2),+        (accept p3 x3, explain p3 x3),+        (accept p4 x4, explain p4 x4)+      ]++-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the+-- corresponding child 'Predicate's.+--+-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5)+-- True+-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1)+-- False+zip5P ::+  Predicate a ->+  Predicate b ->+  Predicate c ->+  Predicate d ->+  Predicate e ->+  Predicate (a, b, c, d, e)+zip5P p1 p2 p3 p4 p5 =+  Predicate+    { showPredicate = show (p1, p2, p3, p4, p5),+      showNegation = "not " ++ show (p1, p2, p3, p4, p5),+      accept = all fst . acceptAndExplain,+      explain = \xs ->+        let results = acceptAndExplain xs+            significant+              | all fst results = results+              | otherwise = filter (not . fst) results+         in intercalate " and " $ map snd significant+    }+  where+    acceptAndExplain = \(x1, x2, x3, x4, x5) ->+      [ (accept p1 x1, explain p1 x1),+        (accept p2 x2, explain p2 x2),+        (accept p3 x3, explain p3 x3),+        (accept p4 x4, explain p4 x4),+        (accept p5 x5, explain 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,+      showNegation = showNegation p ++ " or " ++ showNegation q,+      accept = \x -> accept p x && accept q x,+      explain = \x ->+        if+            | not (accept p x) -> explain p x+            | not (accept q x) -> explain q x+            | otherwise -> explain p x ++ " and " ++ explain 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 = notP (notP p `andP` notP q)++-- | 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 = showNegation p,+      showNegation = showPredicate p,+      accept = not . accept p,+      explain = explain p+    }++#ifdef REGEX++-- | 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, Show a) => String -> Predicate a+matchesRegex s =+  Predicate+    { showPredicate = pat,+      showNegation = "not " ++ pat,+      accept = accepts,+      explain = \x ->+        if accepts x+          then show x ++ " matches " ++ pat+          else show x ++ " doesn't match " ++ pat+    }+  where+    pat = "/" ++ init (tail $ show s) ++ "/"+    accepts x = case matchOnceText r x of+      Just (a, _, b) -> a == empty && b == empty+      Nothing -> False+    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, Show a) => String -> Predicate a+matchesCaseInsensitiveRegex s =+  Predicate+    { showPredicate = pat,+      showNegation = "not " ++ pat,+      accept = accepts,+      explain = \x ->+        if accepts x+          then show x ++ " matches " ++ pat+          else show x ++ " doesn't match " ++ pat+    }+  where+    pat = "/" ++ init (tail $ show s) ++ "/i"+    accepts x = case matchOnceText r x of+      Just (a, _, b) -> a == empty && b == empty+      Nothing -> False+    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, Show a) => String -> Predicate a+containsRegex s = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "contains " ++ pat,+      showNegation = "doesn't contain " ++ pat,+      accept = isJust . matchOnce r,+      explain = explainImpl+    }+  where+    pat = "/" ++ init (tail $ show s) ++ "/"+    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, Show a) => String -> Predicate a+containsCaseInsensitiveRegex s = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "contains " ++ pat,+      showNegation = "doesn't contain " ++ pat,+      accept = isJust . matchOnce r,+      explain = explainImpl+    }+  where+    pat = "/" ++ init (tail $ show s) ++ "/i"+    r = makeRegexOpts comp exec s :: Regex+    comp =+      defaultCompOpt+        { newSyntax = True,+          lastStarGreedy = True,+          caseSensitive = False+        }+    exec = defaultExecOpt {captureGroups = False}++#endif++#ifdef CONTAINERS++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "starts with " ++ show pfx,+      showNegation = "doesn't start with " ++ show pfx,+      accept = (pfx `Seq.isPrefixOf`),+      explain = explainImpl+    }++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "ends with " ++ show sfx,+      showNegation = "doesn't end with " ++ show sfx,+      accept = (sfx `Seq.isSuffixOf`),+      explain = explainImpl+    }++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "has substring " ++ show s,+      showNegation = "doesn't have substring " ++ show s,+      accept = (s `Seq.isInfixOf`),+      explain = explainImpl+    }++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "has subsequence " ++ show s,+      showNegation = "doesn't have subsequence " ++ show s,+      accept = (s `isSubsequenceOf`),+      explain = explainImpl+    }++-- | 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),+      showNegation = "(case insensitive) " ++ show (notP (p s)),+      accept = accept capP . omap toUpper,+      explain = explain capP . omap toUpper+    }+  where+    capP = p (omap toUpper s)++-- | A 'Predicate' that accepts empty data structures.+--+-- >>> accept isEmpty ([] :: [Int])+-- True+-- >>> accept isEmpty [1, 2, 3]+-- False+-- >>> accept isEmpty ""+-- True+-- >>> accept isEmpty "gas tank"+-- False+isEmpty :: (MonoFoldable t, Show t) => Predicate t+isEmpty = withDefaultExplain show " is " $ \explainImpl ->+  Predicate+    { showPredicate = "empty",+      showNegation = "non-empty",+      accept = onull,+      explain = explainImpl+    }++-- | A 'Predicate' that accepts non-empty data structures.+--+-- >>> accept nonEmpty ([] :: [Int])+-- False+-- >>> accept nonEmpty [1, 2, 3]+-- True+-- >>> accept nonEmpty ""+-- False+-- >>> accept nonEmpty "gas tank"+-- True+nonEmpty :: (MonoFoldable t, Show t) => Predicate t+nonEmpty = notP isEmpty++-- | 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, Show t) => Predicate Int -> Predicate t+sizeIs p =+  Predicate+    { showPredicate = "size " ++ showPredicate p,+      showNegation = "size " ++ showNegation p,+      accept = accept p . olength,+      explain = \y ->+        let detail+              | accept p (olength y) = showPredicate p+              | otherwise = showNegation p+            detailStr+              | show (olength y) == detail = ""+              | otherwise = ", which is " ++ detail+         in show y ++ " has size " ++ show (olength y) ++ detailStr+    }++-- | 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,+      showNegation = "not " ++ show ps,+      accept = \xs ->+        olength xs == olength ps+          && and (zipWith accept ps (otoList xs)),+      explain = \xs ->+        let results = acceptAndExplain (otoList xs)+         in if+                | olength xs /= length ps ->+                  "wrong size (got "+                    ++ show (olength xs)+                    ++ "; expected "+                    ++ show (length ps)+                    ++ ")"+                | all fst results -> "elements are " ++ show ps+                | otherwise ->+                  intercalate "; and " $+                    snd <$> filter (not . fst) results+    }+  where+    acceptAndExplain xs = zipWith3 matchAndExplain [1 :: Int ..] ps xs+    matchAndExplain i p x =+      (accept p x, "in element #" ++ show i ++ ": " ++ explain p x)++-- | 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,+      showNegation =+        "not (in any order) " ++ show ps,+      accept = \xs ->+        let (_, orphanPs, orphanXs) = matchAll xs+         in null orphanPs && null orphanXs,+      explain = \xs ->+        let (matches, orphanPs, orphanXs) = matchAll xs+         in if null orphanPs && null orphanXs+              then intercalate "; and " (explainMatch <$> matches)+              else+                let missingExplanation =+                      if null orphanPs+                        then Nothing+                        else+                          Just+                            ( "Missing: "+                                ++ intercalate ", " (showPredicate <$> orphanPs)+                            )+                    extraExplanation =+                      if null orphanXs+                        then Nothing+                        else+                          Just+                            ( "Extra elements: "+                                ++ intercalate+                                  ", "+                                  (("#" ++) . show . fst <$> orphanXs)+                            )+                 in intercalate+                      "; "+                      (catMaybes [missingExplanation, extraExplanation])+    }+  where+    matchOne p (_, x) = accept p x+    matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs))+    explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x++-- | 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 ++ ")",+      showNegation = "contains (" ++ showNegation p ++ ")",+      accept = all fst . acceptAndExplain,+      explain = \xs ->+        let results = acceptAndExplain xs+            format (i, explanation) =+              "element #" ++ show i ++ ": " ++ explanation+         in if all fst results+              then "all elements " ++ showPredicate p+              else+                intercalate "; and " $+                  format . snd <$> filter (not . fst) results+    }+  where+    acceptAndExplain xs =+      [(accept p x, (i, explain p x)) | i <- [1 :: Int ..] | x <- otoList xs]++-- | 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 = notP . each . notP++-- | A 'Predicate' that accepts data structures whose elements all satisfy the+-- given child 'Predicate's.+--+-- >>> 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+--+-- Each child 'Predicate' must be satisfied by a different element, so repeating+-- a 'Predicate' requires that two different matching elements exist.  If you+-- want a 'Predicate' to match multiple elements, instead, you can accomplish+-- this with @'contains' p1 `'andP'` 'contains' p2 `'andP'` ...@.+--+-- >>> accept (containsAll [startsWith "f", endsWith "o"]) ["foo"]+-- False+-- >>> accept (contains (startsWith "f") `andP` contains (endsWith "o")) ["foo"]+-- True+containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+containsAll ps =+  Predicate+    { showPredicate = "contains all of " ++ show ps,+      showNegation = "not all of " ++ show ps,+      accept = \xs -> let (_, orphanPs, _) = matchAll xs in null orphanPs,+      explain = \xs ->+        let (matches, orphanPs, _) = matchAll xs+         in if null orphanPs+              then intercalate "; and " (explainMatch <$> matches)+              else "Missing: " ++ intercalate ", " (showPredicate <$> orphanPs)+    }+  where+    matchOne p (_, x) = accept p x+    matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs))+    explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x++-- | A 'Predicate' that accepts data structures whose elements all satisfy one+-- of the child 'Predicate's.+--+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo"]+-- True+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]+-- True+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]+-- False+--+-- Each element must satisfy a different child 'Predicate'.  If you want+-- multiple elements to match the same 'Predicate', instead, you can accomplish+-- this with @'each' (p1 `'orP'` p2 `'orP'` ...)@.+--+-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]+-- False+-- >>> accept (each (eq "foo" `orP` eq "bar")) ["foo", "foo"]+-- True+containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t+containsOnly ps =+  Predicate+    { showPredicate = "contains only " ++ show ps,+      showNegation = "not only " ++ show ps,+      accept = \xs -> let (_, _, orphanXs) = matchAll xs in null orphanXs,+      explain = \xs ->+        let (matches, _, orphanXs) = matchAll xs+         in if null orphanXs+              then intercalate "; and " (explainMatch <$> matches)+              else+                "Extra elements: "+                  ++ intercalate ", " (("#" ++) . show . fst <$> orphanXs)+    }+  where+    matchOne p (_, x) = accept p x+    matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs))+    explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x++-- | Transforms a 'Predicate' on a list of keys into a 'Predicate' on map-like+-- data structures.+--+-- This is equivalent to @'with' ('map' 'fst' '.' 'toList')@, but more readable.+--+-- >>> accept (keys (each (eq "foo"))) [("foo", 5)]+-- True+--+-- >>> accept (keys (each (eq "foo"))) [("foo", 5), ("bar", 6)]+-- False+keys :: (IsList t, Item t ~ (k, v)) => Predicate [k] -> Predicate t+keys p =+  Predicate+    { showPredicate = "keys (" ++ showPredicate p ++ ")",+      showNegation = "keys (" ++ showNegation p ++ ")",+      accept = accept p . map fst . toList,+      explain = ("in keys, " ++) . explain p . map fst . toList+    }++-- | Transforms a 'Predicate' on a list of values into a 'Predicate' on map-like+-- data structures.+--+-- This is equivalent to @'with' ('map' 'snd' '.' 'toList')@, but more readable.+--+-- >>> accept (values (each (eq 5))) [("foo", 5), ("bar", 5)]+-- True+--+-- >>> accept (values (each (eq 5))) [("foo", 5), ("bar", 6)]+-- False+values :: (IsList t, Item t ~ (k, v)) => Predicate [v] -> Predicate t+values p =+  Predicate+    { showPredicate = "values (" ++ showPredicate p ++ ")",+      showNegation = "values (" ++ showNegation p ++ ")",+      accept = accept p . map snd . toList,+      explain = ("in values, " ++) . explain p . map snd . toList+    }++#endif++-- | 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 = withDefaultExplain show " " $ \explainImpl ->+  Predicate+    { showPredicate = "≈ " ++ show x,+      showNegation = "≇" ++ show x,+      accept = \y -> abs (x - y) < diff,+      explain = explainImpl+    }+  where+    diff = encodeFloat 1 (snd (decodeFloat x) + floatDigits x `div` 2)++-- | A 'Predicate' that accepts positive numbers of any 'Ord'ered 'Num' type.+--+-- >>> accept positive 1+-- True+--+-- >>> accept positive 0+-- False+--+-- >>> accept positive (-1)+-- False+positive :: (Ord a, Num a) => Predicate a+positive =+  Predicate+    { showPredicate = "positive",+      showNegation = "non-positive",+      accept = \x -> signum x > 0,+      explain = \x ->+        if+            | signum x > 0 -> "value is positive"+            | x == 0 -> "value is zero"+            | signum x < 0 -> "value is negative"+            | otherwise -> "value has unknown sign"+    }++-- | A 'Predicate' that accepts negative numbers of any 'Ord'ered 'Num' type.+--+-- >>> accept negative 1+-- False+--+-- >>> accept negative 0+-- False+--+-- >>> accept negative (-1)+-- True+negative :: (Ord a, Num a) => Predicate a+negative =+  Predicate+    { showPredicate = "negative",+      showNegation = "non-negative",+      accept = \x -> signum x < 0,+      explain = \x ->+        if+            | signum x < 0 -> "value is negative"+            | x == 0 -> "value is zero"+            | signum x < 0 -> "value is positive"+            | otherwise -> "value has unknown sign"+    }++-- | A 'Predicate' that accepts non-positive numbers of any 'Ord'ered 'Num'+-- type.+--+-- >>> accept nonPositive 1+-- False+--+-- >>> accept nonPositive 0+-- True+--+-- >>> accept nonPositive (-1)+-- True+nonPositive :: (Ord a, Num a) => Predicate a+nonPositive = notP positive++-- | A 'Predicate' that accepts non-negative numbers of any 'Ord'ered 'Num'+-- type.+--+-- >>> accept nonNegative 1+-- True+--+-- >>> accept nonNegative 0+-- True+--+-- >>> accept nonNegative (-1)+-- False+nonNegative :: (Ord a, Num a) => Predicate a+nonNegative = notP negative++-- | 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",+      showNegation = "non-finite",+      accept = isFinite,+      explain = \x ->+        if isFinite x+          then "value is finite"+          else "value is not finite"+    }+  where+    isFinite 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",+      showNegation = "non-infinite",+      accept = isInfinite,+      explain = \x ->+        if isInfinite x+          then "value is infinite"+          else "value is not infinite"+    }++-- | 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",+      showNegation = "non-NaN",+      accept = isNaN,+      explain = \x ->+        if isNaN x+          then "value is NaN"+          else "value is not NaN"+    }++-- | 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.  You can use+-- 'qIs' instead to get better descriptions using Template Haskell.+--+-- >>> accept (is even) 3+-- False+-- >>> accept (is even) 4+-- True+is :: HasCallStack => (a -> Bool) -> Predicate a+is p =+  Predicate+    { showPredicate = withLoc (locate callStack "custom predicate"),+      showNegation = withLoc (locate callStack "negated custom predicate"),+      accept = p,+      explain = \x ->+        if p x+          then "value matched custom predicate"+          else "value did not match custom predicate"+    }++-- | A Template Haskell splice that acts like 'is', but receives a quoted+-- expression at compile time and has a more helpful explanation.+--+-- >>> accept $(qIs [| even |]) 3+-- False+-- >>> accept $(qIs [| even |]) 4+-- True+--+-- >>> show $(qIs [| even |])+-- "even"+qIs :: HasCallStack => ExpQ -> ExpQ+qIs p =+  [|+    Predicate+      { showPredicate = $description,+        showNegation = "not " ++ $description,+        accept = $p,+        explain = \x -> if $p x then $description else "not " ++ $description+      }+    |]+  where+    description = lift . pprint . removeModNames =<< p++-- | A combinator to lift a 'Predicate' to work on a property or computed value+-- of the original value.  The explanations are less helpful that standard+-- predicates like 'sizeIs'.  You can use 'qWith' instead to get better+-- explanations using Template Haskell.+--+-- >>> 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 = prop ++ ": " ++ show p,+      showNegation = prop ++ ": " ++ showNegation p,+      accept = accept p . f,+      explain = ((prop ++ ": ") ++) . explain p . f+    }+  where+    prop = withLoc (locate callStack "property")++-- | Use 'with' or 'qWith' instead of 'contramap' to get better explanations.+instance Contravariant Predicate where+  contramap f p =+    Predicate+      { showPredicate = "in a property: " ++ show p,+        showNegation = "in a property: " ++ showNegation p,+        accept = accept p . f,+        explain = ("in a property: " ++) . explain p . f+      }++-- | A Template Haskell splice that acts like 'with', but receives a quoted+-- typed expression at compile time and has a more helpful explanation.+--+-- >>> 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 = $prop ++ ": " ++ show p,+          showNegation = $prop ++ ": " ++ showNegation p,+          accept = accept p . $f,+          explain = (($prop ++ ": ") ++) . explain p . $f+        }+    |]+  where+    prop = lift . pprint . removeModNames =<< f++-- | A 'Predicate' that accepts values with a given nested value.  This is+-- intended to match constructors with arguments.  You can use 'qADT' instead+-- to get better explanations using Template Haskell.+--+-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 1)+-- True+-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 0)+-- False+-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Right 1)+-- False+inBranch :: String -> (a -> Maybe b) -> Predicate b -> Predicate a+inBranch name f p =+  Predicate+    { showPredicate = "(" ++ name ++ " _)",+      showNegation = "not (" ++ name ++ " _)",+      accept = \x -> case f x of Just y -> accept p y; _ -> False,+      explain = \x -> case f x of+        Just y -> "In " ++ name ++ ": " ++ explain p y+        _ -> "Branch didn't match"+    }++-- | A Template Haskell splice which, given a constructor for an abstract data+-- type, writes a 'Predicate' that matches on that constructor and applies other+-- 'Predicate's to its fields.+--+-- >>> accept $(qADT 'Nothing) Nothing+-- True+-- >>> accept $(qADT 'Nothing) (Just 5)+-- False+-- >>> accept ($(qADT 'Just) positive) (Just 5)+-- True+-- >>> accept ($(qADT 'Just) positive) Nothing+-- False+-- >>> accept ($(qADT 'Just) positive) (Just 0)+-- False+qADT :: Name -> ExpQ+qADT conName =+  do+    let prettyConName = lift (pprint (removeModNames conName))+    t <- reify conName >>= (\case+       DataConI _ ty _ -> pure ty+       PatSynI _ ty -> pure ty+       _ -> fail $ "qADT: " ++ show conName ++ " is not a data constructor")++    let n = countArguments t+    subpreds <- replicateM n (newName "p")+    let subdescs =+          map+            (\p -> [|"(" ++ showPredicate $p ++ ")"|])+            (varE <$> subpreds)+    let desc = [|unwords ($prettyConName : $(listE subdescs))|]+    let negDesc+          | n == 0 = [|"≠ " ++ $desc|]+          | otherwise = [|"not (" ++ $desc ++ ")"|]+    args <- replicateM n (newName "x")+    let pattern = conP conName (varP <$> args)+    let acceptExplainFields =+          listE $+            zipWith+              (\p x -> [|(accept $p $x, explain $p $x)|])+              (varE <$> subpreds)+              (varE <$> args)+    y <- newName "y"+    lamE+      (varP <$> subpreds)+      [|+        let acceptAndExplain $(varP y) = case $(varE y) of+              $pattern -> Just $acceptExplainFields+              _ -> Nothing+         in Predicate+              { showPredicate = $desc,+                showNegation = $negDesc,+                accept = maybe False (all fst) . acceptAndExplain,+                explain = \x -> case acceptAndExplain x of+                  Nothing -> "Not a " ++ $prettyConName+                  Just results ->+                    let significant+                          | all fst results = results+                          | otherwise = filter (not . fst) results+                     in "In " ++ $prettyConName ++ ": "+                          ++ intercalate " and " (map snd significant)+              }+        |]+  where+    countArguments (ForallT _ _ t) = countArguments t+    countArguments (AppT (AppT ArrowT _) t) = countArguments t + 1+#if MIN_VERSION_template_haskell(2,17,0)+    countArguments (AppT (AppT (AppT MulArrowT _) _) t) = countArguments t + 1+#endif+    countArguments _ = 0++-- | 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 = $patString,+        showNegation = "not " ++ $patString,+        accept = \case+          $qpat -> True+          _ -> False,+        explain = \case+          $qpat -> "value matched " ++ $patString+          _ -> "value didn't match " ++ $patString+      }+    |]+  where+    patString = lift . pprint . removeModNames =<< qpat++-- | 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)),+      showNegation =+        "not " ++ showPredicate p ++ " :: "+          ++ show (typeRep (Proxy :: Proxy a)),+      accept = \x -> case cast x of+        Nothing -> False+        Just y -> accept p y,+      explain = \x -> case cast x of+        Nothing ->+          "wrong type ("+            ++ show (typeRep (undefined :: Proxy b))+            ++ " vs. "+            ++ show (typeRep (undefined :: Proxy a))+            ++ ")"+        Just y -> explain p y+    }

@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | An implementation of bipartite matching using the Ford-Fulkerson algorithm.+module Test.Predicates.Internal.FlowMatcher where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.Array.IArray (Array, assocs, elems)+import Data.Array.ST+  ( MArray (newArray),+    STArray,+    newListArray,+    readArray,+    runSTArray,+    writeArray,+  )+import Data.List ((\\))+import Data.Maybe (catMaybes)++-- $setup+-- >>> :set -Wno-type-defaults++-- | Computes the best bipartite matching of the elements in the two lists,+-- given the compatibility function.+--+-- Returns matched pairs, then unmatched lhs elements, then unmatched rhs+-- elements.+--+-- >>> bipartiteMatching (==) [1 .. 5] [6, 5 .. 2]+-- ([(2,2),(3,3),(4,4),(5,5)],[1],[6])+bipartiteMatching ::+  forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])+bipartiteMatching compatible xs ys = (matchedPairs, unmatchedX, unmatchedY)+  where+    matchedPairs :: [(a, b)]+    matchedPairs = [(xs !! i, ys !! j) | (i, Just j) <- assocs matches]++    unmatchedX :: [a]+    unmatchedX = [xs !! i | (i, Nothing) <- assocs matches]++    unmatchedY :: [b]+    unmatchedY = [ys !! j | j <- [0 .. numYs - 1] \\ catMaybes (elems matches)]++    matches :: Array Int (Maybe Int)+    matches = runSTArray st++    st :: forall s. ST s (STArray s Int (Maybe Int))+    st = do+      compatArray <-+        newListArray+          ((0, 0), (numXs - 1, numYs - 1))+          [compatible x y | x <- xs, y <- ys] ::+          ST s (STArray s (Int, Int) Bool)+      matchArray <-+        newArray (0, numXs - 1) Nothing ::+          ST s (STArray s Int (Maybe Int))+      forM_ [0 .. numYs - 1] $ \j -> do+        seen <-+          newArray (0, numXs - 1) False :: ST s (STArray s Int Bool)+        _ <- go compatArray j matchArray seen+        return ()++      return matchArray++    numXs, numYs :: Int+    numXs = length xs+    numYs = length ys++    go ::+      forall s.+      STArray s (Int, Int) Bool ->+      Int ->+      STArray s Int (Maybe Int) ->+      STArray s Int Bool ->+      ST s Bool+    go compatArray j matchArray seen = loop False 0+      where+        loop True _ = return True+        loop _ i+          | i == numXs = return False+          | otherwise = do+            compat <- readArray compatArray (i, j)+            isSeen <- readArray seen i+            replace <-+              if isSeen || not compat+                then return False+                else do+                  writeArray seen i True+                  matchNum <- readArray matchArray i+                  case matchNum of+                    Nothing -> return True+                    Just n -> go compatArray n matchArray seen+            when replace $ writeArray matchArray i (Just j)+            loop replace (i + 1)

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Internal utilities used for HMock implementation.+module Test.Predicates.Internal.Util where++import Data.Generics (Data, everywhere, mkT)+import GHC.Stack (CallStack, getCallStack, prettySrcLoc)+import Language.Haskell.TH.Syntax (NameFlavour (..))++#ifdef CONTAINERS+import Data.MonoTraversable (Element)+import qualified Data.Sequences as Seq+#endif++-- | A value together with its source location.+data Located a = Loc (Maybe String) a deriving (Functor)++-- | Annotates a value with its source location from the call stack.+locate :: CallStack -> a -> Located a+locate stack = case map snd (getCallStack stack) of+  (loc : _) -> Loc (Just (prettySrcLoc loc))+  _ -> Loc Nothing++-- | Formats a 'Located' 'String' to include its source location.+withLoc :: Located String -> String+withLoc (Loc Nothing s) = s+withLoc (Loc (Just loc) s) = s ++ " at " ++ loc++-- | Returns all ways to choose one element from a list, and the corresponding+-- remaining list.+choices :: [a] -> [(a, [a])]+choices [] = []+choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs)++#ifdef CONTAINERS++-- | Checks if one sequence is a subsequence of another.+isSubsequenceOf :: (Seq.IsSequence t, Eq (Element t)) => t -> t -> Bool+xs `isSubsequenceOf` ys = case Seq.uncons xs of+  Nothing -> True+  Just (x, xs') -> case Seq.uncons (snd (Seq.break (== x) ys)) of+    Nothing -> False+    Just (_, ys') -> xs' `isSubsequenceOf` ys'++#endif++-- | Removes all module names from Template Haskell names in the given value, so+-- that it will pretty-print more cleanly.+removeModNames :: Data a => a -> a+removeModNames = everywhere (mkT unMod)+  where+    unMod NameG {} = NameS+    unMod other = other