{-# LANGUAGE RankNTypes #-}

-- |
-- Module:      Test.Lawful.Hedgehog
-- Description: Hedgehog support for lawful-classes
-- Copyright:   (c) 2023, Nicolas Trangez
-- License:     Apache-2.0
-- Maintainer:  ikke@nicolast.be
-- Stability:   alpha
--
-- Support code to check @lawful-classes@ laws using Hedgehog and, optionally,
-- Tasty.
module Test.Lawful.Hedgehog
  ( testLaws,
    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)

-- | Given a way to evaluate an @m a@ into a base 'Monad', turn a 'Law' into a 'Property'.
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
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ PropertyT IO ()
-> (Bool -> PropertyT IO ()) -> Maybe Bool -> PropertyT IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PropertyT IO ()
forall (m :: * -> *) a. Monad m => PropertyT m a
discard Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert (Maybe Bool -> PropertyT IO ())
-> PropertyT IO (Maybe Bool) -> PropertyT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PropertyT IO (Maybe Bool) -> PropertyT IO (Maybe Bool)
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
evalM (Law m -> PropertyT IO (Maybe Bool)
forall a. m a -> PropertyT IO a
run Law m
law)

-- | Given 'Laws', create a @tasty@ 'TestTree'.
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 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 ((forall a. m a -> PropertyT IO a) -> Law m -> Property
forall (m :: * -> *).
(forall a. m a -> PropertyT IO a) -> Law m -> Property
toProperty m a -> PropertyT IO a
forall a. m a -> PropertyT IO a
run Law m
l) | (TestName
n, Law m
l) <- Laws m
laws]