{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

module HaskellWorks.Hspec.Hedgehog
  ( require
  , requireProperty
  , requireTest
  ) where

import Control.Monad          (unless)
import Control.Monad.IO.Class
import Data.CallStack
import Hedgehog
import Test.HUnit.Lang

import qualified Control.Exception as E

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

require :: HasCallStack => Property -> Assertion
require :: Property -> Assertion
require Property
p = do
  Bool
result <- IO Bool -> IO Bool
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
$ String -> FailureReason
Reason String
"Hedgehog property test failed")

requireProperty :: HasCallStack => PropertyT IO () -> Assertion
requireProperty :: PropertyT IO () -> Assertion
requireProperty = HasCallStack => Property -> Assertion
Property -> Assertion
require (Property -> Assertion)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property

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