{-# 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
(f `oneOfTwo` f') e = f e `oneOfTwo` f' e
(f `also` f') e = f e `also` f' e
stop = \_ -> stop
continue = \_ -> continue
class Exceptional a where
assess :: a -> IO ()
data PredicateFailed = PredicateFailed
deriving (Show, Typeable)
instance Exception PredicateFailed
instance Predicatory Bool where
oneOfTwo = (||)
also = (&&)
stop = False
continue = True
instance Exceptional Bool where
assess b = do
evaluate b
unless b stop
instance Predicatory (IO ()) where
oneOfTwo x y = x <|> y
also = (>>)
stop = throwIO PredicateFailed
continue = return ()
instance Exceptional (IO ()) where
assess x = x >>= 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 p pred = either (const stop) pred . matching p
-- | Operate on the `Just` branch of a `Maybe`, or fail.
just :: Predicatory p => PT p a (Maybe a)
just = match _Just
-- | Operate on the `Left` branch of an `Either`, or fail.
left :: Predicatory p => PT p e (Either e a)
left = match _Left
-- | Operate on the `Right` branch of an `Either`, or fail.
right :: Predicatory p => PT p a (Either e a)
right = match _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 _ (toList -> []) = stop
endingWith p (toList -> xs) = p $ last 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 p (toList -> (x : _)) = p x
startingWith _ (toList -> []) = 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 p (toList -> [x]) = p x
only _ _ = stop
{-# INLINEABLE only #-}
-- | Only test the @k@th element of a foldable.
kth :: (Predicatory p, Foldable f) => Int -> PT p a (f a)
kth k p = startingWith p . drop k . 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 (p : ps) (x : xs) = p x `also` list ps xs
list [] [] = continue
list _ _ = 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 preds values =
bool stop continue ((() <$ preds) == (() <$ values))
`also` list (toList preds) (toList 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 pr fa = tabulate (\r -> index pr r $ index fa r)
{-# INLINEABLE distRep #-}
-- | Test all predicates against one value.
allTrue :: (Predicatory p, Foldable f) => f (a -> p) -> a -> p
allTrue ps a = foldr (\p r -> p a `also` r) continue 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 g p vs =
bool stop continue (notNullOf g vs)
`also` foldrOf g (\x r -> p x `also` r) continue vs
-- | Sugar for tupling.
pattern a :=> b = (a, b)
pair :: Predicatory p => (a -> p) -> (b -> p) -> (a, b) -> p
pair f s (a, b) = f a `also` s b
-- | Flipped function composition; @f !@ for a function @f@ is a predicate transformer.
(!) :: (b -> a) -> (a -> c) -> b -> c
(!) = flip (.)
-- | Prints the input of a predicate, for debugging.
traced :: Show a => (a -> c) -> a -> c
traced p a = traceShow a (p 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 s p a = unsafePerformIO $ do
try (assess (p a)) >>= \case
Left ex -> do
traceIO (s a)
throwIO (ex :: SomeException)
Right () ->
pure continue
traceFailShow :: (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow = traceFail 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 s p a e = unsafePerformIO $ do
try (assess (p a e)) >>= \case
Left ex -> do
traceIO (s e a)
throwIO (ex :: SomeException)
Right () ->
pure continue
-- | Predicate which always succeeds.
something :: Predicatory p => a -> p
something = const 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 a = force a `seq` continue