{-# 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 :: forall (es :: [Effect]) a. (HUnit :> es) => IO a -> Eff es a
hunit IO a
a = do
    HUnit forall (es :: [Effect]) a. IO a -> Eff es a
unlift <- Eff es (StaticRep HUnit)
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
    IO a -> Eff es a
forall (es :: [Effect]) a. IO a -> Eff es a
unlift IO a
a

runHUnit :: (IOE :> es) => Eff (HUnit ': es) a -> Eff es a
runHUnit :: forall (es :: [Effect]) a.
(IOE :> es) =>
Eff (HUnit : es) a -> Eff es a
runHUnit = StaticRep HUnit -> Eff (HUnit : es) a -> Eff es a
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect])
       a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (StaticRep HUnit -> Eff (HUnit : es) a -> Eff es a)
-> StaticRep HUnit -> Eff (HUnit : es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ (forall (es :: [Effect]) a. IO a -> Eff es a) -> StaticRep HUnit
HUnit IO a -> Eff es a
forall (es :: [Effect]) a. IO a -> Eff es a
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_

-------------------------------------------------------------------------------

type Assertion es = Eff es ()

class Assertable es t where
    assert :: (HasCallStack) => t -> Assertion es

instance Assertable es () where
    assert :: HasCallStack => () -> Assertion es
assert = () -> Assertion es
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (HUnit :> es) => Assertable es Bool where
    assert :: HasCallStack => Bool -> Assertion es
assert = String -> Bool -> Assertion es
forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
String -> Bool -> Assertion es
assertBool String
""

instance (ListAssertable es t) => Assertable es [t] where
    assert :: HasCallStack => [t] -> Assertion es
assert = [t] -> Assertion es
forall (es :: [Effect]) t.
(ListAssertable es t, HasCallStack) =>
[t] -> Assertion es
listAssert

instance (Assertable es t) => Assertable es (Eff es t) where
    assert :: HasCallStack => Eff es t -> Assertion es
assert = (Eff es t -> (t -> Assertion es) -> Assertion es
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> Assertion es
forall (es :: [Effect]) t.
(Assertable es t, HasCallStack) =>
t -> Assertion es
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 :: HasCallStack => String -> Assertion es
listAssert = String -> Assertion es
forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
String -> Assertion es
assertString

instance Assertable es (Assertion es) where
    assert :: HasCallStack => Assertion es -> Assertion es
assert = Assertion es -> Assertion es
forall a. a -> a
id

type AssertionPredicate es = Eff es Bool

class AssertionPredicable es t where
    assertionPredicate :: t -> AssertionPredicate es

instance AssertionPredicable es Bool where
    assertionPredicate :: Bool -> AssertionPredicate es
assertionPredicate = Bool -> AssertionPredicate es
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (AssertionPredicable es t) => AssertionPredicable es (Eff es t) where
    assertionPredicate :: Eff es t -> AssertionPredicate es
assertionPredicate = (Eff es t -> (t -> AssertionPredicate es) -> AssertionPredicate es
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> AssertionPredicate es
forall (es :: [Effect]) t.
AssertionPredicable es t =>
t -> AssertionPredicate es
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
t
predi @? :: forall (es :: [Effect]) t.
(HasCallStack, AssertionPredicable es t, HUnit :> es) =>
t -> String -> Assertion es
@? String
msg = t -> AssertionPredicate es
forall (es :: [Effect]) t.
AssertionPredicable es t =>
t -> AssertionPredicate es
assertionPredicate t
predi AssertionPredicate es -> (Bool -> Eff es ()) -> Eff es ()
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Bool -> Eff es ()
forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
String -> Bool -> Assertion es
assertBool String
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
a
expected @=? :: forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Assertion es
@=? a
actual = String -> a -> a -> Assertion es
forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
String -> a -> a -> Assertion es
assertEqual String
"" a
expected a
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
a
actual @?= :: forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Assertion es
@?= a
expected = String -> a -> a -> Assertion es
forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
String -> a -> a -> Assertion es
assertEqual String
"" a
expected a
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 :: Int -> Test es -> ShowS
showsPrec Int
_ (TestCase Assertion es
_) = String -> ShowS
showString String
"TestCase _"
    showsPrec Int
_ (TestList [Test es]
ts) = String -> ShowS
showString String
"TestList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Test es] -> ShowS
forall a. Show a => [a] -> ShowS
showList [Test es]
ts
    showsPrec Int
p (TestLabel String
l Test es
t) =
        String -> ShowS
showString String
"TestLabel "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
l
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Test es -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Test es
t

unliftTest :: (HUnit :> es) => (forall r. Eff es r -> IO r) -> Test es -> HUnit.Test
unliftTest :: forall (es :: [Effect]).
(HUnit :> es) =>
(forall r. Eff es r -> IO r) -> Test es -> Test
unliftTest forall r. Eff es r -> IO r
unlift (TestCase Assertion es
a) = Assertion -> Test
HUnit.TestCase (Assertion -> Test) -> Assertion -> Test
forall a b. (a -> b) -> a -> b
$ Assertion es -> Assertion
forall r. Eff es r -> IO r
unlift Assertion es
a
unliftTest forall r. Eff es r -> IO r
unlift (TestList [Test es]
ts) = [Test] -> Test
HUnit.TestList ([Test] -> Test) -> [Test] -> Test
forall a b. (a -> b) -> a -> b
$ (forall r. Eff es r -> IO r) -> Test es -> Test
forall (es :: [Effect]).
(HUnit :> es) =>
(forall r. Eff es r -> IO r) -> Test es -> Test
unliftTest Eff es r -> IO r
forall r. Eff es r -> IO r
unlift (Test es -> Test) -> [Test es] -> [Test]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Test es]
ts
unliftTest forall r. Eff es r -> IO r
unlift (TestLabel String
l Test es
t) = String -> Test -> Test
HUnit.TestLabel String
l (Test -> Test) -> Test -> Test
forall a b. (a -> b) -> a -> b
$ (forall r. Eff es r -> IO r) -> Test es -> Test
forall (es :: [Effect]).
(HUnit :> es) =>
(forall r. Eff es r -> IO r) -> Test es -> Test
unliftTest Eff es r -> IO r
forall r. Eff es r -> IO r
unlift Test es
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 :: HasCallStack => Test es -> Test es
test = Test es -> Test es
forall a. a -> a
id

instance (Assertable es t) => Testable es t where
    test :: HasCallStack => t -> Test es
test = Assertion es -> Test es
forall (es :: [Effect]). Assertion es -> Test es
TestCase (Assertion es -> Test es) -> (t -> Assertion es) -> t -> Test es
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Assertion es
forall (es :: [Effect]) t.
(Assertable es t, HasCallStack) =>
t -> Assertion es
assert

instance (Testable es t) => Testable es [t] where
    test :: HasCallStack => [t] -> Test es
test = [Test es] -> Test es
forall (es :: [Effect]). [Test es] -> Test es
TestList ([Test es] -> Test es) -> ([t] -> [Test es]) -> [t] -> Test es
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Test es) -> [t] -> [Test es]
forall a b. (a -> b) -> [a] -> [b]
map t -> Test es
forall (es :: [Effect]) t.
(Testable es t, HasCallStack) =>
t -> Test es
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
t
predi ~? :: forall (es :: [Effect]) t.
(HasCallStack, AssertionPredicable es t, HUnit :> es) =>
t -> String -> Test es
~? String
msg = Assertion es -> Test es
forall (es :: [Effect]). Assertion es -> Test es
TestCase (Assertion es -> Test es) -> Assertion es -> Test es
forall a b. (a -> b) -> a -> b
$ t
predi t -> String -> Assertion es
forall (es :: [Effect]) t.
(HasCallStack, AssertionPredicable es t, HUnit :> es) =>
t -> String -> Assertion es
@? String
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
a
expected ~=? :: forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Test es
~=? a
actual = Assertion es -> Test es
forall (es :: [Effect]). Assertion es -> Test es
TestCase (Assertion es -> Test es) -> Assertion es -> Test es
forall a b. (a -> b) -> a -> b
$ a
expected a -> a -> Assertion es
forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Assertion es
@=? a
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
a
actual ~?= :: forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Test es
~?= a
expected = Assertion es -> Test es
forall (es :: [Effect]). Assertion es -> Test es
TestCase (Assertion es -> Test es) -> Assertion es -> Test es
forall a b. (a -> b) -> a -> b
$ a
actual a -> a -> Assertion es
forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
a -> a -> Assertion es
@?= a
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
String
label ~: :: forall (es :: [Effect]) t.
(HasCallStack, Testable es t) =>
String -> t -> Test es
~: t
t = String -> Test es -> Test es
forall (es :: [Effect]). String -> Test es -> Test es
TestLabel String
label (t -> Test es
forall (es :: [Effect]) t.
(Testable es t, HasCallStack) =>
t -> Test es
test t
t)

-- Running Tests
-- -------------

-- | Lifted 'HUnit.runTestTT'.
runTestTT :: (HasCallStack, HUnit :> es) => Test es -> Eff es Counts
runTestTT :: forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
Test es -> Eff es Counts
runTestTT Test es
t = ((forall r. Eff es r -> IO r) -> IO Counts) -> Eff es Counts
forall (es :: [Effect]) a.
HasCallStack =>
((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
unsafeSeqUnliftIO (((forall r. Eff es r -> IO r) -> IO Counts) -> Eff es Counts)
-> ((forall r. Eff es r -> IO r) -> IO Counts) -> Eff es Counts
forall a b. (a -> b) -> a -> b
$ \forall r. Eff es r -> IO r
unlift -> Test -> IO Counts
HUnit.runTestTT ((forall r. Eff es r -> IO r) -> Test es -> Test
forall (es :: [Effect]).
(HUnit :> es) =>
(forall r. Eff es r -> IO r) -> Test es -> Test
unliftTest Eff es r -> IO r
forall r. Eff es r -> IO r
unlift Test es
t)

-- | Lifted 'HUnit.runTestTTAndExit'.
runTestTTAndExit :: (HasCallStack, HUnit :> es) => Test es -> Eff es ()
runTestTTAndExit :: forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
Test es -> Eff es ()
runTestTTAndExit Test es
t = ((forall r. Eff es r -> IO r) -> Assertion) -> Eff es ()
forall (es :: [Effect]) a.
HasCallStack =>
((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
unsafeSeqUnliftIO (((forall r. Eff es r -> IO r) -> Assertion) -> Eff es ())
-> ((forall r. Eff es r -> IO r) -> Assertion) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \forall r. Eff es r -> IO r
unlift -> Test -> Assertion
HUnit.runTestTTAndExit ((forall r. Eff es r -> IO r) -> Test es -> Test
forall (es :: [Effect]).
(HUnit :> es) =>
(forall r. Eff es r -> IO r) -> Test es -> Test
unliftTest Eff es r -> IO r
forall r. Eff es r -> IO r
unlift Test es
t)

-- | Unconditionally signals that a failure has occurred.
assertFailure :: (HasCallStack, HUnit :> es) => String -> Eff es a
assertFailure :: forall (es :: [Effect]) a.
(HasCallStack, HUnit :> es) =>
String -> Eff es a
assertFailure = IO a -> Eff es a
forall (es :: [Effect]) a. (HUnit :> es) => IO a -> Eff es a
hunit (IO a -> Eff es a) -> (String -> IO a) -> String -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. HasCallStack => String -> IO a
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 :: forall a (es :: [Effect]).
(HasCallStack, Eq a, Show a, HUnit :> es) =>
String -> a -> a -> Assertion es
assertEqual = ((Assertion -> Eff es ()
forall (es :: [Effect]) a. (HUnit :> es) => IO a -> Eff es a
hunit (Assertion -> Eff es ()) -> (a -> Assertion) -> a -> Eff es ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Assertion) -> a -> Eff es ())
-> (a -> a -> Assertion) -> a -> a -> Eff es ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> a -> Assertion) -> a -> a -> Eff es ())
-> (String -> a -> a -> Assertion) -> String -> a -> a -> Eff es ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> a -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
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 :: forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
String -> Bool -> Assertion es
assertBool String
msg Bool
b = Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (String -> Eff es ()
forall (es :: [Effect]) a.
(HasCallStack, HUnit :> es) =>
String -> Eff es a
assertFailure String
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 :: forall (es :: [Effect]).
(HasCallStack, HUnit :> es) =>
String -> Assertion es
assertString String
s = Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (String -> Eff es ()
forall (es :: [Effect]) a.
(HasCallStack, HUnit :> es) =>
String -> Eff es a
assertFailure String
s)