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

-- | Explainable 'Predicate's are essentially functions from types to `Bool`
-- which can additionally describe themselves and explain why an argument does
-- or doesn't match.  They are intended to be used during unit tests to provide
-- better error messages when tests fail.
module Test.Predicates
  ( -- * The Predicate type
    Predicate (..),
    (==~),
    PredicateFailure (..),
    acceptIO,

    -- * Predicate combinators

    -- ** Basic predicates
    anything,
    eq,
    neq,
    gt,
    geq,
    lt,
    leq,
    just,
    nothing,
    left,
    right,

    -- ** Zips
    zipP,
    zip3P,
    zip4P,
    zip5P,

    -- ** Logic
    andP,
    orP,
    notP,
#ifdef REGEX
    -- ** Regular expressions
    matchesRegex,
    matchesCaseInsensitiveRegex,
    containsRegex,
    containsCaseInsensitiveRegex,
#endif

#ifdef CONTAINERS
    -- ** Strings and sequences
    startsWith,
    endsWith,
    hasSubstr,
    hasSubsequence,
    caseInsensitive,

    -- ** Containers
    isEmpty,
    nonEmpty,
    sizeIs,
    elemsAre,
    unorderedElemsAre,
    each,
    contains,
    containsAll,
    containsOnly,
    keys,
    values,
#endif

    -- ** Numerics
    approxEq,
    positive,
    negative,
    nonPositive,
    nonNegative,
    finite,
    infinite,
    nAn,

    -- ** Miscellaneous
    is,
    qIs,
    with,
    qWith,
    inBranch,
    qADT,
    qMatch,
    typed,
  )
where

import Control.Exception (Exception, throwIO)
import Control.Monad (replicateM, unless)
import Data.Functor.Contravariant (Contravariant (..))
import Data.List (intercalate)
import Data.Maybe (isNothing)
import Data.Typeable (Proxy (..), Typeable, cast, typeRep)
import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
import Test.Predicates.Internal.Util (locate, removeModNames, withLoc)

#ifdef REGEX
import Data.Maybe (isJust)
import Text.Regex.TDFA
  ( CompOption (caseSensitive, lastStarGreedy, newSyntax),
    ExecOption (captureGroups),
    Extract (empty),
    Regex,
    RegexLike (matchOnce, matchOnceText),
    RegexMaker (makeRegexOpts),
    RegexOptions (defaultCompOpt, defaultExecOpt),
  )
#endif

#ifdef CONTAINERS
import Data.Char (toUpper)
import Data.Maybe (catMaybes)
import Data.MonoTraversable (Element, MonoFoldable (..), MonoFunctor (..))
import qualified Data.Sequences as Seq
import GHC.Exts (IsList (Item, toList))
import Test.Predicates.Internal.FlowMatcher (bipartiteMatching)
import Test.Predicates.Internal.Util (isSubsequenceOf)
#endif

-- $setup
-- >>> :set -XLambdaCase
-- >>> :set -XTemplateHaskell
-- >>> :set -XTypeApplications
-- >>> :set -Wno-type-defaults

-- | A predicate, which tests values and either accepts or rejects them.  This
-- is similar to @a -> 'Bool'@, but also can describe itself and explain why an
-- argument does or doesn't match.
data Predicate a = Predicate
  { forall a. Predicate a -> String
showPredicate :: String,
    forall a. Predicate a -> String
showNegation :: String,
    forall a. Predicate a -> a -> Bool
accept :: a -> Bool,
    forall a. Predicate a -> a -> String
explain :: a -> String
  }

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

data PredicateFailure = PredicateFailure String CallStack

instance Show PredicateFailure where
  show :: PredicateFailure -> String
show (PredicateFailure String
message CallStack
cs) = String
message forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs
instance Exception PredicateFailure

-- | Same as 'accept', except throws a 'PredicateFailure' instead of returning a 'Bool'.
acceptIO :: HasCallStack => Predicate a -> a -> IO ()
acceptIO :: forall a. HasCallStack => Predicate a -> a -> IO ()
acceptIO Predicate a
p a
x =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x) forall a b. (a -> b) -> a -> b
$
    forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> CallStack -> PredicateFailure
PredicateFailure (forall a. Predicate a -> a -> String
explain Predicate a
p a
x) HasCallStack => CallStack
callStack

-- | An infix synonym for 'accept'.
--
-- >>> eq 1 ==~ 1
-- True
-- >>> eq 2 ==~ 1
-- False
(==~) :: Predicate a -> a -> Bool
==~ :: forall a. Predicate a -> a -> Bool
(==~) = forall a. Predicate a -> a -> Bool
accept

withDefaultExplain ::
  (a -> String) -> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain :: forall a.
(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 forall a b. (a -> b) -> a -> b
$ \a
x ->
      if forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
        then a -> String
format a
x forall a. [a] -> [a] -> [a]
++ String
connector forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p
        else a -> String
format a
x forall a. [a] -> [a] -> [a]
++ String
connector forall a. [a] -> [a] -> [a]
++ 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 :: forall a. Predicate a
anything =
  Predicate
    { showPredicate :: String
showPredicate = String
"anything",
      showNegation :: String
showNegation = String
"nothing",
      accept :: a -> Bool
accept = forall a b. a -> b -> a
const Bool
True,
      explain :: a -> String
explain = 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 :: forall a. (Show a, Eq a) => a -> Predicate a
eq a
x =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≠ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (forall a. Eq a => a -> a -> Bool
== a
x),
      explain :: a -> String
explain = \a
y ->
        if a
y forall a. Eq a => a -> a -> Bool
== a
x
          then forall a. Show a => a -> String
show a
y forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x
          else forall a. Show a => a -> String
show a
y forall a. [a] -> [a] -> [a]
++ String
" ≠ " forall a. [a] -> [a] -> [a]
++ 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 :: forall a. (Show a, Eq a) => a -> Predicate a
neq = forall a. Predicate a -> Predicate a
notP forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. (Show a, Ord a) => a -> Predicate a
gt a
x = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≤ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (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 :: forall a. (Show a, Ord a) => a -> Predicate a
geq a
x = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"≥ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"< " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = (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 :: forall a. (Show a, Ord a) => a -> Predicate a
lt = forall a. Predicate a -> Predicate a
notP forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. (Show a, Ord a) => a -> Predicate a
leq = forall a. Predicate a -> Predicate a
notP forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Predicate a -> Predicate (Maybe a)
just Predicate a
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"Just (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Just (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Maybe a -> Bool
accept = \case Just a
x -> 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 -> 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 :: forall a. Predicate (Maybe a)
nothing =
  Predicate
    { showPredicate :: String
showPredicate = String
"Nothing",
      showNegation :: String
showNegation = String
"Just anything",
      accept :: Maybe a -> Bool
accept = 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 :: forall a b. Predicate a -> Predicate (Either a b)
left Predicate a
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"Left (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Left (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Either a b -> Bool
accept = \case Left a
x -> 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 -> 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 :: forall b a. Predicate b -> Predicate (Either a b)
right Predicate b
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"Right (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate b
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"not Right (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate b
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: Either a b -> Bool
accept = \case Right b
x -> 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 -> 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 :: forall a b. Predicate a -> Predicate b -> Predicate (a, b)
zipP Predicate a
p1 Predicate b
p2 =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
      showNegation :: String
showNegation = String
"not " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
      accept :: (a, b) -> Bool
accept = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst 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
              | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in forall a. [a] -> [[a]] -> [a]
intercalate String
" and " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2) ->
      [ (forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, 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 :: forall a b c.
Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)
zip3P Predicate a
p1 Predicate b
p2 Predicate c
p3 =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
      showNegation :: String
showNegation = String
"not " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
      accept :: (a, b, c) -> Bool
accept = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst 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
              | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in forall a. [a] -> [[a]] -> [a]
intercalate String
" and " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, String)]
significant
    }
  where
    acceptAndExplain :: (a, b, c) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3) ->
      [ (forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, 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 :: forall a b c d.
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
    { showPredicate :: String
showPredicate = forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4),
      showNegation :: String
showNegation = String
"not " forall a. [a] -> [a] -> [a]
++ 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst 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
              | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in forall a. [a] -> [[a]] -> [a]
intercalate String
" and " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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) ->
      [ (forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
        (forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, 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 :: forall a b c d e.
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
    { showPredicate :: String
showPredicate = 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 " forall a. [a] -> [a] -> [a]
++ 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst 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
              | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
              | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, String)]
results
         in forall a. [a] -> [[a]] -> [a]
intercalate String
" and " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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) ->
      [ (forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
        (forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
        (forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
        (forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, forall a. Predicate a -> a -> String
explain Predicate d
p4 d
x4),
        (forall a. Predicate a -> a -> Bool
accept Predicate e
p5 e
x5, 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 :: forall a. Predicate a -> Predicate a -> Predicate a
`andP` Predicate a
q =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
q,
      showNegation :: String
showNegation = forall a. Predicate a -> String
showNegation Predicate a
p forall a. [a] -> [a] -> [a]
++ String
" or " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate a
q,
      accept :: a -> Bool
accept = \a
x -> forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x Bool -> Bool -> Bool
&& forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x,
      explain :: a -> String
explain = \a
x ->
        if
            | Bool -> Bool
not (forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x) -> forall a. Predicate a -> a -> String
explain Predicate a
p a
x
            | Bool -> Bool
not (forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x) -> forall a. Predicate a -> a -> String
explain Predicate a
q a
x
            | Bool
otherwise -> forall a. Predicate a -> a -> String
explain Predicate a
p a
x forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ 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 :: forall a. Predicate a -> Predicate a -> Predicate a
`orP` Predicate a
q = forall a. Predicate a -> Predicate a
notP (forall a. Predicate a -> Predicate a
notP Predicate a
p forall a. Predicate a -> Predicate a -> Predicate a
`andP` 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 :: forall a. Predicate a -> Predicate a
notP Predicate a
p =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Predicate a -> String
showNegation Predicate a
p,
      showNegation :: String
showNegation = forall a. Predicate a -> String
showPredicate Predicate a
p,
      accept :: a -> Bool
accept = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Predicate a -> a -> Bool
accept Predicate a
p,
      explain :: a -> String
explain = forall a. Predicate a -> a -> String
explain Predicate a
p
    }

#ifdef REGEX

-- | A 'Predicate' that accepts 'String's or string-like values matching a
-- regular expression.  The expression must match the entire argument.
--
-- You should not use @'caseInsensitive' 'matchesRegex'@, because regular
-- expression syntax itself is still case-sensitive even when the text you are
-- matching is not.  Instead, use 'matchesCaseInsensitiveRegex'.
--
-- >>> accept (matchesRegex "x{2,5}y?") "xxxy"
-- True
-- >>> accept (matchesRegex "x{2,5}y?") "xyy"
-- False
-- >>> accept (matchesRegex "x{2,5}y?") "wxxxyz"
-- False
matchesRegex :: (RegexLike Regex a, Eq a, Show a) => String -> Predicate a
matchesRegex :: forall a.
(RegexLike Regex a, Eq a, Show a) =>
String -> Predicate a
matchesRegex String
s =
  Predicate
    { showPredicate :: String
showPredicate = String
pat,
      showNegation :: String
showNegation = String
"not " 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 forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
" matches " forall a. [a] -> [a] -> [a]
++ String
pat
          else forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
" doesn't match " forall a. [a] -> [a] -> [a]
++ String
pat
    }
  where
    pat :: String
pat = String
"/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
s) forall a. [a] -> [a] -> [a]
++ String
"/"
    accepts :: a -> Bool
accepts a
x = case 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 forall a. Eq a => a -> a -> Bool
== forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
== forall source. Extract source => source
empty
      Maybe (a, MatchText a, a)
Nothing -> Bool
False
    r :: Regex
r = 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 = forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
    exec :: ExecOption
exec = 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 :: forall a.
(RegexLike Regex a, Eq a, Show a) =>
String -> Predicate a
matchesCaseInsensitiveRegex String
s =
  Predicate
    { showPredicate :: String
showPredicate = String
pat,
      showNegation :: String
showNegation = String
"not " 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 forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
" matches " forall a. [a] -> [a] -> [a]
++ String
pat
          else forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
" doesn't match " forall a. [a] -> [a] -> [a]
++ String
pat
    }
  where
    pat :: String
pat = String
"/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
s) forall a. [a] -> [a] -> [a]
++ String
"/i"
    accepts :: a -> Bool
accepts a
x = case 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 forall a. Eq a => a -> a -> Bool
== forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
== forall source. Extract source => source
empty
      Maybe (a, MatchText a, a)
Nothing -> Bool
False
    r :: Regex
r = 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 =
      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 = 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 :: forall a.
(RegexLike Regex a, Eq a, Show a) =>
String -> Predicate a
containsRegex String
s = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"contains " forall a. [a] -> [a] -> [a]
++ String
pat,
      showNegation :: String
showNegation = String
"doesn't contain " forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
s) forall a. [a] -> [a] -> [a]
++ String
"/"
    r :: Regex
r = 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 = forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
    exec :: ExecOption
exec = 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 :: forall a.
(RegexLike Regex a, Eq a, Show a) =>
String -> Predicate a
containsCaseInsensitiveRegex String
s = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"contains " forall a. [a] -> [a] -> [a]
++ String
pat,
      showNegation :: String
showNegation = String
"doesn't contain " forall a. [a] -> [a] -> [a]
++ String
pat,
      accept :: a -> Bool
accept = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
s) forall a. [a] -> [a] -> [a]
++ String
"/i"
    r :: Regex
r = 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 =
      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 = forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
False}

#endif

#ifdef CONTAINERS

-- | A 'Predicate' that accepts sequences that start with the given prefix.
--
-- >>> accept (startsWith "fun") "fungible"
-- True
-- >>> accept (startsWith "gib") "fungible"
-- False
startsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t
startsWith :: forall t.
(Show t, IsSequence t, Eq (Element t)) =>
t -> Predicate t
startsWith t
pfx = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"starts with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
pfx,
      showNegation :: String
showNegation = String
"doesn't start with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
pfx,
      accept :: t -> Bool
accept = (t
pfx 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 :: forall t.
(Show t, IsSequence t, Eq (Element t)) =>
t -> Predicate t
endsWith t
sfx = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"ends with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
sfx,
      showNegation :: String
showNegation = String
"doesn't end with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
sfx,
      accept :: t -> Bool
accept = (t
sfx 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 :: forall t.
(Show t, IsSequence t, Eq (Element t)) =>
t -> Predicate t
hasSubstr t
s = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"has substring " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
s,
      showNegation :: String
showNegation = String
"doesn't have substring " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
s,
      accept :: t -> Bool
accept = (t
s 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 :: forall t.
(Show t, IsSequence t, Eq (Element t)) =>
t -> Predicate t
hasSubsequence t
s = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"has subsequence " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
s,
      showNegation :: String
showNegation = String
"doesn't have subsequence " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
s,
      accept :: t -> Bool
accept = (t
s 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 :: forall t a.
(MonoFunctor t, MonoFunctor a, Element t ~ Char,
 Element a ~ Char) =>
(t -> Predicate a) -> t -> Predicate a
caseInsensitive t -> Predicate a
p t
s =
  Predicate
    { showPredicate :: String
showPredicate = String
"(case insensitive) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (t -> Predicate a
p t
s),
      showNegation :: String
showNegation = String
"(case insensitive) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Predicate a -> Predicate a
notP (t -> Predicate a
p t
s)),
      accept :: a -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate a
capP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
toUpper,
      explain :: a -> String
explain = forall a. Predicate a -> a -> String
explain Predicate a
capP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
toUpper
    }
  where
    capP :: Predicate a
capP = t -> Predicate a
p (forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
toUpper t
s)

-- | A 'Predicate' that accepts empty data structures.
--
-- >>> accept isEmpty ([] :: [Int])
-- True
-- >>> accept isEmpty [1, 2, 3]
-- False
-- >>> accept isEmpty ""
-- True
-- >>> accept isEmpty "gas tank"
-- False
isEmpty :: (MonoFoldable t, Show t) => Predicate t
isEmpty :: forall t. (MonoFoldable t, Show t) => Predicate t
isEmpty = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" is " forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"empty",
      showNegation :: String
showNegation = String
"non-empty",
      accept :: t -> Bool
accept = 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 :: forall t. (MonoFoldable t, Show t) => Predicate t
nonEmpty = forall a. Predicate a -> Predicate a
notP 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 :: forall t. (MonoFoldable t, Show t) => Predicate Int -> Predicate t
sizeIs Predicate Int
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"size " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate Int
p,
      showNegation :: String
showNegation = String
"size " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate Int
p,
      accept :: t -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mono. MonoFoldable mono => mono -> Int
olength,
      explain :: t -> String
explain = \t
y ->
        let detail :: String
detail
              | forall a. Predicate a -> a -> Bool
accept Predicate Int
p (forall mono. MonoFoldable mono => mono -> Int
olength t
y) = forall a. Predicate a -> String
showPredicate Predicate Int
p
              | Bool
otherwise = forall a. Predicate a -> String
showNegation Predicate Int
p
            detailStr :: String
detailStr
              | forall a. Show a => a -> String
show (forall mono. MonoFoldable mono => mono -> Int
olength t
y) forall a. Eq a => a -> a -> Bool
== String
detail = String
""
              | Bool
otherwise = String
", which is " forall a. [a] -> [a] -> [a]
++ String
detail
         in forall a. Show a => a -> String
show t
y forall a. [a] -> [a] -> [a]
++ String
" has size " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall mono. MonoFoldable mono => mono -> Int
olength t
y) 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 :: forall t. MonoFoldable t => [Predicate (Element t)] -> Predicate t
elemsAre [Predicate (Element t)]
ps =
  Predicate
    { showPredicate :: String
showPredicate = forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      accept :: t -> Bool
accept = \t
xs ->
        forall mono. MonoFoldable mono => mono -> Int
olength t
xs forall a. Eq a => a -> a -> Bool
== forall mono. MonoFoldable mono => mono -> Int
olength [Predicate (Element t)]
ps
          Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Predicate a -> a -> Bool
accept [Predicate (Element t)]
ps (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 (forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs)
         in if
                | forall mono. MonoFoldable mono => mono -> Int
olength t
xs forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps ->
                  String
"wrong size (got "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall mono. MonoFoldable mono => mono -> Int
olength t
xs)
                    forall a. [a] -> [a] -> [a]
++ String
"; expected "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps)
                    forall a. [a] -> [a] -> [a]
++ String
")"
                | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, String)]
results -> String
"elements are " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Predicate (Element t)]
ps
                | Bool
otherwise ->
                  forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " forall a b. (a -> b) -> a -> b
$
                    forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, String)]
results
    }
  where
    acceptAndExplain :: [Element t] -> [(Bool, String)]
acceptAndExplain [Element t]
xs = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 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 =
      (forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x, String
"in element #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ 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 :: forall t. MonoFoldable t => [Predicate (Element t)] -> Predicate t
unorderedElemsAre [Predicate (Element t)]
ps =
  Predicate
    { showPredicate :: String
showPredicate =
        String
"(any order) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation =
        String
"not (in any order) " forall a. [a] -> [a] -> [a]
++ 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
              then forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " (forall {a} {a}. Show a => (Predicate a, (a, a)) -> String
explainMatch 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
                        then forall a. Maybe a
Nothing
                        else
                          forall a. a -> Maybe a
Just
                            ( String
"Missing: "
                                forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. Predicate a -> String
showPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate (Element t)]
orphanPs)
                            )
                    extraExplanation :: Maybe String
extraExplanation =
                      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
                        then forall a. Maybe a
Nothing
                        else
                          forall a. a -> Maybe a
Just
                            ( String
"Extra elements: "
                                forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate
                                  String
", "
                                  ((String
"#" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Element t)]
orphanXs)
                            )
                 in forall a. [a] -> [[a]] -> [a]
intercalate
                      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) = 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 = forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching forall {a} {a}. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (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 #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
j forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ 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 :: forall t. MonoFoldable t => Predicate (Element t) -> Predicate t
each Predicate (Element t)
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"each (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate (Element t)
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"contains (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate (Element t)
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst 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 #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
explanation
         in if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, (Int, String))]
results
              then String
"all elements " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate (Element t)
p
              else
                forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " forall a b. (a -> b) -> a -> b
$
                  forall {a}. Show a => (a, String) -> String
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, (Int, String))]
results
    }
  where
    acceptAndExplain :: t -> [(Bool, (Int, String))]
acceptAndExplain t
xs =
      [(forall a. Predicate a -> a -> Bool
accept Predicate (Element t)
p Element t
x, (Int
i, forall a. Predicate a -> a -> String
explain Predicate (Element t)
p Element t
x)) | Int
i <- [Int
1 :: Int ..] | Element t
x <- 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 :: forall t. MonoFoldable t => Predicate (Element t) -> Predicate t
contains = forall a. Predicate a -> Predicate a
notP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MonoFoldable t => Predicate (Element t) -> Predicate t
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall t. MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsAll [Predicate (Element t)]
ps =
  Predicate
    { showPredicate :: String
showPredicate = String
"contains all of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not all of " forall a. [a] -> [a] -> [a]
++ 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 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
              then forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " (forall {a} {a}. Show a => (Predicate a, (a, a)) -> String
explainMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
              else String
"Missing: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. Predicate a -> String
showPredicate 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) = 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 = forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching forall {a} {a}. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (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 #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
j forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ 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 :: forall t. MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsOnly [Predicate (Element t)]
ps =
  Predicate
    { showPredicate :: String
showPredicate = String
"contains only " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
      showNegation :: String
showNegation = String
"not only " forall a. [a] -> [a] -> [a]
++ 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 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
              then forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " (forall {a} {a}. Show a => (Predicate a, (a, a)) -> String
explainMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
              else
                String
"Extra elements: "
                  forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((String
"#" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst 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) = 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 = forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching forall {a} {a}. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (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 #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
j forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ 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 :: forall t k v.
(IsList t, Item t ~ (k, v)) =>
Predicate [k] -> Predicate t
keys Predicate [k]
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"keys (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate [k]
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"keys (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate [k]
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate [k]
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList,
      explain :: t -> String
explain = (String
"in keys, " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Predicate a -> a -> String
explain Predicate [k]
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall t k v.
(IsList t, Item t ~ (k, v)) =>
Predicate [v] -> Predicate t
values Predicate [v]
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"values (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate [v]
p forall a. [a] -> [a] -> [a]
++ String
")",
      showNegation :: String
showNegation = String
"values (" forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate [v]
p forall a. [a] -> [a] -> [a]
++ String
")",
      accept :: t -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate [v]
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList,
      explain :: t -> String
explain = (String
"in values, " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Predicate a -> a -> String
explain Predicate [v]
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList
    }

#endif

-- | A 'Predicate' that accepts values of 'RealFloat' types that are close to
-- the given number.  The expected precision is scaled based on the target
-- value, so that reasonable rounding error is accepted but grossly inaccurate
-- results are not.
--
-- The following naive use of 'eq' fails due to rounding:
--
-- >>> accept (eq 1.0) (sum (replicate 100 0.01))
-- False
--
-- The solution is to use 'approxEq', which accounts for rounding error.
-- However, 'approxEq' doesn't accept results that are far enough off that they
-- likely arise from incorrect calculations instead of rounding error.
--
-- >>> accept (approxEq 1.0) (sum (replicate 100 0.01))
-- True
-- >>> accept (approxEq 1.0) (sum (replicate 100 0.009999))
-- False
approxEq :: (RealFloat a, Show a) => a -> Predicate a
approxEq :: forall a. (RealFloat a, Show a) => a -> Predicate a
approxEq a
x = forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain forall a. Show a => a -> String
show String
" " forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
  Predicate
    { showPredicate :: String
showPredicate = String
"≈ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      showNegation :: String
showNegation = String
"≇" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x,
      accept :: a -> Bool
accept = \a
y -> forall a. Num a => a -> a
abs (a
x forall a. Num a => a -> a -> a
- a
y) forall a. Ord a => a -> a -> Bool
< a
diff,
      explain :: a -> String
explain = a -> String
explainImpl
    }
  where
    diff :: a
diff = forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
1 (forall a b. (a, b) -> b
snd (forall a. RealFloat a => a -> (Integer, Int)
decodeFloat a
x) forall a. Num a => a -> a -> a
+ forall a. RealFloat a => a -> Int
floatDigits a
x 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 :: forall a. (Ord a, Num a) => Predicate a
positive =
  Predicate
    { showPredicate :: String
showPredicate = String
"positive",
      showNegation :: String
showNegation = String
"non-positive",
      accept :: a -> Bool
accept = \a
x -> forall a. Num a => a -> a
signum a
x forall a. Ord a => a -> a -> Bool
> a
0,
      explain :: a -> String
explain = \a
x ->
        if
            | forall a. Num a => a -> a
signum a
x forall a. Ord a => a -> a -> Bool
> a
0 -> String
"value is positive"
            | a
x forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
            | forall a. Num a => a -> a
signum a
x 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 :: forall a. (Ord a, Num a) => Predicate a
negative =
  Predicate
    { showPredicate :: String
showPredicate = String
"negative",
      showNegation :: String
showNegation = String
"non-negative",
      accept :: a -> Bool
accept = \a
x -> forall a. Num a => a -> a
signum a
x forall a. Ord a => a -> a -> Bool
< a
0,
      explain :: a -> String
explain = \a
x ->
        if
            | forall a. Num a => a -> a
signum a
x forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is negative"
            | a
x forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
            | forall a. Num a => a -> a
signum a
x 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 :: forall a. (Ord a, Num a) => Predicate a
nonPositive = forall a. Predicate a -> Predicate a
notP 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 :: forall a. (Ord a, Num a) => Predicate a
nonNegative = forall a. Predicate a -> Predicate a
notP 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 :: forall a. RealFloat a => Predicate a
finite =
  Predicate
    { showPredicate :: String
showPredicate = String
"finite",
      showNegation :: String
showNegation = String
"non-finite",
      accept :: a -> Bool
accept = forall {a}. RealFloat a => a -> Bool
isFinite,
      explain :: a -> String
explain = \a
x ->
        if 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 (forall {a}. RealFloat a => a -> Bool
isInfinite a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (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 :: forall a. RealFloat a => Predicate a
infinite =
  Predicate
    { showPredicate :: String
showPredicate = String
"infinite",
      showNegation :: String
showNegation = String
"non-infinite",
      accept :: a -> Bool
accept = forall {a}. RealFloat a => a -> Bool
isInfinite,
      explain :: a -> String
explain = \a
x ->
        if 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 :: forall a. RealFloat a => Predicate a
nAn =
  Predicate
    { showPredicate :: String
showPredicate = String
"NaN",
      showNegation :: String
showNegation = String
"non-NaN",
      accept :: a -> Bool
accept = forall {a}. RealFloat a => a -> Bool
isNaN,
      explain :: a -> String
explain = \a
x ->
        if 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.  You can use
-- 'qIs' instead to get better descriptions using Template Haskell.
--
-- >>> accept (is even) 3
-- False
-- >>> accept (is even) 4
-- True
is :: HasCallStack => (a -> Bool) -> Predicate a
is :: forall a. HasCallStack => (a -> Bool) -> Predicate a
is a -> Bool
p =
  Predicate
    { showPredicate :: String
showPredicate = Located String -> String
withLoc (forall a. CallStack -> a -> Located a
locate HasCallStack => CallStack
callStack String
"custom predicate"),
      showNegation :: String
showNegation = Located String -> String
withLoc (forall a. CallStack -> a -> Located a
locate 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 explanation.
--
-- >>> accept $(qIs [| even |]) 3
-- False
-- >>> accept $(qIs [| even |]) 4
-- True
--
-- >>> show $(qIs [| even |])
-- "even"
qIs :: HasCallStack => ExpQ -> ExpQ
qIs :: HasCallStack => 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 = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> a
removeModNames 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.  The explanations are less helpful that standard
-- predicates like 'sizeIs'.  You can use 'qWith' instead to get better
-- explanations using Template Haskell.
--
-- >>> accept (with abs (gt 5)) (-6)
-- True
-- >>> accept (with abs (gt 5)) (-5)
-- False
-- >>> accept (with reverse (eq "olleh")) "hello"
-- True
-- >>> accept (with reverse (eq "olleh")) "goodbye"
-- False
with :: HasCallStack => (a -> b) -> Predicate b -> Predicate a
with :: forall a b. HasCallStack => (a -> b) -> Predicate b -> Predicate a
with a -> b
f Predicate b
p =
  Predicate
    { showPredicate :: String
showPredicate = String
prop forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Predicate b
p,
      showNegation :: String
showNegation = String
prop forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate b
p,
      accept :: a -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate b
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f,
      explain :: a -> String
explain = ((String
prop forall a. [a] -> [a] -> [a]
++ String
": ") forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Predicate a -> a -> String
explain Predicate b
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
    }
  where
    prop :: String
prop = Located String -> String
withLoc (forall a. CallStack -> a -> Located a
locate HasCallStack => CallStack
callStack String
"property")

-- | Use 'with' or 'qWith' instead of 'contramap' to get better explanations.
instance Contravariant Predicate where
  contramap :: forall a' a. (a' -> a) -> Predicate a -> Predicate a'
contramap a' -> a
f Predicate a
p =
    Predicate
      { showPredicate :: String
showPredicate = String
"in a property: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Predicate a
p,
        showNegation :: String
showNegation = String
"in a property: " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showNegation Predicate a
p,
        accept :: a' -> Bool
accept = forall a. Predicate a -> a -> Bool
accept Predicate a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f,
        explain :: a' -> String
explain = (String
"in a property: " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Predicate a -> a -> String
explain Predicate a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f
      }

-- | A Template Haskell splice that acts like 'with', but receives a quoted
-- typed expression at compile time and has a more helpful explanation.
--
-- >>> accept ($(qWith [| abs |]) (gt 5)) (-6)
-- True
-- >>> accept ($(qWith [| abs |]) (gt 5)) (-5)
-- False
-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "hello"
-- True
-- >>> accept ($(qWith [| reverse |]) (eq "olleh")) "goodbye"
-- False
--
-- >>> show ($(qWith [| abs |]) (gt 5))
-- "abs: > 5"
qWith :: ExpQ -> ExpQ
qWith :: 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 = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> a
removeModNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ
f

-- | A 'Predicate' that accepts values with a given nested value.  This is
-- intended to match constructors with arguments.  You can use 'qADT' instead
-- to get better explanations using Template Haskell.
--
-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 1)
-- True
-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Left 0)
-- False
-- >>> accept (inBranch "Left" (\case {Left x -> Just x; _ -> Nothing}) positive) (Right 1)
-- False
inBranch :: String -> (a -> Maybe b) -> Predicate b -> Predicate a
inBranch :: forall a b. String -> (a -> Maybe b) -> Predicate b -> Predicate a
inBranch String
name a -> Maybe b
f Predicate b
p =
  Predicate
    { showPredicate :: String
showPredicate = String
"(" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" _)",
      showNegation :: String
showNegation = String
"not (" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" _)",
      accept :: a -> Bool
accept = \a
x -> case a -> Maybe b
f a
x of Just b
y -> forall a. Predicate a -> a -> Bool
accept Predicate b
p b
y; Maybe b
_ -> Bool
False,
      explain :: a -> String
explain = \a
x -> case a -> Maybe b
f a
x of
        Just b
y -> String
"In " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> a -> String
explain Predicate b
p b
y
        Maybe b
_ -> String
"Branch didn't match"
    }

-- | A Template Haskell splice which, given a constructor for an abstract data
-- type, writes a 'Predicate' that matches on that constructor and applies other
-- 'Predicate's to its fields.
--
-- >>> accept $(qADT 'Nothing) Nothing
-- True
-- >>> accept $(qADT 'Nothing) (Just 5)
-- False
-- >>> accept ($(qADT 'Just) positive) (Just 5)
-- True
-- >>> accept ($(qADT 'Just) positive) Nothing
-- False
-- >>> accept ($(qADT 'Just) positive) (Just 0)
-- False
qADT :: Name -> ExpQ
qADT :: Name -> ExpQ
qADT Name
conName =
  do
    let prettyConName :: ExpQ
prettyConName = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (forall a. Ppr a => a -> String
pprint (forall a. Data a => a -> a
removeModNames Name
conName))
    Type
t <- Name -> Q Info
reify Name
conName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
       DataConI Name
_ Type
ty Name
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
       PatSynI Name
_ Type
ty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
       Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"qADT: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
conName forall a. [a] -> [a] -> [a]
++ String
" is not a data constructor")

    let n :: Int
n = forall {t}. Num t => Type -> t
countArguments Type
t
    [Name]
subpreds <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall (m :: * -> *). Quote m => String -> m Name
newName String
"p")
    let subdescs :: [ExpQ]
subdescs =
          forall a b. (a -> b) -> [a] -> [b]
map
            (\ExpQ
p -> [|"(" ++ showPredicate $p ++ ")"|])
            (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subpreds)
    let desc :: ExpQ
desc = [|unwords ($prettyConName : $(listE subdescs))|]
    let negDesc :: ExpQ
negDesc
          | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = [|"≠ " ++ $desc|]
          | Bool
otherwise = [|"not (" ++ $desc ++ ")"|]
    [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let pattern :: Q Pat
pattern = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
    let acceptExplainFields :: ExpQ
acceptExplainFields =
          forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
              (\ExpQ
p ExpQ
x -> [|(accept $p $x, explain $p $x)|])
              (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subpreds)
              (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
    Name
y <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
      (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subpreds)
      [|
        let acceptAndExplain $(varP y) = case $(varE y) of
              $pattern -> Just $acceptExplainFields
              _ -> Nothing
         in Predicate
              { showPredicate = $desc,
                showNegation = $negDesc,
                accept = maybe False (all fst) . acceptAndExplain,
                explain = \x -> case acceptAndExplain x of
                  Nothing -> "Not a " ++ $prettyConName
                  Just results ->
                    let significant
                          | all fst results = results
                          | otherwise = filter (not . fst) results
                     in "In " ++ $prettyConName ++ ": "
                          ++ intercalate " and " (map snd significant)
              }
        |]
  where
    countArguments :: Type -> t
countArguments (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) = Type -> t
countArguments Type
t
    countArguments (AppT (AppT Type
ArrowT Type
_) Type
t) = Type -> t
countArguments Type
t forall a. Num a => a -> a -> a
+ t
1
#if MIN_VERSION_template_haskell(2,17,0)
    countArguments (AppT (AppT (AppT Type
MulArrowT Type
_) Type
_) Type
t) = Type -> t
countArguments Type
t forall a. Num a => a -> a -> a
+ t
1
#endif
    countArguments Type
_ = t
0

-- | A Template Haskell splice that turns a quoted pattern into a predicate that
-- accepts values that match the pattern.
--
-- >>> accept $(qMatch [p| Just (Left _) |]) Nothing
-- False
-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Left 5))
-- True
-- >>> accept $(qMatch [p| Just (Left _) |]) (Just (Right 5))
-- False
--
-- >>> show $(qMatch [p| Just (Left _) |])
-- "Just (Left _)"
qMatch :: PatQ -> ExpQ
qMatch :: Q Pat -> ExpQ
qMatch Q Pat
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 = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> a
removeModNames forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Pat
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 :: forall a b. (Typeable a, Typeable b) => Predicate a -> Predicate b
typed Predicate a
p =
  Predicate
    { showPredicate :: String
showPredicate =
        forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)),
      showNegation :: String
showNegation =
        String
"not " forall a. [a] -> [a] -> [a]
++ forall a. Predicate a -> String
showPredicate Predicate a
p forall a. [a] -> [a] -> [a]
++ String
" :: "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)),
      accept :: b -> Bool
accept = \b
x -> case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
        Maybe a
Nothing -> Bool
False
        Just a
y -> forall a. Predicate a -> a -> Bool
accept Predicate a
p a
y,
      explain :: b -> String
explain = \b
x -> case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
        Maybe a
Nothing ->
          String
"wrong type ("
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall a. HasCallStack => a
undefined :: Proxy b))
            forall a. [a] -> [a] -> [a]
++ String
" vs. "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall a. HasCallStack => a
undefined :: Proxy a))
            forall a. [a] -> [a] -> [a]
++ String
")"
        Just a
y -> forall a. Predicate a -> a -> String
explain Predicate a
p a
y
    }