{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Test.Hspec.Core.Example (
  Example (..)
, Params (..)
, defaultParams
, ActionWith
, Progress
, ProgressCallback
, Result(..)
, ResultStatus (..)
, Location (..)
, FailureReason (..)
, safeEvaluateExample
) where

import qualified Test.HUnit.Lang as HUnit

import           Data.CallStack

import           Control.Exception
import           Control.DeepSeq
import           Data.Typeable (Typeable)
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.Compat
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 -> Int
paramsSmallCheckDepth :: Int
} deriving (Int -> Params -> ShowS
[Params] -> ShowS
Params -> String
(Int -> Params -> ShowS)
-> (Params -> String) -> ([Params] -> ShowS) -> Show Params
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 :: Args -> Int -> Params
Params {
  paramsQuickCheckArgs :: Args
paramsQuickCheckArgs = Args
QC.stdArgs
, paramsSmallCheckDepth :: Int
paramsSmallCheckDepth = 5
}

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
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
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, Typeable)

data ResultStatus =
    Success
  | Pending (Maybe Location) (Maybe String)
  | Failure (Maybe Location) FailureReason
  deriving (Int -> ResultStatus -> ShowS
[ResultStatus] -> ShowS
ResultStatus -> String
(Int -> ResultStatus -> ShowS)
-> (ResultStatus -> String)
-> ([ResultStatus] -> ShowS)
-> Show ResultStatus
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, Typeable)

data FailureReason =
    NoReason
  | Reason String
  | ExpectedButGot (Maybe String) String String
  | Error (Maybe String) SomeException
  deriving (Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
(Int -> FailureReason -> ShowS)
-> (FailureReason -> String)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
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, Typeable)

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

instance Exception ResultStatus

safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result
safeEvaluateExample :: e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
safeEvaluateExample example :: e
example params :: Params
params around :: ActionWith (Arg e) -> IO ()
around progress :: ProgressCallback
progress = do
  Either SomeException Result
r <- IO Result -> IO (Either SomeException Result)
forall a. IO a -> IO (Either SomeException a)
safeTry (IO Result -> IO (Either SomeException Result))
-> IO Result -> IO (Either SomeException Result)
forall a b. (a -> b) -> a -> b
$ Result -> Result
forceResult (Result -> Result) -> IO Result -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
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
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ case Either SomeException Result
r of
    Left e :: SomeException
e | Just result :: ResultStatus
result <- SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result "" ResultStatus
result
    Left e :: SomeException
e | Just hunit :: HUnitFailure
hunit <- SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result "" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult Maybe String
forall a. Maybe a
Nothing HUnitFailure
hunit
    Left e :: SomeException
e -> String -> ResultStatus -> Result
Result "" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ Maybe String -> SomeException -> FailureReason
Error Maybe String
forall a. Maybe a
Nothing SomeException
e
    Right result :: Result
result -> Result
result
  where
    forceResult :: Result -> Result
    forceResult :: Result -> Result
forceResult r :: Result
r@(Result info :: String
info status :: ResultStatus
status) = String
info String -> ResultStatus -> ResultStatus
forall a b. NFData a => a -> b -> b
`deepseq` (ResultStatus -> ResultStatus
forceResultStatus ResultStatus
status) ResultStatus -> Result -> Result
forall a b. a -> b -> b
`seq` Result
r

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

instance Example Result where
  type Arg Result = ()
  evaluateExample :: Result
-> Params
-> (ActionWith (Arg Result) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample e :: Result
e = (() -> Result)
-> Params
-> (ActionWith (Arg (() -> Result)) -> IO ())
-> ProgressCallback
-> IO Result
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 example :: a -> Result
example _params :: Params
_params action :: ActionWith (Arg (a -> Result)) -> IO ()
action _callback :: ProgressCallback
_callback = do
    IORef Result
ref <- Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef (String -> ResultStatus -> Result
Result "" ResultStatus
Success)
    ActionWith (Arg (a -> Result)) -> IO ()
action (Result -> IO Result
forall a. a -> IO a
evaluate (Result -> IO Result) -> (a -> Result) -> a -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result
example (a -> IO Result) -> (Result -> IO ()) -> a -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref)
    IORef Result -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
ref

instance Example Bool where
  type Arg Bool = ()
  evaluateExample :: Bool
-> Params
-> (ActionWith (Arg Bool) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample e :: Bool
e = (() -> Bool)
-> Params
-> (ActionWith (Arg (() -> Bool)) -> IO ())
-> ProgressCallback
-> IO Result
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 p :: a -> Bool
p _params :: Params
_params action :: ActionWith (Arg (a -> Bool)) -> IO ()
action _callback :: ProgressCallback
_callback = do
    IORef Result
ref <- Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef (String -> ResultStatus -> Result
Result "" ResultStatus
Success)
    ActionWith (Arg (a -> Bool)) -> IO ()
action (Result -> IO Result
forall a. a -> IO a
evaluate (Result -> IO Result) -> (a -> Result) -> a -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result
example (a -> IO Result) -> (Result -> IO ()) -> a -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref)
    IORef Result -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
ref
    where
      example :: a -> Result
example a :: a
a
        | a -> Bool
p a
a = String -> ResultStatus -> Result
Result "" ResultStatus
Success
        | Bool
otherwise = String -> ResultStatus -> Result
Result "" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
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 e :: IO ()
e = (() -> IO ())
-> Params
-> (ActionWith (Arg (() -> IO ())) -> IO ())
-> ProgressCallback
-> IO Result
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 pre :: Maybe String
pre e :: HUnitFailure
e = case HUnitFailure
e of
  HUnit.HUnitFailure mLoc :: Maybe SrcLoc
mLoc err :: FailureReason
err ->
      case FailureReason
err of
        HUnit.Reason reason :: String
reason -> Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
location (String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ ShowS
addPre String
reason)
        HUnit.ExpectedButGot preface :: Maybe String
preface expected :: String
expected actual :: 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 xs :: Maybe String
xs = case (Maybe String
pre, Maybe String
xs) of
              (Just x :: String
x, Just y :: String
y) -> String -> Maybe String
forall a. a -> Maybe a
Just (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y)
              _ -> Maybe String
pre Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
xs
    where
      location :: Maybe Location
location = case Maybe SrcLoc
mLoc of
        Nothing -> Maybe Location
forall a. Maybe a
Nothing
        Just loc :: SrcLoc
loc -> Location -> Maybe Location
forall a. a -> Maybe a
Just (Location -> Maybe Location) -> Location -> Maybe Location
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Location
Location (SrcLoc -> String
srcLocFile SrcLoc
loc) (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) (SrcLoc -> Int
srcLocStartCol SrcLoc
loc)
  where
    addPre :: String -> String
    addPre :: ShowS
addPre xs :: String
xs = case Maybe String
pre of
      Just x :: String
x -> String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
      Nothing -> String
xs

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

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

fromQuickCheckResult :: QC.Result -> Result
fromQuickCheckResult :: Result -> Result
fromQuickCheckResult r :: Result
r = case Result -> QuickCheckResult
parseQuickCheckResult Result
r of
  QuickCheckResult _ info :: String
info (QuickCheckOtherFailure err :: String
err) -> String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (String -> FailureReason
Reason String
err)
  QuickCheckResult _ info :: String
info QuickCheckSuccess -> String -> ResultStatus -> Result
Result String
info ResultStatus
Success
  QuickCheckResult n :: Int
n info :: String
info (QuickCheckFailure QCFailure{..}) -> case Maybe SomeException
quickCheckFailureException of
    Just e :: SomeException
e | Just result :: ResultStatus
result <- SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info ResultStatus
result
    Just e :: SomeException
e | Just hunit :: HUnitFailure
hunit <- SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult (String -> Maybe String
forall a. a -> Maybe a
Just String
hunitAssertion) HUnitFailure
hunit
    Just e :: SomeException
e -> String -> Result
failure (SomeException -> String
uncaughtException SomeException
e)
    Nothing -> String -> Result
failure String
falsifiable
    where
      failure :: String -> Result
failure = String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result)
-> (String -> ResultStatus) -> String -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus)
-> (String -> FailureReason) -> String -> ResultStatus
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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [
          "Falsifiable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
numbers String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":"
        , ShowS
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
        ]

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

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

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