{-# LANGUAGE RankNTypes #-}
module Test.Lawful.Hedgehog
(
testLaws,
testLawsWith,
toProperty,
)
where
import Hedgehog (Property, PropertyT, assert, discard, evalM, property)
import Test.Lawful.Types (Law, Laws)
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)
toProperty :: (forall a. m a -> PropertyT IO a) -> Law m -> Property
toProperty :: forall (m :: * -> *).
(forall a. m a -> PropertyT IO a) -> Law m -> Property
toProperty forall a. m a -> PropertyT IO a
run Law m
law = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. Monad m => PropertyT m a
discard forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
evalM (forall a. m a -> PropertyT IO a
run Law m
law)
testLaws :: TestName -> (forall a. m a -> PropertyT IO a) -> Laws m -> TestTree
testLaws :: forall (m :: * -> *).
TestName -> (forall a. m a -> PropertyT IO a) -> Laws m -> TestTree
testLaws = forall (m :: * -> *).
(Property -> Property)
-> TestName
-> (forall a. m a -> PropertyT IO a)
-> Laws m
-> TestTree
testLawsWith forall a. a -> a
id
testLawsWith :: (Property -> Property) -> TestName -> (forall a. m a -> PropertyT IO a) -> Laws m -> TestTree
testLawsWith :: forall (m :: * -> *).
(Property -> Property)
-> TestName
-> (forall a. m a -> PropertyT IO a)
-> Laws m
-> TestTree
testLawsWith Property -> Property
fn TestName
name forall a. m a -> PropertyT IO a
run Laws m
laws = TestName -> [TestTree] -> TestTree
testGroup TestName
name [TestName -> Property -> TestTree
testProperty TestName
n (Property -> Property
fn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(forall a. m a -> PropertyT IO a) -> Law m -> Property
toProperty forall a. m a -> PropertyT IO a
run Law m
l) | (TestName
n, Law m
l) <- Laws m
laws]