{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}

-- | 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.Applicative
import Control.DeepSeq (NFData, force)
import Control.Exception (Exception, SomeException, evaluate, throwIO, try)
import Control.Lens hiding (index, zoom)
import Control.Monad
import Control.Monad.Writer (execWriter, tell)
import Data.Bool
import Data.Foldable (toList)
import Data.Functor.Rep (Representable (..))
import Data.Semigroup (All (..), Any (..))
import Data.Typeable
import Debug.Trace
import System.IO.Unsafe

class Predicatory a where
  oneOfTwo :: a -> a -> a
  also :: a -> a -> a
  stop :: a
  continue :: a

instance Predicatory a => Predicatory (e -> a) where
  (e -> a
f oneOfTwo :: (e -> a) -> (e -> a) -> e -> a
`oneOfTwo` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. Predicatory a => a -> a -> a
`oneOfTwo` e -> a
f' e
e
  (e -> a
f also :: (e -> a) -> (e -> a) -> e -> a
`also` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. Predicatory a => a -> a -> a
`also` e -> a
f' e
e
  stop :: e -> a
stop = \e
_ -> a
forall a. Predicatory a => a
stop
  continue :: e -> a
continue = \e
_ -> a
forall a. Predicatory a => a
continue

class Exceptional a where
  assess :: a -> IO ()

data PredicateFailed = PredicateFailed
  deriving (Int -> PredicateFailed -> ShowS
[PredicateFailed] -> ShowS
PredicateFailed -> String
(Int -> PredicateFailed -> ShowS)
-> (PredicateFailed -> String)
-> ([PredicateFailed] -> ShowS)
-> Show PredicateFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PredicateFailed -> ShowS
showsPrec :: Int -> PredicateFailed -> ShowS
$cshow :: PredicateFailed -> String
show :: PredicateFailed -> String
$cshowList :: [PredicateFailed] -> ShowS
showList :: [PredicateFailed] -> ShowS
Show, Typeable)

instance Exception PredicateFailed

instance Predicatory Bool where
  oneOfTwo :: Bool -> Bool -> Bool
oneOfTwo = Bool -> Bool -> Bool
(||)
  also :: Bool -> Bool -> Bool
also = Bool -> Bool -> Bool
(&&)
  stop :: Bool
stop = Bool
False
  continue :: Bool
continue = Bool
True

instance Exceptional Bool where
  assess :: Bool -> IO ()
assess Bool
b = do
    Bool -> IO Bool
forall a. a -> IO a
evaluate Bool
b
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b IO ()
forall a. Predicatory a => a
stop

instance Predicatory (IO ()) where
  oneOfTwo :: IO () -> IO () -> IO ()
oneOfTwo IO ()
x IO ()
y = IO ()
x IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO ()
y
  also :: IO () -> IO () -> IO ()
also = IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
  stop :: IO ()
stop = PredicateFailed -> IO ()
forall e a. Exception e => e -> IO a
throwIO PredicateFailed
PredicateFailed
  continue :: IO ()
continue = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance Exceptional (IO ()) where
  assess :: IO () -> IO ()
assess IO ()
x = IO ()
x IO () -> (() -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= () -> IO ()
forall a. a -> IO a
evaluate

-- | 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 p a b = (a -> p) -> (b -> p)

-- | Operate on the target of a prism, or fail.
match :: Predicatory p => APrism s t a b -> PT p a s
match :: forall p s t a b. Predicatory p => APrism s t a b -> PT p a s
match APrism s t a b
p a -> p
pred = (t -> p) -> (a -> p) -> Either t a -> p
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (p -> t -> p
forall a b. a -> b -> a
const p
forall a. Predicatory a => a
stop) a -> p
pred (Either t a -> p) -> (s -> Either t a) -> s -> p
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

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

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

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

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

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

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

-- | Only test the @k@th element of a foldable.
kth :: (Predicatory p, Foldable f) => Int -> PT p a (f a)
kth :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
Int -> PT p a (f a)
kth Int
k a -> p
p = PT p a [a]
forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
PT p a (f a)
startingWith a -> p
p ([a] -> p) -> (f a -> [a]) -> f a -> p
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 a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
{-# INLINEABLE 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 :: Predicatory p => [a -> p] -> [a] -> p
list :: forall p a. Predicatory p => [a -> p] -> [a] -> p
list (a -> p
p : [a -> p]
ps) (a
x : [a]
xs) = a -> p
p a
x p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` [a -> p] -> [a] -> p
forall p a. Predicatory p => [a -> p] -> [a] -> p
list [a -> p]
ps [a]
xs
list [] [] = p
forall a. Predicatory a => a
continue
list [a -> p]
_ [a]
_ = p
forall a. Predicatory a => a
stop

-- | 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 ::
  (Predicatory p, Eq (f ()), Functor f, Foldable f) =>
  f (a -> p) ->
  f a ->
  p
dist :: forall p (f :: * -> *) a.
(Predicatory p, Eq (f ()), Functor f, Foldable f) =>
f (a -> p) -> f a -> p
dist f (a -> p)
preds f a
values =
  p -> p -> Bool -> p
forall a. a -> a -> Bool -> a
bool p
forall a. Predicatory a => a
stop p
forall a. Predicatory a => a
continue ((() () -> f (a -> p) -> f ()
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f (a -> p)
preds) f () -> f () -> Bool
forall a. Eq a => a -> a -> Bool
== (() () -> f a -> f ()
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
values))
    p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` [a -> p] -> [a] -> p
forall p a. Predicatory p => [a -> p] -> [a] -> p
list (f (a -> p) -> [a -> p]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (a -> p)
preds) (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
values)
{-# INLINEABLE 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 -> p) ->
  f a ->
  f p
distRep :: forall (f :: * -> *) a p.
Representable f =>
f (a -> p) -> f a -> f p
distRep f (a -> p)
pr f a
fa = (Rep f -> p) -> f p
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\Rep f
r -> f (a -> p) -> Rep f -> a -> p
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f (a -> p)
pr Rep f
r (a -> p) -> a -> p
forall a b. (a -> b) -> a -> b
$ f a -> Rep f -> a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f a
fa Rep f
r)
{-# INLINEABLE distRep #-}

-- | Test all predicates against one value.
allTrue :: (Predicatory p, Foldable f) => f (a -> p) -> a -> p
allTrue :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
f (a -> p) -> a -> p
allTrue f (a -> p)
ps a
a = ((a -> p) -> p -> p) -> p -> f (a -> p) -> p
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a -> p
p p
r -> a -> p
p a
a p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` p
r) p
forall a. Predicatory a => a
continue f (a -> p)
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 :: Predicatory p => Fold s a -> PT p a s
allOf1 :: forall p s a. Predicatory p => Fold s a -> PT p a s
allOf1 Fold s a
g a -> p
p s
vs =
  p -> p -> Bool -> p
forall a. a -> a -> Bool -> a
bool p
forall a. Predicatory a => a
stop p
forall a. Predicatory a => a
continue (Getting Any s a -> s -> Bool
forall s a. Getting Any s a -> s -> Bool
notNullOf Getting Any s a
Fold s a
g s
vs)
    p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` Getting (Endo p) s a -> (a -> p -> p) -> p -> s -> p
forall r s a. Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldrOf Getting (Endo p) s a
Fold s a
g (\a
x p
r -> a -> p
p a
x p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` p
r) p
forall a. Predicatory a => a
continue s
vs

-- | Sugar for tupling.
pattern a $m:=> :: forall {r} {a} {b}. (a, b) -> (a -> b -> r) -> ((# #) -> r) -> r
$b:=> :: forall {a} {b}. a -> b -> (a, b)
:=> b = (a, b)

pair :: Predicatory p => (a -> p) -> (b -> p) -> (a, b) -> p
pair :: forall p a b. Predicatory p => (a -> p) -> (b -> p) -> (a, b) -> p
pair a -> p
f b -> p
s (a
a, b
b) = a -> p
f a
a p -> p -> p
forall a. Predicatory a => a -> a -> a
`also` b -> p
s b
b

-- | Flipped function composition; @f !@ for a function @f@ is a predicate transformer.
(!) :: (b -> a) -> (a -> c) -> b -> c
! :: forall b a c. (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 :: forall a c. Show a => (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.
--   Requires that the predicate's output type includes a notion of failure.
traceFail :: (Predicatory p, Exceptional p) => (a -> String) -> PT p a a
traceFail :: forall p a.
(Predicatory p, Exceptional p) =>
(a -> String) -> PT p a a
traceFail a -> String
s a -> p
p a
a = IO p -> p
forall a. IO a -> a
unsafePerformIO (IO p -> p) -> IO p -> p
forall a b. (a -> b) -> a -> b
$ do
  IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (p -> IO ()
forall a. Exceptional a => a -> IO ()
assess (a -> p
p a
a)) IO (Either SomeException ())
-> (Either SomeException () -> IO p) -> IO p
forall a b. IO a -> (a -> IO b) -> IO b
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 p
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
    Right () ->
      p -> IO p
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure p
forall a. Predicatory a => a
continue

traceFailShow :: (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow :: forall p a. (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow = (a -> String) -> PT p a a
forall p a.
(Predicatory p, Exceptional p) =>
(a -> String) -> PT p a a
traceFail a -> String
forall a. Show a => a -> String
show
--
-- | Prints the input of a predicate over functions, if the predicate fails.
--   Requires that the predicate's output type includes a notion of failure.
traceFailFun :: (Predicatory p, Exceptional p) => (e -> a -> String) -> PT (e -> p) a a
traceFailFun :: forall p e a.
(Predicatory p, Exceptional p) =>
(e -> a -> String) -> PT (e -> p) a a
traceFailFun e -> a -> String
s a -> e -> p
p a
a e
e = IO p -> p
forall a. IO a -> a
unsafePerformIO (IO p -> p) -> IO p -> p
forall a b. (a -> b) -> a -> b
$ do
  IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (p -> IO ()
forall a. Exceptional a => a -> IO ()
assess (a -> e -> p
p a
a e
e)) IO (Either SomeException ())
-> (Either SomeException () -> IO p) -> IO p
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
ex -> do
      String -> IO ()
traceIO (e -> a -> String
s e
e a
a)
      SomeException -> IO p
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
    Right () ->
      p -> IO p
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure p
forall a. Predicatory a => a
continue


-- | Predicate which always succeeds.
something :: Predicatory p => a -> p
something :: forall a e. Predicatory a => e -> a
something = p -> a -> p
forall a b. a -> b -> a
const p
forall a. Predicatory a => a
continue

-- | Predicate which triggers full evaluation of its input and succeeds.
--  Useful for testing that an exception isn't thrown.
forced :: (Predicatory p, NFData a) => a -> p
forced :: forall p a. (Predicatory p, NFData a) => a -> p
forced a
a = a -> a
forall a. NFData a => a -> a
force a
a a -> p -> p
forall a b. a -> b -> b
`seq` p
forall a. Predicatory a => a
continue