diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,7 +4,7 @@ versions in `A.B.C.D` format. `A` may be incremented arbitrarily for non-technical reasons, but [semantic versioning][SemVer] is otherwise followed, where `A.B` is the major version, `C` is the minor version, and `D` -is the patch version. Initial development uses versions `0.0.0.D`, for which +is the patch version. Initial development uses versions `0.0.C.D`, for which every version is considered breaking. [PVP]: @@ -23,6 +23,23 @@ * Changes are listed in arbitrary order and present tense. [KaC]: + +## 0.7.0.0 (2024-12-04) + +### Breaking + +* Remove support for GHC 8.6, constraining lower bounds +* Remove support for GHC 8.4, constraining lower bounds +* Remove support for GHC 8.2, constraining lower bounds +* Change minimal Cabal from 1.24 to 3.0 + +### Non-Breaking + +* Bump `base` dependency version upper bound +* Bump `tasty` dependency version upper bound +* Bump `text` dependency version upper bound +* Bump `time` dependency version upper bound +* Vendor `HMock` and `explainable-predicates` ## 0.6.0.0 (2023-05-28) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2019-2023 Travis Cardwell +Copyright (c) 2019-2024 Travis Cardwell Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal 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-2023 Travis Cardwell +-- Copyright : Copyright (c) 2019-2024 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-2023 Travis Cardwell +-- Copyright : Copyright (c) 2019-2024 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,36 +1,34 @@ -name: horizontal-rule -version: 0.6.0.0 -category: Utils -synopsis: horizontal rule for the terminal +cabal-version: 3.0 +name: horizontal-rule +version: 0.7.0.0 +synopsis: horizontal rule for the terminal description: This package provides a utility for displaying a horizontal rule in a terminal. Please see the README on GitHub at . +homepage: https://github.com/ExtremaIS/hr-haskell#readme +bug-reports: https://github.com/ExtremaIS/hr-haskell/issues +license: MIT +license-file: LICENSE +author: Travis Cardwell +maintainer: Travis Cardwell +copyright: Copyright (c) 2019-2024 Travis Cardwell +category: Utils +build-type: Simple -homepage: https://github.com/ExtremaIS/hr-haskell#readme -bug-reports: https://github.com/ExtremaIS/hr-haskell/issues -author: Travis Cardwell -maintainer: Travis Cardwell -copyright: Copyright (c) 2019-2023 Travis Cardwell -license: MIT -license-file: LICENSE +extra-doc-files: + CHANGELOG.md + README.md -cabal-version: 1.24 -build-type: Simple tested-with: - GHC ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.4 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 - || ==9.4.5 - || ==9.6.2 - -extra-source-files: - CHANGELOG.md - README.md + || ==9.4.8 + || ==9.6.6 + || ==9.8.4 + || ==9.10.1 source-repository head type: git @@ -49,10 +47,12 @@ , HR.Monad.Terminal other-modules: Paths_horizontal_rule + autogen-modules: + Paths_horizontal_rule build-depends: - base >=4.10.1 && <4.19 - , terminal-size >=0.2 && <0.4 - , text >=1.2.3 && <2.1 + base >=4.13.0.0 && <4.21 + , terminal-size >=0.3.2.1 && <0.4 + , text >=1.2.4.0 && <2.2 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -67,15 +67,15 @@ base , horizontal-rule , text - , time >=1.8.0.2 && <1.13 + , time >=1.9.3 && <1.15 if flag(optparse-applicative_ge_0_18) build-depends: optparse-applicative >=0.18 && <0.19 , prettyprinter >=1.7.1 && <1.8 else build-depends: - ansi-wl-pprint >=0.6.8 && <1.1 - , optparse-applicative >=0.13 && <0.18 + ansi-wl-pprint >=0.6.9 && <1.1 + , optparse-applicative >=0.15.1.0 && <0.18 default-language: Haskell2010 ghc-options: -Wall @@ -84,16 +84,48 @@ hs-source-dirs: test main-is: Spec.hs other-modules: - HR.Test + HR.Mock + , HR.Test + other-modules: + -- vendored explainable-preducates + Test.Predicates + , Test.Predicates.Internal.FlowMatcher + , Test.Predicates.Internal.Util + other-modules: + -- vendored HMock + Test.HMock + , Test.HMock.ExpectContext + , Test.HMock.Internal.ExpectSet + , Test.HMock.Internal.Rule + , Test.HMock.Internal.State + , Test.HMock.Internal.Step + , Test.HMock.Internal.TH + , Test.HMock.Internal.Util + , Test.HMock.MockMethod + , Test.HMock.MockT + , Test.HMock.Mockable + , Test.HMock.Multiplicity + , Test.HMock.Rule + , Test.HMock.TH build-depends: base , horizontal-rule - , tasty >=0.12 && <1.5 - , tasty-hunit >=0.8 && <0.11 - if impl(ghc >= 8.6.1) - other-modules: - HR.Mock - build-depends: - HMock >=0.5.1 && <0.6 + , tasty >=1.2.3 && <1.6 + , tasty-hunit >=0.10.0.3 && <0.11 + build-depends: + -- vendored dependencies + array >=0.5.2 && <0.6 + , constraints >=0.13 && <0.15 + , containers >=0.6.2 && <0.8 + , data-default >=0.7.1 && <0.9 + , exceptions >=0.10.4 && <0.11 + , extra >=1.7.9 && <1.9 + , monad-control >=1.0.2 && <1.1 + , mtl >=2.2.2 && <2.4 + , stm >=2.5.0 && <2.6 + , syb >=0.7.2 && <0.8 + , template-haskell >=2.14 && <2.23 + , transformers-base >=0.4.5 && <0.5 + , unliftio >=0.2.18 && <0.3 default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 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-2023 Travis Cardwell +-- Copyright : Copyright (c) 2019-2024 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-2023 Travis Cardwell +-- Copyright : Copyright (c) 2019-2024 Travis Cardwell -- License : MIT ------------------------------------------------------------------------------ diff --git a/test/Test/HMock.hs b/test/Test/HMock.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- +-- This module provides a monad transformer, 'MockT', which can be used to test +-- with mocks of Haskell @mtl@-style type classes. To use a mock, you define +-- the expected actions and their results, and then run the code you are +-- testing. The framework verifies that the behavior of the code matched your +-- expectations. +-- +-- For an introduction to the idea of mocks, see +-- , +-- 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 new file mode 100644 --- /dev/null +++ b/test/Test/HMock/ExpectContext.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +-- | This module defines the 'ExpectContext' class, whose members provide the +-- combinators for building the execution plan for your mocks. Notably, there +-- is a 'Test.HMock.MockT.MockT' instance for 'ExpectContext', so you can use +-- these combinators to add expectations inside your tests that run in +-- 'Test.HMock.MockT.MockT', as well as nesting them in other combinators. +module Test.HMock.ExpectContext + ( MockableMethod, + ExpectContext (..), + ) +where + +import Control.Monad.IO.Class (MonadIO) +import Data.Kind (Constraint, Type) +import Data.Typeable (Typeable) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol, Symbol) +import Test.HMock.Mockable (Mockable) +import Test.HMock.Multiplicity (Multiplicity) +import Test.HMock.Rule (Expectable) + +-- | All constraints needed to mock a method with the given class, name, base +-- monad, and return type. +type MockableMethod + (cls :: (Type -> Type) -> Constraint) + (name :: Symbol) + (m :: Type -> Type) + (r :: Type) = + (Mockable cls, Typeable m, KnownSymbol name, Typeable r) + +-- | Type class for contexts in which one can build expectations. Notably, this +-- includes `Test.HMock.MockT.MockT`, which expects actions to be performed +-- during a test. +-- +-- The methods of this class represent the user-facing API for build your +-- execution plan for mocks. +class ExpectContext (ctx :: (Type -> Type) -> Type -> Type) where + -- | Creates an expectation that an action is performed once per given + -- response (or exactly once if there is no response). + -- + -- @ + -- 'Test.HMock.MockT.runMockT' '$' do + -- 'expect' '$' + -- ReadFile "foo.txt" + -- 'Test.HMock.Rule.|->' "lorem ipsum" + -- 'Test.HMock.Rule.|->' "oops, the file changed out from under me!" + -- callCodeUnderTest + -- @ + -- + -- In this example, `readFile` must be called exactly twice by the tested + -- code, and will return "lorem ipsum" the first time, but something different + -- the second time. + expect :: + ( HasCallStack, + MonadIO m, + MockableMethod cls name m r, + Expectable cls name m r expectable + ) => + expectable -> + ctx m () + + -- | Creates an expectation that an action is performed some number of times. + -- + -- @ + -- 'Test.HMock.MockT.runMockT' '$' do + -- 'expect' '$' MakeList + -- 'expectN' ('Test.HMock.atLeast' 2) '$' + -- CheckList "Cindy Lou Who" 'Test.HMock.Rule.|->' Nice + -- + -- callCodeUnderTest + -- @ + expectN :: + ( HasCallStack, + MonadIO m, + MockableMethod cls name m r, + Expectable cls name m r expectable + ) => + -- | The number of times the action should be performed. + Multiplicity -> + -- | The action and its response. + expectable -> + ctx m () + + -- | Specifies a response if a matching action is performed, but doesn't + -- expect anything. This is equivalent to @'expectN' + -- 'Test.HMock.Multiplicity.anyMultiplicity'@, but shorter. + -- + -- In this example, the later use of 'expectAny' overrides earlier uses, but + -- only for calls that match its conditions. + -- + -- @ + -- 'Test.HMock.MockT.runMockT' '$' do + -- 'expectAny' '$' + -- ReadFile_ anything 'Test.HMock.Rule.|->' "tlhIngan maH!" + -- 'expectAny' '$' + -- ReadFile "config.txt" 'Test.HMock.Rule.|->' "lang: klingon" + -- + -- callCodeUnderTest + -- @ + expectAny :: + ( HasCallStack, + MonadIO m, + MockableMethod cls name m r, + Expectable cls name m r expectable + ) => + expectable -> + ctx m () + + -- | Creates a sequential expectation. Other actions can still happen during + -- the sequence, but these specific expectations must be met in this order. + -- + -- @ + -- 'inSequence' + -- [ 'expect' '$' MoveForward, + -- 'expect' '$' TurnRight, + -- 'expect' '$' MoveForward + -- ] + -- @ + -- + -- Beware of using 'inSequence' too often. It is appropriate when the + -- property you are testing is that the order of effects is correct. If + -- that's not the purpose of the test, consider adding several independent + -- expectations, instead. This avoids over-asserting, and keeps your tests + -- less brittle. + inSequence :: + MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m () + + -- | Combines multiple expectations, which can occur in any order. Most of + -- the time, you can achieve the same thing by expecting each separately, but + -- this can be combined in compound expectations to describe more complex + -- ordering constraints. + -- + -- If ambiguity checking is disabled, the choice is left-biased, so earlier + -- options are preferred over ambiguous later options. + -- + -- @ + -- 'inSequence' + -- [ 'inAnyOrder' + -- [ 'expect' '$' AdjustMirrors, + -- 'expect' '$' FastenSeatBelt + -- ], + -- 'expect' '$' StartCar + -- ] + -- @ + inAnyOrder :: + MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m () + + -- | Combines multiple expectations, requiring exactly one of them to occur. + -- If ambiguity checking is disabled, the choice is left-biased, so earlier + -- options are preferred over ambiguous later options. + -- + -- @ + -- 'anyOf' + -- [ 'expect' $ ApplyForJob, + -- 'expect' $ ApplyForUniversity + -- ] + -- @ + anyOf :: + MonadIO m => (forall ctx'. ExpectContext ctx' => [ctx' m ()]) -> ctx m () + + -- | Creates a parent expectation that the child expectation will happen a + -- certain number of times. Unlike `expectN`, the child expectation can be + -- arbitrarily complex and span multiple actions. Also unlike 'expectN', each + -- new execution will restart response sequences for rules with more than one + -- response. + -- + -- Different occurrences of the child can be interleaved. If ambiguity + -- checking is disabled, progressing on an existing occurrence is preferred + -- over starting a new occurrence when it's ambiguous. + times :: + MonadIO m => + Multiplicity -> + (forall ctx'. ExpectContext ctx' => ctx' m ()) -> + ctx m () + + -- | Creates a parent expectation that the child expectation will happen a + -- certain number of times. Unlike `expectN`, the child expectation can be + -- arbitrarily complex and span multiple actions. Also unlike 'expectN', each + -- new execution will restart response sequences for rules with more than one + -- response. + -- + -- Different occurrences of the child must happen consecutively, with one + -- finishing before the next begins. + consecutiveTimes :: + MonadIO m => + Multiplicity -> + (forall ctx'. ExpectContext ctx' => ctx' m ()) -> + ctx m () diff --git a/test/Test/HMock/Internal/ExpectSet.hs b/test/Test/HMock/Internal/ExpectSet.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/ExpectSet.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | The internal core language of expectations in HMock. +module Test.HMock.Internal.ExpectSet where + +import Test.HMock.Multiplicity + ( Multiplicity, + between, + feasible, meetsMultiplicity + ) + +-- | A set of expected steps and their responses. This is the "core" language +-- of expectations for HMock. It's based roughly on Svenningsson, Svensson, +-- Smallbone, Arts, Norell, and Hughes' Expressive Semantics of Mocking. +-- However, there are a few small adjustments. We have two repetition operators +-- which respectively represent general repetition with interleaving, and +-- consecutive repetition. We also attach arbitrary multiplicities to +-- repetition. +data ExpectSet step where + ExpectStep :: step -> ExpectSet step + ExpectNothing :: ExpectSet step + ExpectSequence :: ExpectSet step -> ExpectSet step -> ExpectSet step + ExpectInterleave :: ExpectSet step -> ExpectSet step -> ExpectSet step + ExpectEither :: ExpectSet step -> ExpectSet step -> ExpectSet step + ExpectMulti :: Multiplicity -> ExpectSet step -> ExpectSet step + ExpectConsecutive :: Multiplicity -> ExpectSet step -> ExpectSet step + deriving (Show, Eq) + +-- | Checks whether an ExpectSet is in an "accepting" state. In other words, is +-- it okay for the test to end here? If False, then there are still +-- expectations that must be satisfied before the test can succeed. +satisfied :: ExpectSet step -> Bool +satisfied (ExpectStep _) = False +satisfied ExpectNothing = True +satisfied (ExpectSequence e f) = satisfied e && satisfied f +satisfied (ExpectInterleave e f) = satisfied e && satisfied f +satisfied (ExpectEither e f) = satisfied e || satisfied f +satisfied (ExpectMulti mult e) = + feasible mult && (meetsMultiplicity mult 0 || satisfied e) +satisfied (ExpectConsecutive mult e) = + feasible mult && (meetsMultiplicity mult 0 || satisfied e) + +-- | Computes the live steps of the ExpectSet. In other words: which individual +-- steps can be matched right now, and what are the remaining expectations in +-- each case? +liveSteps :: ExpectSet step -> [(step, ExpectSet step)] +liveSteps (ExpectStep step) = [(step, ExpectNothing)] +liveSteps ExpectNothing = [] +liveSteps (ExpectSequence e f) = + (fmap (`ExpectSequence` f) <$> liveSteps e) + ++ if satisfied e then liveSteps f else [] +liveSteps (ExpectInterleave e f) = + (fmap (`ExpectInterleave` f) <$> liveSteps e) + ++ (fmap (ExpectInterleave e) <$> liveSteps f) +liveSteps (ExpectEither e f) = liveSteps e ++ liveSteps f +liveSteps (ExpectMulti mult e) + | feasible (mult - 1) = + [ (step, ExpectInterleave f (ExpectMulti (mult - 1) e)) + | (step, f) <- liveSteps e + ] + | otherwise = [] +liveSteps (ExpectConsecutive mult e) + | feasible (mult - 1) = + [ (step, ExpectSequence f (ExpectConsecutive (mult - 1) e)) + | (step, f) <- liveSteps e + ] + | otherwise = [] + +-- | Performs a complete simplification of the ExpectSet. This could be slow, +-- but we intend to do it only for error messages, so it need not be very fast. +simplify :: ExpectSet step -> ExpectSet step +simplify (ExpectSequence e f) + | ExpectNothing <- e' = f' + | ExpectNothing <- f' = e' + | ExpectSequence e1 e2 <- e' = + simplify (ExpectSequence e1 (ExpectSequence e2 f')) + | otherwise = ExpectSequence e' f' + where + e' = simplify e + f' = simplify f +simplify (ExpectInterleave e f) + | ExpectNothing <- e' = f' + | ExpectNothing <- f' = e' + | ExpectInterleave e1 e2 <- e' = + simplify (ExpectInterleave e1 (ExpectInterleave e2 f')) + | otherwise = ExpectInterleave e' f' + where + e' = simplify e + f' = simplify f +simplify (ExpectEither e f) + | ExpectNothing <- e', ExpectNothing <- f' = ExpectNothing + | ExpectNothing <- e' = simplify (ExpectEither f' ExpectNothing) + | ExpectEither e1 e2 <- e' = + simplify (ExpectEither e1 (ExpectEither e2 f')) + | ExpectNothing <- f', satisfied e' = e' + | ExpectNothing <- f' = simplify (ExpectMulti (between 0 1) e') + | otherwise = ExpectEither e' f' + where + e' = simplify e + f' = simplify f +simplify (ExpectMulti m e) + | not (feasible m) = ExpectMulti m ExpectNothing + | ExpectNothing <- e' = ExpectNothing + | m == 0 = ExpectNothing + | m == 1 = e' + | otherwise = ExpectMulti m e' + where + e' = simplify e +simplify (ExpectConsecutive m e) + | not (feasible m) = ExpectConsecutive m ExpectNothing + | ExpectNothing <- e' = ExpectNothing + | m == 0 = ExpectNothing + | m == 1 = e' + | otherwise = ExpectConsecutive m e' + where + e' = simplify e +simplify other = other + +-- | Get a list of all steps mentioned by an 'ExpectSet'. This is used to +-- determine which classes need to be initialized before adding an expectation. +getSteps :: ExpectSet step -> [step] +getSteps ExpectNothing = [] +getSteps (ExpectStep step) = [step] +getSteps (ExpectInterleave e f) = getSteps e ++ getSteps f +getSteps (ExpectSequence e f) = getSteps e ++ getSteps f +getSteps (ExpectEither e f) = getSteps e ++ getSteps f +getSteps (ExpectMulti _ e) = getSteps e +getSteps (ExpectConsecutive _ e) = getSteps e + +-- | A higher-level intermediate form of an ExpectSet suitable for communication +-- with the user. Chains of binary operators are collected into sequences to +-- be displayed in lists rather than arbitrary nesting. +data CollectedSet step where + CollectedStep :: step -> CollectedSet step + CollectedNothing :: CollectedSet step + CollectedSequence :: [CollectedSet step] -> CollectedSet step + CollectedInterleave :: [CollectedSet step] -> CollectedSet step + CollectedChoice :: [CollectedSet step] -> CollectedSet step + CollectedMulti :: Multiplicity -> CollectedSet step -> CollectedSet step + CollectedConsecutive :: Multiplicity -> CollectedSet step -> CollectedSet step + +-- | Collects an ExpectSet into the intermediate form for display. It's assumed +-- that the expression was simplified before this operation. +collect :: ExpectSet step -> CollectedSet step +collect (ExpectStep s) = CollectedStep s +collect ExpectNothing = CollectedNothing +collect (ExpectSequence e f) = CollectedSequence (collect e : fs) + where + fs = case collect f of + CollectedSequence f' -> f' + f' -> [f'] +collect (ExpectInterleave e f) = CollectedInterleave (collect e : fs) + where + fs = case collect f of + CollectedInterleave f' -> f' + f' -> [f'] +collect (ExpectEither e f) = CollectedChoice (collect e : fs) + where + fs = case collect f of + CollectedChoice f' -> f' + f' -> [f'] +collect (ExpectMulti m e) = CollectedMulti m (collect e) +collect (ExpectConsecutive m e) = CollectedConsecutive m (collect e) + +-- | Converts a set of expectations into a string that summarizes them, with +-- the given prefix (used to indent). +formatExpectSet :: (Show step) => ExpectSet step -> String +formatExpectSet = go "" . collect . simplify + where + go prefix CollectedNothing = prefix ++ "* nothing" + go prefix (CollectedStep step) = prefix ++ "* " ++ show step + go prefix (CollectedSequence cs) = + prefix ++ "* in sequence:\n" ++ unlines (map (go (" " ++ prefix)) cs) + go prefix (CollectedInterleave cs) = + prefix ++ "* in any order:\n" ++ unlines (map (go (" " ++ prefix)) cs) + go prefix (CollectedChoice cs) = + prefix ++ "* any of:\n" ++ unlines (map (go (" " ++ prefix)) cs) + go prefix (CollectedMulti m e) = + prefix ++ "* " ++ show m ++ ":\n" ++ go (" " ++ prefix) e + go prefix (CollectedConsecutive m e) = + prefix ++ "* " ++ show m ++ " consecutively:\n" ++ go (" " ++ prefix) e + +-- | Reduces a set of expectations to the minimum steps that would be required +-- to satisfy the entire set. This weeds out unnecessary information before +-- reporting that there were unmet expectations at the end of the test. +excess :: ExpectSet step -> ExpectSet step +excess = simplify . go + where + go (ExpectSequence e f) = ExpectSequence (go e) (go f) + go (ExpectInterleave e f) = ExpectInterleave (go e) (go f) + go (ExpectEither e f) + | satisfied e || satisfied f = ExpectNothing + | otherwise = ExpectEither (go e) (go f) + go (ExpectMulti m e) + | meetsMultiplicity m 0 = ExpectNothing + | otherwise = ExpectMulti m (go e) + go (ExpectConsecutive m e) + | meetsMultiplicity m 0 = ExpectNothing + | otherwise = ExpectConsecutive m (go e) + go other = other diff --git a/test/Test/HMock/Internal/Rule.hs b/test/Test/HMock/Internal/Rule.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/Rule.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- | Internal module to define 'Rule', so that its constructor can be visible +-- to other implementation code. +module Test.HMock.Internal.Rule where + +import Data.Kind (Constraint, Type) +import GHC.TypeLits (Symbol) +import {-# SOURCE #-} Test.HMock.Internal.State (MockT) +import Test.HMock.Mockable (MockableBase (..)) + +-- | A way to match an entire action, using conditions that might depend on the +-- relationship between arguments. +data WholeMethodMatcher cls name m r where + JustMatcher :: Matcher cls name m r -> WholeMethodMatcher cls name m r + SuchThat :: + Matcher cls name m r -> + (Action cls name m r -> Bool) -> + WholeMethodMatcher cls name m r + +-- | Displays a WholeMethodMatcher. The predicate isn't showable, but we can at +-- least indicate whether there is one present. +showWholeMatcher :: + MockableBase cls => + Maybe (Action cls name m a) -> + WholeMethodMatcher cls name m b -> + String +showWholeMatcher a (JustMatcher m) = showMatcher a m +showWholeMatcher a (m `SuchThat` _) = + showMatcher a m ++ " (with whole method matcher)" + +-- | A rule for matching a method and responding to it when it matches. +-- +-- The method may be matched by providing either an 'Action' to match exactly, +-- or a 'Matcher'. Exact matching is only available when all method arguments +-- +-- A 'Rule' may have zero or more responses, which are attached using +-- 'Test.HMock.Rule.|->' and 'Test.HMock.Rule.|=>'. If there are no responses +-- for a 'Rule', then there must be a default response for that action, and it +-- is used. If more than one response is added, the rule will perform the +-- responses in order, repeating the last response if there are additional +-- matches. +-- +-- Example: +-- +-- @ +-- 'Test.HMock.ExpectContext.expect' $ +-- GetLine_ 'Test.HMock.anything' +-- 'Test.HMock.Rule.|->' "hello" +-- 'Test.HMock.Rule.|=>' \(GetLine prompt) -> "The prompt was " ++ prompt +-- 'Test.HMock.Rule.|->' "quit" +-- @ +data + Rule + (cls :: (Type -> Type) -> Constraint) + (name :: Symbol) + (m :: Type -> Type) + (r :: Type) + where + (:=>) :: + WholeMethodMatcher cls name m r -> + [Action cls name m r -> MockT m r] -> + Rule cls name m r diff --git a/test/Test/HMock/Internal/State.hs b/test/Test/HMock/Internal/State.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/State.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE KindSignatures #-} + +-- | This module contains MockT and SetupMockT state functions. +module Test.HMock.Internal.State where + +import Control.Monad (forM_, unless, (<=<)) +import Control.Monad.Base (MonadBase) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Except (MonadError) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.RWS (MonadRWS) +import Control.Monad.Reader (MonadReader (..), ReaderT, mapReaderT, runReaderT) +import Control.Monad.State (MonadState) +import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad.Writer (MonadWriter) +import Data.Proxy (Proxy (Proxy)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (TypeRep, Typeable, typeRep) +import GHC.Stack (withFrozenCallStack, HasCallStack) +import GHC.TypeLits (KnownSymbol, symbolVal) +import System.IO (hPutStrLn, stderr) +import Test.HMock.ExpectContext (ExpectContext (..)) +import Test.HMock.Internal.ExpectSet (ExpectSet (..), getSteps) +import Test.HMock.Internal.Step (SingleRule, Step (..), unwrapExpected) +import Test.HMock.Internal.Util (Located) +import Test.HMock.Mockable (Mockable (..)) +import UnliftIO + ( MonadIO, + MonadUnliftIO(withRunInIO), + STM, + TVar, + atomically, + modifyTVar, + newTVarIO, + readTVar, + readTVarIO, + ) +import Data.Kind (Type, Constraint) + +#if !MIN_VERSION_base(4, 13, 0) +import Control.Monad.Fail (MonadFail) +#endif + +-- | The severity for a possible problem. +data Severity + = -- | Fail the test. + Error + | -- | Print a message, but continue the test. + Warning + | -- | Don't do anything. + Ignore + +-- | Full state of a mock. +data MockState m = MockState + { mockExpectSet :: TVar (ExpectSet (Step m)), + mockDefaults :: TVar [Step m], + mockAllowUnexpected :: TVar [Step m], + mockSideEffects :: TVar [Step m], + mockAmbiguitySeverity :: TVar Severity, + mockUnexpectedSeverity :: TVar Severity, + mockUninterestingSeverity :: TVar Severity, + mockUnmetSeverity :: TVar Severity, + mockClasses :: TVar (Set TypeRep), + mockInterestingMethods :: TVar (Set (TypeRep, String)), + mockParent :: Maybe (MockState m) + } + +-- | Initializes a new 'MockState' with the given parent. If the parent is +-- 'Nothing', then a new root state is made. +initMockState :: MonadIO m => Maybe (MockState m) -> m (MockState m) +initMockState parent = + MockState + <$> newTVarIO ExpectNothing + <*> newTVarIO [] + <*> newTVarIO [] + <*> newTVarIO [] + <*> maybeM + (newTVarIO Ignore) + (newTVarIO <=< readTVarIO . mockAmbiguitySeverity) + (return parent) + <*> maybeM + (newTVarIO Error) + (newTVarIO <=< readTVarIO . mockUnexpectedSeverity) + (return parent) + <*> maybeM + (newTVarIO Error) + (newTVarIO <=< readTVarIO . mockUninterestingSeverity) + (return parent) + <*> maybeM + (newTVarIO Error) + (newTVarIO <=< readTVarIO . mockUnmetSeverity) + (return parent) + <*> maybe (newTVarIO Set.empty) (return . mockClasses) parent + <*> maybe (newTVarIO Set.empty) (return . mockInterestingMethods) parent + <*> pure parent + +-- | Gets a list of all states, starting with the innermost. +allStates :: MockState m -> [MockState m] +allStates s + | Just s' <- mockParent s = s : allStates s' + | otherwise = [s] + +-- | Gets the root state. +rootState :: MockState m -> MockState m +rootState = last . allStates + +-- | Monad for setting up a mockable class. Note that even though the type +-- looks that way, this is *not* a monad transformer. It's a very restricted +-- environment that can only be used to set up defaults for a class. +newtype MockSetup m a where + MockSetup :: {unMockSetup :: ReaderT (MockState m) STM a} -> MockSetup m a + deriving (Functor, Applicative, Monad) + +-- | Runs a setup action with the root state, rather than the current one. +runInRootState :: MockSetup m a -> MockSetup m a +runInRootState = MockSetup . local rootState . unMockSetup + +-- | Run an STM action in 'MockSetup' +mockSetupSTM :: STM a -> MockSetup m a +mockSetupSTM m = MockSetup (lift m) + +-- | Runs class initialization for a 'Mockable' class, if it hasn't been run +-- yet. +initClassIfNeeded :: + forall cls m proxy. + (Mockable cls, Typeable m, MonadIO m) => + proxy cls -> + MockSetup m () +initClassIfNeeded proxy = runInRootState $ do + state <- MockSetup ask + classes <- mockSetupSTM $ readTVar (mockClasses state) + unless (Set.member t classes) $ do + mockSetupSTM $ modifyTVar (mockClasses state) (Set.insert t) + setupMockable (Proxy :: Proxy cls) + where + t = typeRep proxy + +-- | Marks a method as "interesting". This can have implications for what +-- happens to calls to that method. +markInteresting :: + forall (cls :: (Type -> Type) -> Constraint) name m proxy1 proxy2. + (Typeable cls, KnownSymbol name) => + proxy1 cls -> + proxy2 name -> + MockSetup m () +markInteresting proxyCls proxyName = runInRootState $ do + state <- MockSetup ask + mockSetupSTM $ + modifyTVar + (mockInterestingMethods state) + (Set.insert (typeRep proxyCls, symbolVal proxyName)) + +-- | Determines whether a method is "interesting". +isInteresting :: + forall (cls :: (Type -> Type) -> Constraint) name m proxy1 proxy2. + (Typeable cls, KnownSymbol name) => + proxy1 cls -> + proxy2 name -> + MockSetup m Bool +isInteresting proxyCls proxyName = runInRootState $ do + state <- MockSetup ask + interesting <- mockSetupSTM $ readTVar (mockInterestingMethods state) + return ((typeRep proxyCls, symbolVal proxyName) `Set.member` interesting) + +-- | Runs class initialization for all uninitialized 'Mockable' classes in the +-- given 'ExpectSet'. +initClassesAsNeeded :: MonadIO m => ExpectSet (Step m) -> MockSetup m () +initClassesAsNeeded es = runInRootState $ + forM_ (getSteps es) $ + \(Step (_ :: Located (SingleRule cls name m r))) -> do + initClassIfNeeded (Proxy :: Proxy cls) + markInteresting (Proxy :: Proxy cls) (Proxy :: Proxy name) + +-- | Monad transformer for running mocks. +newtype MockT m a where + MockT :: {unMockT :: ReaderT (MockState m) m a} -> MockT m a + deriving + ( Functor, + Applicative, + Monad, + MonadFail, + MonadIO, + MonadState s, + MonadWriter w, + MonadRWS r w s, + MonadError e, + MonadCont, + MonadBase b, + MonadCatch, + MonadMask, + MonadThrow + ) + +instance MonadTrans MockT where + lift = MockT . lift + +-- Note: The 'MonadUnliftIO' instance is implemented manually because deriving +-- it causes compilation failure in GHC 8.6 and 8.8. (See issue #23.) +instance MonadUnliftIO m => MonadUnliftIO (MockT m) where + withRunInIO inner = MockT $ withRunInIO $ \run -> inner (run . unMockT) + +-- | Applies a function to the base monad of 'MockT'. +mapMockT :: (m a -> m b) -> MockT m a -> MockT m b +mapMockT f = MockT . mapReaderT f . unMockT + +instance MonadReader r m => MonadReader r (MockT m) where + ask = lift ask + local = mapMockT . local + reader = lift . reader + +-- | This type class defines a shared API between the 'MockT' and 'MockSetup' +-- monads. +class MockContext ctx where + -- | Runs a 'MockSetup' action in this monad. + fromMockSetup :: MonadIO m => MockSetup m a -> ctx m a + +instance MockContext MockSetup where + fromMockSetup = id + +instance MockContext MockT where + fromMockSetup m = do + state <- MockT ask + atomically $ runReaderT (unMockSetup m) state + +-- | Adds an expectation to the 'MockState' for the given 'ExpectSet', +-- interleaved with any existing expectations. +expectThisSet :: MonadIO m => ExpectSet (Step m) -> MockSetup m () +expectThisSet e = do + initClassesAsNeeded e + state <- MockSetup ask + mockSetupSTM $ modifyTVar (mockExpectSet state) (e `ExpectInterleave`) + +-- | This instance allows you to add expectations from 'MockSetup' actions. +-- This is an unusual thing to do. Consider using +-- 'Test.HMock.MockT.allowUnexpected', instead. +instance ExpectContext MockSetup where + expect e = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ expect e + expectN mult e = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectN mult e + expectAny e = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ expectAny e + inSequence es = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ inSequence es + inAnyOrder es = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ inAnyOrder es + anyOf es = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ anyOf es + times mult es = + withFrozenCallStack $ expectThisSet $ unwrapExpected $ times mult es + consecutiveTimes mult es = + withFrozenCallStack $ + expectThisSet $ unwrapExpected $ consecutiveTimes mult es + +instance ExpectContext MockT where + expect e = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ expect e + expectN mult e = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ expectN mult e + expectAny e = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ expectAny e + inSequence es = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ inSequence es + inAnyOrder es = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ inAnyOrder es + anyOf es = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ anyOf es + times mult es = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ times mult es + consecutiveTimes mult es = + withFrozenCallStack $ + fromMockSetup $ expectThisSet $ unwrapExpected $ consecutiveTimes mult es + +-- | Reports a potential problem with the given 'Severity'. +reportFault :: (HasCallStack, MonadIO m) => Severity -> String -> MockT m () +reportFault severity msg = case severity of + Ignore -> return () + Warning -> liftIO $ hPutStrLn stderr msg + Error -> error msg diff --git a/test/Test/HMock/Internal/State.hs-boot b/test/Test/HMock/Internal/State.hs-boot new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/State.hs-boot @@ -0,0 +1,18 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} + +module Test.HMock.Internal.State where + +import Data.Kind (Type) + +type role MockT nominal nominal + +data MockT (m :: Type -> Type) (a :: Type) + +instance Monad m => Monad (MockT m) + +type role MockSetup nominal nominal + +data MockSetup (m :: Type -> Type) (a :: Type) + +instance Monad (MockSetup m) diff --git a/test/Test/HMock/Internal/Step.hs b/test/Test/HMock/Internal/Step.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/Step.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- | This module defines the desugaring from multi-response 'Rule's into +-- multiple steps. +module Test.HMock.Internal.Step where + +import Data.Kind (Constraint, Type) +import Data.Maybe (listToMaybe) +import GHC.Stack (CallStack, callStack) +import GHC.TypeLits (Symbol) +import Test.HMock.ExpectContext (ExpectContext (..), MockableMethod) +import Test.HMock.Internal.ExpectSet (ExpectSet (..)) +import Test.HMock.Internal.Rule + ( Rule (..), + WholeMethodMatcher (..), + showWholeMatcher, + ) +import {-# SOURCE #-} Test.HMock.Internal.State (MockT) +import Test.HMock.Internal.Util (Located (..), locate, withLoc) +import Test.HMock.Mockable (MockableBase (..)) +import Test.HMock.Multiplicity + ( Multiplicity, + anyMultiplicity, + feasible, + meetsMultiplicity, + ) +import Test.HMock.Rule (Expectable (toRule)) + +-- | A Rule that contains only a single response. This is the target for +-- desugaring the multi-response rule format. +data + SingleRule + (cls :: (Type -> Type) -> Constraint) + (name :: Symbol) + (m :: Type -> Type) + (r :: Type) + where + (:->) :: + WholeMethodMatcher cls name m r -> + Maybe (Action cls name m r -> MockT m r) -> + SingleRule cls name m r + +-- | A single step of an expectation. +data Step m where + Step :: + MockableMethod cls name m r => + Located (SingleRule cls name m r) -> + Step m + +instance Show (Step m) where + show (Step l@(Loc _ (m :-> _))) = + withLoc (showWholeMatcher Nothing m <$ l) + +-- | Expands a Rule into an expectation. The expected multiplicity will be one +-- if there are no responses; otherwise one call is expected per response. +expandRule :: + MockableMethod cls name m r => + CallStack -> + Rule cls name m r -> + ExpectSet (Step m) +expandRule callstack (m :=> []) = + ExpectStep (Step (locate callstack (m :-> Nothing))) +expandRule callstack (m :=> rs) = + foldr1 + ExpectSequence + (map (ExpectStep . Step . locate callstack . (m :->) . Just) rs) + +-- | Expands a Rule into an expectation, given a target multiplicity. It is an +-- error if there are too many responses for the multiplicity. If there are +-- too few responses, the last response will be repeated. +expandRepeatRule :: + MockableMethod cls name m r => + Multiplicity -> + CallStack -> + Rule cls name m r -> + ExpectSet (Step m) +expandRepeatRule mult _ (_ :=> rs) + | not (feasible (mult - fromIntegral (length rs))) = + error $ + show (length rs) + ++ " responses is too many for multiplicity " + ++ show mult +expandRepeatRule mult callstack (m :=> (r1 : r2 : rs)) + | meetsMultiplicity mult 0 = ExpectEither ExpectNothing body + | otherwise = body + where + body = + ExpectSequence + (ExpectStep (Step (locate callstack (m :-> Just r1)))) + (expandRepeatRule (mult - 1) callstack (m :=> (r2 : rs))) +expandRepeatRule mult callstack (m :=> rs) = + ExpectConsecutive + mult + (ExpectStep (Step (locate callstack (m :-> listToMaybe rs)))) + +-- | Newtype wrapper to make the type of ExpectSet conform to the ExpectContext +-- class. The "return type" a is a phantom. +newtype Expected m a = Expected {unwrapExpected :: ExpectSet (Step m)} + +instance ExpectContext Expected where + expect e = Expected (expandRule callStack (toRule e)) + expectN mult e = Expected (expandRepeatRule mult callStack (toRule e)) + expectAny e = + Expected (expandRepeatRule anyMultiplicity callStack (toRule e)) + inSequence es = Expected (foldr1 ExpectSequence (map unwrapExpected es)) + inAnyOrder es = Expected (foldr1 ExpectInterleave (map unwrapExpected es)) + anyOf es = Expected (foldr1 ExpectEither (map unwrapExpected es)) + times mult e = Expected (ExpectMulti mult (unwrapExpected e)) + consecutiveTimes mult e = + Expected (ExpectConsecutive mult (unwrapExpected e)) diff --git a/test/Test/HMock/Internal/TH.hs b/test/Test/HMock/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/TH.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- | Template Haskell utilities used to implement HMock. +module Test.HMock.Internal.TH + ( unappliedName, + tvName, + bindVar, + substTypeVar, + substTypeVars, + splitType, + freeTypeVars, + relevantContext, + constrainVars, + unifyTypes, + removeModNames, + hasPolyType, + hasNestedPolyType, + resolveInstance, + resolveInstanceType, + simplifyContext, + localizeMember, + ) +where + +import Control.Monad.Extra (mapMaybeM, concatMapM) +import Data.Generics +import Data.List ((\\), nub) +import Data.Maybe (catMaybes, fromMaybe) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (NameFlavour (..)) +import Test.HMock.Internal.Util (choices) + +#if MIN_VERSION_template_haskell(2,17,0) + +-- | Fetches the 'Name' of a 'TyVarBndr'. +tvName :: TyVarBndr flag -> Name +tvName (PlainTV name _) = name +tvName (KindedTV name _ _) = name + +-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation. +bindVar :: Name -> TyVarBndr Specificity +bindVar n = PlainTV n SpecifiedSpec + +#else + +-- | Fetches the 'Name' of a 'TyVarBndr'. +tvName :: TyVarBndr -> Name +tvName (PlainTV name) = name +tvName (KindedTV name _) = name + +-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation. +bindVar :: Name -> TyVarBndr +bindVar = PlainTV + +#endif + +-- | Gets the unapplied top-level name from a type application. +unappliedName :: Type -> Maybe Name +unappliedName (AppT a _) = unappliedName a +unappliedName (ConT a) = Just a +unappliedName _ = Nothing + +-- | Substitutes a 'Type' for all occurrences of the given 'Name'. +substTypeVar :: Name -> Type -> Type -> Type +substTypeVar n t = substTypeVars [(n, t)] + +-- | Makes variable substitutions from the given table. +substTypeVars :: [(Name, Type)] -> Type -> Type +substTypeVars classVars = everywhere (mkT subst) + where + subst (VarT x) | Just t <- lookup x classVars = t + subst t = t + +-- | Splits a type application into a top-level constructor and a list of its +-- type arguments. +splitTypeApp :: Type -> Maybe (Name, [Type]) +splitTypeApp (ConT name) = Just (name, []) +splitTypeApp (AppT a b) = fmap (++ [b]) <$> splitTypeApp a +splitTypeApp _ = Nothing + +-- | Splits a function type into a list of bound type vars, context, parameter +-- types, and return value type. +splitType :: Type -> ([Name], Cxt, [Type], Type) +splitType (ForallT tv cx b) = + let (tvs, cxs, params, retval) = splitType b + in (map tvName tv ++ tvs, cx ++ cxs, params, retval) +splitType (AppT (AppT ArrowT a) b) = + let (tvs, cx, params, retval) = splitType b in (tvs, cx, a : params, retval) +splitType r = ([], [], [], r) + +-- | Gets all free type variable 'Name's in the given 'Type'. +freeTypeVars :: Type -> [Name] +freeTypeVars = everythingWithContext [] (++) (mkQ ([],) go) + where + go (VarT v) bound + | v `elem` bound = ([], bound) + | otherwise = ([v], bound) + go (ForallT vs _ _) bound = ([], map tvName vs ++ bound) + go _ bound = ([], bound) + +-- | Produces a 'CxtQ' that gives all given variable 'Name's all of the given +-- class 'Type's. +constrainVars :: [TypeQ] -> [Name] -> CxtQ +constrainVars cs vs = sequence [appT c (varT v) | c <- cs, v <- vs] + +-- | Culls the given binders and constraints to choose only those that apply to +-- free variables in the given type. +relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt) +relevantContext ty (tvs, cx) = (filter needsTv tvs, filteredCx) + where + filteredCx = filter (any (`elem` freeTypeVars ty) . freeTypeVars) cx + needsTv v = any ((v `elem`) . freeTypeVars) (ty : filteredCx) + +-- | Attempts to unify the given types by constructing a table of substitutions +-- for the variables of the left type that obtain the right one. +unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)]) +unifyTypes = unifyTypesWith [] + +-- | Unify types, but starting with a table of substitutions. +unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)]) +unifyTypesWith tbl (VarT v) t2 + | Just t1 <- lookup v tbl = unifyTypesWith tbl t1 t2 + | otherwise = return (Just ((v, t2) : tbl)) +unifyTypesWith tbl (ConT a) (ConT b) | a == b = return (Just tbl) +unifyTypesWith tbl a b = do + mbA <- replaceSyn a + mbB <- replaceSyn b + case (mbA, mbB) of + (Nothing, Nothing) -> unifyWithin tbl a b + _ -> unifyTypesWith tbl (fromMaybe a mbA) (fromMaybe b mbB) + where + replaceSyn :: Type -> Q (Maybe Type) + replaceSyn (ConT n) = do + info <- reify n + case info of + TyConI (TySynD _ [] t) -> return (Just t) + _ -> return Nothing + replaceSyn _ = return Nothing + +-- Unifies the types that occur within the arguments, starting with a table of +-- substitutions. +unifyWithin :: + (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)]) +unifyWithin tbl a b + | toConstr a == toConstr b = + compose (gzipWithQ (\a' b' tbl' -> unify tbl' a' b') a b) tbl + | otherwise = return Nothing + where + unify :: + (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)]) + unify tbl' a' b' = do + case (cast a', cast b') of + (Just a'', Just b'') -> unifyTypesWith tbl' a'' b'' + _ -> unifyWithin tbl' a' b' + + compose :: Monad m => [t -> m (Maybe t)] -> t -> m (Maybe t) + compose [] x = return (Just x) + compose (f : fs) x = do + y <- f x + case y of + Just y' -> compose fs y' + _ -> return Nothing + +-- | Removes all module names from 'Name's in the given value, so that it will +-- pretty-print more cleanly. +removeModNames :: Data a => a -> a +removeModNames = everywhere (mkT unMod) + where + unMod NameG {} = NameS + unMod other = other + +-- | Determines if there is a polytype nested anywhere in the given type. +-- Top-level quantification doesn't count. +hasNestedPolyType :: Type -> Bool +hasNestedPolyType (ForallT _ _ t) = hasPolyType t +hasNestedPolyType t = hasPolyType t + +-- | Determines if this is a polytype, including top-level quantification. +hasPolyType :: Type -> Bool +hasPolyType = everything (||) (mkQ False isPolyType) + where + isPolyType (ForallT tvs _ _) = not (null tvs) + isPolyType _ = False + +-- | Attempts to produce sufficient constraints for the given 'Type' to be an +-- instance of the given class 'Name'. +resolveInstance :: Name -> [Type] -> Q (Maybe Cxt) +resolveInstance cls args = do + decs <- reifyInstances cls args + results <- catMaybes <$> traverse (tryInstance args) decs + case results of + [cx] -> pure (Just cx) + _ -> return Nothing + where + tryInstance :: [Type] -> InstanceDec -> Q (Maybe Cxt) + tryInstance actualArgs (InstanceD _ cx instType _) = + case splitTypeApp instType of + Just (cls', instArgs) + | cls' == cls -> + unifyWithin [] instArgs actualArgs >>= \case + Just tbl -> simplifyContext (substTypeVars tbl <$> cx) + Nothing -> return Nothing + _ -> return Nothing + tryInstance _ _ = return Nothing + +-- | Attempts to produce sufficient constraints for the given 'Type' to be a +-- satisfied constraint. The type should be a class applied to its type +-- parameters. +-- +-- Unlike 'simplifyContext', this function always resolves the top-level +-- constraint, and returns 'Nothing' if it cannot do so. +resolveInstanceType :: Type -> Q (Maybe Cxt) +resolveInstanceType t = + maybe (pure Nothing) (uncurry resolveInstance) (splitTypeApp t) + +-- | Simplifies a context with complex types (requiring FlexibleContexts) to try +-- to obtain one with all constraints applied to variables. +-- +-- Should return Nothing if and only if the simplified contraint is +-- unsatisfiable, which is the case if and only if it contains a component with +-- no type variables. +simplifyContext :: Cxt -> Q (Maybe Cxt) +simplifyContext preds + | all isVarApp preds = return (Just preds) + | otherwise = do + let simplifyPred t = fromMaybe [t] <$> resolveInstanceType t + components <- concatMapM simplifyPred preds + if any (null . freeTypeVars) components + then return Nothing + else return (Just (nub components)) + where + isVarApp (ConT _) = True + isVarApp (AppT t (VarT _)) | isVarApp t = True + isVarApp _ = False + +-- | Remove instance context from a method. +-- +-- Some GHC versions report class members including the instance context (for +-- example, @show :: Show a => a -> String@, instead of @show :: a -> String@). +-- This looks for the instance context, and substitutes if needed to eliminate +-- it. +localizeMember :: Type -> Name -> Type -> Q Type +localizeMember instTy m t@(ForallT tvs cx ty) = do + let fullConstraint = AppT instTy (VarT m) + let unifyLeft (c, cs) = fmap (,cs) <$> unifyTypes c fullConstraint + results <- mapMaybeM unifyLeft (choices cx) + case results of + ((tbl, remainingCx) : _) -> do + let cx' = substTypeVars tbl <$> remainingCx + ty' = substTypeVars tbl ty + (tvs', cx'') = + relevantContext + ty' + ((tvName <$> tvs) \\ (fst <$> tbl), cx') + t' + | null tvs' && null cx'' = ty' + | otherwise = ForallT (bindVar <$> tvs') cx'' ty' + return t' + _ -> return t +localizeMember _ _ t = return t diff --git a/test/Test/HMock/Internal/Util.hs b/test/Test/HMock/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Internal/Util.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Internal utilities used for HMock implementation. +module Test.HMock.Internal.Util where + +import GHC.Stack (CallStack, getCallStack, prettySrcLoc) + +-- | A value together with its source location. +data Located a = Loc (Maybe String) a deriving (Functor) + +-- | Annotates a value with its source location from the call stack. +locate :: CallStack -> a -> Located a +locate stack = case map snd (getCallStack stack) of + (loc : _) -> Loc (Just (prettySrcLoc loc)) + _ -> Loc Nothing + +-- | Formats a 'Located' 'String' to include its source location. +withLoc :: Located String -> String +withLoc (Loc Nothing s) = s +withLoc (Loc (Just loc) s) = s ++ " at " ++ loc + +-- | Returns all ways to choose one element from a list, and the corresponding +-- remaining list. +choices :: [a] -> [(a, [a])] +choices [] = [] +choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs) diff --git a/test/Test/HMock/MockMethod.hs b/test/Test/HMock/MockMethod.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/MockMethod.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Functions to delegate 'Action's to HMock to match expectations. There is +-- one delegation function that works if the return type has a 'Default' +-- instance, and another that doesn't require the 'Default' instance, but causes +-- the method to return 'undefined' by default. +module Test.HMock.MockMethod + ( mockMethod, + mockDefaultlessMethod, + ) +where + +import Control.Concurrent.STM (TVar, readTVar, writeTVar) +import Control.Monad (forM, forM_, join, unless, void) +import Control.Monad.Extra (concatMapM) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ask) +import Data.Bifunctor (bimap) +import Data.Default (Default (def)) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.Functor (($>)) +import Data.List (intercalate, sortBy) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (cast) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Test.HMock.ExpectContext (MockableMethod) +import Test.HMock.Internal.ExpectSet (ExpectSet, liveSteps) +import Test.HMock.Internal.Rule (WholeMethodMatcher (..), showWholeMatcher) +import Test.HMock.Internal.State + ( MockContext (..), + MockSetup (..), + MockState (..), + MockT, + Severity (..), + allStates, + initClassIfNeeded, + isInteresting, + mockSetupSTM, + reportFault, + ) +import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step)) +import Test.HMock.Internal.Util (Located (Loc), withLoc) +import Test.HMock.MockT (describeExpectations) +import Test.HMock.Mockable + ( MatchResult (..), + Mockable (..), + MockableBase (..), + ) + +matchWholeAction :: + MockableBase cls => + WholeMethodMatcher cls name m a -> + Action cls name m a -> + MatchResult +matchWholeAction (JustMatcher m) a = matchAction m a +matchWholeAction (m `SuchThat` p) a = case matchAction m a of + NoMatch n -> NoMatch n + Match + | p a -> Match + | otherwise -> NoMatch [] + +-- | Implements mock delegation for actions. +mockMethodImpl :: + forall cls name m r. + (HasCallStack, MonadIO m, MockableMethod cls name m r) => + r -> + Action cls name m r -> + MockT m r +mockMethodImpl surrogate action = join $ + fromMockSetup $ do + initClassIfNeeded (Proxy :: Proxy cls) + states <- allStates <$> MockSetup ask + (partial, full) <- fmap (bimap concat concat . unzip) $ + forM states $ \state -> do + expectSet <- mockSetupSTM $ readTVar (mockExpectSet state) + return $ + partitionEithers + (tryMatch (mockExpectSet state) <$> liveSteps expectSet) + let orderedPartial = sortBy (compare `on` (length . fst)) (catMaybes partial) + defaults <- concatMapM (mockSetupSTM . readTVar . mockDefaults) states + unexpected <- + concatMapM + (mockSetupSTM . readTVar . mockAllowUnexpected) + states + sideEffect <- + getSideEffect + <$> concatMapM (mockSetupSTM . readTVar . mockSideEffects) states + ambigSev <- mockSetupSTM $ readTVar . mockAmbiguitySeverity . head $ states + unintSev <- + mockSetupSTM $ readTVar . mockUninterestingSeverity . head $ states + unexpSev <- mockSetupSTM $ readTVar . mockUnexpectedSeverity . head $ states + case ( full, + orderedPartial, + allowedUnexpected unexpected, + findDefault defaults + ) of + (opts@((_, choose, response) : rest), _, _, d) -> do + choose + return $ do + unless (null rest) $ + ambiguityError ambigSev action ((\(s, _, _) -> s) <$> opts) + sideEffect + fromMaybe d response + ([], _, Just response, d) -> return (sideEffect >> fromMaybe d response) + ([], [], _, d) -> do + interesting <- isInteresting (Proxy :: Proxy cls) (Proxy :: Proxy name) + case (interesting, unintSev) of + (True, _) -> return (noMatchError unexpSev action >> d) + (False, Error) -> return (noMatchError unexpSev action >> d) + _ -> return (uninterestingError unintSev action >> d) + ([], _, _, d) -> + return (partialMatchError unexpSev action orderedPartial >> d) + where + tryMatch :: + TVar (ExpectSet (Step m)) -> + (Step m, ExpectSet (Step m)) -> + Either + (Maybe ([(Int, String)], String)) + (String, MockSetup m (), Maybe (MockT m r)) + tryMatch tvar (Step expected, e) + | Just lrule@(Loc _ (m :-> impl)) <- cast expected = + case matchWholeAction m action of + NoMatch n -> + Left (Just (n, withLoc (showWholeMatcher (Just action) m <$ lrule))) + Match -> + Right + ( withLoc (lrule $> showWholeMatcher (Just action) m), + mockSetupSTM $ writeTVar tvar e, + ($ action) <$> impl + ) + | otherwise = Left Nothing + + allowedUnexpected :: [Step m] -> Maybe (Maybe (MockT m r)) + allowedUnexpected [] = Nothing + allowedUnexpected (Step unexpected : steps) + | Just (Loc _ (m :-> impl)) <- cast unexpected, + Match <- matchWholeAction m action = + Just (($ action) <$> impl) + | otherwise = allowedUnexpected steps + + findDefault :: [Step m] -> MockT m r + findDefault [] = return surrogate + findDefault (Step expected : steps) + | Just (Loc _ (m :-> impl)) <- cast expected, + Match <- matchWholeAction m action = + maybe (findDefault steps) ($ action) impl + | otherwise = findDefault steps + + getSideEffect :: [Step m] -> MockT m () + getSideEffect effects = + forM_ effects $ \(Step expected) -> case cast expected of + Just (Loc _ (m :-> Just impl)) + | Match <- matchWholeAction m action -> void (impl action) + _ -> return () + +-- | Implements a method in a 'Mockable' monad by delegating to the mock +-- framework. If the method is called unexpectedly, an exception will be +-- thrown. However, an expected invocation without a specified response will +-- return the default value. +mockMethod :: + ( HasCallStack, + MonadIO m, + MockableMethod cls name m r, + Default r + ) => + Action cls name m r -> + MockT m r +mockMethod action = + withFrozenCallStack $ mockMethodImpl def action + +-- | Implements a method in a 'Mockable' monad by delegating to the mock +-- framework. If the method is called unexpectedly, an exception will be +-- thrown. However, an expected invocation without a specified response will +-- return undefined. This can be used in place of 'mockMethod' when the return +-- type has no default. +mockDefaultlessMethod :: + ( HasCallStack, + MonadIO m, + MockableMethod cls name m r + ) => + Action cls name m r -> + MockT m r +mockDefaultlessMethod action = + withFrozenCallStack $ mockMethodImpl undefined action + +-- | An error for an action that matches no expectations at all. This is only +-- used if severity is Ignore or Warning. +uninterestingError :: + (HasCallStack, Mockable cls, MonadIO m) => + Severity -> + Action cls name m r -> + MockT m () +uninterestingError severity a = + reportFault severity $ "Uninteresting action: " ++ showAction a + +-- | An error for an action that matches no expectations at all. +noMatchError :: + (HasCallStack, Mockable cls, MonadIO m) => + Severity -> + Action cls name m r -> + MockT m () +noMatchError severity a = do + fullExpectations <- describeExpectations + reportFault severity $ + "Unexpected action: " ++ showAction a + ++ "\n\nFull expectations:\n" + ++ fullExpectations + +-- | An error for an action that doesn't match the argument predicates for any +-- of the method's expectations. +partialMatchError :: + (HasCallStack, Mockable cls, MonadIO m) => + Severity -> + Action cls name m r -> + [([(Int, String)], String)] -> + MockT m () +partialMatchError severity a partials = do + fullExpectations <- describeExpectations + reportFault severity $ + "Wrong arguments: " + ++ showAction a + ++ "\n\nClosest matches:\n - " + ++ intercalate "\n - " (map formatPartial $ take 5 partials) + ++ "\n\nFull expectations:\n" + ++ fullExpectations + where + formatPartial :: ([(Int, String)], String) -> String + formatPartial (mismatches, matcher) + | null mismatches = matcher ++ "\n * Failed whole-method matcher" + | otherwise = + matcher ++ "\n * " + ++ intercalate + "\n * " + ( map + ( \(i, mm) -> + "Arg #" ++ show i ++ ": " ++ mm + ) + mismatches + ) + +-- | An error for an 'Action' that matches more than one 'Matcher'. This only +-- triggers an error if ambiguity checks are on. +ambiguityError :: + (HasCallStack, Mockable cls, MonadIO m) => + Severity -> + Action cls name m r -> + [String] -> + MockT m () +ambiguityError severity a choices = do + fullExpectations <- describeExpectations + reportFault severity $ + "Ambiguous action matched multiple expectations: " + ++ showAction a + ++ "\n\nMatches:\n - " + ++ intercalate "\n - " choices + ++ "\n\nFull expectations:\n" + ++ fullExpectations diff --git a/test/Test/HMock/MockT.hs b/test/Test/HMock/MockT.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/MockT.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module defines monads for working with mocks. HMock tests run in the +-- 'MockT' monad transformer. A more limited monad, 'MockSetup', is used for +-- setting up defaults for each class. Both are instances of the 'MockContext' +-- monad, which defines a shared API. +module Test.HMock.MockT + ( MockT, + runMockT, + withMockT, + nestMockT, + withNestedMockT, + Severity (..), + setAmbiguityCheck, + setUninterestingActionCheck, + setUnexpectedActionCheck, + setUnmetExpectationCheck, + describeExpectations, + verifyExpectations, + MockSetup, + MockContext, + allowUnexpected, + byDefault, + whenever, + ) +where + +import Control.Monad (join) +import Control.Monad.Reader + ( MonadReader (..), + runReaderT, + ) +import Control.Monad.Trans (lift) +import Data.List (intercalate) +import Data.Maybe (listToMaybe) +import Data.Proxy (Proxy (Proxy)) +import GHC.Stack (callStack) +import Test.HMock.ExpectContext (MockableMethod) +import Test.HMock.Internal.ExpectSet +import Test.HMock.Internal.Rule (Rule ((:=>))) +import Test.HMock.Internal.State +import Test.HMock.Internal.Step (SingleRule ((:->)), Step (Step)) +import Test.HMock.Internal.Util (locate) +import Test.HMock.Rule (Expectable (toRule)) +import UnliftIO + +-- | Runs a test in the 'MockT' monad, handling all of the mocks. +runMockT :: forall m a. MonadIO m => MockT m a -> m a +runMockT test = withMockT constTest + where + constTest :: (forall b. MockT m b -> m b) -> MockT m a + constTest _inMockT = test + +-- | Runs a test in the 'MockT' monad. The test can unlift other MockT pieces +-- to the base monad while still acting on the same set of expectations. This +-- can be useful for testing concurrency or similar mechanisms. +-- +-- @ +-- test = 'withMockT' '$' \inMockT -> do +-- 'Test.HMock.Expectable.expect' '$' ... +-- +-- 'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT firstThread +-- 'liftIO' '$' 'Control.Concurrent.forkIO' '$' inMockT secondThread +-- @ +-- +-- This is a low-level primitive. Consider using the @unliftio@ package for +-- higher level implementations of multithreading and other primitives. +withMockT :: + forall m b. MonadIO m => ((forall a. MockT m a -> m a) -> MockT m b) -> m b +withMockT test = do + state <- initMockState Nothing + let inMockT :: forall a. MockT m a -> m a + inMockT m = runReaderT (unMockT m) state + flip runReaderT state $ + unMockT $ do + a <- test inMockT + verifyExpectations + return a + +-- | Starts a nested block within 'MockT'. The nested block has its own set of +-- expectations, which must be fulfilled before the end of the block. +-- +-- Beware: use of 'nestMockT' might signify that you are doing too much in a +-- single test. Consider splitting large tests into a separate test for each +-- case. +nestMockT :: forall m a. MonadIO m => MockT m a -> MockT m a +nestMockT nest = withNestedMockT constNest + where + constNest :: (forall b. MockT m b -> m b) -> MockT m a + constNest _inMockT = nest + +-- | Starts a nested block within 'MockT'. The nested block has its own set of +-- expectations, which must be fulfilled before the end of the block. It can +-- unlift other MockT pieces to the base monad while still acting on the same +-- set of expectations. This can be useful for testing concurrency or similar +-- mechanisms. +-- +-- Beware: use of 'nestMockT' might signify that you are doing too much in a +-- single test. Consider splitting large tests into a separate test for each +-- case. +withNestedMockT :: + forall m b. + MonadIO m => + ((forall a. MockT m a -> m a) -> MockT m b) -> + MockT m b +withNestedMockT nest = do + parent <- MockT ask + state <- lift $ initMockState (Just parent) + withState state $ do + a <- nest (flip runReaderT state . unMockT) + verifyExpectations + return a + where + withState state = MockT . local (const state) . unMockT + +-- | Sets the severity for ambiguous actions. An ambiguous action is one that +-- matches expectations in more than one way. If this is not set to `Error`, +-- the most recently added expectation will take precedence. +-- +-- This defaults to 'Ignore'. +setAmbiguityCheck :: MonadIO m => Severity -> MockT m () +setAmbiguityCheck severity = fromMockSetup $ do + state <- MockSetup ask + mockSetupSTM $ writeTVar (mockAmbiguitySeverity state) severity + +-- | Sets the severity for uninteresting actions. An uninteresting action is +-- one for which no expectations or other configuration have been added that +-- mention the method at all. If this is not set to `Error`, then uninteresting +-- methods are treated just like unexpected methods. +-- +-- Before you weaken this check, consider that the labeling of methods as +-- "uninteresting" is non-compositional. A change in one part of your test can +-- result in a formerly uninteresting action being considered interesting in a +-- different part of the test. +-- +-- This defaults to 'Error'. +setUninterestingActionCheck :: MonadIO m => Severity -> MockT m () +setUninterestingActionCheck severity = fromMockSetup $ do + state <- MockSetup ask + mockSetupSTM $ writeTVar (mockUninterestingSeverity state) severity + +-- | Sets the severity for unexpected actions. An unexpected action is one that +-- doesn't match any expectations *and* isn't explicitly allowed by +-- `allowUnexpected`. If this is not set to `Error`, the action returns its +-- default response. +-- +-- This defaults to 'Error'. +setUnexpectedActionCheck :: MonadIO m => Severity -> MockT m () +setUnexpectedActionCheck severity = fromMockSetup $ do + state <- MockSetup ask + mockSetupSTM $ writeTVar (mockUnexpectedSeverity state) severity + +-- | Sets the severity for unmet expectations. An unmet expectation happens +-- when an expectation is added, but either the test (or nesting level) ends or +-- 'verifyExpectations' is used before a matching action takes place. +-- +-- This defaults to 'Error'. +setUnmetExpectationCheck :: MonadIO m => Severity -> MockT m () +setUnmetExpectationCheck severity = fromMockSetup $ do + state <- MockSetup ask + mockSetupSTM $ writeTVar (mockUnmetSeverity state) severity + +-- | Fetches a 'String' that describes the current set of outstanding +-- expectations. This is sometimes useful for debugging test code. The exact +-- format is not specified. +describeExpectations :: MonadIO m => MockT m String +describeExpectations = fromMockSetup $ do + states <- allStates <$> MockSetup ask + expectSets <- mapM (mockSetupSTM . readTVar . mockExpectSet) states + return $ + intercalate "\n----- (next layer) -----\n" $ + formatExpectSet <$> expectSets + +-- | Verifies that all mock expectations are satisfied. If there is a nested +-- block in effect, only the expectations of that nested block are verified +-- You normally don't need to do this, because it happens automatically at the +-- end of your test or nested block. However, it's occasionally useful to check +-- expectations early. +-- +-- Beware: use of 'verifyExpectations' might signify that you are doing too much +-- in a single test. Consider splitting large tests into a separate test for +-- each case. +verifyExpectations :: MonadIO m => MockT m () +verifyExpectations = join $ do + fromMockSetup $ do + states <- MockSetup ask + expectSet <- mockSetupSTM $ readTVar $ mockExpectSet states + missingSev <- mockSetupSTM $ readTVar $ mockUnmetSeverity states + case excess expectSet of + ExpectNothing -> return (return ()) + missing -> + return $ + reportFault missingSev $ + "Unmet expectations:\n" ++ formatExpectSet missing + +-- | Adds a handler for unexpected actions. Matching calls will not fail, but +-- will use a default response instead. The rule passed in must have zero or +-- one responses: if there is a response, @'allowUnexpected' (m +-- 'Test.HMock.Rule.|=>' r)@ is equivalent to @'allowUnexpected' m >> +-- 'byDefault' (m 'Test.HMock.Rule.|=>' r)@. +-- +-- The difference between 'Test.HMock.Expectable.expectAny' and +-- 'allowUnexpected' is subtle, but comes down to ambiguity: +-- +-- * 'allowUnexpected' is not an expectation, so it cannot be ambiguous. It +-- only has an effect if no true expectation matches, regardless of when the +-- expectations were added. +-- * 'Test.HMock.Expectable.expectAny' adds an expectation, so if another +-- expectation is in effect at the same time, a call to the method is +-- ambiguous. If ambiguity checking is enabled, the method will throw an +-- error; otherwise, the more recently added of the two expectations is used. +allowUnexpected :: + forall cls name m r rule ctx. + ( MonadIO m, + MockableMethod cls name m r, + Expectable cls name m r rule, + MockContext ctx + ) => + rule -> + ctx m () +allowUnexpected e = fromMockSetup $ case toRule e of + _ :=> (_ : _ : _) -> error "allowUnexpected may not have multiple responses." + m :=> r -> do + initClassIfNeeded (Proxy :: Proxy cls) + state <- MockSetup ask + mockSetupSTM $ + modifyTVar' + (mockAllowUnexpected state) + (Step (locate callStack (m :-> listToMaybe r)) :) + +-- | Sets a default action for *expected* matching calls. The new default only +-- applies to calls for which an expectation exists, but it lacks an explicit +-- response. The rule passed in must have exactly one response. +byDefault :: + forall cls name m r ctx. + ( MonadIO m, + MockableMethod cls name m r, + MockContext ctx + ) => + Rule cls name m r -> + ctx m () +byDefault (m :=> [r]) = fromMockSetup $ do + initClassIfNeeded (Proxy :: Proxy cls) + state <- MockSetup ask + mockSetupSTM $ + modifyTVar' + (mockDefaults state) + (Step (locate callStack (m :-> Just r)) :) +byDefault _ = error "Defaults must have exactly one response." + +-- | Adds a side-effect, which happens whenever a matching call occurs, in +-- addition to the usual response. The return value is entirely ignored. +-- +-- Be warned: using side effects makes it easy to break abstraction boundaries. +-- Be aware that there may be other uses of a method besides the one which you +-- intend to intercept here. If possible, add the desired behavior to the +-- response for the matching expectation instead. +whenever :: + forall cls name m r ctx. + ( MonadIO m, + MockableMethod cls name m r, + MockContext ctx + ) => + Rule cls name m r -> + ctx m () +whenever (m :=> [r]) = fromMockSetup $ do + initClassIfNeeded (Proxy :: Proxy cls) + state <- MockSetup ask + mockSetupSTM $ + modifyTVar' + (mockSideEffects state) + (Step (locate callStack (m :-> Just r)) :) +whenever _ = error "Side effects must have exactly one response." diff --git a/test/Test/HMock/Mockable.hs b/test/Test/HMock/Mockable.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Mockable.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module defines the 'MockableBase' and 'Mockable' classes that are +-- needed to use an MTL-style type class with 'Test.HMock.MockT.MockT'. You +-- will typically derive 'MockableBase' with Template Haskell, since it's mostly +-- boilerplate. The 'Mockable' class adds a customizable setup method which you +-- can define yourself to add the right defaults for methods in the mocked +-- class. +module Test.HMock.Mockable + ( Mockable (..), + MockableBase (..), + MatchResult (..), + ) +where + +import Control.Monad.Trans (MonadIO) +import Data.Kind (Constraint, Type) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) +import {-# SOURCE #-} Test.HMock.Internal.State (MockSetup) + +-- | The result of matching a @'Matcher' a@ with an @'Action' b@. Because the +-- types should already guarantee that the methods match, all that's left is to +-- match arguments. +data MatchResult where + -- | No match. The 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 new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Multiplicity.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module provides the basic vocabulary for talking about multiplicity, +-- which is the number of times something is allowed to happen. Multiplicities +-- can be any range of natural numbers, with or without an upper bound. +module Test.HMock.Multiplicity + ( Multiplicity, + meetsMultiplicity, + feasible, + once, + anyMultiplicity, + atLeast, + atMost, + between, + ) +where + +-- | An acceptable range of number of times for something to happen. +-- +-- A multiplicity can have a lower and an upper bound. +data Multiplicity = Multiplicity Int (Maybe Int) deriving (Eq) + +instance Show Multiplicity where + show mult = go (normalize mult) + where + go m | not (feasible m) = "infeasible" + go (Multiplicity 0 (Just 0)) = "never" + go (Multiplicity 1 (Just 1)) = "once" + go (Multiplicity 2 (Just 2)) = "twice" + go (Multiplicity 0 Nothing) = "any number of times" + go (Multiplicity 1 Nothing) = "at least once" + go (Multiplicity 2 Nothing) = "at least twice" + go (Multiplicity n Nothing) = "at least " ++ show n ++ " times" + go (Multiplicity 0 (Just 1)) = "at most once" + go (Multiplicity 0 (Just 2)) = "at most twice" + go (Multiplicity 0 (Just n)) = "at most " ++ show n ++ " times" + go (Multiplicity m (Just n)) + | m == n = show n ++ " times" + | m == n - 1 = show m ++ " or " ++ show n ++ " times" + | otherwise = show m ++ " to " ++ show n ++ " times" + +-- | A 'Multiplicity' value representing inconsistent expectations. +infeasible :: Multiplicity +infeasible = Multiplicity 0 (Just (-1)) + +-- | This is an incomplete instance, provided for convenience. +-- +-- >>> meetsMultiplicity 5 4 +-- False +-- >>> meetsMultiplicity 5 5 +-- True +-- >>> between 4 6 - between 1 2 +-- 2 to 5 times +instance Num Multiplicity where + fromInteger n + | n < 0 = infeasible + | otherwise = + normalize $ + Multiplicity (fromInteger n) (Just (fromInteger n)) + + m1@(Multiplicity a b) + m2@(Multiplicity c d) + | feasible m1 && feasible m2 = + normalize $ Multiplicity (a + c) ((+) <$> b <*> d) + | otherwise = infeasible + + m1@(Multiplicity a b) - m2@(Multiplicity c d) + | feasible m1 && feasible m2 = + normalize $ Multiplicity (maybe 0 (a -) d) (subtract c <$> b) + | otherwise = infeasible + + (*) = error "Multiplicities are not closed under multiplication" + + abs = id + signum x = if x == 0 then 0 else 1 + +normalize :: Multiplicity -> Multiplicity +normalize m@(Multiplicity a b) + | not (feasible m) = infeasible + | otherwise = Multiplicity (max a 0) b + +-- | Checks whether a certain number satisfies the 'Multiplicity'. +meetsMultiplicity :: Multiplicity -> Int -> Bool +meetsMultiplicity (Multiplicity lo mbhi) n + | n < lo = False + | Just hi <- mbhi, n > hi = False + | otherwise = True + +-- | A 'Multiplicity' that means exactly once. +-- +-- >>> meetsMultiplicity once 0 +-- False +-- >>> meetsMultiplicity once 1 +-- True +-- >>> meetsMultiplicity once 2 +-- False +once :: Multiplicity +once = 1 + +-- | A 'Multiplicity' that means any number of times. +-- >>> meetsMultiplicity anyMultiplicity 0 +-- True +-- >>> meetsMultiplicity anyMultiplicity 1 +-- True +-- >>> meetsMultiplicity anyMultiplicity 10 +-- True +anyMultiplicity :: Multiplicity +anyMultiplicity = atLeast 0 + +-- | A 'Multiplicity' that means at least this many times. +-- +-- >>> meetsMultiplicity (atLeast 2) 1 +-- False +-- >>> meetsMultiplicity (atLeast 2) 2 +-- True +-- >>> meetsMultiplicity (atLeast 2) 3 +-- True +atLeast :: Multiplicity -> Multiplicity +atLeast (Multiplicity n _) = normalize $ Multiplicity n Nothing + +-- | A 'Multiplicity' that means at most this many times. +-- +-- >>> meetsMultiplicity (atMost 2) 1 +-- True +-- >>> meetsMultiplicity (atMost 2) 2 +-- True +-- >>> meetsMultiplicity (atMost 2) 3 +-- False +atMost :: Multiplicity -> Multiplicity +atMost (Multiplicity _ n) = normalize $ Multiplicity 0 n + +-- | A 'Multiplicity' that means any number in this interval, endpoints +-- included. For example, @'between' 2 3@ means 2 or 3 times, while +-- @'between' n n@ is equivalent to @n@. +-- +-- >>> meetsMultiplicity (between 2 3) 1 +-- False +-- >>> meetsMultiplicity (between 2 3) 2 +-- True +-- >>> meetsMultiplicity (between 2 3) 3 +-- True +-- >>> meetsMultiplicity (between 2 3) 4 +-- False +between :: Multiplicity -> Multiplicity -> Multiplicity +between (Multiplicity m _) (Multiplicity _ n) = normalize $ Multiplicity m n + +-- | Checks whether a 'Multiplicity' is capable of matching any number at all. +-- +-- >>> feasible once +-- True +-- >>> feasible 0 +-- True +-- >>> feasible (once - 2) +-- False +feasible :: Multiplicity -> Bool +feasible (Multiplicity a b) = maybe True (>= max 0 a) b diff --git a/test/Test/HMock/Rule.hs b/test/Test/HMock/Rule.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/Rule.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- | This module defines the 'Rule' type, which describes a matcher for methods +-- and a (possibly empty) list of responses to use for successive calls to +-- matching methods. The 'Expectable' type class generalizes 'Rule', so that +-- you can specify a bare 'Matcher' or 'Action' in most situations where a +-- 'Rule' is needed but you don't want to provide a response. +module Test.HMock.Rule + ( Rule, + Expectable (..), + (|->), + (|=>), + WholeMethodMatcher (SuchThat), + ) +where + +import Test.HMock.Internal.Rule (Rule (..), WholeMethodMatcher (..)) +import {-# SOURCE #-} Test.HMock.Internal.State (MockT) +import Test.HMock.Mockable (MockableBase (Action, Matcher)) + +-- | Class for things that can be expected. This is includes 'Rule's, but also +-- bare 'Matcher's and 'Action's with no explicit response. +class Expectable cls name m r ex | ex -> cls name m r where + -- | Converts an expectable to a Rule that means the same thing. + toRule :: ex -> Rule cls name m r + +-- | Attaches a response to an expectation. This is a flexible response, +-- which can look at arguments, do things in the base monad, set up more +-- expectations, etc. A matching 'Action' is passed to the response. +(|=>) :: + Expectable cls name m r ex => + ex -> + (Action cls name m r -> MockT m r) -> + Rule cls name m r +e |=> r = m :=> (rs ++ [r]) where m :=> rs = toRule e + +infixl 1 |=> + +-- | Attaches a return value to an expectation. This is more convenient than +-- '|=>' in the common case where you just want to return a known result. +-- @e '|->' r@ means the same thing as @e '|=>' 'const' ('return' r)@. +(|->) :: + (Monad m, Expectable cls name m r ex) => + ex -> + r -> + Rule cls name m r +m |-> r = m |=> const (return r) + +infixl 1 |-> + +instance Expectable cls name m r (Rule cls name m r) where + toRule = id + +instance Expectable cls name m r (Matcher cls name m r) where + toRule m = JustMatcher m :=> [] + +instance Expectable cls name m r (WholeMethodMatcher cls name m r) where + toRule m = m :=> [] diff --git a/test/Test/HMock/TH.hs b/test/Test/HMock/TH.hs new file mode 100644 --- /dev/null +++ b/test/Test/HMock/TH.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module provides Template Haskell splices that can be used to derive +-- boilerplate instances for HMock. 'makeMockable' implements the common case +-- where you just want to generate everything you need to mock with a class. +-- The variant 'makeMockableWithOptions' is similar, but takes an options +-- parameter that can be used to customize the generation. +module Test.HMock.TH + ( MakeMockableOptions (..), + makeMockable, + makeMockableWithOptions, + ) +where + +import Control.Monad (replicateM, unless, when, zipWithM) +import Control.Monad.Extra (concatMapM) +import Control.Monad.Trans (MonadIO) +import Data.Bool (bool) +import Data.Char (toUpper) +import Data.Default (Default (..)) +import Data.Either (partitionEithers) +import qualified Data.Kind +import Data.List (foldl', (\\)) +import Data.Maybe (catMaybes, isNothing) +import Data.Proxy (Proxy) +import Data.Typeable (Typeable, typeRep) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (ErrorMessage (Text, (:$$:), (:<>:)), Symbol, TypeError) +import Language.Haskell.TH hiding (Match, match) +import Language.Haskell.TH.Syntax (Lift (lift)) +import Test.HMock.Internal.State (MockT) +import Test.HMock.Internal.TH +import Test.HMock.MockMethod (mockDefaultlessMethod, mockMethod) +import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..)) +import Test.HMock.Rule (Expectable (..)) +import Test.Predicates (Predicate (..), eq) + +-- | Custom options for deriving 'MockableBase' and related instances. +data MakeMockableOptions = MakeMockableOptions + { -- | Whether to generate a 'Mockable' instance with an empty setup. + -- Defaults to 'True'. + -- + -- If this is 'False', you are responsible for providing a 'Mockable' + -- instance as follows: + -- + -- @ + -- instance 'Mockable' MyClass where + -- 'Test.HMock.Mockable.setupMockable' _ = ... + -- @ + mockEmptySetup :: Bool, + -- | Whether to derive instances of the class for 'MockT' or not. Defaults + -- to 'True'. + -- + -- This option will cause a build error if some members of the class are + -- unmockable or are not methods. In this case, you'll need to define this + -- instance yourself, delegating the mockable methods as follows: + -- + -- @ + -- instance MyClass ('MockT' m) where + -- myMethod x y = 'mockMethod' (MyMethod x y) + -- ... + -- @ + mockDeriveForMockT :: Bool, + -- | Suffix to add to 'Action' and 'Matcher' names. Defaults to @""@. + mockSuffix :: String, + -- | Whether to warn about limitations of the generated mocks. This is + -- mostly useful temporarily for finding out why generated code doesn't + -- match your expectations. Defaults to @'False'@. + mockVerbose :: Bool + } + +instance Default MakeMockableOptions where + def = + MakeMockableOptions + { mockEmptySetup = True, + mockDeriveForMockT = True, + mockSuffix = "", + mockVerbose = False + } + +-- | Defines all instances necessary to use HMock with the given type, using +-- default options. The type should be a type class extending 'Monad', applied +-- to zero or more type arguments. +-- +-- This defines all of the following instances, if necessary: +-- +-- * 'MockableBase' and the associated 'Action' and 'Matcher' types. +-- * 'Expectable' instances for the 'Action' type. +-- * 'Mockable' with an empty setup. +-- * Instances of the provided application type class to allow unit tests to be +-- run with the 'MockT' monad transformer. +makeMockable :: Q Type -> Q [Dec] +makeMockable qtype = makeMockableWithOptions qtype def + +-- | Defines all instances necessary to use HMock with the given type, using +-- the provided options. The type should be a type class extending 'Monad', +-- applied to zero or more type arguments. +-- +-- This defines the following instances, if necessary: +-- +-- * 'MockableBase' and the associated 'Action' and 'Matcher' types. +-- * 'Expectable' instances for the 'Action' type. +-- * If 'mockEmptySetup' is 'True': 'Mockable' with an empty setup. +-- * If 'mockDeriveForMockT' is 'True': Instances of the provided application +-- type class to allow unit tests to be run with the 'MockT' monad +-- transformer. +makeMockableWithOptions :: Q Type -> MakeMockableOptions -> Q [Dec] +makeMockableWithOptions qtype options = makeMockableImpl options qtype + +data Instance = Instance + { instType :: Type, + instRequiredContext :: Cxt, + instGeneralParams :: [Name], + instMonadVar :: Name, + instMethods :: [Method], + instExtraMembers :: [Dec] + } + deriving (Show) + +data Method = Method + { methodName :: Name, + methodTyVars :: [Name], + methodCxt :: Cxt, + methodArgs :: [Type], + methodResult :: Type + } + deriving (Show) + +withClass :: Type -> (Dec -> Q a) -> Q a +withClass t f = do + case unappliedName t of + Just cls -> do + info <- reify cls + case info of + ClassI dec@ClassD {} _ -> f dec + _ -> fail $ "Expected " ++ show cls ++ " to be a class, but it wasn't." + _ -> fail "Expected a class, but got something else." + +getInstance :: MakeMockableOptions -> Type -> Q Instance +getInstance options ty = withClass ty go + where + go (ClassD _ className [] _ _) = + fail $ "Class " ++ nameBase className ++ " has no type parameters." + go (ClassD cx _ params _ members) = + matchVars ty [] (tvName <$> params) + where + matchVars :: Type -> [Type] -> [Name] -> Q Instance + matchVars _ _ [] = internalError + matchVars (AppT _ _) _ [_] = + fail $ pprint ty ++ " is applied to too many arguments." + matchVars (AppT a b) ts (_ : ps) = + checkExt FlexibleInstances >> matchVars a (b : ts) ps + matchVars _ ts ps = do + let genVars = init ps + let mVar = last ps + let t = foldl' (\t' v -> AppT t' (VarT v)) ty genVars + let tbl = zip (tvName <$> params) ts + let cx' = substTypeVars tbl <$> cx + makeInstance options t cx' tbl genVars mVar members + go _ = internalError + +makeInstance :: + MakeMockableOptions -> + Type -> + Cxt -> + [(Name, Type)] -> + [Name] -> + Name -> + [Dec] -> + Q Instance +makeInstance options ty cx tbl ps m members = do + processedMembers <- mapM (getMethod ty m tbl) $ filter isRelevantMember members + (extraMembers, methods) <- + partitionEithers <$> zipWithM memberOrMethod members processedMembers + return $ + Instance + { instType = ty, + instRequiredContext = cx, + instGeneralParams = ps, + instMonadVar = m, + instMethods = methods, + instExtraMembers = extraMembers + } + where + isRelevantMember :: Dec -> Bool + isRelevantMember DefaultSigD {} = False + isRelevantMember _ = True + + memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method) + memberOrMethod dec (Left warnings) = do + when (mockVerbose options) $ mapM_ reportWarning warnings + return (Left dec) + memberOrMethod _ (Right method) = return (Right method) + +getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method) +getMethod instTy m tbl (SigD name ty) = do + simpleTy <- localizeMember instTy m (substTypeVars tbl ty) + let (tvs, cx, args, mretval) = splitType simpleTy + return $ do + retval <- case mretval of + AppT (VarT m') retval | m' == m -> return retval + _ -> + Left + [ nameBase name + ++ " can't be mocked: return value not in the expected monad." + ] + unless + ( all + (isVarTypeable cx) + (filter (`elem` tvs) (freeTypeVars retval)) + ) + $ Left + [ nameBase name + ++ " can't be mocked: return value not Typeable." + ] + let argTypes = map (substTypeVar m (AppT (ConT ''MockT) (VarT m))) args + when (any hasNestedPolyType argTypes) $ + Left + [ nameBase name + ++ " can't be mocked: rank-n types nested in arguments." + ] + + return $ + Method + { methodName = name, + methodTyVars = tvs, + methodCxt = cx, + methodArgs = argTypes, + methodResult = retval + } + where + isVarTypeable :: Cxt -> Name -> Bool + isVarTypeable cx v = AppT (ConT ''Typeable) (VarT v) `elem` cx +getMethod _ _ _ (DataD _ name _ _ _ _) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ (NewtypeD _ name _ _ _ _) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ (TySynD name _ _) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ (DataFamilyD name _ _) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = + return $ + Left [nameBase name ++ " must be defined manually in MockT instance."] +getMethod _ _ _ _ = return (Left []) + +isKnownType :: Method -> Type -> Bool +isKnownType method ty = null tyVars && null cx + where + (tyVars, cx) = + relevantContext ty (methodTyVars method, methodCxt method) + +withMethodParams :: Instance -> Method -> TypeQ -> TypeQ +withMethodParams inst method t = + [t| + $t + $(pure (instType inst)) + $(litT (strTyLit (nameBase (methodName method)))) + $(varT (instMonadVar inst)) + $(pure (methodResult method)) + |] + +makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec] +makeMockableImpl options qtype = do + checkExt DataKinds + checkExt FlexibleInstances + checkExt GADTs + checkExt MultiParamTypeClasses + checkExt ScopedTypeVariables + checkExt TypeFamilies + + ty <- qtype + let generalizedTy = case unappliedName ty of + Just cls -> ConT cls + _ -> ty + inst <- getInstance options generalizedTy + + when (null (instMethods inst)) $ do + fail $ + "Cannot derive Mockable because " ++ pprint (instType inst) + ++ " has no mockable methods." + + typeableCxt <- constrainVars [conT ''Typeable] (instGeneralParams inst) + + needsMockableBase <- + isNothing <$> resolveInstance ''MockableBase [instType inst] + mockableBase <- + if needsMockableBase + then do + mockableBase <- + instanceD + (pure typeableCxt) + [t|MockableBase $(pure (instType inst))|] + [ defineActionType options inst, + defineMatcherType options inst, + defineShowAction options (instMethods inst), + defineShowMatcher options (instMethods inst), + defineMatchAction options (instMethods inst) + ] + expectables <- defineExpectableActions options inst + return (mockableBase : expectables) + else return [] + + needsMockable <- + if mockEmptySetup options + then isNothing <$> resolveInstance ''Mockable [instType inst] + else return False + mockable <- + if needsMockable + then do + t <- [t|Mockable $(pure (instType inst))|] + return [InstanceD (Just Overlappable) typeableCxt t []] + else return [] + + mockt <- deriveForMockT options ty + + return $ mockableBase ++ mockable ++ mockt + +defineActionType :: MakeMockableOptions -> Instance -> DecQ +defineActionType options inst = do + kind <- + [t| + Symbol -> + (Data.Kind.Type -> Data.Kind.Type) -> + Data.Kind.Type -> + Data.Kind.Type + |] + let cons = actionConstructor options inst <$> instMethods inst + dataInstD + (pure []) + ''Action + [pure (instType inst)] + (Just kind) + cons + [] + +actionConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ +actionConstructor options inst method = do + forallC [] (return (methodCxt method)) $ + gadtC + [getActionName options method] + [ return (Bang NoSourceUnpackedness NoSourceStrictness, argTy) + | argTy <- methodArgs method + ] + (withMethodParams inst method [t|Action|]) + +getActionName :: MakeMockableOptions -> Method -> Name +getActionName options method = + mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options) + where + name = nameBase (methodName method) + +defineMatcherType :: MakeMockableOptions -> Instance -> Q Dec +defineMatcherType options inst = do + kind <- + [t| + Symbol -> + (Data.Kind.Type -> Data.Kind.Type) -> + Data.Kind.Type -> + Data.Kind.Type + |] + let cons = matcherConstructor options inst <$> instMethods inst + dataInstD + (pure []) + ''Matcher + [pure (instType inst)] + (Just kind) + cons + [] + +matcherConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ +matcherConstructor options inst method = do + gadtC + [getMatcherName options method] + [ (Bang NoSourceUnpackedness NoSourceStrictness,) <$> mkPredicate argTy + | argTy <- methodArgs method + ] + (withMethodParams inst method [t|Matcher|]) + where + mkPredicate argTy + | hasPolyType argTy = do + checkExt RankNTypes + v <- newName "t" + forallT [bindVar v] (pure []) [t|Predicate $(varT v)|] + | null tyVars && null cx = [t|Predicate $(pure argTy)|] + | otherwise = do + checkExt RankNTypes + forallT (bindVar <$> tyVars) (pure cx) [t|Predicate $(pure argTy)|] + where + (tyVars, cx) = + relevantContext argTy (methodTyVars method, methodCxt method) + +getMatcherName :: MakeMockableOptions -> Method -> Name +getMatcherName options method = + mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options ++ "_") + where + name = nameBase (methodName method) + +defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec +defineShowAction options methods = + funD 'showAction (showActionClause options <$> methods) + +showActionClause :: MakeMockableOptions -> Method -> Q Clause +showActionClause options method = do + argVars <- replicateM (length (methodArgs method)) (newName "a") + clause + [ conP + (getActionName options method) + (zipWith argPattern (methodArgs method) argVars) + ] + ( normalB + [| + unwords + ( $(lift (nameBase (methodName method))) : + $(listE (zipWith showArg (methodArgs method) argVars)) + ) + |] + ) + [] + where + isLocalPoly ty = + not . null . fst $ + relevantContext ty (methodTyVars method, methodCxt method) + + canShow ty + | hasPolyType ty = return False + | isLocalPoly ty = (`elem` methodCxt method) <$> [t|Show $(pure ty)|] + | null (freeTypeVars ty) = isInstance ''Show [ty] + | otherwise = return False + + canType ty + | hasPolyType ty = return False + | isLocalPoly ty = + (`elem` methodCxt method) + <$> [t|Typeable $(pure ty)|] + | otherwise = return (null (freeTypeVars ty)) + + argPattern ty v = canShow ty >>= flip sigP (pure ty) . bool wildP (varP v) + + showArg ty var = do + showable <- canShow ty + typeable <- canType ty + case (showable, typeable) of + (True, _) -> [|showsPrec 11 $(varE var) ""|] + (_, True) -> + [| + "(_ :: " + ++ show (typeRep (undefined :: Proxy $(return ty))) + ++ ")" + |] + _ -> lift ("(_ :: " ++ pprint (removeModNames ty) ++ ")") + +defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec +defineShowMatcher options methods = do + clauses <- concatMapM (showMatcherClauses options) methods + funD 'showMatcher clauses + +showMatcherClauses :: MakeMockableOptions -> Method -> Q [ClauseQ] +showMatcherClauses options method = do + argTVars <- replicateM (length (methodArgs method)) (newName "t") + predVars <- replicateM (length (methodArgs method)) (newName "p") + let actionArgs = zipWith actionArg argTVars (methodArgs method) + let matcherArgs = varP <$> predVars + let printedArgs = zipWith3 printedArg predVars argTVars (methodArgs method) + let polyMatcherArgs = zipWith matcherArg predVars (methodArgs method) + let printedPolyArgs = zipWith printedPolyArg predVars (methodArgs method) + let body name args = normalB [|unwords ($(lift name) : $(listE args))|] + return + [ clause + [ conP 'Just [conP (getActionName options method) actionArgs], + conP (getMatcherName options method) matcherArgs + ] + (body (nameBase (methodName method)) printedArgs) + [], + clause + [ conP 'Nothing [], + conP (getMatcherName options method) polyMatcherArgs + ] + (body (nameBase (methodName method)) printedPolyArgs) + [] + ] + where + actionArg t ty + | isKnownType method ty = wildP + | otherwise = sigP wildP (varT t) + + matcherArg p ty + | isKnownType method ty = varP p + | otherwise = wildP + + printedArg p t ty + | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|] + | otherwise = + [|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|] + + printedPolyArg p ty + | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|] + | otherwise = [|"«polymorphic»"|] + +defineMatchAction :: MakeMockableOptions -> [Method] -> Q Dec +defineMatchAction options methods = + funD 'matchAction (matchActionClause options <$> methods) + +matchActionClause :: MakeMockableOptions -> Method -> Q Clause +matchActionClause options method = do + argVars <- + replicateM + (length (methodArgs method)) + ((,) <$> newName "p" <*> newName "a") + mmVar <- newName "mismatches" + clause + [ conP + (getMatcherName options method) + (varP . fst <$> argVars), + conP (getActionName options method) (varP . snd <$> argVars) + ] + ( guardedB + [ (,) <$> normalG [|null $(varE mmVar)|] <*> [|Match|], + (,) <$> normalG [|otherwise|] <*> [|NoMatch $(varE mmVar)|] + ] + ) + [ valD + (varP mmVar) + ( normalB + [| + catMaybes $ + zipWith + (fmap . (,)) + [1 ..] + $(listE (mkAccept <$> argVars)) + |] + ) + [] + ] + where + mkAccept (p, a) = + [| + if accept $(return (VarE p)) $(return (VarE a)) + then Nothing + else Just $ explain $(return (VarE p)) $(return (VarE a)) + |] + +defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec] +defineExpectableActions options inst = + mapM (defineExpectableAction options inst) (instMethods inst) + +type ComplexExpectableMessage name = + ( 'Text "Method " ':<>: 'Text name + ':<>: 'Text " is too complex to expect with an Action." + ) + ':$$: 'Text "Suggested fix: Use a Matcher instead of an Action." + +defineExpectableAction :: MakeMockableOptions -> Instance -> Method -> Q Dec +defineExpectableAction options inst method = do + maybeCxt <- wholeCxt (methodArgs method) + argVars <- replicateM (length (methodArgs method)) (newName "a") + case maybeCxt of + Just cx -> do + instanceD + (pure (methodCxt method ++ cx)) + ( appT + (withMethodParams inst method [t|Expectable|]) + (withMethodParams inst method [t|Action|]) + ) + [ funD + 'toRule + [ clause + [conP (getActionName options method) (map varP argVars)] + ( normalB $ + let matcherCon = conE (getMatcherName options method) + in appE (varE 'toRule) (makeBody argVars matcherCon) + ) + [] + ] + ] + _ -> do + checkExt UndecidableInstances + instanceD + ( (: []) + <$> [t| + TypeError + ( ComplexExpectableMessage + $(litT $ strTyLit $ nameBase $ methodName method) + ) + |] + ) + ( appT + (withMethodParams inst method [t|Expectable|]) + (withMethodParams inst method [t|Action|]) + ) + [ funD + 'toRule + [clause [] (normalB [|undefined|]) []] + ] + where + makeBody [] e = e + makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|] + + wholeCxt :: [Type] -> Q (Maybe Cxt) + wholeCxt (ty : ts) = do + thisCxt <- argCxt ty + otherCxt <- wholeCxt ts + return ((++) <$> thisCxt <*> otherCxt) + wholeCxt [] = return (Just []) + + argCxt :: Type -> Q (Maybe Cxt) + argCxt argTy + | not (isKnownType method argTy) = return Nothing + | otherwise = + simplifyContext [AppT (ConT ''Eq) argTy, AppT (ConT ''Show) argTy] + +deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec] +deriveForMockT options ty = do + inst <- getInstance options {mockVerbose = False} ty + needsMockT <- + if mockDeriveForMockT options + then + isNothing + <$> resolveInstanceType + ( AppT + (instType inst) + (AppT (ConT ''MockT) (VarT (instMonadVar inst))) + ) + else return False + + if needsMockT + then do + unless (null (instExtraMembers inst)) $ + fail $ + "Cannot derive MockT because " ++ pprint (instType inst) + ++ " has unmockable methods." + + m <- newName "m" + let decs = map (implementMethod options) (instMethods inst) + + let cx = + instRequiredContext inst + \\ [ AppT (ConT ''Typeable) (VarT (instMonadVar inst)), + AppT (ConT ''Functor) (VarT (instMonadVar inst)), + AppT (ConT ''Applicative) (VarT (instMonadVar inst)), + AppT (ConT ''Monad) (VarT (instMonadVar inst)), + AppT (ConT ''MonadIO) (VarT (instMonadVar inst)) + ] + + let mockTConstraints = + substTypeVar + (instMonadVar inst) + (AppT (ConT ''MockT) (VarT m)) + <$> cx + simplifyContext mockTConstraints + >>= \case + Just cxMockT -> + (: []) + <$> instanceD + ( concat + <$> sequence + [ return cxMockT, + constrainVars [[t|Typeable|]] (instGeneralParams inst), + constrainVars [[t|Typeable|], [t|MonadIO|]] [m] + ] + ) + [t|$(pure (instType inst)) (MockT $(varT m))|] + decs + Nothing -> fail "Missing MockT instance for a superclass." + else return [] + +implementMethod :: MakeMockableOptions -> Method -> Q Dec +implementMethod options method = do + argVars <- replicateM (length (methodArgs method)) (newName "a") + funD + (methodName method) + [clause (varP <$> argVars) (normalB (body argVars)) []] + where + actionExp [] e = e + actionExp (v : vs) e = actionExp vs [|$e $(varE v)|] + + body argVars = do + defaultCxt <- simplifyContext [AppT (ConT ''Default) (methodResult method)] + let someMockMethod = case defaultCxt of + Just [] -> [|mockMethod|] + _ -> [|mockDefaultlessMethod|] + [| + $someMockMethod + $(actionExp argVars (conE (getActionName options method))) + |] + +checkExt :: Extension -> Q () +checkExt e = do + enabled <- isExtEnabled e + unless enabled $ + fail $ "Please enable " ++ show e ++ " to generate this mock." + +internalError :: HasCallStack => Q a +internalError = error "Internal error in HMock. Please report this as a bug." diff --git a/test/Test/Predicates.hs b/test/Test/Predicates.hs new file mode 100644 --- /dev/null +++ b/test/Test/Predicates.hs @@ -0,0 +1,1477 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Explainable 'Predicate's are essentially functions from types to `Bool` +-- which can additionally describe themselves and explain why an argument does +-- or doesn't match. They are intended to be used during unit tests to provide +-- better error messages when tests fail. +module Test.Predicates + ( -- * The Predicate type + Predicate (..), + (==~), + PredicateFailure (..), + acceptIO, + + -- * Predicate combinators + + -- ** Basic predicates + anything, + eq, + neq, + gt, + geq, + lt, + leq, + just, + nothing, + left, + right, + + -- ** Zips + zipP, + zip3P, + zip4P, + zip5P, + + -- ** Logic + andP, + orP, + notP, +#ifdef REGEX + -- ** Regular expressions + matchesRegex, + matchesCaseInsensitiveRegex, + containsRegex, + containsCaseInsensitiveRegex, +#endif + +#ifdef CONTAINERS + -- ** Strings and sequences + startsWith, + endsWith, + hasSubstr, + hasSubsequence, + caseInsensitive, + + -- ** Containers + isEmpty, + nonEmpty, + sizeIs, + elemsAre, + unorderedElemsAre, + each, + contains, + containsAll, + containsOnly, + keys, + values, +#endif + + -- ** Numerics + approxEq, + positive, + negative, + nonPositive, + nonNegative, + finite, + infinite, + nAn, + + -- ** Miscellaneous + is, + qIs, + with, + qWith, + inBranch, + qADT, + qMatch, + typed, + ) +where + +import Control.Exception (Exception, throwIO) +import Control.Monad (replicateM, unless) +import Data.Functor.Contravariant (Contravariant (..)) +import Data.List (intercalate) +import Data.Maybe (isNothing) +import Data.Typeable (Proxy (..), Typeable, cast, typeRep) +import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import Test.Predicates.Internal.Util (locate, removeModNames, withLoc) + +#ifdef REGEX +import Data.Maybe (isJust) +import Text.Regex.TDFA + ( CompOption (caseSensitive, lastStarGreedy, newSyntax), + ExecOption (captureGroups), + Extract (empty), + Regex, + RegexLike (matchOnce, matchOnceText), + RegexMaker (makeRegexOpts), + RegexOptions (defaultCompOpt, defaultExecOpt), + ) +#endif + +#ifdef CONTAINERS +import Data.Char (toUpper) +import Data.Maybe (catMaybes) +import Data.MonoTraversable (Element, MonoFoldable (..), MonoFunctor (..)) +import qualified Data.Sequences as Seq +import GHC.Exts (IsList (Item, toList)) +import Test.Predicates.Internal.FlowMatcher (bipartiteMatching) +import Test.Predicates.Internal.Util (isSubsequenceOf) +#endif + +-- $setup +-- >>> :set -XLambdaCase +-- >>> :set -XTemplateHaskell +-- >>> :set -XTypeApplications +-- >>> :set -Wno-type-defaults + +-- | A predicate, which tests values and either accepts or rejects them. This +-- is similar to @a -> 'Bool'@, but also can describe itself and explain why an +-- argument does or doesn't match. +data Predicate a = Predicate + { showPredicate :: String, + showNegation :: String, + accept :: a -> Bool, + explain :: a -> String + } + +instance Show (Predicate a) where show = showPredicate + +data PredicateFailure = PredicateFailure String CallStack + +instance Show PredicateFailure where + show (PredicateFailure message cs) = message ++ "\n" ++ prettyCallStack cs +instance Exception PredicateFailure + +-- | Same as 'accept', except throws a 'PredicateFailure' instead of returning a 'Bool'. +acceptIO :: HasCallStack => Predicate a -> a -> IO () +acceptIO p x = + unless (accept p x) $ + throwIO $ PredicateFailure (explain p x) callStack + +-- | An infix synonym for 'accept'. +-- +-- >>> eq 1 ==~ 1 +-- True +-- >>> eq 2 ==~ 1 +-- False +(==~) :: Predicate a -> a -> Bool +(==~) = accept + +withDefaultExplain :: + (a -> String) -> String -> ((a -> String) -> Predicate a) -> Predicate a +withDefaultExplain format connector mk = p + where + p = mk $ \x -> + if accept p x + then format x ++ connector ++ showPredicate p + else format x ++ connector ++ showNegation p + +-- | A 'Predicate' that accepts anything at all. +-- +-- >>> accept anything "foo" +-- True +-- >>> accept anything undefined +-- True +anything :: Predicate a +anything = + Predicate + { showPredicate = "anything", + showNegation = "nothing", + accept = const True, + explain = const "always matches" + } + +-- | A 'Predicate' that accepts only the given value. +-- +-- >>> accept (eq "foo") "foo" +-- True +-- >>> accept (eq "foo") "bar" +-- False +eq :: (Show a, Eq a) => a -> Predicate a +eq x = + Predicate + { showPredicate = show x, + showNegation = "≠ " ++ show x, + accept = (== x), + explain = \y -> + if y == x + then show y ++ " = " ++ show x + else show y ++ " ≠ " ++ show x + } + +-- | A 'Predicate' that accepts anything but the given value. +-- +-- >>> accept (neq "foo") "foo" +-- False +-- >>> accept (neq "foo") "bar" +-- True +neq :: (Show a, Eq a) => a -> Predicate a +neq = notP . eq + +-- | A 'Predicate' that accepts anything greater than the given value. +-- +-- >>> accept (gt 5) 4 +-- False +-- >>> accept (gt 5) 5 +-- False +-- >>> accept (gt 5) 6 +-- True +gt :: (Show a, Ord a) => a -> Predicate a +gt x = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "> " ++ show x, + showNegation = "≤ " ++ show x, + accept = (> x), + explain = explainImpl + } + +-- | A 'Predicate' that accepts anything greater than or equal to the given +-- value. +-- +-- >>> accept (geq 5) 4 +-- False +-- >>> accept (geq 5) 5 +-- True +-- >>> accept (geq 5) 6 +-- True +geq :: (Show a, Ord a) => a -> Predicate a +geq x = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "≥ " ++ show x, + showNegation = "< " ++ show x, + accept = (>= x), + explain = explainImpl + } + +-- | A 'Predicate' that accepts anything less than the given value. +-- +-- >>> accept (lt 5) 4 +-- True +-- >>> accept (lt 5) 5 +-- False +-- >>> accept (lt 5) 6 +-- False +lt :: (Show a, Ord a) => a -> Predicate a +lt = notP . geq + +-- | A 'Predicate' that accepts anything less than or equal to the given value. +-- +-- >>> accept (leq 5) 4 +-- True +-- >>> accept (leq 5) 5 +-- True +-- >>> accept (leq 5) 6 +-- False +leq :: (Show a, Ord a) => a -> Predicate a +leq = notP . gt + +-- | A 'Predicate' that accepts 'Maybe' values of @'Just' x@, where @x@ matches +-- the given child 'Predicate'. +-- +-- >>> accept (just (eq "value")) Nothing +-- False +-- >>> accept (just (eq "value")) (Just "value") +-- True +-- >>> accept (just (eq "value")) (Just "wrong value") +-- False +just :: Predicate a -> Predicate (Maybe a) +just p = + Predicate + { showPredicate = "Just (" ++ showPredicate p ++ ")", + showNegation = "not Just (" ++ showPredicate p ++ ")", + accept = \case Just x -> accept p x; _ -> False, + explain = \case Just x -> explain p x; _ -> "Nothing ≠ Just _" + } + +-- | A Predicate that accepts 'Maybe' values of @'Nothing'@. Unlike 'eq', this +-- doesn't require 'Eq' or 'Show' instances. +-- +-- >>> accept nothing Nothing +-- True +-- +-- >>> accept nothing (Just "something") +-- False +nothing :: Predicate (Maybe a) +nothing = + Predicate + { showPredicate = "Nothing", + showNegation = "Just anything", + accept = isNothing, + explain = \case Nothing -> "Nothing = Nothing"; _ -> "Just _ ≠ Nothing" + } + +-- | A 'Predicate' that accepts an 'Either' value of @'Left' x@, where @x@ +-- matches the given child 'Predicate'. +-- +-- >>> accept (left (eq "value")) (Left "value") +-- True +-- >>> accept (left (eq "value")) (Right "value") +-- False +-- >>> accept (left (eq "value")) (Left "wrong value") +-- False +left :: Predicate a -> Predicate (Either a b) +left p = + Predicate + { showPredicate = "Left (" ++ showPredicate p ++ ")", + showNegation = "not Left (" ++ showPredicate p ++ ")", + accept = \case Left x -> accept p x; _ -> False, + explain = \case Left x -> explain p x; _ -> "Right _ ≠ Left _" + } + +-- | A 'Predicate' that accepts an 'Either' value of @'Right' x@, where @x@ +-- matches the given child 'Predicate'. +-- +-- >>> accept (right (eq "value")) (Right "value") +-- True +-- >>> accept (right (eq "value")) (Right "wrong value") +-- False +-- >>> accept (right (eq "value")) (Left "value") +-- False +right :: Predicate b -> Predicate (Either a b) +right p = + Predicate + { showPredicate = "Right (" ++ showPredicate p ++ ")", + showNegation = "not Right (" ++ showPredicate p ++ ")", + accept = \case Right x -> accept p x; _ -> False, + explain = \case Right x -> explain p x; _ -> "Left _ ≠ Right _" + } + +-- | A 'Predicate' that accepts pairs whose elements satisfy the corresponding +-- child 'Predicate's. +-- +-- >>> accept (zipP (eq "foo") (eq "bar")) ("foo", "bar") +-- True +-- >>> accept (zipP (eq "foo") (eq "bar")) ("bar", "foo") +-- False +zipP :: Predicate a -> Predicate b -> Predicate (a, b) +zipP p1 p2 = + Predicate + { showPredicate = show (p1, p2), + showNegation = "not " ++ show (p1, p2), + accept = all fst . acceptAndExplain, + explain = \xs -> + let results = acceptAndExplain xs + significant + | all fst results = results + | otherwise = filter (not . fst) results + in intercalate " and " $ map snd significant + } + where + acceptAndExplain = \(x1, x2) -> + [ (accept p1 x1, explain p1 x1), + (accept p2 x2, explain p2 x2) + ] + +-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the +-- corresponding child 'Predicate's. +-- +-- >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux") +-- True +-- >>> accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo") +-- False +zip3P :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c) +zip3P p1 p2 p3 = + Predicate + { showPredicate = show (p1, p2, p3), + showNegation = "not " ++ show (p1, p2, p3), + accept = all fst . acceptAndExplain, + explain = \xs -> + let results = acceptAndExplain xs + significant + | all fst results = results + | otherwise = filter (not . fst) results + in intercalate " and " $ map snd significant + } + where + acceptAndExplain = \(x1, x2, x3) -> + [ (accept p1 x1, explain p1 x1), + (accept p2 x2, explain p2 x2), + (accept p3 x3, explain p3 x3) + ] + +-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the +-- corresponding child 'Predicate's. +-- +-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4) +-- True +-- >>> accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1) +-- False +zip4P :: + Predicate a -> + Predicate b -> + Predicate c -> + Predicate d -> + Predicate (a, b, c, d) +zip4P p1 p2 p3 p4 = + Predicate + { showPredicate = show (p1, p2, p3, p4), + showNegation = "not " ++ show (p1, p2, p3, p4), + accept = all fst . acceptAndExplain, + explain = \xs -> + let results = acceptAndExplain xs + significant + | all fst results = results + | otherwise = filter (not . fst) results + in intercalate " and " $ map snd significant + } + where + acceptAndExplain = \(x1, x2, x3, x4) -> + [ (accept p1 x1, explain p1 x1), + (accept p2 x2, explain p2 x2), + (accept p3 x3, explain p3 x3), + (accept p4 x4, explain p4 x4) + ] + +-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the +-- corresponding child 'Predicate's. +-- +-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5) +-- True +-- >>> accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1) +-- False +zip5P :: + Predicate a -> + Predicate b -> + Predicate c -> + Predicate d -> + Predicate e -> + Predicate (a, b, c, d, e) +zip5P p1 p2 p3 p4 p5 = + Predicate + { showPredicate = show (p1, p2, p3, p4, p5), + showNegation = "not " ++ show (p1, p2, p3, p4, p5), + accept = all fst . acceptAndExplain, + explain = \xs -> + let results = acceptAndExplain xs + significant + | all fst results = results + | otherwise = filter (not . fst) results + in intercalate " and " $ map snd significant + } + where + acceptAndExplain = \(x1, x2, x3, x4, x5) -> + [ (accept p1 x1, explain p1 x1), + (accept p2 x2, explain p2 x2), + (accept p3 x3, explain p3 x3), + (accept p4 x4, explain p4 x4), + (accept p5 x5, explain p5 x5) + ] + +-- | A 'Predicate' that accepts anything accepted by both of its children. +-- +-- >>> accept (lt "foo" `andP` gt "bar") "eta" +-- True +-- >>> accept (lt "foo" `andP` gt "bar") "quz" +-- False +-- >>> accept (lt "foo" `andP` gt "bar") "alpha" +-- False +andP :: Predicate a -> Predicate a -> Predicate a +p `andP` q = + Predicate + { showPredicate = showPredicate p ++ " and " ++ showPredicate q, + showNegation = showNegation p ++ " or " ++ showNegation q, + accept = \x -> accept p x && accept q x, + explain = \x -> + if + | not (accept p x) -> explain p x + | not (accept q x) -> explain q x + | otherwise -> explain p x ++ " and " ++ explain q x + } + +-- | A 'Predicate' that accepts anything accepted by either of its children. +-- +-- >>> accept (lt "bar" `orP` gt "foo") "eta" +-- False +-- >>> accept (lt "bar" `orP` gt "foo") "quz" +-- True +-- >>> accept (lt "bar" `orP` gt "foo") "alpha" +-- True +orP :: Predicate a -> Predicate a -> Predicate a +p `orP` q = notP (notP p `andP` notP q) + +-- | A 'Predicate' that inverts another 'Predicate', accepting whatever its +-- child rejects, and rejecting whatever its child accepts. +-- +-- >>> accept (notP (eq "negative")) "positive" +-- True +-- >>> accept (notP (eq "negative")) "negative" +-- False +notP :: Predicate a -> Predicate a +notP p = + Predicate + { showPredicate = showNegation p, + showNegation = showPredicate p, + accept = not . accept p, + explain = explain p + } + +#ifdef REGEX + +-- | A 'Predicate' that accepts 'String's or string-like values matching a +-- regular expression. The expression must match the entire argument. +-- +-- You should not use @'caseInsensitive' 'matchesRegex'@, because regular +-- expression syntax itself is still case-sensitive even when the text you are +-- matching is not. Instead, use 'matchesCaseInsensitiveRegex'. +-- +-- >>> accept (matchesRegex "x{2,5}y?") "xxxy" +-- True +-- >>> accept (matchesRegex "x{2,5}y?") "xyy" +-- False +-- >>> accept (matchesRegex "x{2,5}y?") "wxxxyz" +-- False +matchesRegex :: (RegexLike Regex a, Eq a, Show a) => String -> Predicate a +matchesRegex s = + Predicate + { showPredicate = pat, + showNegation = "not " ++ pat, + accept = accepts, + explain = \x -> + if accepts x + then show x ++ " matches " ++ pat + else show x ++ " doesn't match " ++ pat + } + where + pat = "/" ++ init (tail $ show s) ++ "/" + accepts x = case matchOnceText r x of + Just (a, _, b) -> a == empty && b == empty + Nothing -> False + r = makeRegexOpts comp exec s :: Regex + comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True} + exec = defaultExecOpt {captureGroups = False} + +-- | A 'Predicate' that accepts 'String's or string-like values matching a +-- regular expression in a case-insensitive way. The expression must match the +-- entire argument. +-- +-- You should use this instead of @'caseInsensitive' 'matchesRegex'@, because +-- regular expression syntax itself is still case-sensitive even when the text +-- you are matching is not. +-- +-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY" +-- True +-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY" +-- False +-- >>> accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ" +-- False +matchesCaseInsensitiveRegex :: + (RegexLike Regex a, Eq a, Show a) => String -> Predicate a +matchesCaseInsensitiveRegex s = + Predicate + { showPredicate = pat, + showNegation = "not " ++ pat, + accept = accepts, + explain = \x -> + if accepts x + then show x ++ " matches " ++ pat + else show x ++ " doesn't match " ++ pat + } + where + pat = "/" ++ init (tail $ show s) ++ "/i" + accepts x = case matchOnceText r x of + Just (a, _, b) -> a == empty && b == empty + Nothing -> False + r = makeRegexOpts comp exec s :: Regex + comp = + defaultCompOpt + { newSyntax = True, + lastStarGreedy = True, + caseSensitive = False + } + exec = defaultExecOpt {captureGroups = False} + +-- | A 'Predicate' that accepts 'String's or string-like values containing a +-- match for a regular expression. The expression need not match the entire +-- argument. +-- +-- You should not use @'caseInsensitive' 'containsRegex'@, because regular +-- expression syntax itself is still case-sensitive even when the text you are +-- matching is not. Instead, use 'containsCaseInsensitiveRegex'. +-- +-- >>> accept (containsRegex "x{2,5}y?") "xxxy" +-- True +-- >>> accept (containsRegex "x{2,5}y?") "xyy" +-- False +-- >>> accept (containsRegex "x{2,5}y?") "wxxxyz" +-- True +containsRegex :: (RegexLike Regex a, Eq a, Show a) => String -> Predicate a +containsRegex s = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "contains " ++ pat, + showNegation = "doesn't contain " ++ pat, + accept = isJust . matchOnce r, + explain = explainImpl + } + where + pat = "/" ++ init (tail $ show s) ++ "/" + r = makeRegexOpts comp exec s :: Regex + comp = defaultCompOpt {newSyntax = True, lastStarGreedy = True} + exec = defaultExecOpt {captureGroups = False} + +-- | A 'Predicate' that accepts 'String's or string-like values containing a +-- match for a regular expression in a case-insensitive way. The expression +-- need match the entire argument. +-- +-- You should use this instead of @'caseInsensitive' 'containsRegex'@, because +-- regular expression syntax itself is still case-sensitive even when the text +-- you are matching is not. +-- +-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY" +-- True +-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY" +-- False +-- >>> accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ" +-- True +containsCaseInsensitiveRegex :: + (RegexLike Regex a, Eq a, Show a) => String -> Predicate a +containsCaseInsensitiveRegex s = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "contains " ++ pat, + showNegation = "doesn't contain " ++ pat, + accept = isJust . matchOnce r, + explain = explainImpl + } + where + pat = "/" ++ init (tail $ show s) ++ "/i" + r = makeRegexOpts comp exec s :: Regex + comp = + defaultCompOpt + { newSyntax = True, + lastStarGreedy = True, + caseSensitive = False + } + exec = defaultExecOpt {captureGroups = False} + +#endif + +#ifdef CONTAINERS + +-- | A 'Predicate' that accepts sequences that start with the given prefix. +-- +-- >>> accept (startsWith "fun") "fungible" +-- True +-- >>> accept (startsWith "gib") "fungible" +-- False +startsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t +startsWith pfx = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "starts with " ++ show pfx, + showNegation = "doesn't start with " ++ show pfx, + accept = (pfx `Seq.isPrefixOf`), + explain = explainImpl + } + +-- | A 'Predicate' that accepts sequences that end with the given suffix. +-- +-- >>> accept (endsWith "ow") "crossbow" +-- True +-- >>> accept (endsWith "ow") "trebuchet" +-- False +endsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t +endsWith sfx = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "ends with " ++ show sfx, + showNegation = "doesn't end with " ++ show sfx, + accept = (sfx `Seq.isSuffixOf`), + explain = explainImpl + } + +-- | A 'Predicate' that accepts sequences that contain the given (consecutive) +-- substring. +-- +-- >>> accept (hasSubstr "i") "team" +-- False +-- >>> accept (hasSubstr "i") "partnership" +-- True +hasSubstr :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t +hasSubstr s = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "has substring " ++ show s, + showNegation = "doesn't have substring " ++ show s, + accept = (s `Seq.isInfixOf`), + explain = explainImpl + } + +-- | A 'Predicate' that accepts sequences that contain the given (not +-- necessarily consecutive) subsequence. +-- +-- >>> accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5] +-- True +-- >>> accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0] +-- True +-- >>> accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11] +-- False +hasSubsequence :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t +hasSubsequence s = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "has subsequence " ++ show s, + showNegation = "doesn't have subsequence " ++ show s, + accept = (s `isSubsequenceOf`), + explain = explainImpl + } + +-- | Transforms a 'Predicate' on 'String's or string-like types to match without +-- regard to case. +-- +-- >>> accept (caseInsensitive startsWith "foo") "FOOTBALL!" +-- True +-- >>> accept (caseInsensitive endsWith "ball") "soccer" +-- False +-- >>> accept (caseInsensitive eq "time") "TIME" +-- True +-- >>> accept (caseInsensitive gt "NOTHING") "everything" +-- False +caseInsensitive :: + ( MonoFunctor t, + MonoFunctor a, + Element t ~ Char, + Element a ~ Char + ) => + (t -> Predicate a) -> + (t -> Predicate a) +caseInsensitive p s = + Predicate + { showPredicate = "(case insensitive) " ++ show (p s), + showNegation = "(case insensitive) " ++ show (notP (p s)), + accept = accept capP . omap toUpper, + explain = explain capP . omap toUpper + } + where + capP = p (omap toUpper s) + +-- | A 'Predicate' that accepts empty data structures. +-- +-- >>> accept isEmpty ([] :: [Int]) +-- True +-- >>> accept isEmpty [1, 2, 3] +-- False +-- >>> accept isEmpty "" +-- True +-- >>> accept isEmpty "gas tank" +-- False +isEmpty :: (MonoFoldable t, Show t) => Predicate t +isEmpty = withDefaultExplain show " is " $ \explainImpl -> + Predicate + { showPredicate = "empty", + showNegation = "non-empty", + accept = onull, + explain = explainImpl + } + +-- | A 'Predicate' that accepts non-empty data structures. +-- +-- >>> accept nonEmpty ([] :: [Int]) +-- False +-- >>> accept nonEmpty [1, 2, 3] +-- True +-- >>> accept nonEmpty "" +-- False +-- >>> accept nonEmpty "gas tank" +-- True +nonEmpty :: (MonoFoldable t, Show t) => Predicate t +nonEmpty = notP isEmpty + +-- | A 'Predicate' that accepts data structures whose number of elements match +-- the child 'Predicate'. +-- +-- >>> accept (sizeIs (lt 3)) ['a' .. 'f'] +-- False +-- >>> accept (sizeIs (lt 3)) ['a' .. 'b'] +-- True +sizeIs :: (MonoFoldable t, Show t) => Predicate Int -> Predicate t +sizeIs p = + Predicate + { showPredicate = "size " ++ showPredicate p, + showNegation = "size " ++ showNegation p, + accept = accept p . olength, + explain = \y -> + let detail + | accept p (olength y) = showPredicate p + | otherwise = showNegation p + detailStr + | show (olength y) == detail = "" + | otherwise = ", which is " ++ detail + in show y ++ " has size " ++ show (olength y) ++ detailStr + } + +-- | A 'Predicate' that accepts data structures whose contents each match the +-- corresponding 'Predicate' in the given list, in the same order. +-- +-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4] +-- True +-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5] +-- False +-- >>> accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4] +-- False +elemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t +elemsAre ps = + Predicate + { showPredicate = show ps, + showNegation = "not " ++ show ps, + accept = \xs -> + olength xs == olength ps + && and (zipWith accept ps (otoList xs)), + explain = \xs -> + let results = acceptAndExplain (otoList xs) + in if + | olength xs /= length ps -> + "wrong size (got " + ++ show (olength xs) + ++ "; expected " + ++ show (length ps) + ++ ")" + | all fst results -> "elements are " ++ show ps + | otherwise -> + intercalate "; and " $ + snd <$> filter (not . fst) results + } + where + acceptAndExplain xs = zipWith3 matchAndExplain [1 :: Int ..] ps xs + matchAndExplain i p x = + (accept p x, "in element #" ++ show i ++ ": " ++ explain p x) + +-- | A 'Predicate' that accepts data structures whose contents each match the +-- corresponding 'Predicate' in the given list, in any order. +-- +-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3] +-- True +-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1] +-- True +-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4] +-- False +-- >>> accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3] +-- False +unorderedElemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t +unorderedElemsAre ps = + Predicate + { showPredicate = + "(any order) " ++ show ps, + showNegation = + "not (in any order) " ++ show ps, + accept = \xs -> + let (_, orphanPs, orphanXs) = matchAll xs + in null orphanPs && null orphanXs, + explain = \xs -> + let (matches, orphanPs, orphanXs) = matchAll xs + in if null orphanPs && null orphanXs + then intercalate "; and " (explainMatch <$> matches) + else + let missingExplanation = + if null orphanPs + then Nothing + else + Just + ( "Missing: " + ++ intercalate ", " (showPredicate <$> orphanPs) + ) + extraExplanation = + if null orphanXs + then Nothing + else + Just + ( "Extra elements: " + ++ intercalate + ", " + (("#" ++) . show . fst <$> orphanXs) + ) + in intercalate + "; " + (catMaybes [missingExplanation, extraExplanation]) + } + where + matchOne p (_, x) = accept p x + matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs)) + explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x + +-- | A 'Predicate' that accepts data structures whose elements each match the +-- child 'Predicate'. +-- +-- >>> accept (each (gt 5)) [4, 5, 6] +-- False +-- >>> accept (each (gt 5)) [6, 7, 8] +-- True +-- >>> accept (each (gt 5)) [] +-- True +each :: MonoFoldable t => Predicate (Element t) -> Predicate t +each p = + Predicate + { showPredicate = "each (" ++ showPredicate p ++ ")", + showNegation = "contains (" ++ showNegation p ++ ")", + accept = all fst . acceptAndExplain, + explain = \xs -> + let results = acceptAndExplain xs + format (i, explanation) = + "element #" ++ show i ++ ": " ++ explanation + in if all fst results + then "all elements " ++ showPredicate p + else + intercalate "; and " $ + format . snd <$> filter (not . fst) results + } + where + acceptAndExplain xs = + [(accept p x, (i, explain p x)) | i <- [1 :: Int ..] | x <- otoList xs] + +-- | A 'Predicate' that accepts data structures which contain at least one +-- element matching the child 'Predicate'. +-- +-- >>> accept (contains (gt 5)) [3, 4, 5] +-- False +-- >>> accept (contains (gt 5)) [4, 5, 6] +-- True +-- >>> accept (contains (gt 5)) [] +-- False +contains :: MonoFoldable t => Predicate (Element t) -> Predicate t +contains = notP . each . notP + +-- | A 'Predicate' that accepts data structures whose elements all satisfy the +-- given child 'Predicate's. +-- +-- >>> accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"] +-- True +-- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo"] +-- False +-- >>> accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"] +-- True +-- +-- Each child 'Predicate' must be satisfied by a different element, so repeating +-- a 'Predicate' requires that two different matching elements exist. If you +-- want a 'Predicate' to match multiple elements, instead, you can accomplish +-- this with @'contains' p1 `'andP'` 'contains' p2 `'andP'` ...@. +-- +-- >>> accept (containsAll [startsWith "f", endsWith "o"]) ["foo"] +-- False +-- >>> accept (contains (startsWith "f") `andP` contains (endsWith "o")) ["foo"] +-- True +containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t +containsAll ps = + Predicate + { showPredicate = "contains all of " ++ show ps, + showNegation = "not all of " ++ show ps, + accept = \xs -> let (_, orphanPs, _) = matchAll xs in null orphanPs, + explain = \xs -> + let (matches, orphanPs, _) = matchAll xs + in if null orphanPs + then intercalate "; and " (explainMatch <$> matches) + else "Missing: " ++ intercalate ", " (showPredicate <$> orphanPs) + } + where + matchOne p (_, x) = accept p x + matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs)) + explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x + +-- | A 'Predicate' that accepts data structures whose elements all satisfy one +-- of the child 'Predicate's. +-- +-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo"] +-- True +-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"] +-- True +-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"] +-- False +-- +-- Each element must satisfy a different child 'Predicate'. If you want +-- multiple elements to match the same 'Predicate', instead, you can accomplish +-- this with @'each' (p1 `'orP'` p2 `'orP'` ...)@. +-- +-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"] +-- False +-- >>> accept (each (eq "foo" `orP` eq "bar")) ["foo", "foo"] +-- True +containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t +containsOnly ps = + Predicate + { showPredicate = "contains only " ++ show ps, + showNegation = "not only " ++ show ps, + accept = \xs -> let (_, _, orphanXs) = matchAll xs in null orphanXs, + explain = \xs -> + let (matches, _, orphanXs) = matchAll xs + in if null orphanXs + then intercalate "; and " (explainMatch <$> matches) + else + "Extra elements: " + ++ intercalate ", " (("#" ++) . show . fst <$> orphanXs) + } + where + matchOne p (_, x) = accept p x + matchAll xs = bipartiteMatching matchOne ps (zip [1 :: Int ..] (otoList xs)) + explainMatch (p, (j, x)) = "element #" ++ show j ++ ": " ++ explain p x + +-- | Transforms a 'Predicate' on a list of keys into a 'Predicate' on map-like +-- data structures. +-- +-- This is equivalent to @'with' ('map' 'fst' '.' 'toList')@, but more readable. +-- +-- >>> accept (keys (each (eq "foo"))) [("foo", 5)] +-- True +-- +-- >>> accept (keys (each (eq "foo"))) [("foo", 5), ("bar", 6)] +-- False +keys :: (IsList t, Item t ~ (k, v)) => Predicate [k] -> Predicate t +keys p = + Predicate + { showPredicate = "keys (" ++ showPredicate p ++ ")", + showNegation = "keys (" ++ showNegation p ++ ")", + accept = accept p . map fst . toList, + explain = ("in keys, " ++) . explain p . map fst . toList + } + +-- | Transforms a 'Predicate' on a list of values into a 'Predicate' on map-like +-- data structures. +-- +-- This is equivalent to @'with' ('map' 'snd' '.' 'toList')@, but more readable. +-- +-- >>> accept (values (each (eq 5))) [("foo", 5), ("bar", 5)] +-- True +-- +-- >>> accept (values (each (eq 5))) [("foo", 5), ("bar", 6)] +-- False +values :: (IsList t, Item t ~ (k, v)) => Predicate [v] -> Predicate t +values p = + Predicate + { showPredicate = "values (" ++ showPredicate p ++ ")", + showNegation = "values (" ++ showNegation p ++ ")", + accept = accept p . map snd . toList, + explain = ("in values, " ++) . explain p . map snd . toList + } + +#endif + +-- | A 'Predicate' that accepts values of 'RealFloat' types that are close to +-- the given number. The expected precision is scaled based on the target +-- value, so that reasonable rounding error is accepted but grossly inaccurate +-- results are not. +-- +-- The following naive use of 'eq' fails due to rounding: +-- +-- >>> accept (eq 1.0) (sum (replicate 100 0.01)) +-- False +-- +-- The solution is to use 'approxEq', which accounts for rounding error. +-- However, 'approxEq' doesn't accept results that are far enough off that they +-- likely arise from incorrect calculations instead of rounding error. +-- +-- >>> accept (approxEq 1.0) (sum (replicate 100 0.01)) +-- True +-- >>> accept (approxEq 1.0) (sum (replicate 100 0.009999)) +-- False +approxEq :: (RealFloat a, Show a) => a -> Predicate a +approxEq x = withDefaultExplain show " " $ \explainImpl -> + Predicate + { showPredicate = "≈ " ++ show x, + showNegation = "≇" ++ show x, + accept = \y -> abs (x - y) < diff, + explain = explainImpl + } + where + diff = encodeFloat 1 (snd (decodeFloat x) + floatDigits x `div` 2) + +-- | A 'Predicate' that accepts positive numbers of any 'Ord'ered 'Num' type. +-- +-- >>> accept positive 1 +-- True +-- +-- >>> accept positive 0 +-- False +-- +-- >>> accept positive (-1) +-- False +positive :: (Ord a, Num a) => Predicate a +positive = + Predicate + { showPredicate = "positive", + showNegation = "non-positive", + accept = \x -> signum x > 0, + explain = \x -> + if + | signum x > 0 -> "value is positive" + | x == 0 -> "value is zero" + | signum x < 0 -> "value is negative" + | otherwise -> "value has unknown sign" + } + +-- | A 'Predicate' that accepts negative numbers of any 'Ord'ered 'Num' type. +-- +-- >>> accept negative 1 +-- False +-- +-- >>> accept negative 0 +-- False +-- +-- >>> accept negative (-1) +-- True +negative :: (Ord a, Num a) => Predicate a +negative = + Predicate + { showPredicate = "negative", + showNegation = "non-negative", + accept = \x -> signum x < 0, + explain = \x -> + if + | signum x < 0 -> "value is negative" + | x == 0 -> "value is zero" + | signum x < 0 -> "value is positive" + | otherwise -> "value has unknown sign" + } + +-- | A 'Predicate' that accepts non-positive numbers of any 'Ord'ered 'Num' +-- type. +-- +-- >>> accept nonPositive 1 +-- False +-- +-- >>> accept nonPositive 0 +-- True +-- +-- >>> accept nonPositive (-1) +-- True +nonPositive :: (Ord a, Num a) => Predicate a +nonPositive = notP positive + +-- | A 'Predicate' that accepts non-negative numbers of any 'Ord'ered 'Num' +-- type. +-- +-- >>> accept nonNegative 1 +-- True +-- +-- >>> accept nonNegative 0 +-- True +-- +-- >>> accept nonNegative (-1) +-- False +nonNegative :: (Ord a, Num a) => Predicate a +nonNegative = notP negative + +-- | A 'Predicate' that accepts finite numbers of any 'RealFloat' type. +-- +-- >>> accept finite 1.0 +-- True +-- >>> accept finite (0 / 0) +-- False +-- >>> accept finite (1 / 0) +-- False +finite :: RealFloat a => Predicate a +finite = + Predicate + { showPredicate = "finite", + showNegation = "non-finite", + accept = isFinite, + explain = \x -> + if isFinite x + then "value is finite" + else "value is not finite" + } + where + isFinite x = not (isInfinite x) && not (isNaN x) + +-- | A 'Predicate' that accepts infinite numbers of any 'RealFloat' type. +-- +-- >>> accept infinite 1.0 +-- False +-- >>> accept infinite (0 / 0) +-- False +-- >>> accept infinite (1 / 0) +-- True +infinite :: RealFloat a => Predicate a +infinite = + Predicate + { showPredicate = "infinite", + showNegation = "non-infinite", + accept = isInfinite, + explain = \x -> + if isInfinite x + then "value is infinite" + else "value is not infinite" + } + +-- | A 'Predicate' that accepts NaN values of any 'RealFloat' type. +-- +-- >>> accept nAn 1.0 +-- False +-- >>> accept nAn (0 / 0) +-- True +-- >>> accept nAn (1 / 0) +-- False +nAn :: RealFloat a => Predicate a +nAn = + Predicate + { showPredicate = "NaN", + showNegation = "non-NaN", + accept = isNaN, + explain = \x -> + if isNaN x + then "value is NaN" + else "value is not NaN" + } + +-- | A conversion from @a -> 'Bool'@ to 'Predicate'. This is a fallback that +-- can be used to build a 'Predicate' that checks anything at all. However, its +-- description will be less helpful than standard 'Predicate's. You can use +-- 'qIs' instead to get better descriptions using Template Haskell. +-- +-- >>> accept (is even) 3 +-- False +-- >>> accept (is even) 4 +-- True +is :: HasCallStack => (a -> Bool) -> Predicate a +is p = + Predicate + { showPredicate = withLoc (locate callStack "custom predicate"), + showNegation = withLoc (locate callStack "negated custom predicate"), + accept = p, + explain = \x -> + if p x + then "value matched custom predicate" + else "value did not match custom predicate" + } + +-- | A Template Haskell splice that acts like 'is', but receives a quoted +-- expression at compile time and has a more helpful explanation. +-- +-- >>> accept $(qIs [| even |]) 3 +-- False +-- >>> accept $(qIs [| even |]) 4 +-- True +-- +-- >>> show $(qIs [| even |]) +-- "even" +qIs :: HasCallStack => ExpQ -> ExpQ +qIs p = + [| + Predicate + { showPredicate = $description, + showNegation = "not " ++ $description, + accept = $p, + explain = \x -> if $p x then $description else "not " ++ $description + } + |] + where + description = lift . pprint . removeModNames =<< p + +-- | A combinator to lift a 'Predicate' to work on a property or computed value +-- of the original value. The explanations are less helpful that standard +-- predicates like 'sizeIs'. You can use 'qWith' instead to get better +-- explanations using Template Haskell. +-- +-- >>> accept (with abs (gt 5)) (-6) +-- True +-- >>> accept (with abs (gt 5)) (-5) +-- False +-- >>> accept (with reverse (eq "olleh")) "hello" +-- True +-- >>> accept (with reverse (eq "olleh")) "goodbye" +-- False +with :: HasCallStack => (a -> b) -> Predicate b -> Predicate a +with f p = + Predicate + { showPredicate = prop ++ ": " ++ show p, + showNegation = prop ++ ": " ++ showNegation p, + accept = accept p . f, + explain = ((prop ++ ": ") ++) . explain p . f + } + where + prop = withLoc (locate callStack "property") + +-- | Use 'with' or 'qWith' instead of 'contramap' to get better explanations. +instance Contravariant Predicate where + contramap f p = + Predicate + { showPredicate = "in a property: " ++ show p, + showNegation = "in a property: " ++ showNegation p, + accept = accept p . f, + explain = ("in a property: " ++) . explain p . f + } + +-- | A Template Haskell splice that acts like 'with', but receives a quoted +-- typed expression at compile time and has a more helpful explanation. +-- +-- >>> accept ($(qWith [| abs |]) (gt 5)) (-6) +-- True +-- >>> accept ($(qWith [| abs |]) (gt 5)) (-5) +-- False +-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "hello" +-- True +-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye" +-- False +-- +-- >>> show ($(qWith [| abs |]) (gt 5)) +-- "abs: > 5" +qWith :: ExpQ -> ExpQ +qWith f = + [| + \p -> + Predicate + { showPredicate = $prop ++ ": " ++ show p, + showNegation = $prop ++ ": " ++ showNegation p, + accept = accept p . $f, + explain = (($prop ++ ": ") ++) . explain p . $f + } + |] + where + prop = lift . pprint . removeModNames =<< f + +-- | A 'Predicate' that accepts values with a given nested value. This is +-- intended to match constructors with arguments. You can use 'qADT' instead +-- to get better explanations using Template Haskell. +-- +-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 1) +-- True +-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 0) +-- False +-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Right 1) +-- False +inBranch :: String -> (a -> Maybe b) -> Predicate b -> Predicate a +inBranch name f p = + Predicate + { showPredicate = "(" ++ name ++ " _)", + showNegation = "not (" ++ name ++ " _)", + accept = \x -> case f x of Just y -> accept p y; _ -> False, + explain = \x -> case f x of + Just y -> "In " ++ name ++ ": " ++ explain p y + _ -> "Branch didn't match" + } + +-- | A Template Haskell splice which, given a constructor for an abstract data +-- type, writes a 'Predicate' that matches on that constructor and applies other +-- 'Predicate's to its fields. +-- +-- >>> accept $(qADT 'Nothing) Nothing +-- True +-- >>> accept $(qADT 'Nothing) (Just 5) +-- False +-- >>> accept ($(qADT 'Just) positive) (Just 5) +-- True +-- >>> accept ($(qADT 'Just) positive) Nothing +-- False +-- >>> accept ($(qADT 'Just) positive) (Just 0) +-- False +qADT :: Name -> ExpQ +qADT conName = + do + let prettyConName = lift (pprint (removeModNames conName)) + t <- reify conName >>= (\case + DataConI _ ty _ -> pure ty + PatSynI _ ty -> pure ty + _ -> fail $ "qADT: " ++ show conName ++ " is not a data constructor") + + let n = countArguments t + subpreds <- replicateM n (newName "p") + let subdescs = + map + (\p -> [|"(" ++ showPredicate $p ++ ")"|]) + (varE <$> subpreds) + let desc = [|unwords ($prettyConName : $(listE subdescs))|] + let negDesc + | n == 0 = [|"≠ " ++ $desc|] + | otherwise = [|"not (" ++ $desc ++ ")"|] + args <- replicateM n (newName "x") + let pattern = conP conName (varP <$> args) + let acceptExplainFields = + listE $ + zipWith + (\p x -> [|(accept $p $x, explain $p $x)|]) + (varE <$> subpreds) + (varE <$> args) + y <- newName "y" + lamE + (varP <$> subpreds) + [| + let acceptAndExplain $(varP y) = case $(varE y) of + $pattern -> Just $acceptExplainFields + _ -> Nothing + in Predicate + { showPredicate = $desc, + showNegation = $negDesc, + accept = maybe False (all fst) . acceptAndExplain, + explain = \x -> case acceptAndExplain x of + Nothing -> "Not a " ++ $prettyConName + Just results -> + let significant + | all fst results = results + | otherwise = filter (not . fst) results + in "In " ++ $prettyConName ++ ": " + ++ intercalate " and " (map snd significant) + } + |] + where + countArguments (ForallT _ _ t) = countArguments t + countArguments (AppT (AppT ArrowT _) t) = countArguments t + 1 +#if MIN_VERSION_template_haskell(2,17,0) + countArguments (AppT (AppT (AppT MulArrowT _) _) t) = countArguments t + 1 +#endif + countArguments _ = 0 + +-- | A Template Haskell splice that turns a quoted pattern into a predicate that +-- accepts values that match the pattern. +-- +-- >>> accept $(qMatch [p| Just (Left _) |]) Nothing +-- False +-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Left 5)) +-- True +-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Right 5)) +-- False +-- +-- >>> show $(qMatch [p| Just (Left _) |]) +-- "Just (Left _)" +qMatch :: PatQ -> ExpQ +qMatch qpat = + [| + Predicate + { showPredicate = $patString, + showNegation = "not " ++ $patString, + accept = \case + $qpat -> True + _ -> False, + explain = \case + $qpat -> "value matched " ++ $patString + _ -> "value didn't match " ++ $patString + } + |] + where + patString = lift . pprint . removeModNames =<< qpat + +-- | Converts a 'Predicate' to a new type. Typically used with visible type +-- application, as in the examples below. +-- +-- >>> accept (typed @String anything) "foo" +-- True +-- >>> accept (typed @String (sizeIs (gt 5))) "foo" +-- False +-- >>> accept (typed @String anything) (42 :: Int) +-- False +typed :: forall a b. (Typeable a, Typeable b) => Predicate a -> Predicate b +typed p = + Predicate + { showPredicate = + showPredicate p ++ " :: " ++ show (typeRep (Proxy :: Proxy a)), + showNegation = + "not " ++ showPredicate p ++ " :: " + ++ show (typeRep (Proxy :: Proxy a)), + accept = \x -> case cast x of + Nothing -> False + Just y -> accept p y, + explain = \x -> case cast x of + Nothing -> + "wrong type (" + ++ show (typeRep (undefined :: Proxy b)) + ++ " vs. " + ++ show (typeRep (undefined :: Proxy a)) + ++ ")" + Just y -> explain p y + } diff --git a/test/Test/Predicates/Internal/FlowMatcher.hs b/test/Test/Predicates/Internal/FlowMatcher.hs new file mode 100644 --- /dev/null +++ b/test/Test/Predicates/Internal/FlowMatcher.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An implementation of bipartite matching using the Ford-Fulkerson algorithm. +module Test.Predicates.Internal.FlowMatcher where + +import Control.Monad (forM_, when) +import Control.Monad.ST (ST) +import Data.Array.IArray (Array, assocs, elems) +import Data.Array.ST + ( MArray (newArray), + STArray, + newListArray, + readArray, + runSTArray, + writeArray, + ) +import Data.List ((\\)) +import Data.Maybe (catMaybes) + +-- $setup +-- >>> :set -Wno-type-defaults + +-- | Computes the best bipartite matching of the elements in the two lists, +-- given the compatibility function. +-- +-- Returns matched pairs, then unmatched lhs elements, then unmatched rhs +-- elements. +-- +-- >>> bipartiteMatching (==) [1 .. 5] [6, 5 .. 2] +-- ([(2,2),(3,3),(4,4),(5,5)],[1],[6]) +bipartiteMatching :: + forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b]) +bipartiteMatching compatible xs ys = (matchedPairs, unmatchedX, unmatchedY) + where + matchedPairs :: [(a, b)] + matchedPairs = [(xs !! i, ys !! j) | (i, Just j) <- assocs matches] + + unmatchedX :: [a] + unmatchedX = [xs !! i | (i, Nothing) <- assocs matches] + + unmatchedY :: [b] + unmatchedY = [ys !! j | j <- [0 .. numYs - 1] \\ catMaybes (elems matches)] + + matches :: Array Int (Maybe Int) + matches = runSTArray st + + st :: forall s. ST s (STArray s Int (Maybe Int)) + st = do + compatArray <- + newListArray + ((0, 0), (numXs - 1, numYs - 1)) + [compatible x y | x <- xs, y <- ys] :: + ST s (STArray s (Int, Int) Bool) + matchArray <- + newArray (0, numXs - 1) Nothing :: + ST s (STArray s Int (Maybe Int)) + forM_ [0 .. numYs - 1] $ \j -> do + seen <- + newArray (0, numXs - 1) False :: ST s (STArray s Int Bool) + _ <- go compatArray j matchArray seen + return () + + return matchArray + + numXs, numYs :: Int + numXs = length xs + numYs = length ys + + go :: + forall s. + STArray s (Int, Int) Bool -> + Int -> + STArray s Int (Maybe Int) -> + STArray s Int Bool -> + ST s Bool + go compatArray j matchArray seen = loop False 0 + where + loop True _ = return True + loop _ i + | i == numXs = return False + | otherwise = do + compat <- readArray compatArray (i, j) + isSeen <- readArray seen i + replace <- + if isSeen || not compat + then return False + else do + writeArray seen i True + matchNum <- readArray matchArray i + case matchNum of + Nothing -> return True + Just n -> go compatArray n matchArray seen + when replace $ writeArray matchArray i (Just j) + loop replace (i + 1) diff --git a/test/Test/Predicates/Internal/Util.hs b/test/Test/Predicates/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Predicates/Internal/Util.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Internal utilities used for HMock implementation. +module Test.Predicates.Internal.Util where + +import Data.Generics (Data, everywhere, mkT) +import GHC.Stack (CallStack, getCallStack, prettySrcLoc) +import Language.Haskell.TH.Syntax (NameFlavour (..)) + +#ifdef CONTAINERS +import Data.MonoTraversable (Element) +import qualified Data.Sequences as Seq +#endif + +-- | A value together with its source location. +data Located a = Loc (Maybe String) a deriving (Functor) + +-- | Annotates a value with its source location from the call stack. +locate :: CallStack -> a -> Located a +locate stack = case map snd (getCallStack stack) of + (loc : _) -> Loc (Just (prettySrcLoc loc)) + _ -> Loc Nothing + +-- | Formats a 'Located' 'String' to include its source location. +withLoc :: Located String -> String +withLoc (Loc Nothing s) = s +withLoc (Loc (Just loc) s) = s ++ " at " ++ loc + +-- | Returns all ways to choose one element from a list, and the corresponding +-- remaining list. +choices :: [a] -> [(a, [a])] +choices [] = [] +choices (x : xs) = (x, xs) : (fmap (x :) <$> choices xs) + +#ifdef CONTAINERS + +-- | Checks if one sequence is a subsequence of another. +isSubsequenceOf :: (Seq.IsSequence t, Eq (Element t)) => t -> t -> Bool +xs `isSubsequenceOf` ys = case Seq.uncons xs of + Nothing -> True + Just (x, xs') -> case Seq.uncons (snd (Seq.break (== x) ys)) of + Nothing -> False + Just (_, ys') -> xs' `isSubsequenceOf` ys' + +#endif + +-- | Removes all module names from Template Haskell names in the given value, so +-- that it will pretty-print more cleanly. +removeModNames :: Data a => a -> a +removeModNames = everywhere (mkT unMod) + where + unMod NameG {} = NameS + unMod other = other