{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
-- | 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)
import GHC.Conc (pseq)
-- | Class of possible predicate results.
-- This is mostly a lattice with `otherHand` as disjunction, `also` as conjunction, `stop` as the falsy
-- value, and `continue` as the truthy value. There may be multiple falsy values, however.
-- Note that test failure messages are not really the domain of this library.
-- It's the author's hope that they can be mostly replaced by `traceFail`.
class Predicatory a where
otherHand :: a -> a -> a
also :: a -> a -> a
stop :: a
continue :: a
{-# MINIMAL otherHand, also, stop, continue #-}
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 triggering an action.
class Exceptional a where
assess :: a -> IO () -> a
instance Exceptional a => Exceptional (e -> a) where
assess f act = \e -> assess (f e) act
-- | 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 act
| b = b
| otherwise = unsafePerformIO act `pseq` b
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 act =
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) ->
act >> throwIO ex
]
-- | 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
-- | 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
-- | Require that a @Fold@ has a single element, and operate on that element.
soleOf :: (Predicatory p) => Fold s a -> PT p a s
soleOf f p (toListOf f -> [x]) = p x
soleOf _ _ _ = stop
-- | Require that a @Foldable@ has a single element, and operate on that element.
sole :: (Predicatory p, Foldable f) => PT p a (f a)
sole = soleOf folded
-- | 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
-- | 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)
-- | 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)
-- | 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)
-- | A pair of predicates, made into a predicate on pairs.
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 -> String) -> PT c a a
traced s p a = trace (s a) (p a)
-- | Prints the input of a predicate, for debugging.
tracedShow :: Show a => PT c a a
tracedShow = traced show
-- | Prints the input of a predicate, if the predicate fails, using `Show`.
-- Requires that the predicate's output type can be checked for failure.
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 can be checked for failure.
traceFail :: (Predicatory p, Exceptional p) => (a -> String) -> PT p a a
traceFail s p a =
assess (p a) $ traceIO (s a)
-- | 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')