horizontal-rule 0.7.0.0 → 0.7.1.0
raw patch · 27 files changed
+28/−4633 lines, 27 filesdep −arraydep −constraintsdep −containersdep ~basedep ~optparse-applicativedep ~textPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: array, constraints, containers, data-default, exceptions, extra, monad-control, mtl, stm, syb, template-haskell, transformers-base, unliftio
Dependency ranges changed: base, optparse-applicative, text, time
API changes (from Hackage documentation)
- HR.Monad.Terminal: class Monad m => MonadTerminal m
+ HR.Monad.Terminal: class Monad m => MonadTerminal (m :: Type -> Type)
Files
- CHANGELOG.md +10/−0
- LICENSE +1/−1
- app/LibOA.hs +1/−1
- app/Main.hs +1/−1
- horizontal-rule.cabal +13/−49
- src/HR.hs +1/−1
- src/HR/Monad/Terminal.hs +1/−1
- test/HR/Mock.hs +0/−115
- test/Spec.hs +0/−8
- test/Test/HMock.hs +0/−116
- test/Test/HMock/ExpectContext.hs +0/−192
- test/Test/HMock/Internal/ExpectSet.hs +0/−203
- test/Test/HMock/Internal/Rule.hs +0/−65
- test/Test/HMock/Internal/State.hs +0/−296
- test/Test/HMock/Internal/State.hs-boot +0/−18
- test/Test/HMock/Internal/Step.hs +0/−112
- test/Test/HMock/Internal/TH.hs +0/−262
- test/Test/HMock/Internal/Util.hs +0/−27
- test/Test/HMock/MockMethod.hs +0/−259
- test/Test/HMock/MockT.hs +0/−280
- test/Test/HMock/Mockable.hs +0/−78
- test/Test/HMock/Multiplicity.hs +0/−155
- test/Test/HMock/Rule.hs +0/−59
- test/Test/HMock/TH.hs +0/−707
- test/Test/Predicates.hs +0/−1477
- test/Test/Predicates/Internal/FlowMatcher.hs +0/−95
- test/Test/Predicates/Internal/Util.hs +0/−55
CHANGELOG.md view
@@ -24,6 +24,16 @@ [KaC]: <https://keepachangelog.com/en/1.0.0/> +## 0.7.1.0 (2026-01-10)++### Non-Breaking++* Bump `base` dependency version upper bound+* Bump `optparse-applicative` dependency version upper bound+* Bump `time` dependency version upper bound+* Remove mock tests, vendored `HMock` and `explainable-predicates`+ dependencies+ ## 0.7.0.0 (2024-12-04) ### Breaking
LICENSE view
@@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2019-2024 Travis Cardwell+Copyright (c) 2019-2026 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
app/LibOA.hs view
@@ -2,7 +2,7 @@ -- | -- Module : LibOA -- Description : supplementary functions for optparse-applicative--- Copyright : Copyright (c) 2019-2024 Travis Cardwell+-- Copyright : Copyright (c) 2019-2026 Travis Cardwell -- License : MIT -- -- This is a collection of functions that I often use with
app/Main.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Main -- Description : hr: a horizontal rule for terminals--- Copyright : Copyright (c) 2019-2024 Travis Cardwell+-- Copyright : Copyright (c) 2019-2026 Travis Cardwell -- License : MIT -- -- See the README for details.
horizontal-rule.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: horizontal-rule-version: 0.7.0.0+version: 0.7.1.0 synopsis: horizontal rule for the terminal description: This package provides a utility for displaying a horizontal rule in a@@ -12,7 +12,7 @@ license-file: LICENSE author: Travis Cardwell <travis.cardwell@extrema.is> maintainer: Travis Cardwell <travis.cardwell@extrema.is>-copyright: Copyright (c) 2019-2024 Travis Cardwell+copyright: Copyright (c) 2019-2026 Travis Cardwell category: Utils build-type: Simple @@ -26,18 +26,19 @@ || ==9.0.2 || ==9.2.8 || ==9.4.8- || ==9.6.6+ || ==9.6.7 || ==9.8.4- || ==9.10.1+ || ==9.10.3+ || ==9.12.2+ || ==9.14.1 source-repository head type: git location: https://github.com/ExtremaIS/hr-haskell.git --- This flag is referenced in the Stack build-constraints.yaml configuration. flag optparse-applicative_ge_0_18 description: Use optparse-applicative 0.18 or newer- default: False+ default: True manual: False library@@ -50,9 +51,9 @@ autogen-modules: Paths_horizontal_rule build-depends:- base >=4.13.0.0 && <4.21+ base >=4.13 && <4.23 , terminal-size >=0.3.2.1 && <0.4- , text >=1.2.4.0 && <2.2+ , text >=1.2.4 && <2.2 default-language: Haskell2010 default-extensions: OverloadedStrings@@ -67,15 +68,15 @@ base , horizontal-rule , text- , time >=1.9.3 && <1.15+ , time >=1.9.3 && <1.16 if flag(optparse-applicative_ge_0_18) build-depends:- optparse-applicative >=0.18 && <0.19+ optparse-applicative >=0.18 && <0.20 , prettyprinter >=1.7.1 && <1.8 else build-depends: ansi-wl-pprint >=0.6.9 && <1.1- , optparse-applicative >=0.15.1.0 && <0.18+ , optparse-applicative >=0.15.1 && <0.18 default-language: Haskell2010 ghc-options: -Wall @@ -84,48 +85,11 @@ hs-source-dirs: test main-is: Spec.hs other-modules:- 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+ HR.Test build-depends: base , horizontal-rule , 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
src/HR.hs view
@@ -2,7 +2,7 @@ -- | -- Module : HR -- Description : horizontal rule for terminals--- Copyright : Copyright (c) 2019-2024 Travis Cardwell+-- Copyright : Copyright (c) 2019-2026 Travis Cardwell -- License : MIT -- -- This library is meant to be imported qualified, as follows:
src/HR/Monad/Terminal.hs view
@@ -2,7 +2,7 @@ -- | -- Module : HR.Monad.Terminal -- Description : terminal output--- Copyright : Copyright (c) 2019-2024 Travis Cardwell+-- Copyright : Copyright (c) 2019-2026 Travis Cardwell -- License : MIT ------------------------------------------------------------------------------
− test/HR/Mock.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module HR.Mock (tests) where---- https://hackage.haskell.org/package/HMock-import qualified Test.HMock as HMock-import Test.HMock ((|->))---- https://hackage.haskell.org/package/tasty-import Test.Tasty (TestTree, testGroup)---- https://hackage.haskell.org/package/tasty-hunit-import Test.Tasty.HUnit (testCase)---- (horizontal-rule)-import qualified HR-import HR.Monad.Terminal (MonadTerminal(..))----------------------------------------------------------------------------------HMock.makeMockable [t|MonadTerminal|]----------------------------------------------------------------------------------parts :: HR.Parts-parts = HR.Parts- { HR.leftPart = "══╣"- , HR.midPart = "╠═╣"- , HR.rightPart = "╠══"- , HR.fillPart = '═'- }----------------------------------------------------------------------------------testPutAscii :: TestTree-testPutAscii = testCase "putAscii" . HMock.runMockT $ do- HMock.expect $ PutStrLn "--|test|------------" |-> ()- HR.putAscii 20 ["test"]----------------------------------------------------------------------------------testPutUnicode :: TestTree-testPutUnicode = testCase "putUnicode" . HMock.runMockT $ do- HMock.expect $ PutStrLn "━━┫test┣━━━━━━━━━━━━" |-> ()- HR.putUnicode 20 ["test"]----------------------------------------------------------------------------------testPut :: TestTree-testPut = testCase "put" . HMock.runMockT $ do- HMock.expect $ PutStrLn "══╣test╠════════════" |-> ()- HR.put parts 20 ["test"]----------------------------------------------------------------------------------testPutAutoAscii :: TestTree-testPutAutoAscii = testGroup "putAutoAscii"- [ testCase "auto" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Just 20- HMock.expect $ PutStrLn "--|test|------------" |-> ()- HR.putAutoAscii 30 ["test"]- , testCase "default" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Nothing- HMock.expect $ PutStrLn "--|test|--" |-> ()- HR.putAutoAscii 10 ["test"]- ]----------------------------------------------------------------------------------testPutAutoUnicode :: TestTree-testPutAutoUnicode = testGroup "putAutoUnicode"- [ testCase "auto" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Just 20- HMock.expect $ PutStrLn "━━┫test┣━━━━━━━━━━━━" |-> ()- HR.putAutoUnicode 30 ["test"]- , testCase "default" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Nothing- HMock.expect $ PutStrLn "━━┫test┣━━" |-> ()- HR.putAutoUnicode 10 ["test"]- ]----------------------------------------------------------------------------------testPutAuto :: TestTree-testPutAuto = testGroup "putAuto"- [ testCase "auto" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Just 20- HMock.expect $ PutStrLn "══╣test╠════════════" |-> ()- HR.putAuto parts 30 ["test"]- , testCase "default" . HMock.runMockT $ do- HMock.expect $ GetWidth |-> Nothing- HMock.expect $ PutStrLn "══╣test╠══" |-> ()- HR.putAuto parts 10 ["test"]- ]----------------------------------------------------------------------------------tests :: TestTree-tests = testGroup "HR:Mock"- [ testPutAscii- , testPutUnicode- , testPut- , testPutAutoAscii- , testPutAutoUnicode- , testPutAuto- ]
test/Spec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Main (main) where -- https://hackage.haskell.org/package/tasty@@ -7,16 +5,10 @@ -- (horizontal-rule:test) import qualified HR.Test-#if __GLASGOW_HASKELL__ >= 806-import qualified HR.Mock-#endif ------------------------------------------------------------------------------ main :: IO () main = defaultMain $ testGroup "test" [ HR.Test.tests-#if __GLASGOW_HASKELL__ >= 806- , HR.Mock.tests-#endif ]
− test/Test/HMock.hs
@@ -1,116 +0,0 @@-{-# 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
− test/Test/HMock/ExpectContext.hs
@@ -1,192 +0,0 @@-{-# 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 ()
− test/Test/HMock/Internal/ExpectSet.hs
@@ -1,203 +0,0 @@-{-# 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
− test/Test/HMock/Internal/Rule.hs
@@ -1,65 +0,0 @@-{-# 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
− test/Test/HMock/Internal/State.hs
@@ -1,296 +0,0 @@-{-# 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
− test/Test/HMock/Internal/State.hs-boot
@@ -1,18 +0,0 @@-{-# 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)
− test/Test/HMock/Internal/Step.hs
@@ -1,112 +0,0 @@-{-# 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))
− test/Test/HMock/Internal/TH.hs
@@ -1,262 +0,0 @@-{-# 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
− test/Test/HMock/Internal/Util.hs
@@ -1,27 +0,0 @@-{-# 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)
− test/Test/HMock/MockMethod.hs
@@ -1,259 +0,0 @@-{-# 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
− test/Test/HMock/MockT.hs
@@ -1,280 +0,0 @@-{-# 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."
− test/Test/HMock/Mockable.hs
@@ -1,78 +0,0 @@-{-# 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 ()
− test/Test/HMock/Multiplicity.hs
@@ -1,155 +0,0 @@-{-# 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
− test/Test/HMock/Rule.hs
@@ -1,59 +0,0 @@-{-# 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 :=> []
− test/Test/HMock/TH.hs
@@ -1,707 +0,0 @@-{-# 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."
− test/Test/Predicates.hs
@@ -1,1477 +0,0 @@-{-# 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- }
− test/Test/Predicates/Internal/FlowMatcher.hs
@@ -1,95 +0,0 @@-{-# 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)
− test/Test/Predicates/Internal/Util.hs
@@ -1,55 +0,0 @@-{-# 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