module Effectful.Zoo.HUnit
  ( requireTest,
  ) where

import Control.Monad.IO.Class
import Data.List qualified as L
import GHC.Stack (SrcLoc)
import GHC.Stack qualified as GHC
import HaskellWorks.Prelude
import Hedgehog
import Test.HUnit.Lang

import qualified Control.Exception as E

location :: HasCallStack => Maybe SrcLoc
location :: HasCallStack => Maybe SrcLoc
location = case [([Char], SrcLoc)] -> [([Char], SrcLoc)]
forall a. [a] -> [a]
L.reverse (CallStack -> [([Char], SrcLoc)]
GHC.getCallStack CallStack
HasCallStack => CallStack
GHC.callStack) of
  ([Char]
_, SrcLoc
loc) : [([Char], SrcLoc)]
_ -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
loc
  []           -> Maybe SrcLoc
forall a. Maybe a
Nothing

require :: HasCallStack => Property -> Assertion
require :: HasCallStack => Property -> Assertion
require Property
p = do
  Bool
result <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Property -> IO Bool
forall (m :: * -> *). MonadIO m => Property -> m Bool
check Property
p
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
result (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
    HUnitFailure -> Assertion
forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location (FailureReason -> HUnitFailure) -> FailureReason -> HUnitFailure
forall a b. (a -> b) -> a -> b
$ [Char] -> FailureReason
Reason [Char]
"Hedgehog property test failed")

requireTest :: HasCallStack => TestT IO () -> Assertion
requireTest :: HasCallStack => TestT IO () -> Assertion
requireTest = HasCallStack => Property -> Assertion
Property -> Assertion
require (Property -> Assertion)
-> (TestT IO () -> Property) -> TestT IO () -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Property -> Property
withTests TestLimit
1 (Property -> Property)
-> (TestT IO () -> Property) -> TestT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property)
-> (TestT IO () -> PropertyT IO ()) -> TestT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestT IO () -> PropertyT IO ()
forall (m :: * -> *) a. Monad m => TestT m a -> PropertyT m a
test