{-# language ViewPatterns #-}
{-# language LambdaCase #-}

-- | This library is based on the notion of a predicate transformer, the below
-- type @PT a b@, which is a function from @a@ to predicates on @b@.
-- They act as a sort of compositional "matcher language".
-- Composing these predicate transformers is meant to be analogous to composing optics
-- and there are utilities for using predicate transformers with (`lens`-style) optics.
--
-- Some predicate transformers provided by other libraries:
-- `Data.Foldable.all`, `Data.Foldable.any` (base)
-- `either` (base)
-- `Control.Lens.allOf` (lens)

module PredicateTransformers where

import Control.DeepSeq(NFData, force)
import Control.Exception(SomeException, evaluate, throwIO, try)
import Control.Lens hiding (index, zoom)
import Control.Monad.Writer(execWriter, tell)
import Data.Foldable(toList)
import Data.Functor.Rep(Representable(..))
import Data.Semigroup(All(..), Any(..))
import Debug.Trace
import System.IO.Unsafe

-- |A convenient alias for predicates.
type Pred a = a -> Bool

-- |Predicate transformers form a category where composition is ordinary function composition.
-- Forms a category with `.` and `id`.
-- Multiple are already provided by the standard library,
-- for instance `Data.Foldable.all` and `Data.Foldable.any`.
type PT a b = Pred a -> Pred b

-- |Operate on the target of a prism, or fail.
match :: APrism s t a b -> PT a s
match :: APrism s t a b -> PT a s
match APrism s t a b
p Pred a
pred = (t -> Bool) -> Pred a -> Either t a -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> t -> Bool
forall a b. a -> b -> a
const Bool
False) Pred a
pred (Either t a -> Bool) -> (s -> Either t a) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APrism s t a b -> s -> Either t a
forall s t a b. APrism s t a b -> s -> Either t a
matching APrism s t a b
p

-- |Invert a predicate.
nay :: PT a a
nay :: PT a a
nay = (Bool -> Bool
not (Bool -> Bool) -> PT a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

-- |Operate on the `Just` branch of a `Maybe`, or fail.
just :: PT a (Maybe a)
just :: PT a (Maybe a)
just = APrism (Maybe a) (Maybe Any) a Any -> PT a (Maybe a)
forall s t a b. APrism s t a b -> PT a s
match APrism (Maybe a) (Maybe Any) a Any
forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- |Operate on the `Left` branch of an `Either`, or fail.
left :: PT e (Either e a)
left :: PT e (Either e a)
left = APrism (Either e a) (Either Any a) e Any -> PT e (Either e a)
forall s t a b. APrism s t a b -> PT a s
match APrism (Either e a) (Either Any a) e Any
forall a c b. Prism (Either a c) (Either b c) a b
_Left

-- |Operate on the `Right` branch of an `Either`, or fail.
right :: PT a (Either e a)
right :: PT a (Either e a)
right = APrism (Either e a) (Either e Any) a Any -> PT a (Either e a)
forall s t a b. APrism s t a b -> PT a s
match APrism (Either e a) (Either e Any) a Any
forall c a b. Prism (Either c a) (Either c b) a b
_Right

-- |Operate on the last value in a foldable, or fail if it's not present.
endingWith :: Foldable f => PT a (f a)
endingWith :: PT a (f a)
endingWith Pred a
_ (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = Bool
False
endingWith Pred a
p (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [a]
xs) = Pred a
p Pred a -> Pred a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
last [a]
xs
{-# inlinable endingWith #-}

-- |Operate on the first value in a foldable, or fail if it's not present.
startingWith :: Foldable f => PT a (f a)
startingWith :: PT a (f a)
startingWith Pred a
p (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> (a
x:[a]
_)) = Pred a
p a
x
startingWith Pred a
_ (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = Bool
False
{-# inlinable startingWith #-}

-- |Require that a foldable has a single element, and operate on that element.
only :: Foldable f => PT a (f a)
only :: PT a (f a)
only Pred a
p (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [a
x]) = Pred a
p a
x
only Pred a
_ f a
_ = Bool
False
{-# inlinable only #-}

-- |Only test the @k@th element of a foldable.
kth :: Foldable f => Int -> PT a (f a)
kth :: Int -> PT a (f a)
kth Int
k Pred a
p = PT a [a]
forall (f :: * -> *) a. Foldable f => PT a (f a)
startingWith Pred a
p ([a] -> Bool) -> (f a -> [a]) -> f a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
k ([a] -> [a]) -> (f a -> [a]) -> f a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
{-# inlinable kth #-}

-- |Given a list of predicates and a list of values, ensure that each predicate holds for each respective value.
-- Fails if the two lists have different lengths.
list :: [Pred a] -> Pred [a]
list :: [Pred a] -> Pred [a]
list (Pred a
p:[Pred a]
ps) (a
x:[a]
xs) = Pred a
p a
x Bool -> Bool -> Bool
&& [Pred a] -> Pred [a]
forall (f :: * -> *) a.
(Eq (f ()), Functor f, Foldable f) =>
f (Pred a) -> Pred (f a)
dist [Pred a]
ps [a]
xs
list [] [] = Bool
True
list [Pred a]
_ [a]
_ = Bool
False

-- |Given a functor-full of predicates, and a functor-full of values, ensure that the structures
-- of the two functors match and apply all of the predicates to all of the values.
-- Generalized version of `list`.
dist ::
    (Eq (f ()), Functor f, Foldable f) =>
    f (Pred a) -> Pred (f a)
dist :: f (Pred a) -> Pred (f a)
dist f (Pred a)
preds f a
values =
    (() () -> f (Pred a) -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f (Pred a)
preds) f () -> f () -> Bool
forall a. Eq a => a -> a -> Bool
== (() () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
values) Bool -> Bool -> Bool
&&
    [Pred a] -> Pred [a]
forall a. [Pred a] -> Pred [a]
list (f (Pred a) -> [Pred a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Pred a)
preds) (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
values)
{-# inlinable dist #-}

-- |Given a representable functor-full of predicates, and a functor-full of values,
-- yield a representable functor-full of booleans. Similar to `dist`.
distRep :: Representable f =>
    f (a -> Bool) -> f a -> f Bool
distRep :: f (a -> Bool) -> f a -> f Bool
distRep f (a -> Bool)
pr f a
fa = (Rep f -> Bool) -> f Bool
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\Rep f
r -> f (a -> Bool) -> Rep f -> a -> Bool
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f (a -> Bool)
pr Rep f
r (a -> Bool) -> a -> Bool
forall a b. (a -> b) -> a -> b
$ f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f a
fa Rep f
r)
{-# inlinable distRep #-}

-- |Test all predicates against one value.
allTrue :: [Pred a] -> Pred a
allTrue :: [Pred a] -> Pred a
allTrue [Pred a]
ps a
a = (Pred a -> Bool) -> [Pred a] -> Bool
forall (f :: * -> *) a. Foldable f => PT a (f a)
all (Pred a -> Pred a
forall a b. (a -> b) -> a -> b
$ a
a) [Pred a]
ps

-- |Check that a predicate is true for all values behind a generalized getter
-- and that there's at least one value for which it's true.
allOf1 :: Getting (All, Any) s a -> PT a s
allOf1 :: Getting (All, Any) s a -> PT a s
allOf1 Getting (All, Any) s a
g Pred a
p (Getting (All, Any) s a -> (a -> (All, Any)) -> s -> (All, Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting (All, Any) s a
g (\a
x -> (Bool -> All
All (Bool -> All) -> Bool -> All
forall a b. (a -> b) -> a -> b
$ Pred a
p a
x, Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ Pred a
p a
x)) -> (All Bool
a, Any Bool
y)) = Bool
a Bool -> Bool -> Bool
&& Bool
y

-- |Sugar for tupling.
(==>) :: a -> b -> (a, b)
==> :: a -> b -> (a, b)
(==>) = (,)

pair :: Pred a -> Pred b -> Pred (a,b)
pair :: Pred a -> Pred b -> Pred (a, b)
pair Pred a
f Pred b
s (a
a,b
b) = Pred a
f a
a Bool -> Bool -> Bool
&& Pred b
s b
b

-- |Flipped function composition; @f !@ for a function @f@ is a predicate transformer.
(!) :: (b -> a) -> (a -> c) -> b -> c
(!) = ((a -> c) -> (b -> a) -> b -> c) -> (b -> a) -> (a -> c) -> b -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> c) -> (b -> a) -> b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

-- |Prints the input of a predicate, for debugging.
traced :: Show a => (a -> c) -> a -> c
traced :: (a -> c) -> a -> c
traced a -> c
p a
a = a -> c -> c
forall a b. Show a => a -> b -> b
traceShow a
a (a -> c
p a
a)

-- |Prints the input of a predicate, if the predicate fails.
traceFail :: (a -> String) -> PT a a
traceFail :: (a -> String) -> PT a a
traceFail a -> String
s Pred a
p a
a = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  IO Bool -> IO (Either SomeException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
try (Bool -> IO Bool
forall a. a -> IO a
evaluate (Pred a
p a
a)) IO (Either SomeException Bool)
-> (Either SomeException Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
ex -> do
      String -> IO ()
traceIO (a -> String
s a
a)
      SomeException -> IO Bool
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
    Right Bool
True ->
      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Right Bool
False -> do
      String -> IO ()
traceIO (String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
s a
a)
      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

traceFailShow :: Show a => PT a a
traceFailShow :: PT a a
traceFailShow = (a -> String) -> PT a a
forall a. (a -> String) -> PT a a
traceFail a -> String
forall a. Show a => a -> String
show

-- |Predicate which always succeeds.
something :: Pred a
something :: Pred a
something = Bool -> Pred a
forall a b. a -> b -> a
const Bool
True

-- |Predicate which triggers full evaluation of its input.
-- Useful for testing that an exception isn't thrown.
forced :: NFData a => a -> Bool
forced :: a -> Bool
forced a
a = a -> a
forall a. NFData a => a -> a
force a
a a -> Bool -> Bool
`seq` Bool
True