diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -24,6 +24,16 @@
[KaC]:
+## 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
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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
diff --git a/app/LibOA.hs b/app/LibOA.hs
--- a/app/LibOA.hs
+++ b/app/LibOA.hs
@@ -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
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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.
diff --git a/horizontal-rule.cabal b/horizontal-rule.cabal
--- a/horizontal-rule.cabal
+++ b/horizontal-rule.cabal
@@ -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
maintainer: Travis Cardwell
-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
diff --git a/src/HR.hs b/src/HR.hs
--- a/src/HR.hs
+++ b/src/HR.hs
@@ -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:
diff --git a/src/HR/Monad/Terminal.hs b/src/HR/Monad/Terminal.hs
--- a/src/HR/Monad/Terminal.hs
+++ b/src/HR/Monad/Terminal.hs
@@ -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
------------------------------------------------------------------------------
diff --git a/test/HR/Mock.hs b/test/HR/Mock.hs
deleted file mode 100644
--- a/test/HR/Mock.hs
+++ /dev/null
@@ -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
- ]
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -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
]
diff --git a/test/Test/HMock.hs b/test/Test/HMock.hs
deleted file mode 100644
--- a/test/Test/HMock.hs
+++ /dev/null
@@ -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
--- ,
--- 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
diff --git a/test/Test/HMock/ExpectContext.hs b/test/Test/HMock/ExpectContext.hs
deleted file mode 100644
--- a/test/Test/HMock/ExpectContext.hs
+++ /dev/null
@@ -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 ()
diff --git a/test/Test/HMock/Internal/ExpectSet.hs b/test/Test/HMock/Internal/ExpectSet.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/ExpectSet.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/Internal/Rule.hs b/test/Test/HMock/Internal/Rule.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/Rule.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/Internal/State.hs b/test/Test/HMock/Internal/State.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/State.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/Internal/State.hs-boot b/test/Test/HMock/Internal/State.hs-boot
deleted file mode 100644
--- a/test/Test/HMock/Internal/State.hs-boot
+++ /dev/null
@@ -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)
diff --git a/test/Test/HMock/Internal/Step.hs b/test/Test/HMock/Internal/Step.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/Step.hs
+++ /dev/null
@@ -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))
diff --git a/test/Test/HMock/Internal/TH.hs b/test/Test/HMock/Internal/TH.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/TH.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/Internal/Util.hs b/test/Test/HMock/Internal/Util.hs
deleted file mode 100644
--- a/test/Test/HMock/Internal/Util.hs
+++ /dev/null
@@ -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)
diff --git a/test/Test/HMock/MockMethod.hs b/test/Test/HMock/MockMethod.hs
deleted file mode 100644
--- a/test/Test/HMock/MockMethod.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/MockT.hs b/test/Test/HMock/MockT.hs
deleted file mode 100644
--- a/test/Test/HMock/MockT.hs
+++ /dev/null
@@ -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."
diff --git a/test/Test/HMock/Mockable.hs b/test/Test/HMock/Mockable.hs
deleted file mode 100644
--- a/test/Test/HMock/Mockable.hs
+++ /dev/null
@@ -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 ()
diff --git a/test/Test/HMock/Multiplicity.hs b/test/Test/HMock/Multiplicity.hs
deleted file mode 100644
--- a/test/Test/HMock/Multiplicity.hs
+++ /dev/null
@@ -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
diff --git a/test/Test/HMock/Rule.hs b/test/Test/HMock/Rule.hs
deleted file mode 100644
--- a/test/Test/HMock/Rule.hs
+++ /dev/null
@@ -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 :=> []
diff --git a/test/Test/HMock/TH.hs b/test/Test/HMock/TH.hs
deleted file mode 100644
--- a/test/Test/HMock/TH.hs
+++ /dev/null
@@ -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."
diff --git a/test/Test/Predicates.hs b/test/Test/Predicates.hs
deleted file mode 100644
--- a/test/Test/Predicates.hs
+++ /dev/null
@@ -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
- }
diff --git a/test/Test/Predicates/Internal/FlowMatcher.hs b/test/Test/Predicates/Internal/FlowMatcher.hs
deleted file mode 100644
--- a/test/Test/Predicates/Internal/FlowMatcher.hs
+++ /dev/null
@@ -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)
diff --git a/test/Test/Predicates/Internal/Util.hs b/test/Test/Predicates/Internal/Util.hs
deleted file mode 100644
--- a/test/Test/Predicates/Internal/Util.hs
+++ /dev/null
@@ -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