{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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
import Control.Lens hiding (index)
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
import Control.Concurrent (myThreadId, throwTo)
import Control.Exception (SomeAsyncException)
class Predicatory a where
otherHand :: a -> a -> a
also :: a -> a -> a
stop :: a
continue :: a
instance Predicatory a => Predicatory (e -> a) where
(f `otherHand` f') e = f e `otherHand` f' e
(f `also` f') e = f e `also` f' e
stop = \_ -> stop
continue = \_ -> continue
infixr 3 `also`
infixr 2 `otherHand`
-- | Class of predicate results which can be checked for failure, by surfacing an exception.
class Exceptional a where
assess :: a -> IO ()
-- | The exception thrown by predicates of type `IO ()` by default. Other IOExceptions will work fine.
data PredicateFailed = PredicateFailed
deriving (Show, Typeable)
instance Exception PredicateFailed
instance Predicatory Bool where
otherHand = (||)
also = (&&)
stop = False
continue = True
instance Exceptional Bool where
assess b = do
evaluate b
unless b stop
instance Predicatory (IO ()) where
otherHand x y = do
catches x
-- explicitly do not handle async exceptions.
-- otherwise, a thread being killed may appear as a predicate failure.
[ Handler $ \(ex :: SomeAsyncException) -> do
tid <- myThreadId
throwTo tid ex
, Handler $ \(_ex :: SomeException) -> 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 `Just` branch of a `Maybe`, or fail.
just :: Predicatory p => PT p a (Maybe a)
just = allOf1 _Just
-- | Operate on the `Left` branch of an `Either`, or fail.
left :: Predicatory p => PT p e (Either e a)
left = allOf1 _Left
-- | Operate on the `Right` branch of an `Either`, or fail.
right :: Predicatory p => PT p a (Either e a)
right = allOf1 _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.
onlyContains :: (Predicatory p, Foldable f) => PT p a (f a)
onlyContains p (toList -> [x]) = p x
onlyContains _ _ = stop
{-# INLINEABLE onlyContains #-}
-- | 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 (.)
infixr 9 !
-- | 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
-- | Predicate on equality.
equals :: (Predicatory p, Eq a) => a -> a -> p
equals a a' = bool stop continue (a == a')