module Test.Hspec.Core.Example (
Example (..)
, Params (..)
, ActionWith
, Progress
, ProgressCallback
, Result (..)
) where
import Data.Maybe (fromMaybe)
import Data.List (isPrefixOf)
import Test.HUnit.Lang (HUnitFailure(..))
import qualified Control.Exception as E
import Data.Typeable (Typeable)
import qualified Test.QuickCheck as QC
import Test.Hspec.Expectations (Expectation)
import qualified Test.QuickCheck.State as QC
import qualified Test.QuickCheck.Property as QCP
import qualified Test.QuickCheck.IO ()
import Test.Hspec.Core.QuickCheckUtil
import Test.Hspec.Core.Util
import Test.Hspec.Compat
class Example e where
type Arg e
evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result
data Params = Params {
paramsQuickCheckArgs :: QC.Args
, paramsSmallCheckDepth :: Int
} deriving (Show)
type Progress = (Int, Int)
type ProgressCallback = Progress -> IO ()
type ActionWith a = a -> IO ()
data Result = Success | Pending (Maybe String) | Fail String
deriving (Eq, Show, Read, Typeable)
instance E.Exception Result
instance Example Bool where
type Arg Bool = ()
evaluateExample b _ _ _ = if b then return Success else return (Fail "")
instance Example Expectation where
type Arg Expectation = ()
evaluateExample e = evaluateExample (\() -> e)
instance Example (a -> Expectation) where
type Arg (a -> Expectation) = a
evaluateExample e _ action _ = (action e >> return Success) `E.catches` [
E.Handler (\(HUnitFailure err) -> return (Fail err))
, E.Handler (return :: Result -> IO Result)
]
instance Example Result where
type Arg Result = ()
evaluateExample r _ _ _ = return r
instance Example QC.Property where
type Arg QC.Property = ()
evaluateExample e = evaluateExample (\() -> e)
instance Example (a -> QC.Property) where
type Arg (a -> QC.Property) = a
evaluateExample p c action progressCallback = do
r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p)
return $
case r of
QC.Success {} -> Success
QC.Failure {QC.output = m} -> fromMaybe (Fail $ sanitizeFailureMessage r) (parsePending m)
QC.GaveUp {QC.numTests = n} -> Fail ("Gave up after " ++ pluralize n "test" )
QC.NoExpectedFailure {} -> Fail ("No expected failure")
where
qcProgressCallback = QCP.PostTest QCP.NotCounterexample $
\st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st)
sanitizeFailureMessage :: QC.Result -> String
sanitizeFailureMessage r = let m = QC.output r in strip $
#if MIN_VERSION_QuickCheck(2,7,0)
case QC.theException r of
Just e -> let numbers = formatNumbers r in
"uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of
x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs
_ -> m
Nothing ->
#endif
(addFalsifiable . stripFailed) m
addFalsifiable :: String -> String
addFalsifiable m
| "(after " `isPrefixOf` m = "Falsifiable " ++ m
| otherwise = m
stripFailed :: String -> String
stripFailed m
| prefix `isPrefixOf` m = drop n m
| otherwise = m
where
prefix = "*** Failed! "
n = length prefix
parsePending :: String -> Maybe Result
parsePending m
| exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m
| otherwise = Nothing
where
n = length exceptionPrefix
exceptionPrefix = "*** Failed! Exception: '"