{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Hedgehog.Classes.Common.Property
( heq, heq1, heq2
, heqCtx, heqCtx1, heqCtx2
, hneq, hneq1, hneq2
, hneqCtx, hneqCtx1, hneqCtx2
, himplCtx
, hLessThan, hGreaterThan
, hLessThanCtx, hGreaterThanCtx
, bar
, Context(..)
) where
import Control.Exception (SomeException(..), displayException)
import Data.Typeable (typeOf)
import GHC.Stack
import Hedgehog.Classes.Common.Compat
import Hedgehog.Internal.Exception (tryEvaluate)
import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, discard, Failure(..), PropertyT)
import Text.Show.Pretty (ppShow)
import qualified Data.Char as Char
import qualified Data.List as List
bar :: String
bar :: [Char]
bar = [Char]
"━━━"
bar5 :: String
bar5 :: [Char]
bar5 = [Char]
"━━━━━━━━━━━━━━━"
evalNoSrc :: (MonadTest m, HasCallStack) => a -> m a
evalNoSrc :: forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc a
x = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
SomeException -> m a
failExceptionNoSrc) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Either SomeException a
tryEvaluate a
x)
failWithNoSrc :: (MonadTest m, HasCallStack) => String -> m a
failWithNoSrc :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
[Char] -> m a
failWithNoSrc [Char]
msg = do
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest forall a b. (a -> b) -> a -> b
$ forall a. (Either Failure a, Journal) -> Test a
mkTest (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe Span -> [Char] -> Maybe Diff -> Failure
Failure forall a. Maybe a
Nothing [Char]
msg forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty)
failExceptionNoSrc :: (MonadTest m, HasCallStack) => SomeException -> m a
failExceptionNoSrc :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
SomeException -> m a
failExceptionNoSrc (SomeException e
x) = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
[Char] -> m a
failWithNoSrc forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
bar forall a. [a] -> [a] -> [a]
++ [Char]
" Exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf e
x) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
bar
, forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd Char -> Bool
Char.isSpace (forall e. Exception e => e -> [Char]
displayException e
x)
]
data Context = NoContext | Context String
contextToString :: Context -> String
contextToString :: Context -> [Char]
contextToString = \case
Context
NoContext -> [Char]
"No Context provided."
Context [Char]
ctx -> [Char]
bar forall a. [a] -> [a] -> [a]
++ [Char]
" Context " forall a. [a] -> [a] -> [a]
++ [Char]
bar forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
ctx forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
bar5
failContext::
( MonadTest m, HasCallStack
) => Context -> m ()
failContext :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
[Char] -> m a
failWithNoSrc forall a b. (a -> b) -> a -> b
$ Context -> [Char]
contextToString Context
ctx
hLessThanCtx ::
( MonadTest m
, Ord a
, Show a
, HasCallStack
) => a -> a -> Context -> m ()
hLessThanCtx :: forall (m :: * -> *) a.
(MonadTest m, Ord a, Show a, HasCallStack) =>
a -> a -> Context -> m ()
hLessThanCtx a
x a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Ord a => a -> a -> Bool
< a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
hGreaterThanCtx ::
( MonadTest m
, Ord a
, Show a
, HasCallStack
) => a -> a -> Context -> m ()
hGreaterThanCtx :: forall (m :: * -> *) a.
(MonadTest m, Ord a, Show a, HasCallStack) =>
a -> a -> Context -> m ()
hGreaterThanCtx a
x a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Ord a => a -> a -> Bool
> a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
hLessThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m ()
hLessThan :: forall (m :: * -> *) a.
(MonadTest m, Ord a, Show a, HasCallStack) =>
a -> a -> m ()
hLessThan a
x a
y = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Ord a => a -> a -> Bool
< a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
[Char] -> m a
failWithNoSrc forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
bar forall a. [a] -> [a] -> [a]
++ [Char]
"Not Less Than " forall a. [a] -> [a] -> [a]
++ [Char]
bar
, forall a. Show a => a -> [Char]
ppShow a
x forall a. [a] -> [a] -> [a]
++ [Char]
" is not less than " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
ppShow a
y
]
hGreaterThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m ()
hGreaterThan :: forall (m :: * -> *) a.
(MonadTest m, Ord a, Show a, HasCallStack) =>
a -> a -> m ()
hGreaterThan a
x a
y = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Ord a => a -> a -> Bool
> a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
[Char] -> m a
failWithNoSrc forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
bar forall a. [a] -> [a] -> [a]
++ [Char]
"Not Greater Than " forall a. [a] -> [a] -> [a]
++ [Char]
bar
, forall a. Show a => a -> [Char]
ppShow a
x forall a. [a] -> [a] -> [a]
++ [Char]
" is not greater than " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
ppShow a
y
]
infix 4 `hneq`
hneqCtx ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
) => a -> a -> Context -> m ()
hneqCtx :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
hneqCtx a
x a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Eq a => a -> a -> Bool
`neq` a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
hneq ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
) => a -> a -> m ()
hneq :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> m ()
hneq a
x a
y = forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
hneqCtx a
x a
y Context
NoContext
infix 4 `heq`
heqCtx ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
) => a -> a -> Context -> m ()
heqCtx :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
x a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (a
x forall a. Eq a => a -> a -> Bool
`eq` a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
heq ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
) => a -> a -> m ()
heq :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> m ()
heq a
x a
y = forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
x a
y Context
NoContext
infix 4 `heq1`
hneqCtx1 ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
, forall x. Eq x => Eq (f x)
, forall x. Show x => Show (f x)
) => f a -> f a -> Context -> m ()
hneqCtx1 :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
hneqCtx1 f a
x f a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (f a
x forall a (f :: * -> *).
(Eq a, forall x. Eq x => Eq (f x)) =>
f a -> f a -> Bool
`neq1` f a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
hneq1 ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
, forall x. Eq x => Eq (f x)
, forall x. Show x => Show (f x)
) => f a -> f a -> m ()
hneq1 :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> m ()
hneq1 f a
x f a
y = forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
hneqCtx1 f a
x f a
y Context
NoContext
heqCtx1 ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
, forall x. Eq x => Eq (f x)
, forall x. Show x => Show (f x)
) => f a -> f a -> Context -> m ()
heqCtx1 :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
heqCtx1 f a
x f a
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (f a
x forall a (f :: * -> *).
(Eq a, forall x. Eq x => Eq (f x)) =>
f a -> f a -> Bool
`eq1` f a
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
heq1 ::
( MonadTest m
, HasCallStack
, Eq a
, Show a
, forall x. Eq x => Eq (f x)
, forall x. Show x => Show (f x)
) => f a -> f a -> m ()
heq1 :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> m ()
heq1 f a
x f a
y = forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
heqCtx1 f a
x f a
y Context
NoContext
infix 4 `heq2`
heqCtx2 ::
( MonadTest m
, HasCallStack
, Eq a
, Eq b
, Show a
, Show b
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => f a b -> f a b -> Context -> m ()
heqCtx2 :: forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> Context -> m ()
heqCtx2 f a b
x f a b
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (f a b
x forall a b (f :: * -> * -> *).
(Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) =>
f a b -> f a b -> Bool
`eq2` f a b
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
heq2 ::
( MonadTest m
, HasCallStack
, Eq a
, Eq b
, Show a
, Show b
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => f a b -> f a b -> m ()
heq2 :: forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> m ()
heq2 f a b
x f a b
y = forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> Context -> m ()
heqCtx2 f a b
x f a b
y Context
NoContext
infix 4 `hneq2`
hneqCtx2 ::
( MonadTest m
, HasCallStack
, Eq a
, Eq b
, Show a
, Show b
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => f a b -> f a b -> Context -> m ()
hneqCtx2 :: forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> Context -> m ()
hneqCtx2 f a b
x f a b
y Context
ctx = do
Bool
ok <- forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
evalNoSrc (f a b
x forall a b (f :: * -> * -> *).
(Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) =>
f a b -> f a b -> Bool
`neq2` f a b
y)
if Bool
ok
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx
hneq2 ::
( MonadTest m
, HasCallStack
, Eq a
, Eq b
, Show a
, Show b
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => f a b -> f a b -> m ()
hneq2 :: forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> m ()
hneq2 f a b
x f a b
y = forall (m :: * -> *) a b (f :: * -> * -> *).
(MonadTest m, HasCallStack, Eq a, Eq b, Show a, Show b,
forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
f a b -> f a b -> Context -> m ()
hneqCtx2 f a b
x f a b
y Context
NoContext
himplCtx ::
( Monad m
, HasCallStack
) => Bool -> Bool -> Context -> PropertyT m ()
himplCtx :: forall (m :: * -> *).
(Monad m, HasCallStack) =>
Bool -> Bool -> Context -> PropertyT m ()
himplCtx Bool
False Bool
_ Context
_ = forall (m :: * -> *) a. Monad m => PropertyT m a
discard
himplCtx Bool
True Bool
b Context
ctx = if Bool
b
then forall (m :: * -> *). MonadTest m => m ()
success
else forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
Context -> m ()
failContext Context
ctx