{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
-- | 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
( Boolish(..)
, PredicateFailed(..)
, Pred
, PT
, endingWith
, startingWith
, match
, kth
, list
, predful
, compose
, allTrue
, allOf1
, pattern (:=>)
, pair
, fun
, (?)
, traced
, tracedShow
, traceFailShow
, traceFail
, forced
, equals
)
where
import Prelude hiding (and, fail, or)
import Control.DeepSeq (NFData, force)
import Control.Exception
import Control.Monad hiding (fail)
import Data.Foldable (toList)
import Data.Functor.Const
import Data.Functor.Rep (Representable (..))
import Data.Typeable
import Debug.Trace
import System.IO.Unsafe
import Control.Concurrent (myThreadId)
import GHC.Conc (pseq)
import GHC.Stack
import Text.Pretty.Simple
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.String as PP
import Debug.RecoverRTTI
import qualified Data.Text.Lazy as TL
type Getting r s a = (a -> Const r a) -> s -> Const r s
-- | Class of possible predicate results.
-- This is almost a lattice with `or` as disjunction, `and` as conjunction, `fail` as the falsy
-- value, and `succeed` as the truthy value. However there may be multiple falsy values, and
-- `and` will pick the first one it's passed, whereas `or` will pick the second it's passed.
class Boolish a where
or :: a -> a -> a
and :: a -> a -> a
fail :: HasCallStack => PP.Doc ann -> v -> a
succeed :: a
-- | Check and execute a callback on failure.
assess :: a -> IO () -> a
{-# MINIMAL or, and, fail, succeed, assess #-}
instance Boolish a => Boolish (e -> a) where
(f `or` f') e = f e `or` f' e
(f `and` f') e = f e `and` f' e
fail expected actual = withFrozenCallStack $ \_ -> fail expected actual
succeed = \_ -> succeed
assess f act = \e -> assess (f e) act
infixr 3 `and`
infixr 2 `or`
-- | The exception thrown by predicates of type `IO ()` by default. Other IOExceptions will work fine.
data PredicateFailed = forall actual ann. PredicateFailed !CallStack (PP.Doc ann) actual
deriving (Typeable)
instance Show PredicateFailed where
show = displayException
anythingToStringPretty :: a -> String
anythingToStringPretty = TL.unpack . pStringOpt opts . anythingToString
where
opts = defaultOutputOptionsNoColor
{ outputOptionsIndentAmount = 2
, outputOptionsPageWidth = 120
, outputOptionsCompact = True
, outputOptionsCompactParens = True
, outputOptionsInitialIndent = 0
}
instance Exception PredicateFailed where
displayException (PredicateFailed cs expected actual)
= PP.renderString $ PP.layoutSmart PP.defaultLayoutOptions $
PP.sep
[ "Actual" <> PP.softline <> PP.pretty prettyActual
, "but expected" <> PP.softline <> expected
] <> PP.hardline <> PP.pretty (prettyCallStack cs)
where
prettyActual = anythingToStringPretty actual
instance Boolish Bool where
or = (||)
and = (&&)
fail _ _ = False
succeed = True
assess b act
| b = b
| otherwise = unsafePerformIO act `pseq` b
instance a ~ () => Boolish (IO a) where
or 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
]
and = (>>)
fail expected actual = throwIO (PredicateFailed (popCallStack callStack) expected actual)
succeed = return ()
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 p a = a -> p
-- | 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 = Pred p a -> Pred p b
-- | Operate on the last value in a foldable, or fail if it's not present.
endingWith :: (HasCallStack, Boolish p, Foldable f) => PT p a (f a)
endingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
endingWith p (toList -> xs) = p $ last xs
-- | Operate on the first value in a foldable, or fail if it's not present.
startingWith :: (HasCallStack, Boolish p, Foldable f) => PT p a (f a)
startingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
startingWith p (toList -> (x : _)) = p x
-- | Require that a @Prism@ matches, and apply the predicate to its contents.
-- This works for folds, too.
match
:: (HasCallStack, Boolish p)
=> Getting [a] s a
-> PT p a s
match f p s =
case f (Const . pure) s of
Const [x] -> p x
_ -> fail "fold yields exactly one element" s
-- | Only test the @k@th element of a foldable.
kth :: (Boolish 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 :: (HasCallStack, Boolish p) => [Pred p a] -> [a] -> p
list ps xs
| psl == length xs = foldr and succeed (zipWith ($) ps xs)
| otherwise = fail ("list with length " <> PP.pretty psl) xs
where
psl = length ps
-- | 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`.
predful ::
(HasCallStack, Boolish p, Eq (f ()), Functor f, Foldable f) =>
f (Pred p a) ->
Pred p (f a)
predful preds values
| void preds == void values =
list (toList preds) (toList values)
| otherwise =
fail ("shape equal to that of" <> PP.pretty (anythingToStringPretty preds)) values
-- | Given a representable functor-full of predicates, and a functor-full of values,
-- yield a representable functor-full of booleans. Similar to `predful`.
compose ::
Representable f =>
f (Pred p a) ->
f a ->
f p
compose pr fa = tabulate (\r -> index pr r $ index fa r)
-- | Test all predicates against one value.
allTrue :: (Boolish p, Foldable f) => f (Pred p a) -> Pred p a
allTrue ps a = foldr (\p r -> p a `and` r) succeed 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
:: (HasCallStack, Boolish p)
=> Getting [a] s a
-> PT p a s
allOf1 g p vs
| [] <- vsList =
foldr (\x r -> p x `and` r) succeed vsList
| otherwise = fail "non-empty for fold" vs
where
Const vsList = g (Const . pure) vs
-- | Sugar for tupling.
pattern (:=>) :: a -> b -> (a, b)
pattern a :=> b = (a, b)
-- | A pair of predicates, made into a predicate on pairs.
pair :: Boolish p => Pred p a -> Pred p b -> Pred p (a, b)
pair f s (a, b) = f a `and` s b
-- | Flipped function composition; @pf f@ for a function @f@ is a predicate transformer
-- such that @pf f p i == p (f i)@.
fun :: (a -> b) -> PT p b a
fun f p = p . f
-- | Higher precedence '$', to work well with '&'.
(?) :: (a -> b) -> a -> b
(?) = ($)
infixr 8 ?
-- | 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 :: (Boolish 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 :: (Boolish p) => (a -> String) -> PT p a a
traceFail s p a =
assess (p a) $ traceIO (s a)
-- | 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
-- | Predicate which triggers full evaluation of its input and succeeds.
-- Useful for testing that an exception isn't thrown.
forced :: (Boolish p, NFData a) => Pred p a
forced a = force a `seq` succeed
-- | Predicate on equality.
equals :: (HasCallStack, Boolish p, Eq a) => a -> Pred p a
equals expected actual
| expected == actual = succeed
| otherwise = fail ("equal to" <> PP.softline <> PP.pretty (anythingToStringPretty expected)) actual