{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Test.Hspec.Core.Example (
-- RE-EXPORTED from Test.Hspec.Core.Spec
  Example (..)
, Params (..)
, defaultParams
, ActionWith
, Progress
, ProgressCallback
, Result(..)
, ResultStatus (..)
, Location (..)
, FailureReason (..)
, safeEvaluate
, safeEvaluateExample
-- END RE-EXPORTED from Test.Hspec.Core.Spec
, safeEvaluateResultStatus
, exceptionToResultStatus
, toLocation
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import qualified Test.HUnit.Lang as HUnit

import           Data.CallStack (SrcLoc(..))

import           Control.DeepSeq
import qualified Test.QuickCheck as QC
import           Test.Hspec.Expectations (Expectation)

import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests)
import qualified Test.QuickCheck.Property as QCP

import           Test.Hspec.Core.QuickCheckUtil
import           Test.Hspec.Core.Util
import           Test.Hspec.Core.Example.Location

-- | A type class for examples
class Example e where
  type Arg e
  type Arg e = ()
  evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result

data Params = Params {
  Params -> Args
paramsQuickCheckArgs  :: QC.Args
, Params -> Maybe Int
paramsSmallCheckDepth :: Maybe Int
} deriving (Int -> Params -> ShowS
[Params] -> ShowS
Params -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Params] -> ShowS
$cshowList :: [Params] -> ShowS
show :: Params -> String
$cshow :: Params -> String
showsPrec :: Int -> Params -> ShowS
$cshowsPrec :: Int -> Params -> ShowS
Show)

defaultParams :: Params
defaultParams :: Params
defaultParams = Params {
  paramsQuickCheckArgs :: Args
paramsQuickCheckArgs = Args
QC.stdArgs
, paramsSmallCheckDepth :: Maybe Int
paramsSmallCheckDepth = forall a. Maybe a
Nothing
}

type Progress = (Int, Int)
type ProgressCallback = Progress -> IO ()

-- | An `IO` action that expects an argument of type @a@
type ActionWith a = a -> IO ()

-- | The result of running an example
data Result = Result {
  Result -> String
resultInfo :: String
, Result -> ResultStatus
resultStatus :: ResultStatus
} deriving Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show

data ResultStatus =
    Success
  | Pending (Maybe Location) (Maybe String)
  | Failure (Maybe Location) FailureReason
  deriving Int -> ResultStatus -> ShowS
[ResultStatus] -> ShowS
ResultStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResultStatus] -> ShowS
$cshowList :: [ResultStatus] -> ShowS
show :: ResultStatus -> String
$cshow :: ResultStatus -> String
showsPrec :: Int -> ResultStatus -> ShowS
$cshowsPrec :: Int -> ResultStatus -> ShowS
Show

data FailureReason =
    NoReason
  | Reason String
  | ColorizedReason String
  | ExpectedButGot (Maybe String) String String
  | Error (Maybe String) SomeException
  deriving Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> String
$cshow :: FailureReason -> String
showsPrec :: Int -> FailureReason -> ShowS
$cshowsPrec :: Int -> FailureReason -> ShowS
Show

instance NFData FailureReason where
  rnf :: FailureReason -> ()
rnf FailureReason
reason = case FailureReason
reason of
    FailureReason
NoReason -> ()
    Reason String
r -> String
r forall a b. NFData a => a -> b -> b
`deepseq` ()
    ColorizedReason String
r -> String
r forall a b. NFData a => a -> b -> b
`deepseq` ()
    ExpectedButGot Maybe String
p String
e String
a  -> Maybe String
p forall a b. NFData a => a -> b -> b
`deepseq` String
e forall a b. NFData a => a -> b -> b
`deepseq` String
a forall a b. NFData a => a -> b -> b
`deepseq` ()
    Error Maybe String
m SomeException
e -> Maybe String
m forall a b. NFData a => a -> b -> b
`deepseq` forall a. Show a => a -> String
show SomeException
e forall a b. NFData a => a -> b -> b
`deepseq` ()

instance Exception ResultStatus

forceResult :: Result -> Result
forceResult :: Result -> Result
forceResult r :: Result
r@(Result String
info ResultStatus
status) = String
info forall a b. NFData a => a -> b -> b
`deepseq` (ResultStatus -> ResultStatus
forceResultStatus ResultStatus
status) seq :: forall a b. a -> b -> b
`seq` Result
r

forceResultStatus :: ResultStatus -> ResultStatus
forceResultStatus :: ResultStatus -> ResultStatus
forceResultStatus ResultStatus
r = case ResultStatus
r of
  ResultStatus
Success -> ResultStatus
r
  Pending Maybe Location
_ Maybe String
m -> Maybe String
m forall a b. NFData a => a -> b -> b
`deepseq` ResultStatus
r
  Failure Maybe Location
_ FailureReason
m -> FailureReason
m forall a b. NFData a => a -> b -> b
`deepseq` ResultStatus
r

safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result
safeEvaluateExample :: forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
safeEvaluateExample e
example Params
params ActionWith (Arg e) -> IO ()
around ProgressCallback
progress = IO Result -> IO Result
safeEvaluate forall a b. (a -> b) -> a -> b
$ forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample e
example Params
params ActionWith (Arg e) -> IO ()
around ProgressCallback
progress

safeEvaluate :: IO Result -> IO Result
safeEvaluate :: IO Result -> IO Result
safeEvaluate IO Result
action = do
  Either SomeException Result
r <- forall a. IO a -> IO (Either SomeException a)
safeTry forall a b. (a -> b) -> a -> b
$ Result -> Result
forceResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Result
action
  case Either SomeException Result
r of
    Left SomeException
e -> String -> ResultStatus -> Result
Result String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> IO ResultStatus
exceptionToResultStatus SomeException
e
    Right Result
result -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
result

safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus IO ResultStatus
action = do
  Either SomeException ResultStatus
r <- forall a. IO a -> IO (Either SomeException a)
safeTry forall a b. (a -> b) -> a -> b
$ ResultStatus -> ResultStatus
forceResultStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ResultStatus
action
  case Either SomeException ResultStatus
r of
    Left SomeException
e -> SomeException -> IO ResultStatus
exceptionToResultStatus SomeException
e
    Right ResultStatus
status -> forall (m :: * -> *) a. Monad m => a -> m a
return ResultStatus
status

exceptionToResultStatus :: SomeException -> IO ResultStatus
exceptionToResultStatus :: SomeException -> IO ResultStatus
exceptionToResultStatus = IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ResultStatus
toResultStatus
  where
    toResultStatus :: SomeException -> ResultStatus
    toResultStatus :: SomeException -> ResultStatus
toResultStatus SomeException
e
      | Just ResultStatus
result <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = ResultStatus
result
      | Just HUnitFailure
hunit <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult forall a. Maybe a
Nothing HUnitFailure
hunit
      | Bool
otherwise = Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe String -> SomeException -> FailureReason
Error forall a. Maybe a
Nothing SomeException
e

instance Example Result where
  type Arg Result = ()
  evaluateExample :: Result
-> Params
-> (ActionWith (Arg Result) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample Result
e = forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> Result
e)

instance Example (a -> Result) where
  type Arg (a -> Result) = a
  evaluateExample :: (a -> Result)
-> Params
-> (ActionWith (Arg (a -> Result)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> Result
example Params
_params ActionWith (Arg (a -> Result)) -> IO ()
hook ProgressCallback
_callback = do
    forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success) ActionWith (Arg (a -> Result)) -> IO ()
hook (forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result
example)

instance Example Bool where
  type Arg Bool = ()
  evaluateExample :: Bool
-> Params
-> (ActionWith (Arg Bool) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample Bool
e = forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> Bool
e)

instance Example (a -> Bool) where
  type Arg (a -> Bool) = a
  evaluateExample :: (a -> Bool)
-> Params
-> (ActionWith (Arg (a -> Bool)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> Bool
p Params
_params ActionWith (Arg (a -> Bool)) -> IO ()
hook ProgressCallback
_callback = do
    forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success) ActionWith (Arg (a -> Bool)) -> IO ()
hook (forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result
example)
    where
      example :: a -> Result
example a
a
        | a -> Bool
p a
a = String -> ResultStatus -> Result
Result String
"" ResultStatus
Success
        | Bool
otherwise = String -> ResultStatus -> Result
Result String
"" forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing FailureReason
NoReason

instance Example Expectation where
  type Arg Expectation = ()
  evaluateExample :: IO ()
-> Params
-> (ActionWith (Arg (IO ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample IO ()
e = forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> IO ()
e)

hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus
hunitFailureToResult :: Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult Maybe String
pre HUnitFailure
e = case HUnitFailure
e of
  HUnit.HUnitFailure Maybe SrcLoc
mLoc FailureReason
err ->
      case FailureReason
err of
        HUnit.Reason String
reason -> Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
location (String -> FailureReason
Reason forall a b. (a -> b) -> a -> b
$ ShowS
addPre String
reason)
        HUnit.ExpectedButGot Maybe String
preface String
expected String
actual -> Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
location (Maybe String -> String -> String -> FailureReason
ExpectedButGot (Maybe String -> Maybe String
addPreMaybe Maybe String
preface) String
expected String
actual)
          where
            addPreMaybe :: Maybe String -> Maybe String
            addPreMaybe :: Maybe String -> Maybe String
addPreMaybe Maybe String
xs = case (Maybe String
pre, Maybe String
xs) of
              (Just String
x, Just String
y) -> forall a. a -> Maybe a
Just (String
x forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
y)
              (Maybe String, Maybe String)
_ -> Maybe String
pre forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
xs
    where
      location :: Maybe Location
location = case Maybe SrcLoc
mLoc of
        Maybe SrcLoc
Nothing -> forall a. Maybe a
Nothing
        Just SrcLoc
loc -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SrcLoc -> Location
toLocation SrcLoc
loc
  where
    addPre :: String -> String
    addPre :: ShowS
addPre String
xs = case Maybe String
pre of
      Just String
x -> String
x forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
xs
      Maybe String
Nothing -> String
xs

toLocation :: SrcLoc -> Location
toLocation :: SrcLoc -> Location
toLocation SrcLoc
loc = String -> Int -> Int -> Location
Location (SrcLoc -> String
srcLocFile SrcLoc
loc) (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) (SrcLoc -> Int
srcLocStartCol SrcLoc
loc)

instance Example (a -> Expectation) where
  type Arg (a -> Expectation) = a
  evaluateExample :: (a -> IO ())
-> Params
-> (ActionWith (Arg (a -> IO ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> IO ()
e Params
_ ActionWith (Arg (a -> IO ())) -> IO ()
hook ProgressCallback
_ = ActionWith (Arg (a -> IO ())) -> IO ()
hook a -> IO ()
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success)

instance Example QC.Property where
  type Arg QC.Property = ()
  evaluateExample :: Property
-> Params
-> (ActionWith (Arg Property) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample Property
e = forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> Property
e)

instance Example (a -> QC.Property) where
  type Arg (a -> QC.Property) = a
  evaluateExample :: (a -> Property)
-> Params
-> (ActionWith (Arg (a -> Property)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> Property
p Params
c ActionWith (Arg (a -> Property)) -> IO ()
hook ProgressCallback
progressCallback = do
    Result
r <- forall prop. Testable prop => Args -> prop -> IO Result
QC.quickCheckWithResult (Params -> Args
paramsQuickCheckArgs Params
c) {chatty :: Bool
QC.chatty = Bool
False} (forall prop. Testable prop => Callback -> prop -> Property
QCP.callback Callback
qcProgressCallback forall a b. (a -> b) -> a -> b
$ forall a. ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
aroundProperty ActionWith (Arg (a -> Property)) -> IO ()
hook a -> Property
p)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result -> Result
fromQuickCheckResult Result
r
    where
      qcProgressCallback :: Callback
qcProgressCallback = CallbackKind -> (State -> Result -> IO ()) -> Callback
QCP.PostTest CallbackKind
QCP.NotCounterexample forall a b. (a -> b) -> a -> b
$
        \State
st Result
_ -> ProgressCallback
progressCallback (State -> Int
QC.numSuccessTests State
st, State -> Int
QC.maxSuccessTests State
st)

fromQuickCheckResult :: QC.Result -> Result
fromQuickCheckResult :: Result -> Result
fromQuickCheckResult Result
r = case Result -> QuickCheckResult
parseQuickCheckResult Result
r of
  QuickCheckResult Int
_ String
info (QuickCheckOtherFailure String
err) -> String -> ResultStatus -> Result
Result String
info forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing (String -> FailureReason
Reason String
err)
  QuickCheckResult Int
_ String
info Status
QuickCheckSuccess -> String -> ResultStatus -> Result
Result String
info ResultStatus
Success
  QuickCheckResult Int
n String
info (QuickCheckFailure QCFailure{Int
String
[String]
Maybe SomeException
quickCheckFailureCounterexample :: QuickCheckFailure -> [String]
quickCheckFailureReason :: QuickCheckFailure -> String
quickCheckFailureException :: QuickCheckFailure -> Maybe SomeException
quickCheckFailureNumShrinks :: QuickCheckFailure -> Int
quickCheckFailureCounterexample :: [String]
quickCheckFailureReason :: String
quickCheckFailureException :: Maybe SomeException
quickCheckFailureNumShrinks :: Int
..}) -> case Maybe SomeException
quickCheckFailureException of
    Just SomeException
e | Just ResultStatus
result <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info ResultStatus
result
    Just SomeException
e | Just HUnitFailure
hunit <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info forall a b. (a -> b) -> a -> b
$ Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult (forall a. a -> Maybe a
Just String
hunitAssertion) HUnitFailure
hunit
    Just SomeException
e -> String -> Result
failure (SomeException -> String
uncaughtException SomeException
e)
    Maybe SomeException
Nothing -> String -> Result
failure String
falsifiable
    where
      failure :: String -> Result
failure = String -> ResultStatus -> Result
Result String
info forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FailureReason
Reason

      numbers :: String
numbers = Int -> Int -> String
formatNumbers Int
n Int
quickCheckFailureNumShrinks

      hunitAssertion :: String
      hunitAssertion :: String
hunitAssertion = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
          String
"Falsifiable " forall a. [a] -> [a] -> [a]
++ String
numbers forall a. [a] -> [a] -> [a]
++ String
":"
        , ShowS
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
        ]

      uncaughtException :: SomeException -> String
uncaughtException SomeException
e = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
          String
"uncaught exception: " forall a. [a] -> [a] -> [a]
++ SomeException -> String
formatException SomeException
e
        , String
numbers
        , ShowS
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
        ]

      falsifiable :: String
falsifiable = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
          String
quickCheckFailureReason forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
numbers forall a. [a] -> [a] -> [a]
++ String
":"
        , ShowS
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
        ]

indent :: String -> String
indent :: ShowS
indent = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines