{-# 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 :: 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
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
.)
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
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
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
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 #-}
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 #-}
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 #-}
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 #-}
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
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 #-}
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 #-}
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
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
(==>) :: 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
(!) :: (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
(.)
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)
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
something :: Pred a
something :: Pred a
something = Bool -> Pred a
forall a b. a -> b -> a
const Bool
True
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