{-# language ViewPatterns #-}
module PredicateTransformers where
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
type Pred a = a -> Bool
type PT a b = Pred a -> Pred b
match :: APrism s t a b -> PT a s
match p pred = either (const False) pred . matching p
{-# inlinable match #-}
nay :: PT a a
nay = (not .)
{-# inlinable nay #-}
just :: PT a (Maybe a)
just = match _Just
{-# inlinable just #-}
left :: PT e (Either e a)
left = match _Left
{-# inlinable left #-}
right :: PT a (Either e a)
right = match _Right
{-# inlinable right #-}
endingWith :: Foldable f => PT a (f a)
endingWith _ (toList -> []) = False
endingWith p (toList -> xs) = p $ last xs
{-# inlinable endingWith #-}
startingWith :: Foldable f => PT a (f a)
startingWith p (toList -> (x:_)) = p x
startingWith _ (toList -> []) = False
{-# inlinable startingWith #-}
only :: Foldable f => PT a (f a)
only p (toList -> [x]) = p x
only _ _ = False
{-# inlinable only #-}
kth :: Foldable f => Int -> PT a (f a)
kth k p = startingWith p . drop k . toList
{-# inlinable kth #-}
list :: [Pred a] -> Pred [a]
list (p:ps) (x:xs) = p x && dist ps xs
list [] [] = True
list _ _ = False
{-# inlinable list #-}
dist ::
(Eq (f ()), Functor f, Foldable f) =>
f (Pred a) -> Pred (f a)
dist preds values =
(() <$ preds) == (() <$ values) &&
list (toList preds) (toList values)
{-# inlinable dist #-}
distRep :: Representable f =>
f (a -> Bool) -> f a -> f Bool
distRep pr fa = tabulate (\r -> index pr r $ index fa r)
{-# inlinable distRep #-}
allTrue :: [Pred a] -> Pred a
allTrue ps a = all ($ a) ps
{-# inlinable allTrue #-}
allOf1 :: Getting (All, Any) s a -> PT a s
allOf1 g p (foldMapOf g (\x -> (All $ p x, Any $ p x)) -> (All a, Any y)) = a && y
{-# inlinable allOf1 #-}
(==>) :: a -> b -> (a, b)
(==>) = (,)
{-# inline conlike (==>) #-}
pair :: Pred a -> Pred b -> Pred (a,b)
pair f s (a,b) = f a && s b
{-# inline conlike pair #-}
(!) :: (b -> a) -> (a -> c) -> b -> c
(!) = flip (.)
{-# inline conlike (!) #-}
traced :: Show a => (a -> c) -> a -> c
traced p a = traceShow a (p a)
{-# inline traced #-}
traceFailure :: Show a => PT a a
traceFailure p a = if p a then True else traceShow a False
{-# inline traceFailure #-}
something :: Pred a
something = const True
{-# inline something #-}