diff --git a/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -1,8 +1,8 @@ name: hspec-meta -version: 1.4.5 +version: 1.5.0 license: BSD3 license-file: LICENSE -copyright: (c) 2011-2012 Trystan Spangler, (c) 2011-2012 Simon Hengel, (c) 2011 Greg Weber +copyright: (c) 2011-2013 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple cabal-version: >= 1.8 @@ -47,12 +47,11 @@ build-depends: base == 4.* , setenv - , silently >= 1.1.1 , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 && < 0.4.0 , HUnit >= 1.2.5 - , QuickCheck >= 2.4.0.1 + , QuickCheck >= 2.5.1 , hspec-expectations == 0.3.0.* exposed-modules: Test.Hspec.Meta @@ -66,11 +65,11 @@ Test.Hspec.QuickCheck Test.Hspec.Util Test.Hspec.Compat - Test.Hspec.Pending Test.Hspec.Core.Type Test.Hspec.Config Test.Hspec.FailureReport Test.Hspec.Formatters.Internal + Test.Hspec.Timer -- hspec-discover executable hspec-meta-discover diff --git a/src/Test/Hspec.hs b/src/Test/Hspec.hs --- a/src/Test/Hspec.hs +++ b/src/Test/Hspec.hs @@ -21,7 +21,6 @@ -- * Types Spec , Example -, Pending -- * Setting expectations , module Test.Hspec.Expectations @@ -30,7 +29,9 @@ , describe , context , it +, example , pending +, pendingWith -- * Running a spec , hspec @@ -40,7 +41,6 @@ import Test.Hspec.Runner import Test.Hspec.HUnit () import Test.Hspec.Expectations -import Test.Hspec.Pending import qualified Test.Hspec.Core as Core -- $intro @@ -126,3 +126,18 @@ -- > absolute (-1) == 1 it :: Example v => String -> v -> Spec it label action = fromSpecList [Core.it label action] + +-- | This is a type restricted version of `id`. It can be used to get better +-- error messages on type mismatches. +-- +-- Compare e.g. +-- +-- > it "exposes some behavior" $ example $ do +-- > putStrLn +-- +-- with +-- +-- > it "exposes some behavior" $ do +-- > putStrLn +example :: Expectation -> Expectation +example = id diff --git a/src/Test/Hspec/Compat.hs b/src/Test/Hspec/Compat.hs --- a/src/Test/Hspec/Compat.hs +++ b/src/Test/Hspec/Compat.hs @@ -1,12 +1,60 @@ {-# LANGUAGE CPP #-} -module Test.Hspec.Compat where +module Test.Hspec.Compat ( + showType +, showFullType +, isUserInterrupt +, readMaybe +, module Data.IORef +#if !MIN_VERSION_base(4,6,0) +, modifyIORef' +#endif +) where import Data.Typeable (Typeable, typeOf, typeRepTyCon) +import qualified Test.QuickCheck as QC +import Text.Read +import Data.IORef #if MIN_VERSION_base(4,4,0) import Data.Typeable.Internal (tyConModule, tyConName) #endif +#if !MIN_VERSION_base(4,6,0) +import qualified Text.ParserCombinators.ReadP as P +import Prelude +#endif + +#if !MIN_VERSION_base(4,6,0) +-- |Strict version of 'modifyIORef' +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + let x' = f x + x' `seq` writeIORef ref x' + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a +#endif + showType :: Typeable a => a -> String showType a = let t = typeRepTyCon (typeOf a) in #if MIN_VERSION_base(4,4,0) @@ -23,3 +71,12 @@ #else show t #endif + +isUserInterrupt :: QC.Result -> Bool +isUserInterrupt r = case r of +#if MIN_VERSION_QuickCheck(2,6,0) + QC.Failure {QC.interrupted = x} -> x +#else + QC.Failure {QC.reason = "Exception: 'user interrupt'"} -> True +#endif + _ -> False diff --git a/src/Test/Hspec/Config.hs b/src/Test/Hspec/Config.hs --- a/src/Test/Hspec/Config.hs +++ b/src/Test/Hspec/Config.hs @@ -16,7 +16,6 @@ import Test.Hspec.Formatters import Test.Hspec.Util -import Test.Hspec.Core.Type (Params (..), defaultParams) -- for Monad (Either e) when base < 4.3 import Control.Monad.Trans.Error () @@ -32,17 +31,19 @@ -- A predicate that is used to filter the spec before it is run. Only examples -- that satisfy the predicate are run. , configFilterPredicate :: Maybe (Path -> Bool) -, configParams :: Params +, configQuickCheckArgs :: QC.Args , configColorMode :: ColorMode , configFormatter :: Formatter , configHtmlOutput :: Bool , configHandle :: Handle } +{-# DEPRECATED configVerbose "this has no effect anymore and will be removed with a future release" #-} -- deprecated since 1.5.0 + data ColorMode = ColorAuto | ColorNever | ColorAlway defaultConfig :: Config -defaultConfig = Config False False False False False Nothing defaultParams ColorAuto specdoc False stdout +defaultConfig = Config False False False False False Nothing QC.stdArgs {QC.chatty = False} ColorAuto specdoc False stdout formatters :: [(String, Formatter)] formatters = [ @@ -69,10 +70,7 @@ mp = configFilterPredicate c setQC_MaxSuccess :: String -> Result -> Result -setQC_MaxSuccess n x = (mapParams $ \p -> p {paramsQuickCheckArgs = (paramsQuickCheckArgs p) {QC.maxSuccess = read n}}) <$> x - where - mapParams :: (Params -> Params) -> Config -> Config - mapParams f c = c {configParams = f (configParams c)} +setQC_MaxSuccess n x = (\c -> c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.maxSuccess = read n}}) <$> x addLineBreaks :: String -> [String] addLineBreaks = lineBreaksAt 44 @@ -80,14 +78,13 @@ options :: [OptDescr (Result -> Result)] options = [ Option [] ["help"] (NoArg (const $ Left Help)) (h "display this help and exit") - , Option "v" ["verbose"] (NoArg setVerbose) (h "do not suppress output to stdout when evaluating examples") , Option "m" ["match"] (ReqArg setFilter "PATTERN") (h "only run examples that match given PATTERN") , Option [] ["color"] (OptArg setColor "WHEN") (h "colorize the output; WHEN defaults to `always' or can be `never' or `auto'") , Option "f" ["format"] (ReqArg setFormatter "FORMATTER") formatHelp , Option "a" ["qc-max-success"] (ReqArg setQC_MaxSuccess "N") (h "maximum number of successful tests before a QuickCheck property succeeds") , Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) (h "include used CPU time in summary") , Option [] ["dry-run"] (NoArg setDryRun) (h "pretend that everything passed; don't verify anything") - , Option [] ["fast-fail"] (NoArg setFastFail) (h "stop after first failure") + , Option [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") ] where h = unlines . addLineBreaks @@ -95,7 +92,6 @@ setFilter :: String -> Result -> Result setFilter pattern x = configAddFilter (filterPredicate pattern) <$> x - setVerbose x = x >>= \c -> return c {configVerbose = True} setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True} setDryRun x = x >>= \c -> return c {configDryRun = True} setFastFail x = x >>= \c -> return c {configFastFail = True} @@ -123,6 +119,9 @@ -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future , Option [] ["html"] (NoArg setHtml) "produce HTML output" + + -- now a noop + , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" ] where setReRun :: Result -> Result diff --git a/src/Test/Hspec/Core.hs b/src/Test/Hspec/Core.hs --- a/src/Test/Hspec/Core.hs +++ b/src/Test/Hspec/Core.hs @@ -8,6 +8,7 @@ -- * A type class for examples Example (..) , Params (..) +, Progress , Result (..) -- * A writer monad for constructing specs @@ -27,15 +28,12 @@ , hspecX , hHspec , hspec -, Pending -, pending ) where import Control.Applicative import System.IO (Handle) import Test.Hspec.Core.Type hiding (Spec) -import qualified Test.Hspec.Pending as Pending import qualified Test.Hspec.Runner as Runner import Test.Hspec.Runner (Summary(..), Config(..), defaultConfig) @@ -63,10 +61,3 @@ {-# DEPRECATED Specs "use `[SpecTree]` instead" #-} -- since 1.4.0 type Specs = [SpecTree] - -{-# DEPRECATED pending "use `Test.Hspec.pending` instead" #-} -- since 1.4.0 -pending :: String -> Pending -pending = Pending.pending - -{-# DEPRECATED Pending "use `Test.Hspec.Pending` instead" #-} -- since 1.4.0 -type Pending = Pending.Pending diff --git a/src/Test/Hspec/Core/Type.hs b/src/Test/Hspec/Core/Type.hs --- a/src/Test/Hspec/Core/Type.hs +++ b/src/Test/Hspec/Core/Type.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Type ( Spec , SpecM (..) @@ -7,24 +8,33 @@ , SpecTree (..) , Example (..) , Result (..) - , Params (..) -, defaultParams +, Progress , describe , it + +, pending +, pendingWith ) where import qualified Control.Exception as E import Control.Applicative import Control.Monad (when) import Control.Monad.Trans.Writer (Writer, execWriter, tell) +import Data.Typeable (Typeable) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) import Test.Hspec.Util import Test.Hspec.Expectations import Test.HUnit.Lang (HUnitFailure(..)) import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.State as QC +import qualified Test.QuickCheck.Property as QCP +import Test.Hspec.Compat (isUserInterrupt) + type Spec = SpecM () -- | A writer monad for `SpecTree` forests. @@ -41,15 +51,17 @@ -- | The result of running an example. data Result = Success | Pending (Maybe String) | Fail String - deriving (Eq, Show) + deriving (Eq, Show, Read, Typeable) +instance E.Exception Result + +type Progress = (Int, Int) + data Params = Params { paramsQuickCheckArgs :: QC.Args +, paramsReportProgress :: Progress -> IO () } -defaultParams :: Params -defaultParams = Params QC.stdArgs - -- | Internal representation of a spec. data SpecTree = SpecGroup String [SpecTree] @@ -57,11 +69,19 @@ -- | The @describe@ function combines a list of specs into a larger spec. describe :: String -> [SpecTree] -> SpecTree -describe = SpecGroup +describe s = SpecGroup msg + where + msg + | null s = "(no description given)" + | otherwise = s -- | Create a spec item. it :: Example a => String -> a -> SpecTree -it s e = SpecItem s (`evaluateExample` e) +it s e = SpecItem msg (`evaluateExample` e) + where + msg + | null s = "(unspecified behavior)" + | otherwise = s -- | A type class for examples. class Example a where @@ -71,25 +91,80 @@ evaluateExample _ b = if b then return Success else return (Fail "") instance Example Expectation where - evaluateExample _ action = (action >> return Success) `E.catch` \(HUnitFailure err) -> return (Fail err) + evaluateExample _ action = (action >> return Success) `E.catches` [ + E.Handler (\(HUnitFailure err) -> (return . Fail) err) + , E.Handler (return :: Result -> IO Result) + ] instance Example Result where evaluateExample _ r = return r instance Example QC.Property where evaluateExample c p = do - r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) p + r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) (QCP.callback progressCallback p) when (isUserInterrupt r) $ do E.throwIO E.UserInterrupt return $ case r of QC.Success {} -> Success - f@(QC.Failure {}) -> Fail (QC.output f) + QC.Failure {QC.output = m} -> fromMaybe (Fail $ sanitizeFailureMessage m) (parsePending m) QC.GaveUp {QC.numTests = n} -> Fail ("Gave up after " ++ quantify n "test" ) QC.NoExpectedFailure {} -> Fail ("No expected failure") where - isUserInterrupt :: QC.Result -> Bool - isUserInterrupt r = case r of - QC.Failure {QC.reason = "Exception: 'user interrupt'"} -> True - _ -> False + progressCallback = QCP.PostTest QCP.NotCounterexample $ + \st _ -> paramsReportProgress c (QC.numSuccessTests st, QC.maxSuccessTests st) + + sanitizeFailureMessage :: String -> String + sanitizeFailureMessage = strip . addFalsifiable . stripFailed + + 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 + | prefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m + | otherwise = Nothing + where + n = length prefix + prefix = "*** Failed! Exception: '" + +instance QC.Testable Expectation where + property = propertyIO + exhaustive _ = True + +propertyIO :: Expectation -> QC.Property +propertyIO action = QCP.morallyDubiousIOProperty $ do + (action >> return succeeded) `E.catch` \(HUnitFailure err) -> return (failed err) + where + succeeded = QC.property QCP.succeeded + failed err = QC.property QCP.failed {QCP.reason = err} + +-- | Specifies a pending example. +-- +-- If you want to textually specify a behavior but do not have an example yet, +-- use this: +-- +-- > describe "fancyFormatter" $ do +-- > it "can format text in a way that everyone likes" $ +-- > pending +pending :: Expectation +pending = E.throwIO (Pending Nothing) + +-- | Specifies a pending example with a reason for why it's pending. +-- +-- > describe "fancyFormatter" $ do +-- > it "can format text in a way that everyone likes" $ +-- > pendingWith "waiting for clarification from the designers" +pendingWith :: String -> Expectation +pendingWith = E.throwIO . Pending . Just diff --git a/src/Test/Hspec/Formatters.hs b/src/Test/Hspec/Formatters.hs --- a/src/Test/Hspec/Formatters.hs +++ b/src/Test/Hspec/Formatters.hs @@ -54,6 +54,7 @@ import Control.Monad (unless, forM_) import Control.Applicative import qualified Control.Exception as E +import System.IO (hPutStr) -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. @@ -90,6 +91,7 @@ headerFormatter = return () , exampleGroupStarted = \_ _ _ -> return () , exampleGroupDone = return () +, exampleProgress = \_ _ _ -> return () , exampleSucceeded = \_ -> return () , exampleFailed = \_ _ -> return () , examplePending = \_ _ -> return () @@ -114,6 +116,9 @@ , exampleGroupDone = do newParagraph + +, exampleProgress = \h _ (current, total) -> do + hPutStr h $ "(" ++ show current ++ "/" ++ show total ++ ")\r" , exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do writeLine $ indentationFor nesting ++ "- " ++ requirement diff --git a/src/Test/Hspec/Formatters/Internal.hs b/src/Test/Hspec/Formatters/Internal.hs --- a/src/Test/Hspec/Formatters/Internal.hs +++ b/src/Test/Hspec/Formatters/Internal.hs @@ -43,10 +43,11 @@ import Control.Monad.Trans.State hiding (gets, modify) import qualified Control.Monad.IO.Class as IOClass import qualified System.CPUTime as CPUTime -import Data.IORef import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Test.Hspec.Util (Path) +import Test.Hspec.Compat +import Test.Hspec.Core.Type (Progress) -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a @@ -56,7 +57,7 @@ -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do - get >>= IOClass.liftIO . (`modifyIORef` f) + get >>= IOClass.liftIO . (`modifyIORef'` f) -- | A lifted version of `IOClass.liftIO` -- @@ -146,6 +147,11 @@ , exampleGroupStarted :: Int -> [String] -> String -> FormatM () , exampleGroupDone :: FormatM () + +-- | used to notify the progress of the currently evaluated example +-- +-- NOTE: This is only called when interactive/color mode. +, exampleProgress :: Handle -> Path -> Progress -> IO () -- | evaluated after each successful example , exampleSucceeded :: Path -> FormatM () diff --git a/src/Test/Hspec/Monadic.hs b/src/Test/Hspec/Monadic.hs --- a/src/Test/Hspec/Monadic.hs +++ b/src/Test/Hspec/Monadic.hs @@ -3,7 +3,6 @@ -- * Types Spec , Example -, Pending -- * Defining a spec , describe diff --git a/src/Test/Hspec/Pending.hs b/src/Test/Hspec/Pending.hs deleted file mode 100644 --- a/src/Test/Hspec/Pending.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Test.Hspec.Pending where - -import qualified Test.Hspec.Core.Type as Core -import Test.Hspec.Core.Type (Example(..)) - --- NOTE: This is defined in a separate packages, because it clashes with --- Result.Pending. - --- | A pending example. -newtype Pending = Pending (Maybe String) - -instance Example Pending where - evaluateExample c (Pending reason) = evaluateExample c (Core.Pending reason) - -instance Example (String -> Pending) where - evaluateExample c _ = evaluateExample c (Pending Nothing) - --- | A pending example. --- --- If you want to textually specify a behavior but do not have an example yet, --- use this: --- --- > describe "fancyFormatter" $ do --- > it "can format text in a way that everyone likes" $ --- > pending --- --- You can give an optional reason for why it's pending: --- --- > describe "fancyFormatter" $ do --- > it "can format text in a way that everyone likes" $ --- > pending "waiting for clarification from the designers" -pending :: String -> Pending -pending = Pending . Just diff --git a/src/Test/Hspec/Runner.hs b/src/Test/Hspec/Runner.hs --- a/src/Test/Hspec/Runner.hs +++ b/src/Test/Hspec/Runner.hs @@ -21,7 +21,6 @@ import System.IO import System.Environment import System.Exit -import System.IO.Silently (silence) import Test.Hspec.Util (Path, safeEvaluate) import Test.Hspec.Core.Type @@ -29,6 +28,8 @@ import Test.Hspec.Formatters import Test.Hspec.Formatters.Internal import Test.Hspec.FailureReport +import System.Console.ANSI (hHideCursor, hShowCursor) +import Test.Hspec.Timer -- | Filter specs by given predicate. -- @@ -47,8 +48,8 @@ xs -> Just (SpecGroup group xs) -- | Evaluate all examples of a given spec and produce a report. -runFormatter :: Config -> Formatter -> [SpecTree] -> FormatM () -runFormatter c formatter specs = headerFormatter formatter >> zip [0..] specs `each` go [] +runFormatter :: Bool -> Config -> Formatter -> [SpecTree] -> FormatM () +runFormatter useColor c formatter specs = headerFormatter formatter >> zip [0..] specs `each` go [] where -- like forM_, but respects --fast-fail each :: [a] -> (a -> FormatM ()) -> FormatM () @@ -59,13 +60,9 @@ unless (configFastFail c && fails /= 0) $ do xs `each` f - silence_ - | configVerbose c = id - | otherwise = silence - eval | configDryRun c = \_ -> return (Right Success) - | otherwise = liftIO . safeEvaluate . silence_ + | otherwise = liftIO . safeEvaluate go :: [String] -> (Int, SpecTree) -> FormatM () go rGroups (n, SpecGroup group xs) = do @@ -73,7 +70,8 @@ zip [0..] xs `each` go (group : rGroups) exampleGroupDone formatter go rGroups (_, SpecItem requirement example) = do - result <- eval (example $ configParams c) + progressHandler <- mkProgressHandler + result <- eval (example $ Params (configQuickCheckArgs c) progressHandler) case result of Right Success -> do increaseSuccessCount @@ -92,6 +90,14 @@ addFailMessage path err exampleFailed formatter path err + mkProgressHandler + | useColor = do + timer <- liftIO $ newTimer 0.05 + return $ \p -> do + f <- timer + when f $ do + exampleProgress formatter (configHandle c) path p + | otherwise = return . const $ return () -- | Run given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails. @@ -123,9 +129,11 @@ h = configHandle c useColor <- doesUseColor h c + when useColor (hHideCursor h) runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) h $ do - runFormatter c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) `finally_` + runFormatter useColor c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) `finally_` do failedFormatter formatter + liftIO $ when useColor (hShowCursor h) footerFormatter formatter diff --git a/src/Test/Hspec/Timer.hs b/src/Test/Hspec/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Timer.hs @@ -0,0 +1,14 @@ +module Test.Hspec.Timer where + +import Data.IORef +import Data.Time.Clock.POSIX + +newTimer :: POSIXTime -> IO (IO Bool) +newTimer delay = do + ref <- getPOSIXTime >>= newIORef + return $ do + t0 <- readIORef ref + t1 <- getPOSIXTime + if delay < t1 - t0 + then writeIORef ref t1 >> return True + else return False diff --git a/src/Test/Hspec/Util.hs b/src/Test/Hspec/Util.hs --- a/src/Test/Hspec/Util.hs +++ b/src/Test/Hspec/Util.hs @@ -7,6 +7,7 @@ , formatRequirement , readMaybe , getEnv +, strip ) where import Data.List @@ -94,3 +95,6 @@ if length r <= n then go (r, ys) else s : go (y, ys) + +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse