{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TestHelper (
  isDefined,
  isDeeplyDefined,
  mustFail,
  qcWithTimeout,
  qcWithTimeoutAndArgs,
  qcWithTimeoutAndRuns,
  qc,
  qc',
  qcWithArgs, --DEPRECATED
#ifdef IOTASKS
  tcWithTimeout,
  tcWithTimeoutAndArgs,
  tcCustomizedWithTimeoutAndArgs,
  tcWithInputsOnFailure,
#endif
  ) where
import Prelude (
  Bool (..), Either (Left, Right), Int, IO, String,
  const, error, return, seq, ($), (++))

import Control.Exception
  (ErrorCall, SomeException, catch, evaluate, try)
import Test.HUnit                       (Assertion, assertFailure)
import Test.QuickCheck
  (Args, Property, Result (GaveUp, Failure, Success), Testable,
   chatty, failingTestCase, maxSuccess, output,
   quickCheckWithResult, stdArgs, within)
import Test.QuickCheck.Monadic          (monadicIO, run)
import Control.DeepSeq                  (NFData, deepseq)

#ifdef IOTASKS
import Test.IOTasks (
  IOrep,
  Specification,
  taskCheckWithOutcome,
  feedbackStyle,
  printOutcomeWith,
  terminalOutput,
  )
import qualified Test.IOTasks as IOTasks (
  Args,
  CoreOutcome (..),
  Outcome (..),
  stdArgs,
  )
import Prelude                          (Maybe(..), (.), id, show)
import qualified System.Timeout as System (timeout)
#endif

qcWithArgs :: Testable prop => Int -> Args -> prop -> Assertion
qcWithArgs :: forall prop. Testable prop => Int -> Args -> prop -> Assertion
qcWithArgs = Int -> Args -> prop -> Assertion
forall prop. Testable prop => Int -> Args -> prop -> Assertion
qcWithTimeoutAndArgs

qcWithTimeoutAndArgs :: Testable prop => Int -> Args -> prop -> Assertion
qcWithTimeoutAndArgs :: forall prop. Testable prop => Int -> Args -> prop -> Assertion
qcWithTimeoutAndArgs Int
timeout Args
args prop
prop = do
  Result
result <- Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult (Args
args {chatty :: Bool
chatty = Bool
False}) (Int -> prop -> Property
forall prop. Testable prop => Int -> prop -> Property
within Int
timeout prop
prop)
  Result -> Assertion
assertFailureCustom Result
result

qc' :: Testable prop => Int -> Int -> prop -> Assertion
qc' :: forall prop. Testable prop => Int -> Int -> prop -> Assertion
qc' = Int -> Int -> prop -> Assertion
forall prop. Testable prop => Int -> Int -> prop -> Assertion
qcWithTimeoutAndRuns

qcWithTimeoutAndRuns :: Testable prop => Int -> Int -> prop -> Assertion
qcWithTimeoutAndRuns :: forall prop. Testable prop => Int -> Int -> prop -> Assertion
qcWithTimeoutAndRuns Int
timeout Int
n = Int -> Args -> prop -> Assertion
forall prop. Testable prop => Int -> Args -> prop -> Assertion
qcWithArgs Int
timeout (Args
stdArgs {maxSuccess :: Int
maxSuccess = Int
n})

qc :: Testable prop => Int -> prop -> Assertion
qc :: forall prop. Testable prop => Int -> prop -> Assertion
qc = Int -> prop -> Assertion
forall prop. Testable prop => Int -> prop -> Assertion
qcWithTimeout

qcWithTimeout :: Testable prop => Int -> prop -> Assertion
qcWithTimeout :: forall prop. Testable prop => Int -> prop -> Assertion
qcWithTimeout Int
timeout = Int -> Int -> prop -> Assertion
forall prop. Testable prop => Int -> Int -> prop -> Assertion
qcWithTimeoutAndRuns Int
timeout Int
1000

assertFailureCustom :: Result -> IO ()
assertFailureCustom :: Result -> Assertion
assertFailureCustom Success {} = () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
assertFailureCustom GaveUp {} = String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
  String
"Gave up on testing. This usually indicates that your code breaks an assumed invariant.\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Perhaps you missed a detail within the task description."
assertFailureCustom Failure { failingTestCase :: Result -> [String]
failingTestCase = [String
t] } =
  String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String
"Failing test case:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
assertFailureCustom Result
x = String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ Result -> String
output Result
x

mustFail :: a -> String -> Property
mustFail :: forall a. a -> String -> Property
mustFail a
x String
msg =
  PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ Assertion -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Assertion -> PropertyM IO ()) -> Assertion -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException a
resultOrError <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (a -> IO a
forall a. a -> IO a
evaluate a
x)
    case Either SomeException a
resultOrError of
      Left (SomeException
_::SomeException) -> () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- expected failure occurred.
      Right a
_                 -> String -> Assertion
forall a. HasCallStack => String -> a
error String
msg

isDeeplyDefined :: NFData a => a -> IO Bool
isDeeplyDefined :: forall a. NFData a => a -> IO Bool
isDeeplyDefined a
x = IO Bool -> (ErrorCall -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
  (a -> IO Bool -> IO Bool
forall a b. NFData a => a -> b -> b
deepseq a
x (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
  ((IO Bool -> ErrorCall -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> ErrorCall -> IO Bool)
-> IO Bool -> ErrorCall -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) :: ErrorCall -> IO Bool)

isDefined :: a -> IO Bool
isDefined :: forall a. a -> IO Bool
isDefined a
x = IO Bool -> (ErrorCall -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
  (a -> IO Bool -> IO Bool
forall a b. a -> b -> b
seq a
x (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
  ((IO Bool -> ErrorCall -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> ErrorCall -> IO Bool)
-> IO Bool -> ErrorCall -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) :: ErrorCall -> IO Bool)

#ifdef IOTASKS
-- helper for new IOTasks implementation
tcWithTimeout :: Int -> IOrep () -> Specification -> Assertion
tcWithTimeout :: Int -> IOrep () -> Specification -> Assertion
tcWithTimeout Int
to = Int -> Args -> IOrep () -> Specification -> Assertion
tcWithTimeoutAndArgs Int
to Args
IOTasks.stdArgs

tcWithTimeoutAndArgs :: Int -> IOTasks.Args -> IOrep () -> Specification -> Assertion
tcWithTimeoutAndArgs :: Int -> Args -> IOrep () -> Specification -> Assertion
tcWithTimeoutAndArgs Int
to Args
args IOrep ()
prog Specification
spec = Int
-> Args
-> IOrep ()
-> Specification
-> (String -> String)
-> Assertion
tcCustomizedWithTimeoutAndArgs Int
to Args
args IOrep ()
prog Specification
spec String -> String
forall a. a -> a
id

tcCustomizedWithTimeoutAndArgs :: Int -> IOTasks.Args -> IOrep () -> Specification -> (String -> String) -> Assertion
tcCustomizedWithTimeoutAndArgs :: Int
-> Args
-> IOrep ()
-> Specification
-> (String -> String)
-> Assertion
tcCustomizedWithTimeoutAndArgs Int
to Args
args IOrep ()
prog Specification
spec String -> String
transform =
  Int
-> Args
-> IOrep ()
-> Specification
-> (Outcome -> String)
-> Assertion
tcTimeoutAndArgsHandleFailure Int
to Args
args IOrep ()
prog Specification
spec (String -> String
transform (String -> String) -> (Outcome -> String) -> Outcome -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Outcome -> String
defaultErrorMessage Args
args)

tcWithInputsOnFailure :: Int -> IOTasks.Args -> IOrep () -> Specification -> ([String] -> String) -> Assertion
tcWithInputsOnFailure :: Int
-> Args
-> IOrep ()
-> Specification
-> ([String] -> String)
-> Assertion
tcWithInputsOnFailure Int
to Args
args IOrep ()
prog Specification
spec [String] -> String
withInputs =  Int
-> Args
-> IOrep ()
-> Specification
-> (Outcome -> String)
-> Assertion
tcTimeoutAndArgsHandleFailure Int
to Args
args IOrep ()
prog Specification
spec Outcome -> String
handleFailure
 where
  handleFailure :: Outcome -> String
handleFailure (IOTasks.Outcome (IOTasks.Failure [String]
inputs ExpectedRun
_ ExpectedRun
_ MatchResult
_) OutcomeHints
_) = [String] -> String
withInputs [String]
inputs
  handleFailure Outcome
_ = String -> String
forall a. HasCallStack => String -> a
error String
"only called with failures"

defaultErrorMessage :: IOTasks.Args -> IOTasks.Outcome -> String
defaultErrorMessage :: Args -> Outcome -> String
defaultErrorMessage Args
args = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Outcome -> Doc) -> Outcome -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeedbackStyle -> Outcome -> Doc
printOutcomeWith (Args -> FeedbackStyle
feedbackStyle Args
args)

tcTimeoutAndArgsHandleFailure
  :: Int
  -> IOTasks.Args
  -> IOrep ()
  -> Specification
  -> (IOTasks.Outcome -> String)
  -> Assertion
tcTimeoutAndArgsHandleFailure :: Int
-> Args
-> IOrep ()
-> Specification
-> (Outcome -> String)
-> Assertion
tcTimeoutAndArgsHandleFailure Int
to Args
args IOrep ()
prog Specification
spec Outcome -> String
withFailure = do
  Maybe Outcome
outcome <- Int -> IO Outcome -> IO (Maybe Outcome)
forall a. Int -> IO a -> IO (Maybe a)
System.timeout Int
to (IO Outcome -> IO (Maybe Outcome))
-> IO Outcome -> IO (Maybe Outcome)
forall a b. (a -> b) -> a -> b
$ Args -> IOrep () -> Specification -> IO Outcome
taskCheckWithOutcome Args
args{ terminalOutput :: Bool
terminalOutput = Bool
False } IOrep ()
prog Specification
spec
  case Maybe Outcome
outcome of
    Just (IOTasks.Outcome IOTasks.Success{} OutcomeHints
_) -> () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (IOTasks.Outcome CoreOutcome
IOTasks.GaveUp OutcomeHints
_) -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure
      String
"Gave up on testing. This is usually not caused by a fault within your submission. Please contact your lecturer."
    Just o :: Outcome
o@(IOTasks.Outcome IOTasks.Failure{} OutcomeHints
_) -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ Outcome -> String
withFailure Outcome
o
    Maybe Outcome
Nothing -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
"Failure: Timeout"
#endif