diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for explainable-predicates + +## 0.1.0.0 -- 2021-09-18 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Chris Smith + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Smith nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/explainable-predicates.cabal b/explainable-predicates.cabal new file mode 100644 --- /dev/null +++ b/explainable-predicates.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.4 +name: explainable-predicates +version: 0.1.0.0 +synopsis: Predicates that can explain themselves. +description: Explainable predicates 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. For example, if a + collection is missing an element, an explainable predicate + can tell you which element is missing. +category: Testing +homepage: https://github.com/cdsmith/explainable-predicates +bug-reports: https://github.com/cdsmith/explainable-predicates/issues +license: BSD-3-Clause +license-file: LICENSE + +author: Chris Smith +maintainer: Chris Smith + +extra-source-files: CHANGELOG.md + +tested-with: GHC == 8.4.4 || == 8.6.5 || == 8.8.4 || == 8.10.4 || == 9.0.1 + +source-repository head + type: git + location: git://github.com/cdsmith/explainable-predicates.git + +library + exposed-modules: Test.Predicates, + Test.Predicates.Internal.FlowMatcher + other-modules: Test.Predicates.Internal.Util + build-depends: array >= 0.5.2 && < 0.6, + base >=4.11.0 && < 4.16, + mono-traversable >= 1.0.15 && < 1.1, + regex-tdfa >= 1.3.1 && < 1.4, + syb >= 0.7.2 && < 0.8, + template-haskell >= 2.13.0 && < 2.18, + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: DocTests.All, + DocTests.Test.Predicates, + DocTests.Test.Predicates.Internal.FlowMatcher + build-depends: base, + doctest-exitcode-stdio, + doctest-lib, + explainable-predicates, + hspec, + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -Wall -Wcompat -Wincomplete-uni-patterns diff --git a/src/Test/Predicates.hs b/src/Test/Predicates.hs new file mode 100644 --- /dev/null +++ b/src/Test/Predicates.hs @@ -0,0 +1,1312 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | 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 (..), + + -- * Predicate combinators + anything, + eq, + neq, + gt, + geq, + lt, + leq, + just, + nothing, + left, + right, + zipP, + zip3P, + zip4P, + zip5P, + andP, + orP, + notP, + startsWith, + endsWith, + hasSubstr, + hasSubsequence, + caseInsensitive, + matchesRegex, + matchesCaseInsensitiveRegex, + containsRegex, + containsCaseInsensitiveRegex, + isEmpty, + nonEmpty, + sizeIs, + elemsAre, + unorderedElemsAre, + each, + contains, + containsAll, + containsOnly, + keys, + values, + approxEq, + positive, + negative, + nonPositive, + nonNegative, + finite, + infinite, + nAn, + is, + qIs, + with, + qWith, + qMatch, + typed, + ) +where + +import Data.Char (toUpper) +import Data.List (intercalate) +import Data.Maybe (catMaybes, isJust, isNothing) +import Data.MonoTraversable (Element, MonoFoldable (..), MonoFunctor (..)) +import qualified Data.Sequences as Seq +import Data.Typeable (Proxy (..), Typeable, cast, typeRep) +import GHC.Exts (IsList (Item, toList)) +import GHC.Stack (HasCallStack, callStack) +import Language.Haskell.TH (ExpQ, PatQ, pprint) +import Language.Haskell.TH.Syntax (lift) +import Test.Predicates.Internal.FlowMatcher (bipartiteMatching) +import Test.Predicates.Internal.Util + ( isSubsequenceOf, + locate, + removeModNames, + withLoc, + ) +import Text.Regex.TDFA + ( CompOption (caseSensitive, lastStarGreedy, newSyntax), + ExecOption (captureGroups), + Extract (empty), + Regex, + RegexLike (matchOnce, matchOnceText), + RegexMaker (makeRegexOpts), + RegexOptions (defaultCompOpt, defaultExecOpt), + ) + +-- $setup +-- >>> :set -XTemplateHaskell +-- >>> :set -XTypeApplications +-- >>> :set -Wno-type-defaults + +-- | A predicate, which tests values and either accepts or rejects them. This +-- is similar to @a -> 'Bool'@, but also 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 + +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 + } + +-- | 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 '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} + +-- | 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 + } + +-- | 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. +-- +-- >>> 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 description for error +-- messages. +-- +-- >>> 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. +-- +-- >>> 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") + +-- | A Template Haskell splice that acts like 'is', but receives a quoted typed +-- expression at compile time and has a more helpful description for error +-- messages. +-- +-- >>> accept ($(qWith [| abs |]) (gt 5)) (-6) +-- True +-- >>> accept ($(qWith [| abs |]) (gt 5)) (-5) +-- False +-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "hello" +-- True +-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye" +-- False +-- +-- >>> show ($(qWith [| abs |]) (gt 5)) +-- "abs: > 5" +qWith :: ExpQ -> ExpQ +qWith f = + [| + \p -> + Predicate + { showPredicate = $prop ++ ": " ++ show p, + showNegation = $prop ++ ": " ++ showNegation p, + accept = accept p . $f, + explain = (($prop ++ ": ") ++) . explain p . $f + } + |] + where + prop = lift . pprint . removeModNames =<< f + +-- | A Template Haskell splice that turns a quoted pattern into a predicate that +-- accepts values that match the pattern. +-- +-- >>> accept $(qMatch [p| Just (Left _) |]) Nothing +-- False +-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Left 5)) +-- True +-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Right 5)) +-- False +-- +-- >>> show $(qMatch [p| Just (Left _) |]) +-- "Just (Left _)" +qMatch :: PatQ -> ExpQ +qMatch qpat = + [| + Predicate + { showPredicate = $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/src/Test/Predicates/Internal/FlowMatcher.hs b/src/Test/Predicates/Internal/FlowMatcher.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Test/Predicates/Internal/Util.hs b/src/Test/Predicates/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Predicates/Internal/Util.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Internal utilities used for HMock implementation. +module Test.Predicates.Internal.Util where + +import Data.Generics (Data, everywhere, mkT) +import Data.MonoTraversable (Element) +import qualified Data.Sequences as Seq +import GHC.Stack (CallStack, getCallStack, prettySrcLoc) +import Language.Haskell.TH.Syntax (NameFlavour (..)) + +-- | 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) + +-- | 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' + +-- | 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 diff --git a/test/DocTests/All.hs b/test/DocTests/All.hs new file mode 100644 --- /dev/null +++ b/test/DocTests/All.hs @@ -0,0 +1,12 @@ +-- Do not edit! Automatically created with doctest-extract. +module DocTests.All where + +import qualified DocTests.Test.Predicates +import qualified DocTests.Test.Predicates.Internal.FlowMatcher + +import qualified Test.DocTest.Driver as DocTest + +main :: DocTest.T () +main = do + DocTests.Test.Predicates.test + DocTests.Test.Predicates.Internal.FlowMatcher.test diff --git a/test/DocTests/Test/Predicates.hs b/test/DocTests/Test/Predicates.hs new file mode 100644 --- /dev/null +++ b/test/DocTests/Test/Predicates.hs @@ -0,0 +1,928 @@ +-- Do not edit! Automatically created with doctest-extract from src/Test/Predicates.hs +{-# LINE 90 "src/Test/Predicates.hs" #-} + +{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# OPTIONS_GHC -XTypeApplications #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +module DocTests.Test.Predicates where + +import Test.Predicates +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 94 "src/Test/Predicates.hs" #-} + +test :: DocTest.T () +test = do + DocTest.printPrefix "Test.Predicates:121: " +{-# LINE 121 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 121 "src/Test/Predicates.hs" #-} + (accept anything "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:123: " +{-# LINE 123 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 123 "src/Test/Predicates.hs" #-} + (accept anything undefined) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:136: " +{-# LINE 136 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 136 "src/Test/Predicates.hs" #-} + (accept (eq "foo") "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:138: " +{-# LINE 138 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 138 "src/Test/Predicates.hs" #-} + (accept (eq "foo") "bar") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:154: " +{-# LINE 154 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 154 "src/Test/Predicates.hs" #-} + (accept (neq "foo") "foo") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:156: " +{-# LINE 156 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 156 "src/Test/Predicates.hs" #-} + (accept (neq "foo") "bar") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:163: " +{-# LINE 163 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 163 "src/Test/Predicates.hs" #-} + (accept (gt 5) 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:165: " +{-# LINE 165 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 165 "src/Test/Predicates.hs" #-} + (accept (gt 5) 5) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:167: " +{-# LINE 167 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 167 "src/Test/Predicates.hs" #-} + (accept (gt 5) 6) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:181: " +{-# LINE 181 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 181 "src/Test/Predicates.hs" #-} + (accept (geq 5) 4) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:183: " +{-# LINE 183 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 183 "src/Test/Predicates.hs" #-} + (accept (geq 5) 5) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:185: " +{-# LINE 185 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 185 "src/Test/Predicates.hs" #-} + (accept (geq 5) 6) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:198: " +{-# LINE 198 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 198 "src/Test/Predicates.hs" #-} + (accept (lt 5) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:200: " +{-# LINE 200 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 200 "src/Test/Predicates.hs" #-} + (accept (lt 5) 5) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:202: " +{-# LINE 202 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 202 "src/Test/Predicates.hs" #-} + (accept (lt 5) 6) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:209: " +{-# LINE 209 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 209 "src/Test/Predicates.hs" #-} + (accept (leq 5) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:211: " +{-# LINE 211 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 211 "src/Test/Predicates.hs" #-} + (accept (leq 5) 5) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:213: " +{-# LINE 213 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 213 "src/Test/Predicates.hs" #-} + (accept (leq 5) 6) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:221: " +{-# LINE 221 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 221 "src/Test/Predicates.hs" #-} + (accept (just (eq "value")) Nothing) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:223: " +{-# LINE 223 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 223 "src/Test/Predicates.hs" #-} + (accept (just (eq "value")) (Just "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:225: " +{-# LINE 225 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 225 "src/Test/Predicates.hs" #-} + (accept (just (eq "value")) (Just "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:239: " +{-# LINE 239 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 239 "src/Test/Predicates.hs" #-} + (accept nothing Nothing) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:242: " +{-# LINE 242 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 242 "src/Test/Predicates.hs" #-} + (accept nothing (Just "something")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:256: " +{-# LINE 256 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 256 "src/Test/Predicates.hs" #-} + (accept (left (eq "value")) (Left "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:258: " +{-# LINE 258 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 258 "src/Test/Predicates.hs" #-} + (accept (left (eq "value")) (Right "value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:260: " +{-# LINE 260 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 260 "src/Test/Predicates.hs" #-} + (accept (left (eq "value")) (Left "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:274: " +{-# LINE 274 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 274 "src/Test/Predicates.hs" #-} + (accept (right (eq "value")) (Right "value")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:276: " +{-# LINE 276 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 276 "src/Test/Predicates.hs" #-} + (accept (right (eq "value")) (Right "wrong value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:278: " +{-# LINE 278 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 278 "src/Test/Predicates.hs" #-} + (accept (right (eq "value")) (Left "value")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:292: " +{-# LINE 292 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 292 "src/Test/Predicates.hs" #-} + (accept (zipP (eq "foo") (eq "bar")) ("foo", "bar")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:294: " +{-# LINE 294 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 294 "src/Test/Predicates.hs" #-} + (accept (zipP (eq "foo") (eq "bar")) ("bar", "foo")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:318: " +{-# LINE 318 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 318 "src/Test/Predicates.hs" #-} + (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("foo", "bar", "qux")) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:320: " +{-# LINE 320 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 320 "src/Test/Predicates.hs" #-} + (accept (zip3P (eq "foo") (eq "bar") (eq "qux")) ("qux", "bar", "foo")) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:345: " +{-# LINE 345 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 345 "src/Test/Predicates.hs" #-} + (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (1, 2, 3, 4)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:347: " +{-# LINE 347 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 347 "src/Test/Predicates.hs" #-} + (accept (zip4P (eq 1) (eq 2) (eq 3) (eq 4)) (4, 3, 2, 1)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:378: " +{-# LINE 378 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 378 "src/Test/Predicates.hs" #-} + (accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (1, 2, 3, 4, 5)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:380: " +{-# LINE 380 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 380 "src/Test/Predicates.hs" #-} + (accept (zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5)) (5, 4, 3, 2, 1)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:412: " +{-# LINE 412 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 412 "src/Test/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "eta") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:414: " +{-# LINE 414 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 414 "src/Test/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "quz") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:416: " +{-# LINE 416 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 416 "src/Test/Predicates.hs" #-} + (accept (lt "foo" `andP` gt "bar") "alpha") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:433: " +{-# LINE 433 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 433 "src/Test/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "eta") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:435: " +{-# LINE 435 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 435 "src/Test/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "quz") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:437: " +{-# LINE 437 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 437 "src/Test/Predicates.hs" #-} + (accept (lt "bar" `orP` gt "foo") "alpha") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:445: " +{-# LINE 445 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 445 "src/Test/Predicates.hs" #-} + (accept (notP (eq "negative")) "positive") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:447: " +{-# LINE 447 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 447 "src/Test/Predicates.hs" #-} + (accept (notP (eq "negative")) "negative") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:460: " +{-# LINE 460 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 460 "src/Test/Predicates.hs" #-} + (accept (startsWith "fun") "fungible") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:462: " +{-# LINE 462 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 462 "src/Test/Predicates.hs" #-} + (accept (startsWith "gib") "fungible") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:475: " +{-# LINE 475 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 475 "src/Test/Predicates.hs" #-} + (accept (endsWith "ow") "crossbow") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:477: " +{-# LINE 477 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 477 "src/Test/Predicates.hs" #-} + (accept (endsWith "ow") "trebuchet") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:491: " +{-# LINE 491 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 491 "src/Test/Predicates.hs" #-} + (accept (hasSubstr "i") "team") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:493: " +{-# LINE 493 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 493 "src/Test/Predicates.hs" #-} + (accept (hasSubstr "i") "partnership") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:507: " +{-# LINE 507 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 507 "src/Test/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [1, 2, 3, 4, 5]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:509: " +{-# LINE 509 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 509 "src/Test/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [0, 1, 0, 2, 0, 3, 0, 4, 0, 5, 0]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:511: " +{-# LINE 511 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 511 "src/Test/Predicates.hs" #-} + (accept (hasSubsequence [1..5]) [2, 3, 5, 7, 11]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:525: " +{-# LINE 525 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 525 "src/Test/Predicates.hs" #-} + (accept (caseInsensitive startsWith "foo") "FOOTBALL!") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:527: " +{-# LINE 527 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 527 "src/Test/Predicates.hs" #-} + (accept (caseInsensitive endsWith "ball") "soccer") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:529: " +{-# LINE 529 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 529 "src/Test/Predicates.hs" #-} + (accept (caseInsensitive eq "time") "TIME") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:531: " +{-# LINE 531 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 531 "src/Test/Predicates.hs" #-} + (accept (caseInsensitive gt "NOTHING") "everything") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:558: " +{-# LINE 558 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 558 "src/Test/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "xxxy") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:560: " +{-# LINE 560 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 560 "src/Test/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "xyy") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:562: " +{-# LINE 562 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 562 "src/Test/Predicates.hs" #-} + (accept (matchesRegex "x{2,5}y?") "wxxxyz") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:592: " +{-# LINE 592 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 592 "src/Test/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XXXY") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:594: " +{-# LINE 594 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 594 "src/Test/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "XYY") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:596: " +{-# LINE 596 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 596 "src/Test/Predicates.hs" #-} + (accept (matchesCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:632: " +{-# LINE 632 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 632 "src/Test/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "xxxy") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:634: " +{-# LINE 634 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 634 "src/Test/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "xyy") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:636: " +{-# LINE 636 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 636 "src/Test/Predicates.hs" #-} + (accept (containsRegex "x{2,5}y?") "wxxxyz") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:660: " +{-# LINE 660 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 660 "src/Test/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XXXY") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:662: " +{-# LINE 662 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 662 "src/Test/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "XYY") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:664: " +{-# LINE 664 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 664 "src/Test/Predicates.hs" #-} + (accept (containsCaseInsensitiveRegex "x{2,5}y?") "WXXXYZ") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:688: " +{-# LINE 688 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 688 "src/Test/Predicates.hs" #-} + (accept isEmpty ([] :: [Int])) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:690: " +{-# LINE 690 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 690 "src/Test/Predicates.hs" #-} + (accept isEmpty [1, 2, 3]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:692: " +{-# LINE 692 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 692 "src/Test/Predicates.hs" #-} + (accept isEmpty "") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:694: " +{-# LINE 694 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 694 "src/Test/Predicates.hs" #-} + (accept isEmpty "gas tank") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:707: " +{-# LINE 707 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 707 "src/Test/Predicates.hs" #-} + (accept nonEmpty ([] :: [Int])) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:709: " +{-# LINE 709 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 709 "src/Test/Predicates.hs" #-} + (accept nonEmpty [1, 2, 3]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:711: " +{-# LINE 711 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 711 "src/Test/Predicates.hs" #-} + (accept nonEmpty "") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:713: " +{-# LINE 713 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 713 "src/Test/Predicates.hs" #-} + (accept nonEmpty "gas tank") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:721: " +{-# LINE 721 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 721 "src/Test/Predicates.hs" #-} + (accept (sizeIs (lt 3)) ['a' .. 'f']) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:723: " +{-# LINE 723 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 723 "src/Test/Predicates.hs" #-} + (accept (sizeIs (lt 3)) ['a' .. 'b']) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:744: " +{-# LINE 744 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 744 "src/Test/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:746: " +{-# LINE 746 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 746 "src/Test/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 3, 4, 5]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:748: " +{-# LINE 748 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 748 "src/Test/Predicates.hs" #-} + (accept (elemsAre [lt 3, lt 4, lt 5]) [2, 10, 4]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:780: " +{-# LINE 780 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 780 "src/Test/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:782: " +{-# LINE 782 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 782 "src/Test/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [2, 3, 1]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:784: " +{-# LINE 784 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 784 "src/Test/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 2, 3, 4]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:786: " +{-# LINE 786 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 786 "src/Test/Predicates.hs" #-} + (accept (unorderedElemsAre [eq 1, eq 2, eq 3]) [1, 3]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:833: " +{-# LINE 833 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 833 "src/Test/Predicates.hs" #-} + (accept (each (gt 5)) [4, 5, 6]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:835: " +{-# LINE 835 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 835 "src/Test/Predicates.hs" #-} + (accept (each (gt 5)) [6, 7, 8]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:837: " +{-# LINE 837 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 837 "src/Test/Predicates.hs" #-} + (accept (each (gt 5)) []) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:862: " +{-# LINE 862 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 862 "src/Test/Predicates.hs" #-} + (accept (contains (gt 5)) [3, 4, 5]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:864: " +{-# LINE 864 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 864 "src/Test/Predicates.hs" #-} + (accept (contains (gt 5)) [4, 5, 6]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:866: " +{-# LINE 866 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 866 "src/Test/Predicates.hs" #-} + (accept (contains (gt 5)) []) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:874: " +{-# LINE 874 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 874 "src/Test/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["bar", "foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:876: " +{-# LINE 876 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 876 "src/Test/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["foo"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:878: " +{-# LINE 878 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 878 "src/Test/Predicates.hs" #-} + (accept (containsAll [eq "foo", eq "bar"]) ["foo", "bar", "qux"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:886: " +{-# LINE 886 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 886 "src/Test/Predicates.hs" #-} + (accept (containsAll [startsWith "f", endsWith "o"]) ["foo"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:888: " +{-# LINE 888 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 888 "src/Test/Predicates.hs" #-} + (accept (contains (startsWith "f") `andP` contains (endsWith "o")) ["foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:910: " +{-# LINE 910 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 910 "src/Test/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:912: " +{-# LINE 912 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 912 "src/Test/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:914: " +{-# LINE 914 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 914 "src/Test/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:921: " +{-# LINE 921 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 921 "src/Test/Predicates.hs" #-} + (accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:923: " +{-# LINE 923 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 923 "src/Test/Predicates.hs" #-} + (accept (each (eq "foo" `orP` eq "bar")) ["foo", "foo"]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:949: " +{-# LINE 949 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 949 "src/Test/Predicates.hs" #-} + (accept (keys (each (eq "foo"))) [("foo", 5)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:952: " +{-# LINE 952 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 952 "src/Test/Predicates.hs" #-} + (accept (keys (each (eq "foo"))) [("foo", 5), ("bar", 6)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:968: " +{-# LINE 968 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 968 "src/Test/Predicates.hs" #-} + (accept (values (each (eq 5))) [("foo", 5), ("bar", 5)]) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:971: " +{-# LINE 971 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 971 "src/Test/Predicates.hs" #-} + (accept (values (each (eq 5))) [("foo", 5), ("bar", 6)]) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:989: " +{-# LINE 989 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 989 "src/Test/Predicates.hs" #-} + (accept (eq 1.0) (sum (replicate 100 0.01))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:996: " +{-# LINE 996 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 996 "src/Test/Predicates.hs" #-} + (accept (approxEq 1.0) (sum (replicate 100 0.01))) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:998: " +{-# LINE 998 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 998 "src/Test/Predicates.hs" #-} + (accept (approxEq 1.0) (sum (replicate 100 0.009999))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1013: " +{-# LINE 1013 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1013 "src/Test/Predicates.hs" #-} + (accept positive 1) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1016: " +{-# LINE 1016 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1016 "src/Test/Predicates.hs" #-} + (accept positive 0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1019: " +{-# LINE 1019 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1019 "src/Test/Predicates.hs" #-} + (accept positive (-1)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1037: " +{-# LINE 1037 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1037 "src/Test/Predicates.hs" #-} + (accept negative 1) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1040: " +{-# LINE 1040 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1040 "src/Test/Predicates.hs" #-} + (accept negative 0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1043: " +{-# LINE 1043 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1043 "src/Test/Predicates.hs" #-} + (accept negative (-1)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1062: " +{-# LINE 1062 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1062 "src/Test/Predicates.hs" #-} + (accept nonPositive 1) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1065: " +{-# LINE 1065 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1065 "src/Test/Predicates.hs" #-} + (accept nonPositive 0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1068: " +{-# LINE 1068 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1068 "src/Test/Predicates.hs" #-} + (accept nonPositive (-1)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1076: " +{-# LINE 1076 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1076 "src/Test/Predicates.hs" #-} + (accept nonNegative 1) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1079: " +{-# LINE 1079 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1079 "src/Test/Predicates.hs" #-} + (accept nonNegative 0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1082: " +{-# LINE 1082 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1082 "src/Test/Predicates.hs" #-} + (accept nonNegative (-1)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1089: " +{-# LINE 1089 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1089 "src/Test/Predicates.hs" #-} + (accept finite 1.0) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1091: " +{-# LINE 1091 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1091 "src/Test/Predicates.hs" #-} + (accept finite (0 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1093: " +{-# LINE 1093 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1093 "src/Test/Predicates.hs" #-} + (accept finite (1 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1111: " +{-# LINE 1111 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1111 "src/Test/Predicates.hs" #-} + (accept infinite 1.0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1113: " +{-# LINE 1113 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1113 "src/Test/Predicates.hs" #-} + (accept infinite (0 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1115: " +{-# LINE 1115 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1115 "src/Test/Predicates.hs" #-} + (accept infinite (1 / 0)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1131: " +{-# LINE 1131 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1131 "src/Test/Predicates.hs" #-} + (accept nAn 1.0) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1133: " +{-# LINE 1133 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1133 "src/Test/Predicates.hs" #-} + (accept nAn (0 / 0)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1135: " +{-# LINE 1135 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1135 "src/Test/Predicates.hs" #-} + (accept nAn (1 / 0)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1153: " +{-# LINE 1153 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1153 "src/Test/Predicates.hs" #-} + (accept (is even) 3) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1155: " +{-# LINE 1155 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1155 "src/Test/Predicates.hs" #-} + (accept (is even) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1173: " +{-# LINE 1173 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1173 "src/Test/Predicates.hs" #-} + (accept $(qIs [| even |]) 3) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1175: " +{-# LINE 1175 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1175 "src/Test/Predicates.hs" #-} + (accept $(qIs [| even |]) 4) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1178: " +{-# LINE 1178 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1178 "src/Test/Predicates.hs" #-} + (show $(qIs [| even |])) + [ExpectedLine [LineChunk "\"even\""]] + DocTest.printPrefix "Test.Predicates:1196: " +{-# LINE 1196 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1196 "src/Test/Predicates.hs" #-} + (accept (with abs (gt 5)) (-6)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1198: " +{-# LINE 1198 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1198 "src/Test/Predicates.hs" #-} + (accept (with abs (gt 5)) (-5)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1200: " +{-# LINE 1200 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1200 "src/Test/Predicates.hs" #-} + (accept (with reverse (eq "olleh")) "hello") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1202: " +{-# LINE 1202 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1202 "src/Test/Predicates.hs" #-} + (accept (with reverse (eq "olleh")) "goodbye") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1219: " +{-# LINE 1219 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1219 "src/Test/Predicates.hs" #-} + (accept ($(qWith [| abs |]) (gt 5)) (-6)) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1221: " +{-# LINE 1221 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1221 "src/Test/Predicates.hs" #-} + (accept ($(qWith [| abs |]) (gt 5)) (-5)) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1223: " +{-# LINE 1223 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1223 "src/Test/Predicates.hs" #-} + (accept ($(qWith [| reverse |]) (eq "olleh")) "hello") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1225: " +{-# LINE 1225 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1225 "src/Test/Predicates.hs" #-} + (accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1228: " +{-# LINE 1228 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1228 "src/Test/Predicates.hs" #-} + (show ($(qWith [| abs |]) (gt 5))) + [ExpectedLine [LineChunk "\"abs: > 5\""]] + DocTest.printPrefix "Test.Predicates:1247: " +{-# LINE 1247 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1247 "src/Test/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) Nothing) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1249: " +{-# LINE 1249 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1249 "src/Test/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) (Just (Left 5))) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1251: " +{-# LINE 1251 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1251 "src/Test/Predicates.hs" #-} + (accept $(qMatch [p| Just (Left _) |]) (Just (Right 5))) + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1254: " +{-# LINE 1254 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1254 "src/Test/Predicates.hs" #-} + (show $(qMatch [p| Just (Left _) |])) + [ExpectedLine [LineChunk "\"Just (Left _)\""]] + DocTest.printPrefix "Test.Predicates:1276: " +{-# LINE 1276 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1276 "src/Test/Predicates.hs" #-} + (accept (typed @String anything) "foo") + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Test.Predicates:1278: " +{-# LINE 1278 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1278 "src/Test/Predicates.hs" #-} + (accept (typed @String (sizeIs (gt 5))) "foo") + [ExpectedLine [LineChunk "False"]] + DocTest.printPrefix "Test.Predicates:1280: " +{-# LINE 1280 "src/Test/Predicates.hs" #-} + DocTest.example +{-# LINE 1280 "src/Test/Predicates.hs" #-} + (accept (typed @String anything) (42 :: Int)) + [ExpectedLine [LineChunk "False"]] diff --git a/test/DocTests/Test/Predicates/Internal/FlowMatcher.hs b/test/DocTests/Test/Predicates/Internal/FlowMatcher.hs new file mode 100644 --- /dev/null +++ b/test/DocTests/Test/Predicates/Internal/FlowMatcher.hs @@ -0,0 +1,20 @@ +-- Do not edit! Automatically created with doctest-extract from src/Test/Predicates/Internal/FlowMatcher.hs +{-# LINE 14 "src/Test/Predicates/Internal/FlowMatcher.hs" #-} + +{-# OPTIONS_GHC -Wno-type-defaults #-} +module DocTests.Test.Predicates.Internal.FlowMatcher where + +import Test.Predicates.Internal.FlowMatcher +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 16 "src/Test/Predicates/Internal/FlowMatcher.hs" #-} + +test :: DocTest.T () +test = do + DocTest.printPrefix "Test.Predicates.Internal.FlowMatcher:23: " +{-# LINE 23 "src/Test/Predicates/Internal/FlowMatcher.hs" #-} + DocTest.example +{-# LINE 23 "src/Test/Predicates/Internal/FlowMatcher.hs" #-} + (bipartiteMatching (==) [1 .. 5] [6, 5 .. 2]) + [ExpectedLine [LineChunk "([(2,2),(3,3),(4,4),(5,5)],[1],[6])"]] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +import Data.List (isPrefixOf) +import Data.Typeable (Typeable) +import qualified DocTests.All +import qualified Test.DocTest.Driver as DocTest +import Test.Hspec +import Test.Predicates + +main :: IO () +main = do + hspec predicateTests + DocTest.run DocTests.All.main + +predicateTests :: SpecWith () +predicateTests = do + describe "Predicate" $ do + it "describes itself" $ + example $ do + show anything `shouldBe` "anything" + show (eq "foo") `shouldBe` "\"foo\"" + show (neq "foo") `shouldBe` "≠ \"foo\"" + show (gt "foo") `shouldBe` "> \"foo\"" + show (geq "foo") `shouldBe` "≥ \"foo\"" + show (lt "foo") `shouldBe` "< \"foo\"" + show (leq "foo") `shouldBe` "≤ \"foo\"" + show (just (gt "foo")) `shouldBe` "Just (> \"foo\")" + show (left (gt "foo")) `shouldBe` "Left (> \"foo\")" + show (right (gt "foo")) `shouldBe` "Right (> \"foo\")" + show (zipP (eq 1) (eq 2) :: Predicate (Int, Int)) `shouldBe` "(1,2)" + show (zip3P (eq 1) (eq 2) (eq 3) :: Predicate (Int, Int, Int)) + `shouldBe` "(1,2,3)" + show + ( zip4P (eq 1) (eq 2) (eq 3) (eq 4) :: + Predicate (Int, Int, Int, Int) + ) + `shouldBe` "(1,2,3,4)" + show + ( zip5P (eq 1) (eq 2) (eq 3) (eq 4) (eq 5) :: + Predicate (Int, Int, Int, Int, Int) + ) + `shouldBe` "(1,2,3,4,5)" + show (lt "foo" `andP` gt "bar") + `shouldBe` "< \"foo\" and > \"bar\"" + show (lt "bar" `orP` gt "foo") + `shouldBe` "< \"bar\" or > \"foo\"" + show (notP (gt "foo")) `shouldBe` "≤ \"foo\"" + show (startsWith "fun") `shouldBe` "starts with \"fun\"" + show (endsWith "ing") `shouldBe` "ends with \"ing\"" + show (hasSubstr "i") `shouldBe` "has substring \"i\"" + show (hasSubsequence "abc") `shouldBe` "has subsequence \"abc\"" + show (caseInsensitive eq "foo") `shouldBe` "(case insensitive) \"foo\"" + show (caseInsensitive startsWith "foo") + `shouldBe` "(case insensitive) starts with \"foo\"" + show (caseInsensitive endsWith "foo") + `shouldBe` "(case insensitive) ends with \"foo\"" + show (matchesRegex "foo" :: Predicate String) + `shouldBe` "/foo/" + show (matchesCaseInsensitiveRegex "foo" :: Predicate String) + `shouldBe` "/foo/i" + show (containsRegex "foo" :: Predicate String) + `shouldBe` "contains /foo/" + show (containsCaseInsensitiveRegex "foo" :: Predicate String) + `shouldBe` "contains /foo/i" + show (isEmpty :: Predicate [()]) `shouldBe` "empty" + show (nonEmpty :: Predicate [()]) `shouldBe` "non-empty" + show (sizeIs (gt 5) :: Predicate [()]) `shouldBe` "size > 5" + show (elemsAre [gt 5, eq 5] :: Predicate [Int]) `shouldBe` "[> 5,5]" + show (unorderedElemsAre [gt 5, eq 5] :: Predicate [Int]) + `shouldBe` "(any order) [> 5,5]" + show (each (gt 5) :: Predicate [Int]) `shouldBe` "each (> 5)" + show (contains (gt 5) :: Predicate [Int]) `shouldBe` "contains (> 5)" + show (containsAll [gt 5] :: Predicate [Int]) + `shouldBe` "contains all of [> 5]" + show (containsOnly [gt 5] :: Predicate [Int]) + `shouldBe` "contains only [> 5]" + show (keys (contains (eq "foo")) :: Predicate [(String, String)]) + `shouldBe` "keys (contains (\"foo\"))" + show + ( contains (eq "foo" `zipP` eq "bar") :: + Predicate [(String, String)] + ) + `shouldBe` "contains ((\"foo\",\"bar\"))" + show + ( keys (unorderedElemsAre [eq 1, eq 2, eq 3]) :: + Predicate [(Int, String)] + ) + `shouldBe` "keys ((any order) [1,2,3])" + show + (values (elemsAre [eq "one", eq "two"]) :: Predicate [(Int, String)]) + `shouldBe` "values ([\"one\",\"two\"])" + show (approxEq 1.0 :: Predicate Double) `shouldBe` "≈ 1.0" + show (finite :: Predicate Double) `shouldBe` "finite" + show (infinite :: Predicate Double) `shouldBe` "infinite" + show (positive :: Predicate Double) `shouldBe` "positive" + show (negative :: Predicate Double) `shouldBe` "negative" + show (nonPositive :: Predicate Double) `shouldBe` "non-positive" + show (nonNegative :: Predicate Double) `shouldBe` "non-negative" + show (nAn :: Predicate Double) `shouldBe` "NaN" + show (is even :: Predicate Int) + `shouldSatisfy` ("custom predicate at " `isPrefixOf`) + show ($(qIs [|even|]) :: Predicate Int) `shouldBe` "even" + show (with length (gt 5) :: Predicate String) + `shouldSatisfy` ("property at " `isPrefixOf`) + show ($(qWith [|length|]) (gt 5) :: Predicate String) + `shouldBe` "length: > 5" + + it "matches patterns" $ + example $ do + let p = $(qMatch [p|Just (Left _)|]) + show p `shouldBe` "Just (Left _)" + + accept p (Just (Left "foo")) `shouldBe` True + accept p (Just (Right "foo")) `shouldBe` False + accept p Nothing `shouldBe` False + + it "checks types" $ + example $ do + let p1 :: Typeable a => Predicate a + p1 = typed @String anything + + p2 :: Typeable a => Predicate a + p2 = typed @String (eq "foo") + + show (p1 :: Predicate String) + `shouldBe` "anything :: [Char]" + show (p1 :: Predicate Int) + `shouldBe` "anything :: [Char]" + + accept p1 "foo" `shouldBe` True + accept p1 "bar" `shouldBe` True + accept p1 () `shouldBe` False + accept p1 (5 :: Int) `shouldBe` False + + show (p2 :: Predicate String) + `shouldBe` "\"foo\" :: [Char]" + show (p2 :: Predicate Int) + `shouldBe` "\"foo\" :: [Char]" + + accept p2 "foo" `shouldBe` True + accept p2 "bar" `shouldBe` False + accept p2 (5 :: Int) `shouldBe` False