{-# 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
  (e -> a
f or :: (e -> a) -> (e -> a) -> e -> a
`or` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. Boolish a => a -> a -> a
`or` e -> a
f' e
e
  (e -> a
f and :: (e -> a) -> (e -> a) -> e -> a
`and` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. Boolish a => a -> a -> a
`and` e -> a
f' e
e
  fail :: forall ann v. HasCallStack => Doc ann -> v -> e -> a
fail Doc ann
expected v
actual = (HasCallStack => e -> a) -> e -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => e -> a) -> e -> a)
-> (HasCallStack => e -> a) -> e -> a
forall a b. (a -> b) -> a -> b
$ \e
_ -> Doc ann -> v -> a
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> a
fail Doc ann
expected v
actual
  succeed :: e -> a
succeed = \e
_ -> a
forall a. Boolish a => a
succeed
  assess :: (e -> a) -> IO () -> e -> a
assess e -> a
f IO ()
act = \e
e -> a -> IO () -> a
forall a. Boolish a => a -> IO () -> a
assess (e -> a
f e
e) IO ()
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 :: PredicateFailed -> String
show = PredicateFailed -> String
forall e. Exception e => e -> String
displayException

anythingToStringPretty :: a -> String
anythingToStringPretty :: forall a. a -> String
anythingToStringPretty = Text -> String
TL.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> String -> Text
pStringOpt OutputOptions
opts (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. a -> String
anythingToString
  where
  opts :: OutputOptions
opts = OutputOptions
defaultOutputOptionsNoColor
    { outputOptionsIndentAmount = 2
    , outputOptionsPageWidth = 120
    , outputOptionsCompact = True
    , outputOptionsCompactParens = True
    , outputOptionsInitialIndent = 0
    }

instance Exception PredicateFailed where
  displayException :: PredicateFailed -> String
displayException (PredicateFailed CallStack
cs Doc ann
expected actual
actual)
    = SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (SimpleDocStream ann -> String) -> SimpleDocStream ann -> String
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions (Doc ann -> SimpleDocStream ann) -> Doc ann -> SimpleDocStream ann
forall a b. (a -> b) -> a -> b
$
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.sep
        [ Doc ann
"Actual" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty String
prettyActual
        , Doc ann
"but expected" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
expected
        ] Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (CallStack -> String
prettyCallStack CallStack
cs)
    where
    prettyActual :: String
prettyActual = actual -> String
forall a. a -> String
anythingToStringPretty actual
actual

instance Boolish Bool where
  or :: Bool -> Bool -> Bool
or = Bool -> Bool -> Bool
(||)
  and :: Bool -> Bool -> Bool
and = Bool -> Bool -> Bool
(&&)
  fail :: forall ann v. HasCallStack => Doc ann -> v -> Bool
fail Doc ann
_ v
_ = Bool
False
  succeed :: Bool
succeed = Bool
True
  assess :: Bool -> IO () -> Bool
assess Bool
b IO ()
act
    | Bool
b = Bool
b
    | Bool
otherwise = IO () -> ()
forall a. IO a -> a
unsafePerformIO IO ()
act () -> Bool -> Bool
forall a b. a -> b -> b
`pseq` Bool
b

instance a ~ () => Boolish (IO a) where
  or :: IO a -> IO a -> IO a
or IO a
x IO a
y = do
    IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
x
      -- explicitly do not handle async exceptions.
      -- otherwise, a thread being killed may appear as a predicate failure.
      [ (SomeAsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO a) -> Handler a)
-> (SomeAsyncException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
ex :: SomeAsyncException) -> do
        ThreadId
tid <- IO ThreadId
myThreadId
        ThreadId -> SomeAsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid SomeAsyncException
ex
      , (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO a) -> Handler a)
-> (SomeException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ex :: SomeException) -> IO a
y
      ]
  and :: IO a -> IO a -> IO a
and = IO a -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
  fail :: forall ann v. HasCallStack => Doc ann -> v -> IO a
fail Doc ann
expected v
actual = PredicateFailed -> IO a
forall e a. Exception e => e -> IO a
throwIO (CallStack -> Doc ann -> v -> PredicateFailed
forall actual ann.
CallStack -> Doc ann -> actual -> PredicateFailed
PredicateFailed (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack) Doc ann
expected v
actual)
  succeed :: IO a
succeed = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  assess :: IO a -> IO () -> IO a
assess IO a
x IO ()
act =
    IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
x
      -- explicitly do not handle async exceptions.
      -- otherwise, a thread being killed may appear as a predicate failure.
      [ (SomeAsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO a) -> Handler a)
-> (SomeAsyncException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
ex :: SomeAsyncException) -> do
        ThreadId
tid <- IO ThreadId
myThreadId
        ThreadId -> SomeAsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid SomeAsyncException
ex
      , (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO a) -> Handler a)
-> (SomeException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) ->
        IO ()
act IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
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 :: forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Foldable f) =>
PT p a (f a)
endingWith Pred p a
_ actual :: f a
actual@(f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = Doc Any -> f a -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail Doc Any
"nonempty foldable" f a
actual
endingWith Pred p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [a]
xs) = Pred p a
p Pred p a -> Pred p a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
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 :: forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Foldable f) =>
PT p a (f a)
startingWith Pred p a
_ actual :: f a
actual@(f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = Doc Any -> f a -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail Doc Any
"nonempty foldable" f a
actual
startingWith Pred p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> (a
x : [a]
_)) = Pred p a
p a
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 :: forall p a s.
(HasCallStack, Boolish p) =>
Getting [a] s a -> PT p a s
match Getting [a] s a
f Pred p a
p s
s =
  case Getting [a] s a
f ([a] -> Const [a] a
forall {k} a (b :: k). a -> Const a b
Const ([a] -> Const [a] a) -> (a -> [a]) -> a -> Const [a] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) s
s of
    Const [a
x] -> Pred p a
p a
x
    Const [a] s
_ -> Doc Any -> s -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail Doc Any
"fold yields exactly one element" s
s

-- | Only test the @k@th element of a foldable.
kth :: (Boolish p, Foldable f) => Int -> PT p a (f a)
kth :: forall p (f :: * -> *) a.
(Boolish p, Foldable f) =>
Int -> PT p a (f a)
kth Int
k Pred p a
p = PT p a [a]
forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Foldable f) =>
PT p a (f a)
startingWith Pred p a
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

-- | 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 :: forall p a. (HasCallStack, Boolish p) => [Pred p a] -> [a] -> p
list [Pred p a]
ps [a]
xs
  | Int
psl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = (p -> p -> p) -> p -> [p] -> p
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr p -> p -> p
forall a. Boolish a => a -> a -> a
and p
forall a. Boolish a => a
succeed ((Pred p a -> Pred p a) -> [Pred p a] -> [a] -> [p]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pred p a -> Pred p a
forall a b. (a -> b) -> a -> b
($) [Pred p a]
ps [a]
xs)
  | Bool
otherwise = Doc Any -> [a] -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail (Doc Any
"list with length " Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Any
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
psl) [a]
xs
  where
  psl :: Int
psl = [Pred p a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pred p a]
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 :: forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Eq (f ()), Functor f, Foldable f) =>
f (Pred p a) -> Pred p (f a)
predful f (Pred p a)
preds f a
values
  | f (Pred p a) -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f (Pred p a)
preds f () -> f () -> Bool
forall a. Eq a => a -> a -> Bool
== f a -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f a
values =
    [Pred p a] -> [a] -> p
forall p a. (HasCallStack, Boolish p) => [Pred p a] -> [a] -> p
list (f (Pred p a) -> [Pred p a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Pred p a)
preds) (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
values)
  | Bool
otherwise =
    Doc Any -> f a -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail (Doc Any
"shape equal to that of" Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> String -> Doc Any
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (f (Pred p a) -> String
forall a. a -> String
anythingToStringPretty f (Pred p a)
preds)) f a
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 :: forall (f :: * -> *) p a.
Representable f =>
f (Pred p a) -> f a -> f p
compose f (Pred p a)
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 (Pred p a) -> Rep f -> Pred p a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f (Pred p a)
pr Rep f
r Pred p a -> Pred p a
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)

-- | Test all predicates against one value.
allTrue :: (Boolish p, Foldable f) => f (Pred p a) -> Pred p a
allTrue :: forall p (f :: * -> *) a.
(Boolish p, Foldable f) =>
f (Pred p a) -> Pred p a
allTrue f (Pred p a)
ps a
a = (Pred p a -> p -> p) -> p -> f (Pred p a) -> 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 (\Pred p a
p p
r -> Pred p a
p a
a p -> p -> p
forall a. Boolish a => a -> a -> a
`and` p
r) p
forall a. Boolish a => a
succeed f (Pred p a)
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 :: forall p a s.
(HasCallStack, Boolish p) =>
Getting [a] s a -> PT p a s
allOf1 Getting [a] s a
g Pred p a
p s
vs
  | [] <- [a]
vsList =
    (a -> p -> p) -> p -> [a] -> p
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x p
r -> Pred p a
p a
x p -> p -> p
forall a. Boolish a => a -> a -> a
`and` p
r) p
forall a. Boolish a => a
succeed [a]
vsList
  | Bool
otherwise = Doc Any -> s -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail Doc Any
"non-empty for fold" s
vs
  where
  Const [a]
vsList = Getting [a] s a
g ([a] -> Const [a] a
forall {k} a (b :: k). a -> Const a b
Const ([a] -> Const [a] a) -> (a -> [a]) -> a -> Const [a] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) s
vs

-- | Sugar for tupling.
pattern (:=>) :: a -> b -> (a, b)
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)

-- | A pair of predicates, made into a predicate on pairs.
pair :: Boolish p => Pred p a -> Pred p b -> Pred p (a, b)
pair :: forall p a b. Boolish p => Pred p a -> Pred p b -> Pred p (a, b)
pair Pred p a
f Pred p b
s (a
a, b
b) = Pred p a
f a
a p -> p -> p
forall a. Boolish a => a -> a -> a
`and` Pred p b
s b
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 :: forall a b p. (a -> b) -> PT p b a
fun a -> b
f Pred p b
p = Pred p b
p Pred p b -> (a -> b) -> a -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

-- | Higher precedence '$', to work well with '&'.
(?) :: (a -> b) -> a -> b
? :: forall a b. (a -> b) -> a -> b
(?) = (a -> b) -> a -> b
forall a b. (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 :: forall p a. (Boolish p, Show a) => PT p a a
traceFailShow = (a -> String) -> PT p a a
forall p a. Boolish 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 can be checked for failure.
traceFail :: (Boolish p) => (a -> String) -> PT p a a
traceFail :: forall p a. Boolish p => (a -> String) -> PT p a a
traceFail a -> String
s Pred p a
p a
a =
  p -> IO () -> p
forall a. Boolish a => a -> IO () -> a
assess (Pred p a
p a
a) (IO () -> p) -> IO () -> p
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceIO (a -> String
s a
a)

-- | Prints the input of a predicate, for debugging.
traced :: Show a => (a -> String) -> PT c a a
traced :: forall a c. Show a => (a -> String) -> PT c a a
traced a -> String
s Pred c a
p a
a = String -> c -> c
forall a. String -> a -> a
trace (a -> String
s a
a) (Pred c a
p a
a)

-- | Prints the input of a predicate, for debugging.
tracedShow :: Show a => PT c a a
tracedShow :: forall a c. Show a => PT c a a
tracedShow = (a -> String) -> PT c a a
forall a c. Show a => (a -> String) -> PT c a a
traced a -> String
forall a. Show a => a -> String
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 :: forall p a. (Boolish p, NFData a) => Pred p a
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. Boolish a => a
succeed

-- | Predicate on equality.
equals :: (HasCallStack, Boolish p, Eq a) => a -> Pred p a
equals :: forall p a. (HasCallStack, Boolish p, Eq a) => a -> Pred p a
equals a
expected a
actual
  | a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual = p
forall a. Boolish a => a
succeed
  | Bool
otherwise = Doc Any -> a -> p
forall a ann v. (Boolish a, HasCallStack) => Doc ann -> v -> a
forall ann v. HasCallStack => Doc ann -> v -> p
fail (Doc Any
"equal to" Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
PP.softline Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> String -> Doc Any
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (a -> String
forall a. a -> String
anythingToStringPretty a
expected)) a
actual