{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Test.Hspec.Core.Example (
Example (..)
, Params (..)
, defaultParams
, ActionWith
, Progress
, ProgressCallback
, Result(..)
, ResultStatus (..)
, Location (..)
, FailureReason (..)
, safeEvaluate
, safeEvaluateExample
, safeEvaluateResultStatus
, exceptionToResultStatus
, toLocation
, hunitFailureToResult
) 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 Test.Hspec.Core.Util
import Test.Hspec.Core.QuickCheck.Util (liftHook)
import Test.Hspec.Core.Example.Location
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
(Int -> Params -> ShowS)
-> (Params -> String) -> ([Params] -> ShowS) -> Show Params
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Params -> ShowS
showsPrec :: Int -> Params -> ShowS
$cshow :: Params -> String
show :: Params -> String
$cshowList :: [Params] -> ShowS
showList :: [Params] -> ShowS
Show)
defaultParams :: Params
defaultParams :: Params
defaultParams = Params {
paramsQuickCheckArgs :: Args
paramsQuickCheckArgs = Args
QC.stdArgs
, paramsSmallCheckDepth :: Maybe Int
paramsSmallCheckDepth = Maybe Int
forall a. Maybe a
Nothing
}
type Progress = (Int, Int)
type ProgressCallback = Progress -> IO ()
type ActionWith a = a -> IO ()
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
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show
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
$cshowsPrec :: Int -> ResultStatus -> ShowS
showsPrec :: Int -> ResultStatus -> ShowS
$cshow :: ResultStatus -> String
show :: ResultStatus -> String
$cshowList :: [ResultStatus] -> ShowS
showList :: [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
(Int -> FailureReason -> ShowS)
-> (FailureReason -> String)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailureReason -> ShowS
showsPrec :: Int -> FailureReason -> ShowS
$cshow :: FailureReason -> String
show :: FailureReason -> String
$cshowList :: [FailureReason] -> ShowS
showList :: [FailureReason] -> ShowS
Show
instance NFData FailureReason where
rnf :: FailureReason -> ()
rnf FailureReason
reason = case FailureReason
reason of
FailureReason
NoReason -> ()
Reason String
r -> String
r String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()
ColorizedReason String
r -> String
r String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()
ExpectedButGot Maybe String
p String
e String
a -> Maybe String
p Maybe String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` String
e String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` String
a String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()
Error Maybe String
m SomeException
e -> Maybe String
m Maybe String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> () -> ()
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 String -> Result -> Result
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 ResultStatus
r = case ResultStatus
r of
ResultStatus
Success -> ResultStatus
r
Pending Maybe Location
_ Maybe String
m -> Maybe String
m Maybe String -> ResultStatus -> ResultStatus
forall a b. NFData a => a -> b -> b
`deepseq` ResultStatus
r
Failure Maybe Location
_ FailureReason
m -> FailureReason
m FailureReason -> ResultStatus -> ResultStatus
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 = IO Result -> IO Result
safeEvaluate (IO Result -> IO Result)
-> (ProgressCallback -> IO Result) -> ProgressCallback -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
safeEvaluate :: IO Result -> IO Result
safeEvaluate :: IO Result -> IO Result
safeEvaluate IO Result
action = 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
<$> IO Result
action
case Either SomeException Result
r of
Left SomeException
e -> String -> ResultStatus -> Result
Result String
"" (ResultStatus -> Result) -> IO ResultStatus -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> IO ResultStatus
exceptionToResultStatus SomeException
e
Right Result
result -> Result -> IO Result
forall a. a -> IO a
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 <- IO ResultStatus -> IO (Either SomeException ResultStatus)
forall a. IO a -> IO (Either SomeException a)
safeTry (IO ResultStatus -> IO (Either SomeException ResultStatus))
-> IO ResultStatus -> IO (Either SomeException ResultStatus)
forall a b. (a -> b) -> a -> b
$ ResultStatus -> ResultStatus
forceResultStatus (ResultStatus -> ResultStatus)
-> IO ResultStatus -> IO ResultStatus
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 -> ResultStatus -> IO ResultStatus
forall a. a -> IO a
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 (IO ResultStatus -> IO ResultStatus)
-> (SomeException -> IO ResultStatus)
-> SomeException
-> IO ResultStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultStatus -> IO ResultStatus
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResultStatus -> IO ResultStatus)
-> (SomeException -> ResultStatus)
-> SomeException
-> IO ResultStatus
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 <- SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = ResultStatus
result
| Just HUnitFailure
hunit <- SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult Maybe String
forall a. Maybe a
Nothing HUnitFailure
hunit
| Bool
otherwise = 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
instance Example Result where
type Arg Result = ()
evaluateExample :: Result
-> Params
-> (ActionWith (Arg Result) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample 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 a -> Result
example Params
_params ActionWith (Arg (a -> Result)) -> IO ()
hook ProgressCallback
_callback = do
Result -> ((a -> IO ()) -> IO ()) -> (a -> IO Result) -> IO Result
forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success) (a -> IO ()) -> IO ()
ActionWith (Arg (a -> Result)) -> IO ()
hook (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)
instance Example Bool where
type Arg Bool = ()
evaluateExample :: Bool
-> Params
-> (ActionWith (Arg Bool) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample 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 a -> Bool
p Params
_params ActionWith (Arg (a -> Bool)) -> IO ()
hook ProgressCallback
_callback = do
Result -> ((a -> IO ()) -> IO ()) -> (a -> IO Result) -> IO Result
forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success) (a -> IO ()) -> IO ()
ActionWith (Arg (a -> Bool)) -> IO ()
hook (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)
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
"" (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 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 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 (String -> FailureReason) -> String -> FailureReason
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) -> String -> Maybe String
forall a. a -> Maybe a
Just (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y)
(Maybe String, Maybe String)
_ -> Maybe String
pre Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
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 -> Maybe Location
forall a. Maybe a
Nothing
Just SrcLoc
loc -> Location -> Maybe Location
forall a. a -> Maybe a
Just (Location -> Maybe Location) -> Location -> Maybe Location
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
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
_params ActionWith (Arg (a -> IO ())) -> IO ()
hook ProgressCallback
_ = ActionWith (Arg (a -> IO ())) -> IO ()
hook a -> IO ()
ActionWith (Arg (a -> IO ()))
e IO () -> IO Result -> IO Result
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success)