{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Predicates
(
Predicate (..),
(==~),
anything,
eq,
neq,
gt,
geq,
lt,
leq,
just,
nothing,
left,
right,
zipP,
zip3P,
zip4P,
zip5P,
andP,
orP,
notP,
#ifdef REGEX
matchesRegex,
matchesCaseInsensitiveRegex,
containsRegex,
containsCaseInsensitiveRegex,
#endif
#ifdef CONTAINERS
startsWith,
endsWith,
hasSubstr,
hasSubsequence,
caseInsensitive,
isEmpty,
nonEmpty,
sizeIs,
elemsAre,
unorderedElemsAre,
each,
contains,
containsAll,
containsOnly,
keys,
values,
#endif
approxEq,
positive,
negative,
nonPositive,
nonNegative,
finite,
infinite,
nAn,
is,
qIs,
with,
qWith,
inBranch,
qADT,
qMatch,
typed,
)
where
import Control.Monad (replicateM)
import Data.Functor.Contravariant (Contravariant (..))
import Data.List (intercalate)
import Data.Maybe (isNothing)
import Data.Typeable (Proxy (..), Typeable, cast, typeRep)
import GHC.Stack (HasCallStack, callStack)
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
data Predicate a = Predicate
{ Predicate a -> String
showPredicate :: String,
Predicate a -> String
showNegation :: String,
Predicate a -> a -> Bool
accept :: a -> Bool,
Predicate a -> a -> String
explain :: a -> String
}
instance Show (Predicate a) where show :: Predicate a -> String
show = Predicate a -> String
forall a. Predicate a -> String
showPredicate
(==~) :: Predicate a -> a -> Bool
==~ :: Predicate a -> a -> Bool
(==~) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept
withDefaultExplain ::
(a -> String) -> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain :: (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
format String
connector (a -> String) -> Predicate a
mk = Predicate a
p
where
p :: Predicate a
p = (a -> String) -> Predicate a
mk ((a -> String) -> Predicate a) -> (a -> String) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a
x ->
if Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
then a -> String
format a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
connector String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p
else a -> String
format a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
connector String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p
anything :: Predicate a
anything :: Predicate a
anything =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"anything",
showNegation :: String
showNegation = String
"nothing",
accept :: a -> Bool
accept = Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True,
explain :: a -> String
explain = String -> a -> String
forall a b. a -> b -> a
const String
"always matches"
}
eq :: (Show a, Eq a) => a -> Predicate a
eq :: a -> Predicate a
eq a
x =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = a -> String
forall a. Show a => a -> String
show a
x,
showNegation :: String
showNegation = String
"≠ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x),
explain :: a -> String
explain = \a
y ->
if a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x
then a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
else a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ≠ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
}
neq :: (Show a, Eq a) => a -> Predicate a
neq :: a -> Predicate a
neq = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Eq a) => a -> Predicate a
eq
gt :: (Show a, Ord a) => a -> Predicate a
gt :: a -> Predicate a
gt a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
showNegation :: String
showNegation = String
"≤ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
x),
explain :: a -> String
explain = a -> String
explainImpl
}
geq :: (Show a, Ord a) => a -> Predicate a
geq :: a -> Predicate a
geq a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"≥ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
showNegation :: String
showNegation = String
"< " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
accept :: a -> Bool
accept = (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x),
explain :: a -> String
explain = a -> String
explainImpl
}
lt :: (Show a, Ord a) => a -> Predicate a
lt :: a -> Predicate a
lt = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Ord a) => a -> Predicate a
geq
leq :: (Show a, Ord a) => a -> Predicate a
leq :: a -> Predicate a
leq = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a)
-> (a -> Predicate a) -> a -> Predicate a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate a
forall a. (Show a, Ord a) => a -> Predicate a
gt
just :: Predicate a -> Predicate (Maybe a)
just :: Predicate a -> Predicate (Maybe a)
just Predicate a
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"Just (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"not Just (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: Maybe a -> Bool
accept = \case Just a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x; Maybe a
_ -> Bool
False,
explain :: Maybe a -> String
explain = \case Just a
x -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x; Maybe a
_ -> String
"Nothing ≠ Just _"
}
nothing :: Predicate (Maybe a)
nothing :: Predicate (Maybe a)
nothing =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"Nothing",
showNegation :: String
showNegation = String
"Just anything",
accept :: Maybe a -> Bool
accept = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing,
explain :: Maybe a -> String
explain = \case Maybe a
Nothing -> String
"Nothing = Nothing"; Maybe a
_ -> String
"Just _ ≠ Nothing"
}
left :: Predicate a -> Predicate (Either a b)
left :: Predicate a -> Predicate (Either a b)
left Predicate a
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"Left (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"not Left (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: Either a b -> Bool
accept = \case Left a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x; Either a b
_ -> Bool
False,
explain :: Either a b -> String
explain = \case Left a
x -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x; Either a b
_ -> String
"Right _ ≠ Left _"
}
right :: Predicate b -> Predicate (Either a b)
right :: Predicate b -> Predicate (Either a b)
right Predicate b
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"Right (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showPredicate Predicate b
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"not Right (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showPredicate Predicate b
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: Either a b -> Bool
accept = \case Right b
x -> Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p b
x; Either a b
_ -> Bool
False,
explain :: Either a b -> String
explain = \case Right b
x -> Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p b
x; Either a b
_ -> String
"Left _ ≠ Right _"
}
zipP :: Predicate a -> Predicate b -> Predicate (a, b)
zipP :: Predicate a -> Predicate b -> Predicate (a, b)
zipP Predicate a
p1 Predicate b
p2 =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = (Predicate a, Predicate b) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2),
accept :: (a, b) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b) -> [(Bool, String)]) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> [(Bool, String)]
acceptAndExplain,
explain :: (a, b) -> String
explain = \(a, b)
xs ->
let results :: [(Bool, String)]
results = (a, b) -> [(Bool, String)]
acceptAndExplain (a, b)
xs
significant :: [(Bool, String)]
significant
| ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
| Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
}
where
acceptAndExplain :: (a, b) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2) ->
[ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
(Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2)
]
zip3P :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)
zip3P :: Predicate a -> Predicate b -> Predicate c -> Predicate (a, b, c)
zip3P Predicate a
p1 Predicate b
p2 Predicate c
p3 =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3),
accept :: (a, b, c) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c) -> [(Bool, String)]) -> (a, b, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c) -> [(Bool, String)]
acceptAndExplain,
explain :: (a, b, c) -> String
explain = \(a, b, c)
xs ->
let results :: [(Bool, String)]
results = (a, b, c) -> [(Bool, String)]
acceptAndExplain (a, b, c)
xs
significant :: [(Bool, String)]
significant
| ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
| Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
}
where
acceptAndExplain :: (a, b, c) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3) ->
[ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
(Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
(Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3)
]
zip4P ::
Predicate a ->
Predicate b ->
Predicate c ->
Predicate d ->
Predicate (a, b, c, d)
zip4P :: Predicate a
-> Predicate b
-> Predicate c
-> Predicate d
-> Predicate (a, b, c, d)
zip4P Predicate a
p1 Predicate b
p2 Predicate c
p3 Predicate d
p4 =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c, Predicate d) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4),
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c, Predicate d) -> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4),
accept :: (a, b, c, d) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c, d) -> [(Bool, String)]) -> (a, b, c, d) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c, d) -> [(Bool, String)]
acceptAndExplain,
explain :: (a, b, c, d) -> String
explain = \(a, b, c, d)
xs ->
let results :: [(Bool, String)]
results = (a, b, c, d) -> [(Bool, String)]
acceptAndExplain (a, b, c, d)
xs
significant :: [(Bool, String)]
significant
| ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
| Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
}
where
acceptAndExplain :: (a, b, c, d) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3, d
x4) ->
[ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
(Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
(Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
(Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, Predicate d -> d -> String
forall a. Predicate a -> a -> String
explain Predicate d
p4 d
x4)
]
zip5P ::
Predicate a ->
Predicate b ->
Predicate c ->
Predicate d ->
Predicate e ->
Predicate (a, b, c, d, e)
zip5P :: Predicate a
-> Predicate b
-> Predicate c
-> Predicate d
-> Predicate e
-> Predicate (a, b, c, d, e)
zip5P Predicate a
p1 Predicate b
p2 Predicate c
p3 Predicate d
p4 Predicate e
p5 =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = (Predicate a, Predicate b, Predicate c, Predicate d, Predicate e)
-> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4, Predicate e
p5),
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Predicate a, Predicate b, Predicate c, Predicate d, Predicate e)
-> String
forall a. Show a => a -> String
show (Predicate a
p1, Predicate b
p2, Predicate c
p3, Predicate d
p4, Predicate e
p5),
accept :: (a, b, c, d, e) -> Bool
accept = ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> Bool)
-> ((a, b, c, d, e) -> [(Bool, String)]) -> (a, b, c, d, e) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain,
explain :: (a, b, c, d, e) -> String
explain = \(a, b, c, d, e)
xs ->
let results :: [(Bool, String)]
results = (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain (a, b, c, d, e)
xs
significant :: [(Bool, String)]
significant
| ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results = [(Bool, String)]
results
| Bool
otherwise = ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
significant
}
where
acceptAndExplain :: (a, b, c, d, e) -> [(Bool, String)]
acceptAndExplain = \(a
x1, b
x2, c
x3, d
x4, e
x5) ->
[ (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p1 a
x1, Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p1 a
x1),
(Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p2 b
x2, Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p2 b
x2),
(Predicate c -> c -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate c
p3 c
x3, Predicate c -> c -> String
forall a. Predicate a -> a -> String
explain Predicate c
p3 c
x3),
(Predicate d -> d -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate d
p4 d
x4, Predicate d -> d -> String
forall a. Predicate a -> a -> String
explain Predicate d
p4 d
x4),
(Predicate e -> e -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate e
p5 e
x5, Predicate e -> e -> String
forall a. Predicate a -> a -> String
explain Predicate e
p5 e
x5)
]
andP :: Predicate a -> Predicate a -> Predicate a
Predicate a
p andP :: Predicate a -> Predicate a -> Predicate a
`andP` Predicate a
q =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
q,
showNegation :: String
showNegation = Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" or " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
q,
accept :: a -> Bool
accept = \a
x -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x Bool -> Bool -> Bool
&& Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x,
explain :: a -> String
explain = \a
x ->
if
| Bool -> Bool
not (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x) -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x
| Bool -> Bool
not (Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
q a
x) -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
q a
x
| Bool
otherwise -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
q a
x
}
orP :: Predicate a -> Predicate a -> Predicate a
Predicate a
p orP :: Predicate a -> Predicate a -> Predicate a
`orP` Predicate a
q = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
p Predicate a -> Predicate a -> Predicate a
forall a. Predicate a -> Predicate a -> Predicate a
`andP` Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
q)
notP :: Predicate a -> Predicate a
notP :: Predicate a -> Predicate a
notP Predicate a
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = Predicate a -> String
forall a. Predicate a -> String
showNegation Predicate a
p,
showNegation :: String
showNegation = Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p,
accept :: a -> Bool
accept = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p,
explain :: a -> String
explain = Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p
}
#ifdef REGEX
matchesRegex :: (RegexLike Regex a, Eq a, Show a) => String -> Predicate a
matchesRegex :: String -> Predicate a
matchesRegex String
s =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
pat,
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
accept :: a -> Bool
accept = a -> Bool
accepts,
explain :: a -> String
explain = \a
x ->
if a -> Bool
accepts a
x
then a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" matches " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
else a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" doesn't match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
}
where
pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
accepts :: a -> Bool
accepts a
x = case Regex -> a -> Maybe (a, MatchText a, a)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
matchOnceText Regex
r a
x of
Just (a
a, MatchText a
_, a
b) -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty
Maybe (a, MatchText a, a)
Nothing -> Bool
False
r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
comp :: CompOption
comp = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
False}
matchesCaseInsensitiveRegex ::
(RegexLike Regex a, Eq a, Show a) => String -> Predicate a
matchesCaseInsensitiveRegex :: String -> Predicate a
matchesCaseInsensitiveRegex String
s =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
pat,
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
accept :: a -> Bool
accept = a -> Bool
accepts,
explain :: a -> String
explain = \a
x ->
if a -> Bool
accepts a
x
then a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" matches " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
else a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" doesn't match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat
}
where
pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/i"
accepts :: a -> Bool
accepts a
x = case Regex -> a -> Maybe (a, MatchText a, a)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
matchOnceText Regex
r a
x of
Just (a
a, MatchText a
_, a
b) -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall source. Extract source => source
empty
Maybe (a, MatchText a, a)
Nothing -> Bool
False
r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
comp :: CompOption
comp =
CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
{ newSyntax :: Bool
newSyntax = Bool
True,
lastStarGreedy :: Bool
lastStarGreedy = Bool
True,
caseSensitive :: Bool
caseSensitive = Bool
False
}
exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
False}
containsRegex :: (RegexLike Regex a, Eq a, Show a) => String -> Predicate a
containsRegex :: String -> Predicate a
containsRegex String
s = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"contains " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
showNegation :: String
showNegation = String
"doesn't contain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
accept :: a -> Bool
accept = Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MatchArray -> Bool) -> (a -> Maybe MatchArray) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> a -> Maybe MatchArray
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe MatchArray
matchOnce Regex
r,
explain :: a -> String
explain = a -> String
explainImpl
}
where
pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
comp :: CompOption
comp = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax :: Bool
newSyntax = Bool
True, lastStarGreedy :: Bool
lastStarGreedy = Bool
True}
exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
False}
containsCaseInsensitiveRegex ::
(RegexLike Regex a, Eq a, Show a) => String -> Predicate a
containsCaseInsensitiveRegex :: String -> Predicate a
containsCaseInsensitiveRegex String
s = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"contains " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
showNegation :: String
showNegation = String
"doesn't contain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pat,
accept :: a -> Bool
accept = Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MatchArray -> Bool) -> (a -> Maybe MatchArray) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> a -> Maybe MatchArray
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe MatchArray
matchOnce Regex
r,
explain :: a -> String
explain = a -> String
explainImpl
}
where
pat :: String
pat = String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/i"
r :: Regex
r = CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
comp ExecOption
exec String
s :: Regex
comp :: CompOption
comp =
CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
{ newSyntax :: Bool
newSyntax = Bool
True,
lastStarGreedy :: Bool
lastStarGreedy = Bool
True,
caseSensitive :: Bool
caseSensitive = Bool
False
}
exec :: ExecOption
exec = ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt {captureGroups :: Bool
captureGroups = Bool
False}
#endif
#ifdef CONTAINERS
startsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t
startsWith :: t -> Predicate t
startsWith t
pfx = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"starts with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
pfx,
showNegation :: String
showNegation = String
"doesn't start with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
pfx,
accept :: t -> Bool
accept = (t
pfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isPrefixOf`),
explain :: t -> String
explain = t -> String
explainImpl
}
endsWith :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t
endsWith :: t -> Predicate t
endsWith t
sfx = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"ends with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
sfx,
showNegation :: String
showNegation = String
"doesn't end with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
sfx,
accept :: t -> Bool
accept = (t
sfx t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isSuffixOf`),
explain :: t -> String
explain = t -> String
explainImpl
}
hasSubstr :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t
hasSubstr :: t -> Predicate t
hasSubstr t
s = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"has substring " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
showNegation :: String
showNegation = String
"doesn't have substring " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`Seq.isInfixOf`),
explain :: t -> String
explain = t -> String
explainImpl
}
hasSubsequence :: (Show t, Seq.IsSequence t, Eq (Element t)) => t -> Predicate t
hasSubsequence :: t -> Predicate t
hasSubsequence t
s = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"has subsequence " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
showNegation :: String
showNegation = String
"doesn't have subsequence " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
s,
accept :: t -> Bool
accept = (t
s t -> t -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isSubsequenceOf`),
explain :: t -> String
explain = t -> String
explainImpl
}
caseInsensitive ::
( MonoFunctor t,
MonoFunctor a,
Element t ~ Char,
Element a ~ Char
) =>
(t -> Predicate a) ->
(t -> Predicate a)
caseInsensitive :: (t -> Predicate a) -> t -> Predicate a
caseInsensitive t -> Predicate a
p t
s =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"(case insensitive) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Show a => a -> String
show (t -> Predicate a
p t
s),
showNegation :: String
showNegation = String
"(case insensitive) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Show a => a -> String
show (Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP (t -> Predicate a
p t
s)),
accept :: a -> Bool
accept = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
capP (a -> Bool) -> (a -> a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element a -> Element a) -> a -> a
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element a -> Element a
toUpper,
explain :: a -> String
explain = Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
capP (a -> String) -> (a -> a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element a -> Element a) -> a -> a
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element a -> Element a
toUpper
}
where
capP :: Predicate a
capP = t -> Predicate a
p ((Element t -> Element t) -> t -> t
forall mono.
MonoFunctor mono =>
(Element mono -> Element mono) -> mono -> mono
omap Char -> Char
Element t -> Element t
toUpper t
s)
isEmpty :: (MonoFoldable t, Show t) => Predicate t
isEmpty :: Predicate t
isEmpty = (t -> String)
-> String -> ((t -> String) -> Predicate t) -> Predicate t
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain t -> String
forall a. Show a => a -> String
show String
" is " (((t -> String) -> Predicate t) -> Predicate t)
-> ((t -> String) -> Predicate t) -> Predicate t
forall a b. (a -> b) -> a -> b
$ \t -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"empty",
showNegation :: String
showNegation = String
"non-empty",
accept :: t -> Bool
accept = t -> Bool
forall mono. MonoFoldable mono => mono -> Bool
onull,
explain :: t -> String
explain = t -> String
explainImpl
}
nonEmpty :: (MonoFoldable t, Show t) => Predicate t
nonEmpty :: Predicate t
nonEmpty = Predicate t -> Predicate t
forall a. Predicate a -> Predicate a
notP Predicate t
forall t. (MonoFoldable t, Show t) => Predicate t
isEmpty
sizeIs :: (MonoFoldable t, Show t) => Predicate Int -> Predicate t
sizeIs :: Predicate Int -> Predicate t
sizeIs Predicate Int
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate Int -> String
forall a. Predicate a -> String
showPredicate Predicate Int
p,
showNegation :: String
showNegation = String
"size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate Int -> String
forall a. Predicate a -> String
showNegation Predicate Int
p,
accept :: t -> Bool
accept = Predicate Int -> Int -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate Int
p (Int -> Bool) -> (t -> Int) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength,
explain :: t -> String
explain = \t
y ->
let detail :: String
detail
| Predicate Int -> Int -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate Int
p (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) = Predicate Int -> String
forall a. Predicate a -> String
showPredicate Predicate Int
p
| Bool
otherwise = Predicate Int -> String
forall a. Predicate a -> String
showNegation Predicate Int
p
detailStr :: String
detailStr
| Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
detail = String
""
| Bool
otherwise = String
", which is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
detail
in t -> String
forall a. Show a => a -> String
show t
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
y) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
detailStr
}
elemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
elemsAre :: [Predicate (Element t)] -> Predicate t
elemsAre [Predicate (Element t)]
ps =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
showNegation :: String
showNegation = String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
accept :: t -> Bool
accept = \t
xs ->
t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Predicate (Element t)] -> Int
forall mono. MonoFoldable mono => mono -> Int
olength [Predicate (Element t)]
ps
Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Predicate (Element t) -> Element t -> Bool)
-> [Predicate (Element t)] -> [Element t] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept [Predicate (Element t)]
ps (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs)),
explain :: t -> String
explain = \t
xs ->
let results :: [(Bool, String)]
results = [Element t] -> [(Bool, String)]
acceptAndExplain (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs)
in if
| t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Predicate (Element t)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps ->
String
"wrong size (got "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t -> Int
forall mono. MonoFoldable mono => mono -> Int
olength t
xs)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; expected "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Predicate (Element t)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate (Element t)]
ps)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
| ((Bool, String) -> Bool) -> [(Bool, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, String) -> Bool
forall a b. (a, b) -> a
fst [(Bool, String)]
results -> String
"elements are " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps
| Bool
otherwise ->
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(Bool, String) -> String
forall a b. (a, b) -> b
snd ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
results
}
where
acceptAndExplain :: [Element t] -> [(Bool, String)]
acceptAndExplain [Element t]
xs = (Int -> Predicate (Element t) -> Element t -> (Bool, String))
-> [Int]
-> [Predicate (Element t)]
-> [Element t]
-> [(Bool, String)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Predicate (Element t) -> Element t -> (Bool, String)
forall a a. Show a => a -> Predicate a -> a -> (Bool, String)
matchAndExplain [Int
1 :: Int ..] [Predicate (Element t)]
ps [Element t]
xs
matchAndExplain :: a -> Predicate a -> a -> (Bool, String)
matchAndExplain a
i Predicate a
p a
x =
(Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x, String
"in element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x)
unorderedElemsAre :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
unorderedElemsAre :: [Predicate (Element t)] -> Predicate t
unorderedElemsAre [Predicate (Element t)]
ps =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate =
String
"(any order) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
showNegation :: String
showNegation =
String
"not (in any order) " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
accept :: t -> Bool
accept = \t
xs ->
let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
in [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> Bool
&& [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs,
explain :: t -> String
explain = \t
xs ->
let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
in if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs Bool -> Bool -> Bool
&& [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
else
let missingExplanation :: Maybe String
missingExplanation =
if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
then Maybe String
forall a. Maybe a
Nothing
else
String -> Maybe String
forall a. a -> Maybe a
Just
( String
"Missing: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate (Predicate (Element t) -> String)
-> [Predicate (Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate (Element t)]
orphanPs)
)
extraExplanation :: Maybe String
extraExplanation =
if [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
then Maybe String
forall a. Maybe a
Nothing
else
String -> Maybe String
forall a. a -> Maybe a
Just
( String
"Extra elements: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
String
", "
((String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((Int, Element t) -> String) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, Element t) -> Int) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Element t) -> Int
forall a b. (a, b) -> a
fst ((Int, Element t) -> String) -> [(Int, Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Element t)]
orphanXs)
)
in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
String
"; "
([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
missingExplanation, Maybe String
extraExplanation])
}
where
matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x
each :: MonoFoldable t => Predicate (Element t) -> Predicate t
each :: Predicate (Element t) -> Predicate t
each Predicate (Element t)
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"each (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate Predicate (Element t)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"contains (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showNegation Predicate (Element t)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: t -> Bool
accept = ((Bool, (Int, String)) -> Bool) -> [(Bool, (Int, String))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, (Int, String))] -> Bool)
-> (t -> [(Bool, (Int, String))]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(Bool, (Int, String))]
acceptAndExplain,
explain :: t -> String
explain = \t
xs ->
let results :: [(Bool, (Int, String))]
results = t -> [(Bool, (Int, String))]
acceptAndExplain t
xs
format :: (a, String) -> String
format (a
i, String
explanation) =
String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
explanation
in if ((Bool, (Int, String)) -> Bool) -> [(Bool, (Int, String))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst [(Bool, (Int, String))]
results
then String
"all elements " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate Predicate (Element t)
p
else
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(Int, String) -> String
forall a. Show a => (a, String) -> String
format ((Int, String) -> String)
-> ((Bool, (Int, String)) -> (Int, String))
-> (Bool, (Int, String))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, (Int, String)) -> (Int, String)
forall a b. (a, b) -> b
snd ((Bool, (Int, String)) -> String)
-> [(Bool, (Int, String))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, (Int, String)) -> Bool)
-> [(Bool, (Int, String))] -> [(Bool, (Int, String))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, (Int, String)) -> Bool) -> (Bool, (Int, String)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, (Int, String)) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, (Int, String))]
results
}
where
acceptAndExplain :: t -> [(Bool, (Int, String))]
acceptAndExplain t
xs =
[(Predicate (Element t) -> Element t -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate (Element t)
p Element t
x, (Int
i, Predicate (Element t) -> Element t -> String
forall a. Predicate a -> a -> String
explain Predicate (Element t)
p Element t
x)) | Int
i <- [Int
1 :: Int ..] | Element t
x <- t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs]
contains :: MonoFoldable t => Predicate (Element t) -> Predicate t
contains :: Predicate (Element t) -> Predicate t
contains = Predicate t -> Predicate t
forall a. Predicate a -> Predicate a
notP (Predicate t -> Predicate t)
-> (Predicate (Element t) -> Predicate t)
-> Predicate (Element t)
-> Predicate t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate (Element t) -> Predicate t
forall t. MonoFoldable t => Predicate (Element t) -> Predicate t
each (Predicate (Element t) -> Predicate t)
-> (Predicate (Element t) -> Predicate (Element t))
-> Predicate (Element t)
-> Predicate t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate (Element t) -> Predicate (Element t)
forall a. Predicate a -> Predicate a
notP
containsAll :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsAll :: [Predicate (Element t)] -> Predicate t
containsAll [Predicate (Element t)]
ps =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"contains all of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
showNegation :: String
showNegation = String
"not all of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
accept :: t -> Bool
accept = \t
xs -> let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
_) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs in [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs,
explain :: t -> String
explain = \t
xs ->
let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
orphanPs, [(Int, Element t)]
_) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
in if [Predicate (Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Predicate (Element t)]
orphanPs
then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
else String
"Missing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Predicate (Element t) -> String
forall a. Predicate a -> String
showPredicate (Predicate (Element t) -> String)
-> [Predicate (Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate (Element t)]
orphanPs)
}
where
matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x
containsOnly :: MonoFoldable t => [Predicate (Element t)] -> Predicate t
containsOnly :: [Predicate (Element t)] -> Predicate t
containsOnly [Predicate (Element t)]
ps =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"contains only " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
showNegation :: String
showNegation = String
"not only " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Predicate (Element t)] -> String
forall a. Show a => a -> String
show [Predicate (Element t)]
ps,
accept :: t -> Bool
accept = \t
xs -> let ([(Predicate (Element t), (Int, Element t))]
_, [Predicate (Element t)]
_, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs in [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs,
explain :: t -> String
explain = \t
xs ->
let ([(Predicate (Element t), (Int, Element t))]
matches, [Predicate (Element t)]
_, [(Int, Element t)]
orphanXs) = t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs
in if [(Int, Element t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Element t)]
orphanXs
then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; and " ((Predicate (Element t), (Int, Element t)) -> String
forall a a. Show a => (Predicate a, (a, a)) -> String
explainMatch ((Predicate (Element t), (Int, Element t)) -> String)
-> [(Predicate (Element t), (Int, Element t))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Predicate (Element t), (Int, Element t))]
matches)
else
String
"Extra elements: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((Int, Element t) -> String) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, Element t) -> Int) -> (Int, Element t) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Element t) -> Int
forall a b. (a, b) -> a
fst ((Int, Element t) -> String) -> [(Int, Element t)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Element t)]
orphanXs)
}
where
matchOne :: Predicate a -> (a, a) -> Bool
matchOne Predicate a
p (a
_, a
x) = Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
x
matchAll :: t
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
matchAll t
xs = (Predicate (Element t) -> (Int, Element t) -> Bool)
-> [Predicate (Element t)]
-> [(Int, Element t)]
-> ([(Predicate (Element t), (Int, Element t))],
[Predicate (Element t)], [(Int, Element t)])
forall a b. (a -> b -> Bool) -> [a] -> [b] -> ([(a, b)], [a], [b])
bipartiteMatching Predicate (Element t) -> (Int, Element t) -> Bool
forall a a. Predicate a -> (a, a) -> Bool
matchOne [Predicate (Element t)]
ps ([Int] -> [Element t] -> [(Int, Element t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] (t -> [Element t]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList t
xs))
explainMatch :: (Predicate a, (a, a)) -> String
explainMatch (Predicate a
p, (a
j, a
x)) = String
"element #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
x
keys :: (IsList t, Item t ~ (k, v)) => Predicate [k] -> Predicate t
keys :: Predicate [k] -> Predicate t
keys Predicate [k]
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"keys (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [k] -> String
forall a. Predicate a -> String
showPredicate Predicate [k]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"keys (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [k] -> String
forall a. Predicate a -> String
showNegation Predicate [k]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: t -> Bool
accept = Predicate [k] -> [k] -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate [k]
p ([k] -> Bool) -> (t -> [k]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst ([(k, v)] -> [k]) -> (t -> [(k, v)]) -> t -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList,
explain :: t -> String
explain = (String
"in keys, " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (t -> String) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate [k] -> [k] -> String
forall a. Predicate a -> a -> String
explain Predicate [k]
p ([k] -> String) -> (t -> [k]) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst ([(k, v)] -> [k]) -> (t -> [(k, v)]) -> t -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList
}
values :: (IsList t, Item t ~ (k, v)) => Predicate [v] -> Predicate t
values :: Predicate [v] -> Predicate t
values Predicate [v]
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"values (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [v] -> String
forall a. Predicate a -> String
showPredicate Predicate [v]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
showNegation :: String
showNegation = String
"values (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate [v] -> String
forall a. Predicate a -> String
showNegation Predicate [v]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")",
accept :: t -> Bool
accept = Predicate [v] -> [v] -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate [v]
p ([v] -> Bool) -> (t -> [v]) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> v) -> [(k, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> v
forall a b. (a, b) -> b
snd ([(k, v)] -> [v]) -> (t -> [(k, v)]) -> t -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList,
explain :: t -> String
explain = (String
"in values, " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (t -> String) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate [v] -> [v] -> String
forall a. Predicate a -> a -> String
explain Predicate [v]
p ([v] -> String) -> (t -> [v]) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> v) -> [(k, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> v
forall a b. (a, b) -> b
snd ([(k, v)] -> [v]) -> (t -> [(k, v)]) -> t -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(k, v)]
forall l. IsList l => l -> [Item l]
toList
}
#endif
approxEq :: (RealFloat a, Show a) => a -> Predicate a
approxEq :: a -> Predicate a
approxEq a
x = (a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
forall a.
(a -> String)
-> String -> ((a -> String) -> Predicate a) -> Predicate a
withDefaultExplain a -> String
forall a. Show a => a -> String
show String
" " (((a -> String) -> Predicate a) -> Predicate a)
-> ((a -> String) -> Predicate a) -> Predicate a
forall a b. (a -> b) -> a -> b
$ \a -> String
explainImpl ->
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"≈ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
showNegation :: String
showNegation = String
"≇" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x,
accept :: a -> Bool
accept = \a
y -> a -> a
forall a. Num a => a -> a
abs (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
diff,
explain :: a -> String
explain = a -> String
explainImpl
}
where
diff :: a
diff = Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
1 ((Integer, Int) -> Int
forall a b. (a, b) -> b
snd (a -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat a
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. RealFloat a => a -> Int
floatDigits a
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
positive :: (Ord a, Num a) => Predicate a
positive :: Predicate a
positive =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"positive",
showNegation :: String
showNegation = String
"non-positive",
accept :: a -> Bool
accept = \a
x -> a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0,
explain :: a -> String
explain = \a
x ->
if
| a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 -> String
"value is positive"
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
| a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is negative"
| Bool
otherwise -> String
"value has unknown sign"
}
negative :: (Ord a, Num a) => Predicate a
negative :: Predicate a
negative =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"negative",
showNegation :: String
showNegation = String
"non-negative",
accept :: a -> Bool
accept = \a
x -> a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0,
explain :: a -> String
explain = \a
x ->
if
| a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is negative"
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 -> String
"value is zero"
| a -> a
forall a. Num a => a -> a
signum a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 -> String
"value is positive"
| Bool
otherwise -> String
"value has unknown sign"
}
nonPositive :: (Ord a, Num a) => Predicate a
nonPositive :: Predicate a
nonPositive = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
forall a. (Ord a, Num a) => Predicate a
positive
nonNegative :: (Ord a, Num a) => Predicate a
nonNegative :: Predicate a
nonNegative = Predicate a -> Predicate a
forall a. Predicate a -> Predicate a
notP Predicate a
forall a. (Ord a, Num a) => Predicate a
negative
finite :: RealFloat a => Predicate a
finite :: Predicate a
finite =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"finite",
showNegation :: String
showNegation = String
"non-finite",
accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isFinite,
explain :: a -> String
explain = \a
x ->
if a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x
then String
"value is finite"
else String
"value is not finite"
}
where
isFinite :: a -> Bool
isFinite a
x = Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x)
infinite :: RealFloat a => Predicate a
infinite :: Predicate a
infinite =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"infinite",
showNegation :: String
showNegation = String
"non-infinite",
accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite,
explain :: a -> String
explain = \a
x ->
if a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x
then String
"value is infinite"
else String
"value is not infinite"
}
nAn :: RealFloat a => Predicate a
nAn :: Predicate a
nAn =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"NaN",
showNegation :: String
showNegation = String
"non-NaN",
accept :: a -> Bool
accept = a -> Bool
forall a. RealFloat a => a -> Bool
isNaN,
explain :: a -> String
explain = \a
x ->
if a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x
then String
"value is NaN"
else String
"value is not NaN"
}
is :: HasCallStack => (a -> Bool) -> Predicate a
is :: (a -> Bool) -> Predicate a
is a -> Bool
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"custom predicate"),
showNegation :: String
showNegation = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"negated custom predicate"),
accept :: a -> Bool
accept = a -> Bool
p,
explain :: a -> String
explain = \a
x ->
if a -> Bool
p a
x
then String
"value matched custom predicate"
else String
"value did not match custom predicate"
}
qIs :: HasCallStack => ExpQ -> ExpQ
qIs :: ExpQ -> ExpQ
qIs ExpQ
p =
[|
Predicate
{ showPredicate = $description,
showNegation = "not " ++ $description,
accept = $p,
explain = \x -> if $p x then $description else "not " ++ $description
}
|]
where
description :: ExpQ
description = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Exp -> String) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> (Exp -> Exp) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
forall a. Data a => a -> a
removeModNames (Exp -> ExpQ) -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ
p
with :: HasCallStack => (a -> b) -> Predicate b -> Predicate a
with :: (a -> b) -> Predicate b -> Predicate a
with a -> b
f Predicate b
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Show a => a -> String
show Predicate b
p,
showNegation :: String
showNegation = String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showNegation Predicate b
p,
accept :: a -> Bool
accept = Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f,
explain :: a -> String
explain = ((String
prop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
}
where
prop :: String
prop = Located String -> String
withLoc (CallStack -> String -> Located String
forall a. CallStack -> a -> Located a
locate CallStack
HasCallStack => CallStack
callStack String
"property")
instance Contravariant Predicate where
contramap :: (a -> b) -> Predicate b -> Predicate a
contramap a -> b
f Predicate b
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"in a property: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Show a => a -> String
show Predicate b
p,
showNegation :: String
showNegation = String
"in a property: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> String
forall a. Predicate a -> String
showNegation Predicate b
p,
accept :: a -> Bool
accept = Predicate b -> b -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate b
p (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f,
explain :: a -> String
explain = (String
"in a property: " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
}
qWith :: ExpQ -> ExpQ
qWith :: ExpQ -> ExpQ
qWith ExpQ
f =
[|
\p ->
Predicate
{ showPredicate = $prop ++ ": " ++ show p,
showNegation = $prop ++ ": " ++ showNegation p,
accept = accept p . $f,
explain = (($prop ++ ": ") ++) . explain p . $f
}
|]
where
prop :: ExpQ
prop = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Exp -> String) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> (Exp -> Exp) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
forall a. Data a => a -> a
removeModNames (Exp -> ExpQ) -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ
f
inBranch :: String -> (a -> Maybe b) -> Predicate b -> Predicate a
inBranch :: String -> (a -> Maybe b) -> Predicate b -> Predicate a
inBranch String
name a -> Maybe b
f Predicate b
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" _)",
showNegation :: String
showNegation = String
"not (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" _)",
accept :: a -> Bool
accept = \a
x -> case a -> Maybe b
f a
x of Just b
y -> Predicate b -> b -> Bool
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate b -> b -> String
forall a. Predicate a -> a -> String
explain Predicate b
p b
y
Maybe b
_ -> String
"Branch didn't match"
}
qADT :: Name -> ExpQ
qADT :: Name -> ExpQ
qADT Name
conName =
do
let prettyConName :: ExpQ
prettyConName = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (Name -> String
forall a. Ppr a => a -> String
pprint (Name -> Name
forall a. Data a => a -> a
removeModNames Name
conName))
Type
t <- Name -> Q Info
reify Name
conName Q Info -> (Info -> Q Type) -> Q Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
DataConI Name
_ Type
ty Name
_ -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
PatSynI Name
_ Type
ty -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
Info
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"qADT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
conName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a data constructor")
let n :: Int
n = Type -> Int
forall a. Num a => Type -> a
countArguments Type
t
[Name]
subpreds <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"p")
let subdescs :: [ExpQ]
subdescs =
(ExpQ -> ExpQ) -> [ExpQ] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map
(\ExpQ
p -> [|"(" ++ showPredicate $p ++ ")"|])
(Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [|"≠ " ++ $desc|]
| Bool
otherwise = [|"not (" ++ $desc ++ ")"|]
[Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"x")
let pattern :: PatQ
pattern = Name -> [PatQ] -> PatQ
conP Name
conName (Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
let acceptExplainFields :: ExpQ
acceptExplainFields =
[ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
(ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> [ExpQ] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\ExpQ
p ExpQ
x -> [|(accept $p $x, explain $p $x)|])
(Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subpreds)
(Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
Name
y <- String -> Q Name
newName String
"y"
[PatQ] -> ExpQ -> ExpQ
lamE
(Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
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 -> a
countArguments (ForallT [TyVarBndr]
_ Cxt
_ Type
t) = Type -> a
countArguments Type
t
countArguments (AppT (AppT Type
ArrowT Type
_) Type
t) = Type -> a
countArguments Type
t a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
#if MIN_VERSION_template_haskell(2,17,0)
countArguments (AppT (AppT (AppT MulArrowT _) _) t) = countArguments t + 1
#endif
countArguments Type
_ = a
0
qMatch :: PatQ -> ExpQ
qMatch :: PatQ -> ExpQ
qMatch PatQ
qpat =
[|
Predicate
{ showPredicate = $patString,
showNegation = "not " ++ $patString,
accept = \case
$qpat -> True
_ -> False,
explain = \case
$qpat -> "value matched " ++ $patString
_ -> "value didn't match " ++ $patString
}
|]
where
patString :: ExpQ
patString = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String -> ExpQ) -> (Pat -> String) -> Pat -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> String
forall a. Ppr a => a -> String
pprint (Pat -> String) -> (Pat -> Pat) -> Pat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> Pat
forall a. Data a => a -> a
removeModNames (Pat -> ExpQ) -> PatQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PatQ
qpat
typed :: forall a b. (Typeable a, Typeable b) => Predicate a -> Predicate b
typed :: Predicate a -> Predicate b
typed Predicate a
p =
Predicate :: forall a.
String -> String -> (a -> Bool) -> (a -> String) -> Predicate a
Predicate
{ showPredicate :: String
showPredicate =
Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)),
showNegation :: String
showNegation =
String
"not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Predicate a -> String
forall a. Predicate a -> String
showPredicate Predicate a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)),
accept :: b -> Bool
accept = \b
x -> case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
Maybe a
Nothing -> Bool
False
Just a
y -> Predicate a -> a -> Bool
forall a. Predicate a -> a -> Bool
accept Predicate a
p a
y,
explain :: b -> String
explain = \b
x -> case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
Maybe a
Nothing ->
String
"wrong type ("
String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy b -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy b
forall a. HasCallStack => a
undefined :: Proxy b))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" vs. "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall a. HasCallStack => a
undefined :: Proxy a))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
Just a
y -> Predicate a -> a -> String
forall a. Predicate a -> a -> String
explain Predicate a
p a
y
}