{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module defines 'Predicate's which you can use to match the arguments of
-- a method in your execution plan.
module Test.HMock.Predicates
  ( Predicate (..),
    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
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.HMock.Internal.FlowMatcher (bipartiteMatching)
import Test.HMock.Internal.TH (removeModNames)
import Test.HMock.Internal.Util (isSubsequenceOf, locate, withLoc)
import Text.Regex.TDFA hiding (match, matchAll)

-- $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 has a 'Show' instance to describe what
-- it is checking.
--
-- 'Predicate's are used to define which arguments a general matcher should
-- accept.
data Predicate a = Predicate
  { Predicate a -> String
showPredicate :: String,
    Predicate a -> String
showNegation :: String,
    Predicate a -> a -> Bool
accept :: a -> Bool,
    Predicate a -> a -> String
explain :: a -> String
  }

instance Show (Predicate a) where show :: Predicate a -> String
show = Predicate a -> String
forall a. Predicate a -> String
showPredicate

withDefaultExplain ::
  (a -> String) -> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain :: (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
format String
connector (a -> String) -> Predicate a
mk = Predicate a
p
  where
    p :: Predicate a
p = (a -> String) -> Predicate a
mk ((a -> String) -> Predicate a) -> (a -> String) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a
x ->
      if Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
        then a -> String
format a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
connector String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p
        else a -> String
format a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
connector String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p

-- | A 'Predicate' that accepts anything at all.
--
-- >>> accept anything "foo"
-- True
-- >>> accept anything undefined
-- True
anything :: Predicate a
anything :: Predicate a
anything =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"anything",
      showNegation :: String
showNegation = String
"nothing",
      accept :: a -> Bool
accept = Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True,
      explain :: a -> String
explain = String -> a -> String
forall a b. a -> b -> a
const String
"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 :: a -> Predicate a
eq a
x =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = a -> String
forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≠ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x),
      explain :: a -> String
explain = \a
y ->
        if a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x
          then a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
          else a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ≠ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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 :: a -> Predicate a
neq = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Eq a) => a -> Predicate a
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 :: a -> Predicate a
gt a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≤ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
x),
      explain :: a -> String
explain = a -> String
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 :: a -> Predicate a
geq a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"≥ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"< " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x),
      explain :: a -> String
explain = a -> String
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 :: a -> Predicate a
lt = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Ord a) => a -> Predicate a
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 :: a -> Predicate a
leq = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Ord a) => a -> Predicate a
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 :: Predicate a -> Predicate (Maybe a)
just Predicate a
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"Just (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Just (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Maybe a -> Bool
accept = \case Just a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x; Maybe a
_ -> Bool
False,
      explain :: Maybe a -> String
explain = \case Just a
x -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x; Maybe a
_ -> String
"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 (Maybe a)
nothing =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"Nothing",
      showNegation :: String
showNegation = String
"Just anything",
      accept :: Maybe a -> Bool
accept = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing,
      explain :: Maybe a -> String
explain = \case Maybe a
Nothing -> String
"Nothing = Nothing"; Maybe a
_ -> String
"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 :: Predicate a -> Predicate (Either a b)
left Predicate a
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"Left (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Left (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Either a b -> Bool
accept = \case Left a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x; Either a b
_ -> Bool
False,
      explain :: Either a b -> String
explain = \case Left a
x -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x; Either a b
_ -> String
"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 :: Predicate b -> Predicate (Either a b)
right Predicate b
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"Right (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showPredicate Predicate b
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Right (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showPredicate Predicate b
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Either a b -> Bool
accept = \case Right b
x -> Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p b
x; Either a b
_ -> Bool
False,
      explain :: Either a b -> String
explain = \case Right b
x -> Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p b
x; Either a b
_ -> String
"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 :: Predicate a -> Predicate b -> Predicate (a, b)
zipP Predicate a
p1 Predicate b
p2 =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = (Predicate a, Predicate b) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
      accept :: (a, b) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b) -> [(Bool, String)]) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> [(Bool, String)]
acceptAndExplain,
      explain :: (a, b) -> String
explain = \(a, b)
xs ->
        let results :: [(Bool, String)]
results = (a, b) -> [(Bool, String)]
acceptAndExplain (a, b)
xs
            significant :: [(Bool, String)]
significant
              | ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2) ->
      [ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
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 :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)
zip3P Predicate a
p1 Predicate b
p2 Predicate c
p3 =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
      accept :: (a, b, c) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c) -> [(Bool, String)]) -> (a, b, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c) -> [(Bool, String)]
acceptAndExplain,
      explain :: (a, b, c) -> String
explain = \(a, b, c)
xs ->
        let results :: [(Bool, String)]
results = (a, b, c) -> [(Bool, String)]
acceptAndExplain (a, b, c)
xs
            significant :: [(Bool, String)]
significant
              | ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b, c) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3) ->
      [ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
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 :: Predicate a
-> Predicate b
-> Predicate c
-> Predicate d
-> Predicate (a, b, c, d)
zip4P Predicate a
p1 Predicate b
p2 Predicate c
p3 Predicate d
p4 =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c, Predicate d) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4),
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c, Predicate d) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4),
      accept :: (a, b, c, d) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c, d) -> [(Bool, String)]) -> (a, b, c, d) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c, d) -> [(Bool, String)]
acceptAndExplain,
      explain :: (a, b, c, d) -> String
explain = \(a, b, c, d)
xs ->
        let results :: [(Bool, String)]
results = (a, b, c, d) -> [(Bool, String)]
acceptAndExplain (a, b, c, d)
xs
            significant :: [(Bool, String)]
significant
              | ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b, c, d) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3, d
x4) ->
      [ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
        (Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, Predicate d -> d -> String
forall a. Predicate a -> a -> String
explain Predicate d
p4 d
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 :: Predicate a
-> Predicate b
-> Predicate c
-> Predicate d
-> Predicate e
-> Predicate (a, b, c, d, e)
zip5P Predicate a
p1 Predicate b
p2 Predicate c
p3 Predicate d
p4 Predicate e
p5 =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c, Predicate d, Predicate e)
-> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4, Predicate e
p5),
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c, Predicate d, Predicate e)
-> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4, Predicate e
p5),
      accept :: (a, b, c, d, e) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c, d, e) -> [(Bool, String)]) -> (a, b, c, d, e) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain,
      explain :: (a, b, c, d, e) -> String
explain = \(a, b, c, d, e)
xs ->
        let results :: [(Bool, String)]
results = (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain (a, b, c, d, e)
xs
            significant :: [(Bool, String)]
significant
              | ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3, d
x4, e
x5) ->
      [ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
        (Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, Predicate d -> d -> String
forall a. Predicate a -> a -> String
explain Predicate d
p4 d
x4),
        (Predicate e -> e -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate e
p5 e
x5, Predicate e -> e -> String
forall a. Predicate a -> a -> String
explain Predicate e
p5 e
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
Predicate a
p andP :: Predicate a -> Predicate a -> Predicate a
`andP` Predicate a
q =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
q,
      showNegation :: String
showNegation = Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" or " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
q,
      accept :: a -> Bool
accept = \a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x Bool -> Bool -> Bool
&& Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x,
      explain :: a -> String
explain = \a
x ->
        if
            | Bool -> Bool
not (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x) -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x
            | Bool -> Bool
not (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x) -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
q a
x
            | Bool
otherwise -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
q a
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
Predicate a
p orP :: Predicate a -> Predicate a -> Predicate a
`orP` Predicate a
q = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
p Predicate a -> Predicate a -> Predicate a
forall a. Predicate a -> Predicate a -> Predicate a
`andP` Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
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 :: Predicate a -> Predicate a
notP Predicate a
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p,
      showNegation :: String
showNegation = Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p,
      accept :: a -> Bool
accept = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p,
      explain :: a -> String
explain = Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
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 :: t -> Predicate t
startsWith t
pfx = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"starts with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
pfx,
      showNegation :: String
showNegation = String
"doesn't start with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
pfx,
      accept :: t -> Bool
accept = (t
pfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isPrefixOf`),
      explain :: t -> String
explain = t -> String
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 :: t -> Predicate t
endsWith t
sfx = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"ends with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
sfx,
      showNegation :: String
showNegation = String
"doesn't end with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
sfx,
      accept :: t -> Bool
accept = (t
sfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isSuffixOf`),
      explain :: t -> String
explain = t -> String
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 :: t -> Predicate t
hasSubstr t
s = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"has substring " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
      showNegation :: String
showNegation = String
"doesn't have substring " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
      accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isInfixOf`),
      explain :: t -> String
explain = t -> String
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 :: t -> Predicate t
hasSubsequence t
s = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"has subsequence " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
      showNegation :: String
showNegation = String
"doesn't have subsequence " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
      accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isSubsequenceOf`),
      explain :: t -> String
explain = t -> String
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 :: (t -> Predicate a) -> t -> Predicate a
caseInsensitive t -> Predicate a
p t
s =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"(case insensitive) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Show a => a -> String
show (t -> Predicate a
p t
s),
      showNegation :: String
showNegation = String
"(case insensitive) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Show a => a -> String
show (Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (t -> Predicate a
p t
s)),
      accept :: a -> Bool
accept = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
capP (a -> Bool) -> (a -> a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element a -> Element a) -> a -> a
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element a -> Element a
toUpper,
      explain :: a -> String
explain = Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
capP (a -> String) -> (a -> a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element a -> Element a) -> a -> a
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element a -> Element a
toUpper
    }
  where
    capP :: Predicate a
capP = t -> Predicate a
p ((Element t -> Element t) -> t -> t
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element t -> Element t
toUpper t
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 :: String -> Predicate a
matchesRegex String
s =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
pat,
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = a -> Bool
accepts,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
accepts a
x
          then a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" matches " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
          else a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" doesn't match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
    }
  where
    pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
    accepts :: a -> Bool
accepts a
x = case Regex -> a -> Maybe (a, MatchText a, a)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
matchOnceText Regex
r a
x of
      Just (a
a, MatchText a
_, a
b) -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty
      Maybe (a, MatchText a, a)
Nothing -> Bool
False
    r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
    comp :: CompOption
comp = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
    exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
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 :: String -> Predicate a
matchesCaseInsensitiveRegex String
s =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
pat,
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = a -> Bool
accepts,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
accepts a
x
          then a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" matches " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
          else a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" doesn't match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
    }
  where
    pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/i"
    accepts :: a -> Bool
accepts a
x = case Regex -> a -> Maybe (a, MatchText a, a)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
matchOnceText Regex
r a
x of
      Just (a
a, MatchText a
_, a
b) -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty
      Maybe (a, MatchText a, a)
Nothing -> Bool
False
    r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
    comp :: CompOption
comp =
      CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
        { newSyntax :: Bool
newSyntax = Bool
True,
          lastStarGreedy :: Bool
lastStarGreedy = Bool
True,
          caseSensitive :: Bool
caseSensitive = Bool
False
        }
    exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
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 :: String -> Predicate a
containsRegex String
s = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      showNegation :: String
showNegation = String
"doesn't contain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MatchArray -> Bool) -> (a -> Maybe MatchArray) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> a -> Maybe MatchArray
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe MatchArray
matchOnce Regex
r,
      explain :: a -> String
explain = a -> String
explainImpl
    }
  where
    pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
    r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
    comp :: CompOption
comp = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
    exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
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 :: String -> Predicate a
containsCaseInsensitiveRegex String
s = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      showNegation :: String
showNegation = String
"doesn't contain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MatchArray -> Bool) -> (a -> Maybe MatchArray) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> a -> Maybe MatchArray
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe MatchArray
matchOnce Regex
r,
      explain :: a -> String
explain = a -> String
explainImpl
    }
  where
    pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/i"
    r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
    comp :: CompOption
comp =
      CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
        { newSyntax :: Bool
newSyntax = Bool
True,
          lastStarGreedy :: Bool
lastStarGreedy = Bool
True,
          caseSensitive :: Bool
caseSensitive = Bool
False
        }
    exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
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 :: Predicate t
isEmpty = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" is " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"empty",
      showNegation :: String
showNegation = String
"non-empty",
      accept :: t -> Bool
accept = t -> Bool
forall mono. MonoFoldable mono => mono -> Bool
onull,
      explain :: t -> String
explain = t -> String
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 :: Predicate t
nonEmpty = Predicate t -> Predicate t
forall a. Predicate a -> Predicate a
notP Predicate t
forall t. (MonoFoldable t, Show t) => Predicate t
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 :: Predicate Int -> Predicate t
sizeIs Predicate Int
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate Int -> String
forall a. Predicate a -> String
showPredicate Predicate Int
p,
      showNegation :: String
showNegation = String
"size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate Int -> String
forall a. Predicate a -> String
showNegation Predicate Int
p,
      accept :: t -> Bool
accept = Predicate Int -> Int -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate Int
p (Int -> Bool) -> (t -> Int) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength,
      explain :: t -> String
explain = \t
y ->
        let detail :: String
detail
              | Predicate Int -> Int -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate Int
p (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) = Predicate Int -> String
forall a. Predicate a -> String
showPredicate Predicate Int
p
              | Bool
otherwise = Predicate Int -> String
forall a. Predicate a -> String
showNegation Predicate Int
p
            detailStr :: String
detailStr
              | Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
detail = String
""
              | Bool
otherwise = String
", which is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
detail
         in t -> String
forall a. Show a => a -> String
show t
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 :: [Predicate (Element t)] -> Predicate t
elemsAre [Predicate (Element t)]
ps =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      accept :: t -> Bool
accept = \t
xs ->
        t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Predicate (Element t)] -> Int
forall mono. MonoFoldable mono => mono -> Int
olength [Predicate (Element t)]
ps
          Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Predicate (Element t) -> Element t -> Bool)
-> [Predicate (Element t)] -> [Element t] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept [Predicate (Element t)]
ps (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs)),
      explain :: t -> String
explain = \t
xs ->
        let results :: [(Bool, String)]
results = [Element t] -> [(Bool, String)]
acceptAndExplain (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs)
         in if
                | t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Predicate (Element t)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps ->
                  String
"wrong size (got "
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs)
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; expected "
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Predicate (Element t)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps)
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
                | ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results -> String
"elements are " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps
                | Bool
otherwise ->
                  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                    (Bool, String) -> String
forall a b. (a, b) -> b
snd ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
    }
  where
    acceptAndExplain :: [Element t] -> [(Bool, String)]
acceptAndExplain [Element t]
xs = (Int -> Predicate (Element t) -> Element t -> (Bool, String))
-> [Int]
-> [Predicate (Element t)]
-> [Element t]
-> [(Bool, String)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Predicate (Element t) -> Element t -> (Bool, String)
forall a a. Show a => a -> Predicate a -> a -> (Bool, String)
matchAndExplain [Int
1 :: Int ..] [Predicate (Element t)]
ps [Element t]
xs
    matchAndExplain :: a -> Predicate a -> a -> (Bool, String)
matchAndExplain a
i Predicate a
p a
x =
      (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x, String
"in element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
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 :: [Predicate (Element t)] -> Predicate t
unorderedElemsAre [Predicate (Element t)]
ps =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate =
        String
"(any order) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation =
        String
"not (in any order) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      accept :: t -> Bool
accept = \t
xs ->
        let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
         in [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> Bool
&& [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs,
      explain :: t -> String
explain = \t
xs ->
        let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
         in if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> Bool
&& [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
              then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
              else
                let missingExplanation :: Maybe String
missingExplanation =
                      if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
                        then Maybe String
forall a. Maybe a
Nothing
                        else
                          String -> Maybe String
forall a. a -> Maybe a
Just
                            ( String
"Missing: "
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate (Predicate (Element t) -> String)
-> [Predicate (Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate (Element t)]
orphanPs)
                            )
                    extraExplanation :: Maybe String
extraExplanation =
                      if [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
                        then Maybe String
forall a. Maybe a
Nothing
                        else
                          String -> Maybe String
forall a. a -> Maybe a
Just
                            ( String
"Extra elements: "
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
                                  String
", "
                                  ((String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((Int, Element t) -> String) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, Element t) -> Int) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Element t) -> Int
forall a b. (a, b) -> a
fst ((Int, Element t) -> String) -> [(Int, Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Element t)]
orphanXs)
                            )
                 in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
                      String
"; "
                      ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
missingExplanation, Maybe String
extraExplanation])
    }
  where
    matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
    matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
    explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
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 :: Predicate (Element t) -> Predicate t
each Predicate (Element t)
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"each (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate Predicate (Element t)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"contains (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showNegation Predicate (Element t)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = ((Bool, (Int, String)) -> Bool) -> [(Bool, (Int, String))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, (Int, String))] -> Bool)
-> (t -> [(Bool, (Int, String))]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(Bool, (Int, String))]
acceptAndExplain,
      explain :: t -> String
explain = \t
xs ->
        let results :: [(Bool, (Int, String))]
results = t -> [(Bool, (Int, String))]
acceptAndExplain t
xs
            format :: (a, String) -> String
format (a
i, String
explanation) =
              String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
explanation
         in if ((Bool, (Int, String)) -> Bool) -> [(Bool, (Int, String))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst [(Bool, (Int, String))]
results
              then String
"all elements " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate Predicate (Element t)
p
              else
                String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                  (Int, String) -> String
forall a. Show a => (a, String) -> String
format ((Int, String) -> String)
-> ((Bool, (Int, String)) -> (Int, String))
-> (Bool, (Int, String))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, (Int, String)) -> (Int, String)
forall a b. (a, b) -> b
snd ((Bool, (Int, String)) -> String)
-> [(Bool, (Int, String))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, (Int, String)) -> Bool)
-> [(Bool, (Int, String))] -> [(Bool, (Int, String))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, (Int, String)) -> Bool) -> (Bool, (Int, String)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, (Int, String))]
results
    }
  where
    acceptAndExplain :: t -> [(Bool, (Int, String))]
acceptAndExplain t
xs =
      [(Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate (Element t)
p Element t
x, (Int
i, Predicate (Element t) -> Element t -> String
forall a. Predicate a -> a -> String
explain Predicate (Element t)
p Element t
x)) | Int
i <- [Int
1 :: Int ..] | Element t
x <- t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
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 :: Predicate (Element t) -> Predicate t
contains = Predicate t -> Predicate t
forall a. Predicate a -> Predicate a
notP (Predicate t -> Predicate t)
-> (Predicate (Element t) -> Predicate t)
-> Predicate (Element t)
-> Predicate t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate (Element t) -> Predicate t
forall t. MonoFoldable t => Predicate (Element t) -> Predicate t
each (Predicate (Element t) -> Predicate t)
-> (Predicate (Element t) -> Predicate (Element t))
-> Predicate (Element t)
-> Predicate t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate (Element t) -> Predicate (Element t)
forall a. Predicate a -> Predicate a
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 :: [Predicate (Element t)] -> Predicate t
containsAll [Predicate (Element t)]
ps =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains all of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not all of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      accept :: t -> Bool
accept = \t
xs -> let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
_) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs in [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs,
      explain :: t -> String
explain = \t
xs ->
        let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
_) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
         in if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
              then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
              else String
"Missing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate (Predicate (Element t) -> String)
-> [Predicate (Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate (Element t)]
orphanPs)
    }
  where
    matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
    matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
    explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
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 :: [Predicate (Element t)] -> Predicate t
containsOnly [Predicate (Element t)]
ps =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains only " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not only " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      accept :: t -> Bool
accept = \t
xs -> let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
_, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs in [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs,
      explain :: t -> String
explain = \t
xs ->
        let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
_, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
         in if [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
              then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
              else
                String
"Extra elements: "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((Int, Element t) -> String) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, Element t) -> Int) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Element t) -> Int
forall a b. (a, b) -> a
fst ((Int, Element t) -> String) -> [(Int, Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Element t)]
orphanXs)
    }
  where
    matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
    matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
    [Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
    explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
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 :: Predicate [k] -> Predicate t
keys Predicate [k]
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"keys (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [k] -> String
forall a. Predicate a -> String
showPredicate Predicate [k]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"keys (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [k] -> String
forall a. Predicate a -> String
showNegation Predicate [k]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = Predicate [k] -> [k] -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate [k]
p ([k] -> Bool) -> (t -> [k]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst ([(k, v)] -> [k]) -> (t -> [(k, v)]) -> t -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList,
      explain :: t -> String
explain = (String
"in keys, " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (t -> String) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate [k] -> [k] -> String
forall a. Predicate a -> a -> String
explain Predicate [k]
p ([k] -> String) -> (t -> [k]) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst ([(k, v)] -> [k]) -> (t -> [(k, v)]) -> t -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
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 :: Predicate [v] -> Predicate t
values Predicate [v]
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"values (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [v] -> String
forall a. Predicate a -> String
showPredicate Predicate [v]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"values (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [v] -> String
forall a. Predicate a -> String
showNegation Predicate [v]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = Predicate [v] -> [v] -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate [v]
p ([v] -> Bool) -> (t -> [v]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> v) -> [(k, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> v
forall a b. (a, b) -> b
snd ([(k, v)] -> [v]) -> (t -> [(k, v)]) -> t -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList,
      explain :: t -> String
explain = (String
"in values, " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (t -> String) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate [v] -> [v] -> String
forall a. Predicate a -> a -> String
explain Predicate [v]
p ([v] -> String) -> (t -> [v]) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> v) -> [(k, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> v
forall a b. (a, b) -> b
snd ([(k, v)] -> [v]) -> (t -> [(k, v)]) -> t -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
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 :: a -> Predicate a
approxEq a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"≈ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≇" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = \a
y -> a -> a
forall a. Num a => a -> a
abs (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
diff,
      explain :: a -> String
explain = a -> String
explainImpl
    }
  where
    diff :: a
diff = Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
1 ((Integer, Int) -> Int
forall a b. (a, b) -> b
snd (a -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat a
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. RealFloat a => a -> Int
floatDigits a
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
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 a
positive =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"positive",
      showNegation :: String
showNegation = String
"non-positive",
      accept :: a -> Bool
accept = \a
x -> a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0,
      explain :: a -> String
explain = \a
x ->
        if
            | a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 -> String
"value is positive"
            | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
            | a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is negative"
            | Bool
otherwise -> String
"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 a
negative =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"negative",
      showNegation :: String
showNegation = String
"non-negative",
      accept :: a -> Bool
accept = \a
x -> a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0,
      explain :: a -> String
explain = \a
x ->
        if
            | a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is negative"
            | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
            | a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is positive"
            | Bool
otherwise -> String
"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 :: Predicate a
nonPositive = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
forall a. (Ord a, Num a) => Predicate a
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 :: Predicate a
nonNegative = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
forall a. (Ord a, Num a) => Predicate a
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 a
finite =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"finite",
      showNegation :: String
showNegation = String
"non-finite",
      accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isFinite,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x
          then String
"value is finite"
          else String
"value is not finite"
    }
  where
    isFinite :: a -> Bool
isFinite a
x = Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
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 a
infinite =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"infinite",
      showNegation :: String
showNegation = String
"non-infinite",
      accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x
          then String
"value is infinite"
          else String
"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 a
nAn =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"NaN",
      showNegation :: String
showNegation = String
"non-NaN",
      accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isNaN,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x
          then String
"value is NaN"
          else String
"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 :: (a -> Bool) -> Predicate a
is a -> Bool
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"custom predicate"),
      showNegation :: String
showNegation = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"negated custom predicate"),
      accept :: a -> Bool
accept = a -> Bool
p,
      explain :: a -> String
explain = \a
x ->
        if a -> Bool
p a
x
          then String
"value matched custom predicate"
          else String
"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 :: ExpQ -> ExpQ
qIs ExpQ
p =
  [|
    Predicate
      { showPredicate = $description,
        showNegation = "not " ++ $description,
        accept = $p,
        explain = \x -> if $p x then $description else "not " ++ $description
      }
    |]
  where
    description :: ExpQ
description = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Exp -> String) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> (Exp -> Exp) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
forall a. Data a => a -> a
removeModNames (Exp -> ExpQ) -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ
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 :: (a -> b) -> Predicate b -> Predicate a
with a -> b
f Predicate b
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Show a => a -> String
show Predicate b
p,
      showNegation :: String
showNegation = String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showNegation Predicate b
p,
      accept :: a -> Bool
accept = Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f,
      explain :: a -> String
explain = ((String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
    }
  where
    prop :: String
prop = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"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 :: ExpQ -> ExpQ
qWith ExpQ
f =
  [|
    \p ->
      Predicate
        { showPredicate = $prop ++ ": " ++ show p,
          showNegation = $prop ++ ": " ++ showNegation p,
          accept = accept p . $f,
          explain = (($prop ++ ": ") ++) . explain p . $f
        }
    |]
  where
    prop :: ExpQ
prop = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Exp -> String) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> (Exp -> Exp) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
forall a. Data a => a -> a
removeModNames (Exp -> ExpQ) -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ
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 :: PatQ -> ExpQ
qMatch PatQ
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 :: ExpQ
patString = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Pat -> String) -> Pat -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> String
forall a. Ppr a => a -> String
pprint (Pat -> String) -> (Pat -> Pat) -> Pat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> Pat
forall a. Data a => a -> a
removeModNames (Pat -> ExpQ) -> PatQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PatQ
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 :: Predicate a -> Predicate b
typed Predicate a
p =
  Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate =
        Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)),
      showNegation :: String
showNegation =
        String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)),
      accept :: b -> Bool
accept = \b
x -> case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
        Maybe a
Nothing -> Bool
False
        Just a
y -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
y,
      explain :: b -> String
explain = \b
x -> case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
        Maybe a
Nothing ->
          String
"wrong type ("
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy b -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy b
forall a. HasCallStack => a
undefined :: Proxy b))
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" vs. "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall a. HasCallStack => a
undefined :: Proxy a))
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Just a
y -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
y
    }