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

module Test.HMock.Internal.Predicates where

import Data.Char (toUpper)
import Data.Maybe (isJust)
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.TH.Util (removeModNames)
import Test.HMock.Internal.Util (choices, locate, isSubsequenceOf, withLoc)
import Text.Regex.TDFA hiding (match)

-- $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.
--
-- Predicates are used to define which arguments a general matcher should
-- accept.
data Predicate a = Predicate
  { Predicate a -> String
showPredicate :: String,
    Predicate a -> a -> Bool
accept :: a -> Bool
  }

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

-- | 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"anything",
      accept :: a -> Bool
accept = Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True
    }

-- | 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = 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)
    }

-- | 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 a
x =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x)
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
x)
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x)
    }

-- | 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 a
x =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x)
    }

-- | 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 a
x =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x)
    }

-- | A 'Predicate' that matches 'True' values.
--
-- >>> accept true True
-- True
-- >>> accept true False
-- False
true :: Predicate Bool
true :: Predicate Bool
true = Bool -> Predicate Bool
forall a. (Show a, Eq a) => a -> Predicate a
eq Bool
True

-- | A 'Predicate' that matches 'False' values.
--
-- >>> accept false True
-- False
-- >>> accept false False
-- True
false :: Predicate Bool
false :: Predicate Bool
false = Bool -> Predicate Bool
forall a. (Show a, Eq a) => a -> Predicate a
eq Bool
False

-- | 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 -> (a -> Bool) -> 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
")",
      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
    }

-- | 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 -> (a -> Bool) -> 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
")",
      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
    }

-- | 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 -> (a -> Bool) -> 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
")",
      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
    }

-- | A 'Predicate' that accepts pairs whose elements satisfy the corresponding
-- child 'Predicates'.
--
-- >>> 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
p Predicate b
q =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = (Predicate a, Predicate b) -> String
forall a. Show a => a -> String
show (Predicate a
p, Predicate b
q),
      accept :: (a, b) -> Bool
accept = \(a
x, b
y) -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x Bool -> Bool -> Bool
&& Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
q b
y
    }

-- | 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 -> (a -> Bool) -> 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),
      accept :: (a, b, c) -> Bool
accept = \(a
x1, b
x2, c
x3) -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1 Bool -> Bool -> Bool
&& Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2 Bool -> Bool -> Bool
&& Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3
    }

-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the
-- corresponding child 'Predicates'.
--
-- >>> 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 -> (a -> Bool) -> 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),
      accept :: (a, b, c, d) -> Bool
accept = \(a
x1, b
x2, c
x3, d
x4) ->
        Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1 Bool -> Bool -> Bool
&& Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2 Bool -> Bool -> Bool
&& Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3 Bool -> Bool -> Bool
&& Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4
    }

-- | A 'Predicate' that accepts 3-tuples whose elements satisfy the
-- corresponding child 'Predicates'.
--
-- >>> 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 -> (a -> Bool) -> 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),
      accept :: (a, b, c, d, e) -> Bool
accept = \(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 Bool -> Bool -> Bool
&& Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2 Bool -> Bool -> Bool
&& Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3 Bool -> Bool -> Bool
&& Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4
          Bool -> Bool -> Bool
&& Predicate e -> e -> Bool
forall a. Predicate a -> a -> Bool
accept 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 -> (a -> Bool) -> 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,
      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
    }

-- | 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 :: forall a. String -> (a -> Bool) -> 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
" or " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate 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
    }

-- | 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ 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
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = (t
pfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isPrefixOf`)
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = (t
sfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isSuffixOf`)
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isInfixOf`)
    }

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isSubsequenceOf`)
    }

-- | 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 -> (a -> Bool) -> 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),
      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
    }
  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) => String -> Predicate a
matchesRegex :: String -> Predicate a
matchesRegex String
s =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = 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
"/",
      accept :: a -> Bool
accept = \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
    }
  where
    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) => String -> Predicate a
matchesCaseInsensitiveRegex :: String -> Predicate a
matchesCaseInsensitiveRegex String
s =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = 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",
      accept :: a -> Bool
accept = \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
    }
  where
    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) => String -> Predicate a
containsRegex :: String -> Predicate a
containsRegex String
s =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains /" 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
"/",
      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
    }
  where
    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) => String -> Predicate a
containsCaseInsensitiveRegex :: String -> Predicate a
containsCaseInsensitiveRegex String
s =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains /" 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",
      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
    }
  where
    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 []
-- True
-- >>> accept isEmpty [1, 2, 3]
-- False
-- >>> accept isEmpty ""
-- True
-- >>> accept isEmpty "gas tank"
-- False
isEmpty :: MonoFoldable t => Predicate t
isEmpty :: Predicate t
isEmpty =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"empty",
      accept :: t -> Bool
accept = t -> Bool
forall mono. MonoFoldable mono => mono -> Bool
onull
    }

-- | A 'Predicate' that accepts non-empty data structures.
--
-- >>> accept nonEmpty []
-- False
-- >>> accept nonEmpty [1, 2, 3]
-- True
-- >>> accept nonEmpty ""
-- False
-- >>> accept nonEmpty "gas tank"
-- True
nonEmpty :: MonoFoldable t => Predicate t
nonEmpty :: Predicate t
nonEmpty =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"nonempty",
      accept :: t -> Bool
accept = Bool -> Bool
not (Bool -> Bool) -> (t -> Bool) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Bool
forall mono. MonoFoldable mono => mono -> Bool
onull
    }

-- | 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 => Predicate Int -> Predicate t
sizeIs :: Predicate Int -> Predicate t
sizeIs Predicate Int
p =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      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
    }

-- | 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = [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))
    }

-- | 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 -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = [Predicate (Element t)] -> [Element t] -> Bool
forall a. [Predicate a] -> [a] -> Bool
matches [Predicate (Element t)]
ps ([Element t] -> Bool) -> (t -> [Element t]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList
    }
  where
    matches :: [Predicate a] -> [a] -> Bool
matches (Predicate a
q : [Predicate a]
qs) [a]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [[Predicate a] -> [a] -> Bool
matches [Predicate a]
qs [a]
ys | (a
y, [a]
ys) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
choices [a]
xs, Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
y]
    matches [] [a]
xs = [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs

-- | 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 -> (a -> Bool) -> 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
")",
      accept :: t -> Bool
accept = (Element t -> Bool) -> t -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
oall (Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate (Element t)
p)
    }

-- | 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 (Element t)
p =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains (" 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
")",
      accept :: t -> Bool
accept = (Element t -> Bool) -> t -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
oany (Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate (Element t)
p)
    }

-- | A 'Predicate' that accepts data structures which contain an element
-- satisfying each of the child predicates.  @'containsAll' [p1, p2, ..., pn]@
-- is equivalent to @'contains' p1 `'andP'` 'contains' p2 `'andP'` ... `'andP'`
-- 'contains' pn@.
--
-- >>> 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
containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsAll :: [Predicate (Element t)] -> Predicate t
containsAll [Predicate (Element t)]
ps =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = \t
xs -> (Predicate (Element t) -> Bool) -> [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (((Element t -> Bool) -> t -> Bool)
-> t -> (Element t -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Element t -> Bool) -> t -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
oany t
xs ((Element t -> Bool) -> Bool)
-> (Predicate (Element t) -> Element t -> Bool)
-> Predicate (Element t)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept) [Predicate (Element t)]
ps
    }

-- | A 'Predicate' that accepts data structures whose elements all satisfy at
-- least one of the child predicates.  @'containsOnly' [p1, p2, ..., pn]@ is
-- equivalent to @'each' (p1 `'orP'` p2 `'orP'` ... `'orP'` pn)@.
--
-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "foo"]
-- True
-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "bar"]
-- True
-- >>> accept (containsOnly [eq "foo", eq "bar"]) ["foo", "qux"]
-- False
containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsOnly :: [Predicate (Element t)] -> Predicate t
containsOnly [Predicate (Element t)]
ps =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      accept :: t -> Bool
accept = (Element t -> Bool) -> t -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
oall (\Element t
x -> (Predicate (Element t) -> Bool) -> [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
`accept` Element t
x) [Predicate (Element t)]
ps)
    }

-- | A 'Predicate' that accepts map-like structures which contain a key matching
-- the child 'Predicate'.
--
-- >>> accept (containsKey (eq "foo")) [("foo", 1), ("bar", 2)]
-- True
-- >>> accept (containsKey (eq "foo")) [("bar", 1), ("qux", 2)]
-- False
containsKey :: (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate t
containsKey :: Predicate k -> Predicate t
containsKey Predicate k
p =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate k -> String
forall a. Show a => a -> String
show Predicate k
p,
      accept :: t -> Bool
accept = \t
m -> (k -> Bool) -> [k] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Predicate k -> k -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate k
p) ((k, v) -> k
forall a b. (a, b) -> a
fst ((k, v) -> k) -> [(k, v)] -> [k]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> [Item t]
forall l. IsList l => l -> [Item l]
toList t
m)
    }

-- | A 'Predicate' that accepts map-like structures which contain a key/value
-- pair matched by the given child 'Predicate's (one for the key, and one for
-- the value).
--
-- >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 12), ("bar", 5)]
-- True
-- >>> accept (containsEntry (eq "foo") (gt 10)) [("foo", 5), ("bar", 12)]
-- False
-- >>> accept (containsEntry (eq "foo") (gt 10)) [("bar", 12)]
-- False
containsEntry ::
  (IsList t, Item t ~ (k, v)) => Predicate k -> Predicate v -> Predicate t
containsEntry :: Predicate k -> Predicate v -> Predicate t
containsEntry Predicate k
p Predicate v
q =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"contains entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate k, Predicate v) -> String
forall a. Show a => a -> String
show (Predicate k
p, Predicate v
q),
      accept :: t -> Bool
accept = ((k, v) -> Bool) -> [(k, v)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(k
x, v
y) -> Predicate k -> k -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate k
p k
x Bool -> Bool -> Bool
&& Predicate v -> v -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate v
q v
y) ([(k, v)] -> Bool) -> (t -> [(k, v)]) -> t -> Bool
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 map-like structures whose keys are exactly those
-- matched by the given list of 'Predicates', in any order.
--
-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("b", 2), ("c", 3)]
-- True
-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("c", 1), ("b", 2), ("a", 3)]
-- True
-- >>> accept (keysAre [eq "a", eq "b", eq "c"]) [("a", 1), ("c", 3)]
-- False
-- >>> accept (keysAre [eq "a", eq "b"]) [("a", 1), ("b", 2), ("c", 3)]
-- False
keysAre ::
  (IsList t, Item t ~ (k, v)) => [Predicate k] -> Predicate t
keysAre :: [Predicate k] -> Predicate t
keysAre [Predicate k]
ps =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"keys are " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate k] -> String
forall a. Show a => a -> String
show [Predicate k]
ps,
      accept :: t -> Bool
accept = [Predicate k] -> [k] -> Bool
forall a. [Predicate a] -> [a] -> Bool
matches [Predicate k]
ps ([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
    }
  where
    matches :: [Predicate a] -> [a] -> Bool
matches (Predicate a
q : [Predicate a]
qs) [a]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [[Predicate a] -> [a] -> Bool
matches [Predicate a]
qs [a]
ys | (a
y, [a]
ys) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
choices [a]
xs, Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
y]
    matches [] [a]
xs = [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs

-- | A 'Predicate' that accepts map-like structures whose entries are exactly
-- those matched by the given list of 'Predicate' pairs, in any order.
--
-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4)]
-- True
-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(3, 4), (1, 2)]
-- True
-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 4), (3, 2)]
-- False
-- >>> accept (entriesAre [(eq 1, eq 2), (eq 3, eq 4)]) [(1, 2), (3, 4), (5, 6)]
-- False
entriesAre ::
  (IsList t, Item t ~ (k, v)) => [(Predicate k, Predicate v)] -> Predicate t
entriesAre :: [(Predicate k, Predicate v)] -> Predicate t
entriesAre [(Predicate k, Predicate v)]
ps =
  Predicate :: forall a. String -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"entries are " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Predicate k, Predicate v)] -> String
forall a. Show a => a -> String
show [(Predicate k, Predicate v)]
ps,
      accept :: t -> Bool
accept = [(Predicate k, Predicate v)] -> [(k, v)] -> Bool
forall a a. [(Predicate a, Predicate a)] -> [(a, a)] -> Bool
matches [(Predicate k, Predicate v)]
ps ([(k, v)] -> Bool) -> (t -> [(k, v)]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList
    }
  where
    matches :: [(Predicate a, Predicate a)] -> [(a, a)] -> Bool
matches ((Predicate a
p, Predicate a
q) : [(Predicate a, Predicate a)]
pqs) [(a, a)]
xs =
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [[(Predicate a, Predicate a)] -> [(a, a)] -> Bool
matches [(Predicate a, Predicate a)]
pqs [(a, a)]
ys | ((a
k, a
v), [(a, a)]
ys) <- [(a, a)] -> [((a, a), [(a, a)])]
forall a. [a] -> [(a, [a])]
choices [(a, a)]
xs, Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
k, Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
v]
    matches [] [(a, a)]
xs = [(a, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, a)]
xs

-- | 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 =
  Predicate :: forall a. String -> (a -> Bool) -> 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,
      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
    }
  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 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"finite",
      accept :: a -> Bool
accept = \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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"infinite",
      accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite
    }

-- | 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 -> (a -> Bool) -> Predicate a
Predicate
    { showPredicate :: String
showPredicate = String
"NaN",
      accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isNaN
    }

-- | 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
f =
  Predicate :: forall a. String -> (a -> Bool) -> 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"),
      accept :: a -> Bool
accept = a -> Bool
f
    }

-- | 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
f =
  [|
    Predicate
      { showPredicate = $(lift . pprint . removeModNames =<< f),
        accept = $f
      }
    |]

-- | 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 -> (a -> Bool) -> 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
"property") 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,
      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
    }

-- | 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 =
            $(lift . pprint . removeModNames =<< f) ++ ": " ++ show p,
          accept = accept p . $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 = $(lift . pprint . removeModNames =<< qpat),
        accept = \case
          $(qpat) -> True
          _ -> False
      }
    |]

-- | 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 -> (a -> Bool) -> 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)),
      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
    }