{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Effectful.HUnit
-- Copyright : (c) 2026 Institute for Digital Autonomy
-- License : EUPL-1.2
-- Maintainer : IDA
--
-- Effectful bindings for the <http://hackage.haskell.org/package/HUnit HUnit library>.
--
-- = Overview
--
-- This library provides @HUnit@'s 'Assertion' and 'Test' types, along with all the standard
-- test combinators and operators, expressed in terms of the 'HUnit' effect.
-- This effect allows you to intersperse test assertions with arbitrary other effects.
--
-- = Example usage
--
-- Suppose we wish to test stateful operations on an account balance:
--
-- > deposit :: (State Int :> es) => Int -> Eff es ()
-- > deposit amount = modify (+ amount)
-- >
-- > balance :: (State Int :> es) => Eff es Int
-- > balance = get
--
-- > withdraw :: (State Int :> es) => Int -> Eff es Bool
-- > withdraw amount = do
-- > funds <- balance
-- > if funds < amount
-- > then pure False
-- > else do
-- > put $ funds - amount
-- > pure True
--
-- Use 'TestCase' to define individual unit tests, and 'TestLabel' to give them a description:
--
-- > depositsAccumulate :: (State Int :> es, HUnit :> es) => Test es
-- > depositsAccumulate = TestLabel "deposits accumulate" . TestCase $ do
-- > deposit 100
-- > deposit 50
-- > funds <- balance
-- > funds @?= 150
-- >
-- > withdrawalsAreChecked :: (State Int :> es, HUnit :> es) => Test es
-- > withdrawalsAreChecked = TestLabel "withdrawals are checked" . TestCase $ do
-- > withdraw 30 >>= (@? "Insufficient funds")
-- > funds <- balance
-- > funds @?= 120
--
-- Group multiple test cases with 'TestList':
--
-- > accountTests :: (State Int :> es, HUnit :> es) => Test es
-- > accountTests = TestLabel "account tests" $ TestList [depositsAccumulate, withdrawalsAreChecked]
--
-- Finally, run the tests with 'runTestTTAndExit', and use 'runHUnit' to resolve the effect:
--
-- > main :: IO ()
-- > main = runEff . runHUnit . evalState @Int 0 $ runTestTTAndExit accountTests
--
-- Alternatively, use 'runTestTT' to handle the test results manually.
module Effectful.HUnit
( -- * Effect
HUnit
, runHUnit
-- * Declaring tests
, Test (..)
, (~=?)
, (~?=)
, (~:)
, (~?)
-- * Making assertions
, Assertion
, assertFailure
, assertBool
, assertEqual
, assertString
, (@=?)
, (@?=)
, (@?)
-- * Running tests
, runTestTT
, runTestTTAndExit
-- * Extending the assertion functionality
, Assertable (..)
, ListAssertable (..)
, AssertionPredicate
, AssertionPredicable (..)
, Testable (..)
-- * Re-eports from @HUnit@
, Counts (..)
)
where
import Control.Monad (unless)
import Effectful
import Effectful.Dispatch.Static
import Test.HUnit (Counts (..))
import Test.HUnit qualified as HUnit
import Prelude
data HUnit :: Effect
type instance DispatchOf HUnit = 'Static 'WithSideEffects
newtype instance StaticRep HUnit = HUnit (forall es a. IO a -> Eff es a)
hunit :: (HUnit :> es) => IO a -> Eff es a
hunit a = do
HUnit unlift <- getStaticRep
unlift a
runHUnit :: (IOE :> es) => Eff (HUnit ': es) a -> Eff es a
runHUnit = evalStaticRep $ HUnit unsafeEff_
-------------------------------------------------------------------------------
type Assertion es = Eff es ()
class Assertable es t where
assert :: (HasCallStack) => t -> Assertion es
instance Assertable es () where
assert = pure
instance (HUnit :> es) => Assertable es Bool where
assert = assertBool ""
instance (ListAssertable es t) => Assertable es [t] where
assert = listAssert
instance (Assertable es t) => Assertable es (Eff es t) where
assert = (>>= assert)
-- | A specialised form of 'Assertable' to handle lists.
class ListAssertable es t where
listAssert :: (HasCallStack) => [t] -> Assertion es
instance (HUnit :> es) => ListAssertable es Char where
listAssert = assertString
instance Assertable es (Assertion es) where
assert = id
type AssertionPredicate es = Eff es Bool
class AssertionPredicable es t where
assertionPredicate :: t -> AssertionPredicate es
instance AssertionPredicable es Bool where
assertionPredicate = pure
instance (AssertionPredicable es t) => AssertionPredicable es (Eff es t) where
assertionPredicate = (>>= assertionPredicate)
-- Assertion Construction Operators
-- --------------------------------
infix 1 @?, @=?, @?=
-- | Asserts that the condition obtained from the specified
-- 'AssertionPredicable' holds.
(@?)
:: (HasCallStack, AssertionPredicable es t, HUnit :> es)
=> t
-- ^ A value of which the asserted condition is predicated
-> String
-- ^ A message that is displayed if the assertion fails
-> Assertion es
predi @? msg = assertionPredicate predi >>= assertBool msg
-- | Asserts that the specified actual value is equal to the expected value.
(@=?)
:: (HasCallStack, Eq a, Show a, HUnit :> es)
=> a
-- ^ The expected value
-> a
-- ^ The actual value
-> Assertion es
expected @=? actual = assertEqual "" expected actual
-- | Asserts that the specified actual value is equal to the expected value.
(@?=)
:: (HasCallStack, Eq a, Show a, HUnit :> es)
=> a
-- ^ The actual value
-> a
-- ^ The expected value
-> Assertion es
actual @?= expected = assertEqual "" expected actual
-- ===============
-- | The basic structure used to create an annotated tree of test cases.
data Test es
= -- | A single, independent test case composed.
TestCase (Assertion es)
| -- | A set of @Test@s sharing the same level in the hierarchy.
TestList [Test es]
| -- | A name or description for a subtree of the @Test@s.
TestLabel String (Test es)
instance Show (Test es) where
showsPrec _ (TestCase _) = showString "TestCase _"
showsPrec _ (TestList ts) = showString "TestList " . showList ts
showsPrec p (TestLabel l t) =
showString "TestLabel "
. showString l
. showChar ' '
. showsPrec p t
unliftTest :: (HUnit :> es) => (forall r. Eff es r -> IO r) -> Test es -> HUnit.Test
unliftTest unlift (TestCase a) = HUnit.TestCase $ unlift a
unliftTest unlift (TestList ts) = HUnit.TestList $ unliftTest unlift <$> ts
unliftTest unlift (TestLabel l t) = HUnit.TestLabel l $ unliftTest unlift t
-- Overloaded `test` Function
-- --------------------------
-- | Provides a way to convert data into a @Test@ or set of @Test@.
class Testable es t where
test :: (HasCallStack) => t -> Test es
instance Testable es (Test es) where
test = id
instance (Assertable es t) => Testable es t where
test = TestCase . assert
instance (Testable es t) => Testable es [t] where
test = TestList . map test
-- Test Construction Operators
-- ---------------------------
infix 1 ~?, ~=?, ~?=
infixr 0 ~:
-- | Creates a test case resulting from asserting the condition obtained
-- from the specified 'AssertionPredicable'.
(~?)
:: (HasCallStack, AssertionPredicable es t, HUnit :> es)
=> t
-- ^ A value of which the asserted condition is predicated
-> String
-- ^ A message that is displayed on test failure
-> Test es
predi ~? msg = TestCase $ predi @? msg
-- | Shorthand for a test case that asserts equality.
(~=?)
:: (HasCallStack, Eq a, Show a, HUnit :> es)
=> a
-- ^ The expected value
-> a
-- ^ The actual value
-> Test es
expected ~=? actual = TestCase $ expected @=? actual
-- | Shorthand for a test case that asserts equality.
(~?=)
:: (HasCallStack, Eq a, Show a, HUnit :> es)
=> a
-- ^ The actual value
-> a
-- ^ The expected value
-> Test es
actual ~?= expected = TestCase $ actual @?= expected
-- | Creates a test from the specified 'Testable', with the specified
-- label attached to it.
--
-- Since 'Test' is @Testable@, this can be used as a shorthand way of attaching
-- a 'TestLabel' to one or more tests.
(~:) :: (HasCallStack, Testable es t) => String -> t -> Test es
label ~: t = TestLabel label (test t)
-- Running Tests
-- -------------
-- | Lifted 'HUnit.runTestTT'.
runTestTT :: (HasCallStack, HUnit :> es) => Test es -> Eff es Counts
runTestTT t = unsafeSeqUnliftIO $ \unlift -> HUnit.runTestTT (unliftTest unlift t)
-- | Lifted 'HUnit.runTestTTAndExit'.
runTestTTAndExit :: (HasCallStack, HUnit :> es) => Test es -> Eff es ()
runTestTTAndExit t = unsafeSeqUnliftIO $ \unlift -> HUnit.runTestTTAndExit (unliftTest unlift t)
-- | Unconditionally signals that a failure has occurred.
assertFailure :: (HasCallStack, HUnit :> es) => String -> Eff es a
assertFailure = hunit . HUnit.assertFailure
-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
-- and only the expected and actual values are output.
assertEqual
:: (HasCallStack, Eq a, Show a, HUnit :> es)
=> String
-- ^ The message prefix
-> a
-- ^ The expected value
-> a
-- ^ The actual value
-> Assertion es
assertEqual = ((hunit .) .) . HUnit.assertEqual
-- | Asserts that the specified condition holds.
assertBool
:: (HasCallStack, HUnit :> es)
=> String
-- ^ The message that is displayed if the assertion fails
-> Bool
-- ^ The condition
-> Assertion es
assertBool msg b = unless b (assertFailure msg)
-- | Signals an assertion failure if a non-empty message (i.e., a message
-- other than @\"\"@) is passed.
assertString
:: (HasCallStack, HUnit :> es)
=> String
-- ^ The message that is displayed with the assertion failure
-> Assertion es
assertString s = unless (null s) (assertFailure s)