{-# language ViewPatterns #-}
{-# language LambdaCase #-}
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
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
nay :: PT a a
nay = (not .)
just :: PT a (Maybe a)
just = match _Just
left :: PT e (Either e a)
left = match _Left
right :: PT a (Either e a)
right = match _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
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
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
(==>) :: a -> b -> (a, b)
(==>) = (,)
pair :: Pred a -> Pred b -> Pred (a,b)
pair f s (a,b) = f a && s b
(!) :: (b -> a) -> (a -> c) -> b -> c
(!) = flip (.)
traced :: Show a => (a -> c) -> a -> c
traced p a = traceShow a (p a)
traceFail :: (a -> String) -> PT a a
traceFail s p a = unsafePerformIO $ do
try (evaluate (p a)) >>= \case
Left ex -> do
traceIO (s a)
throwIO (ex :: SomeException)
Right True ->
pure True
Right False -> do
traceIO ("\n" <> s a)
pure False
traceFailShow :: Show a => PT a a
traceFailShow = traceFail show
something :: Pred a
something = const True
forced :: NFData a => a -> Bool
forced a = force a `seq` True