{-# 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 #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ImportQualifiedPost #-}

-- | This library is based on the notion of a property transformer, the below
-- type @PT a b@, which is a function from @a@ to properties on @b@.
-- They act as a sort of compositional "matcher language".
-- Composing these property transformers is meant to be analogous to composing optics
-- and there are utilities for using property transformers with (lens-style) optics.
--
-- Some property transformers provided by other libraries:
-- `Data.Foldable.all`, `Data.Foldable.any` (base)
-- `either` (base)
-- `Control.Lens.allOf` (lens)
module PropertyMatchers
  ( Boolish(..)
  , PropertyFailed(..)
  , Prop
  , PT
  , endingWith
  , startingWith
  , match
  , atIndex
  , list
  , propful
  , compose
  , allTrue
  , allOf1
  , pattern (:=>)
  , pair
  , fun
  , (?)
  , traced
  , tracedShow
  , traceFailShow
  , traceFail
  , forced
  , equals
  )
  where

import "base" Prelude hiding (and, fail, or)
import "base" Control.Concurrent (myThreadId)
import "base" Control.Exception
import "base" Control.Monad hiding (fail)
import "base" Data.Foldable (toList)
import "base" Data.Functor.Const
import "base" Data.Typeable
import "base" Debug.Trace
import "base" GHC.Conc (pseq)
import "base" GHC.Stack
import "base" System.IO.Unsafe

import "deepseq" Control.DeepSeq (NFData, force)
import "text" Data.Text.Lazy qualified as TL
import "adjunctions" Data.Functor.Rep (Representable (..))

import "pretty-simple" Text.Pretty.Simple qualified as Pretty.Simple
import "prettyprinter" Prettyprinter qualified as PP
import "prettyprinter" Prettyprinter.Render.String qualified as PP
import "recover-rtti" Debug.RecoverRTTI (anythingToString)

type Getting r s a = (a -> Const r a) -> s -> Const r s

-- | Class of possible property 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 properties of type `IO ()` by default. Other IOExceptions will work fine.
data PropertyFailed = forall actual ann. PropertyFailed !CallStack (PP.Doc ann) actual
  deriving (Typeable)
instance Show PropertyFailed where
  show :: PropertyFailed -> String
show = PropertyFailed -> String
forall e. Exception e => e -> String
displayException

anythingToTextPretty :: a -> TL.Text
anythingToTextPretty :: forall a. a -> Text
anythingToTextPretty = OutputOptions -> String -> Text
Pretty.Simple.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
Pretty.Simple.defaultOutputOptionsNoColor
    { Pretty.Simple.outputOptionsIndentAmount = 2
    , Pretty.Simple.outputOptionsPageWidth = 120
    , Pretty.Simple.outputOptionsCompact = True
    , Pretty.Simple.outputOptionsCompactParens = True
    , Pretty.Simple.outputOptionsInitialIndent = 0
    }

instance Exception PropertyFailed where
  displayException :: PropertyFailed -> String
displayException (PropertyFailed 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.group
        ( Doc ann
forall ann. Doc ann
PP.line'
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt Doc ann
"Actual:" Doc ann
"Actual value"
        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
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
prettyActual
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.line' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt Doc ann
"Expected:" 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 :: Text
prettyActual = actual -> Text
forall a. a -> Text
anythingToTextPretty 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 property 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 = PropertyFailed -> IO a
forall e a. Exception e => e -> IO a
throwIO (CallStack -> Doc ann -> v -> PropertyFailed
forall actual ann. CallStack -> Doc ann -> actual -> PropertyFailed
PropertyFailed (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 property 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 properties.
type Prop p a = a -> p

-- | Property 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 = Prop p a -> Prop 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 Prop 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 Prop p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [a]
xs) = Prop p a
p Prop p a -> Prop 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 Prop 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 Prop p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> (a
x : [a]
_)) = Prop p a
p a
x

-- | Require that a @Prism@ matches, and apply the property 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 Prop 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] -> Prop 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 to match" s
s

-- | Test the element of a foldable at some index.
atIndex :: (Boolish p, Foldable f) => Int -> PT p a (f a)
atIndex :: forall p (f :: * -> *) a.
(Boolish p, Foldable f) =>
Int -> PT p a (f a)
atIndex Int
k Prop p a
p = PT p a [a]
forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Foldable f) =>
PT p a (f a)
startingWith Prop 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 properties and a list of values, ensure that each property holds for each respective value.
--  Fails if the two lists have different lengths.
list :: (HasCallStack, Boolish p) => [Prop p a] -> [a] -> p
list :: forall p a. (HasCallStack, Boolish p) => [Prop p a] -> [a] -> p
list [Prop 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 ((Prop p a -> Prop p a) -> [Prop p a] -> [a] -> [p]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Prop p a -> Prop p a
forall a b. (a -> b) -> a -> b
($) [Prop 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 = [Prop p a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Prop p a]
ps

-- | Given a functor-full of properties, and a functor-full of values, ensure that the structures
--  of the two functors match and apply all of the properties to all of the values.
--  Generalized version of `list`.
propful ::
  (HasCallStack, Boolish p, Eq (f ()), Functor f, Foldable f) =>
  f (Prop p a) ->
  Prop p (f a)
propful :: forall p (f :: * -> *) a.
(HasCallStack, Boolish p, Eq (f ()), Functor f, Foldable f) =>
f (Prop p a) -> Prop p (f a)
propful f (Prop p a)
props f a
values
  | f (Prop p a) -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f (Prop p a)
props 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 =
    [Prop p a] -> [a] -> p
forall p a. (HasCallStack, Boolish p) => [Prop p a] -> [a] -> p
list (f (Prop p a) -> [Prop p a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Prop p a)
props) (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
<> Text -> Doc Any
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (f (Prop p a) -> Text
forall a. a -> Text
anythingToTextPretty f (Prop p a)
props)) f a
values

-- | Given a representable functor-full of properties, and a functor-full of values,
--  yield a representable functor-full of booleans. Similar to `propful`.
compose ::
  Representable f =>
  f (Prop p a) ->
  f a ->
  f p
compose :: forall (f :: * -> *) p a.
Representable f =>
f (Prop p a) -> f a -> f p
compose f (Prop 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 (Prop p a) -> Rep f -> Prop p a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f (Prop p a)
pr Rep f
r Prop p a -> Prop 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 properties against one value.
allTrue :: (Boolish p, Foldable f) => f (Prop p a) -> Prop p a
allTrue :: forall p (f :: * -> *) a.
(Boolish p, Foldable f) =>
f (Prop p a) -> Prop p a
allTrue f (Prop p a)
ps a
a = (Prop p a -> p -> p) -> p -> f (Prop 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 (\Prop p a
p p
r -> Prop 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 (Prop p a)
ps

-- | Check that a property 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 Prop 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 -> Prop 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 properties, made into a property of pairs.
pair :: Boolish p => Prop p a -> Prop p b -> Prop p (a, b)
pair :: forall p a b. Boolish p => Prop p a -> Prop p b -> Prop p (a, b)
pair Prop p a
f Prop p b
s (a
a, b
b) = Prop p a
f a
a p -> p -> p
forall a. Boolish a => a -> a -> a
`and` Prop p b
s b
b

-- | Flipped function composition; @pf f@ for a function @f@ is a property 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 Prop p b
p = Prop p b
p Prop 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 '&'.
-- The intended use is something like `x & match _Right ? equals 2`.
(?) :: (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 property, if the property fails, using `Show`.
--   Requires that the property'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 property over functions, if the property fails.
--   Requires that the property'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 Prop p a
p a
a =
  p -> IO () -> p
forall a. Boolish a => a -> IO () -> a
assess (Prop 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 property, 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 Prop c a
p a
a = String -> c -> c
forall a. String -> a -> a
trace (a -> String
s a
a) (Prop c a
p a
a)

-- | Prints the input of a property, 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

-- | Property which triggers full evaluation of its input and succeeds.
--  Useful for testing that an exception isn't thrown.
forced :: (Boolish p, NFData a) => Prop p a
forced :: forall p a. (Boolish p, NFData a) => Prop 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

-- | The property of being equal to some expected value.
equals :: (HasCallStack, Boolish p, Eq a) => a -> Prop p a
equals :: forall p a. (HasCallStack, Boolish p, Eq a) => a -> Prop 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 (Text -> Doc Any
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (a -> Text
forall a. a -> Text
anythingToTextPretty a
expected)) a
actual