diff --git a/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -1,5 +1,5 @@ name: hspec-meta -version: 1.5.1 +version: 1.5.2 license: BSD3 license-file: LICENSE copyright: (c) 2011-2013 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber @@ -46,10 +46,12 @@ src build-depends: base == 4.* + , random == 1.0.* , setenv , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 && < 0.4.0 + , deepseq , HUnit >= 1.2.5 , QuickCheck >= 2.5.1 , quickcheck-io 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 @@ -4,6 +4,10 @@ , defaultConfig , getConfig , configAddFilter +, configSetSeed + +-- exported to silence warnings +, Arg (..) ) where import Control.Monad (unless) @@ -69,37 +73,58 @@ p = maybe p1 (\p0 path -> p0 path || p1 path) mp mp = configFilterPredicate c -setQC_MaxSuccess :: String -> Result -> Result -setQC_MaxSuccess n x = (\c -> c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.maxSuccess = read n}}) <$> x +setMaxSuccess :: Int -> Config -> Config +setMaxSuccess n c = c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.maxSuccess = n}} +configSetSeed :: Integer -> Config -> Config +configSetSeed n c = c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.replay = Just (stdGenFromInteger n, 0)}} + + +data Arg a = Arg { + argumentName :: String +, argumentParser :: String -> Maybe a +, argumentSetter :: a -> Config -> Config +} + +mkOption :: [Char] -> [Char] -> Arg a -> String -> OptDescr (Result -> Result) +mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help + where + arg :: String -> Result -> Result + arg input x = x >>= \c -> case parser input of + Just n -> Right (setter n c) + Nothing -> Left (InvalidArgument name input) + addLineBreaks :: String -> [String] addLineBreaks = lineBreaksAt 44 options :: [OptDescr (Result -> Result)] options = [ - Option [] ["help"] (NoArg (const $ Left Help)) (h "display this help and exit") - , 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 [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") + Option [] ["help"] (NoArg (const $ Left Help)) (h "display this help and exit") + , mkOption "m" "match" (Arg "PATTERN" return setFilter) (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'") + , mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) formatHelp + , mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) (h "maximum number of successful tests before a QuickCheck property succeeds") + , mkOption [] "seed" (Arg "N" readMaybe configSetSeed) (h "used seed for QuickCheck properties") + , 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 [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") ] where h = unlines . addLineBreaks - setFilter :: String -> Result -> Result - setFilter pattern x = configAddFilter (filterPredicate pattern) <$> x + setFilter :: String -> Config -> Config + setFilter = configAddFilter . filterPredicate + readFormatter :: String -> Maybe Formatter + readFormatter = (`lookup` formatters) + + setFormatter :: Formatter -> Config -> Config + setFormatter f c = c {configFormatter = f} + setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True} setDryRun x = x >>= \c -> return c {configDryRun = True} setFastFail x = x >>= \c -> return c {configFastFail = True} - setFormatter name x = x >>= \c -> case lookup name formatters of - Nothing -> Left (InvalidArgument "format" name) - Just f -> return c {configFormatter = f} - setColor mValue x = x >>= \c -> parseColor mValue >>= \v -> return c {configColorMode = v} where parseColor s = case s of @@ -114,7 +139,7 @@ Option "r" ["re-run"] (NoArg setReRun) "only re-run examples that previously failed" -- for compatibility with test-framework - , Option "" ["maximum-generated-tests"] (ReqArg setQC_MaxSuccess "NUMBER") "how many automated tests something like QuickCheck should try, by default" + , mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future 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,5 +1,4 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Type ( Spec , SpecM (..) @@ -13,6 +12,7 @@ , describe , it +, forceResult , pending , pendingWith @@ -35,6 +35,7 @@ import qualified Test.QuickCheck.IO () import Test.Hspec.Compat (isUserInterrupt) +import Control.DeepSeq (deepseq) type Spec = SpecM () @@ -54,6 +55,12 @@ -- | The result of running an example. data Result = Success | Pending (Maybe String) | Fail String deriving (Eq, Show, Read, Typeable) + +forceResult :: Result -> Result +forceResult r = case r of + Success -> r `seq` r + Pending m -> r `seq` m `deepseq` r + Fail m -> r `seq` m `deepseq` r instance E.Exception Result diff --git a/src/Test/Hspec/FailureReport.hs b/src/Test/Hspec/FailureReport.hs --- a/src/Test/Hspec/FailureReport.hs +++ b/src/Test/Hspec/FailureReport.hs @@ -1,16 +1,21 @@ -module Test.Hspec.FailureReport where +module Test.Hspec.FailureReport ( + writeFailureReport +, readFailureReport +) where import System.IO import System.SetEnv +import qualified Test.QuickCheck as QC import Test.Hspec.Config -import Test.Hspec.Util (safeEvaluate, readMaybe, getEnv) +import Test.Hspec.Util (Path, safeTry, readMaybe, getEnv) -writeFailureReport :: String -> IO () +type Seed = Integer + +writeFailureReport :: (Seed, [Path]) -> IO () writeFailureReport x = do -- on Windows this can throw an exception when the input is too large, hence - -- we use `safeEvaluate` here - r <- safeEvaluate (setEnv "HSPEC_FAILURES" x) - either onError return r + -- we use `safeTry` here + safeTry (setEnv "HSPEC_FAILURES" $ show x) >>= either onError return where onError err = do hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") @@ -22,5 +27,12 @@ Nothing -> do hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--re-run' is ignored!" return c - Just xs -> do - return $ configAddFilter (`elem` xs) c + Just (seed, xs) -> do + (return . setSeed seed . configAddFilter (`elem` xs)) c + +setSeed :: Seed -> Config -> Config +setSeed seed c + | hasSeed = c + | otherwise = configSetSeed seed c + where + hasSeed = maybe False (const True) (QC.replay $ configQuickCheckArgs c) 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 @@ -29,6 +29,7 @@ , FailureRecord (..) , getFailMessages +, usedSeed , getCPUTime , getRealTime @@ -72,6 +73,7 @@ , FailureRecord (..) , getFailMessages + , usedSeed , getCPUTime , getRealTime @@ -161,6 +163,8 @@ forM_ (zip [1..] failures) $ \x -> do formatFailure x + writeLine "" + write "Randomized with seed " >> usedSeed >>= writeLine . show writeLine "" where formatFailure :: (Int, FailureRecord) -> FormatM () 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 @@ -12,6 +12,7 @@ , FailureRecord (..) , getFailMessages +, usedSeed , getCPUTime , getRealTime @@ -76,10 +77,15 @@ , pendingCount :: Int , failCount :: Int , failMessages :: [FailureRecord] +, stateUsedSeed :: Integer , cpuStartTime :: Maybe Integer , startTime :: POSIXTime } +-- | The random seed that is used for QuickCheck. +usedSeed :: FormatM Integer +usedSeed = gets stateUsedSeed + -- | The total number of examples encountered so far. totalCount :: FormatterState -> Int totalCount s = successCount s + pendingCount s + failCount s @@ -89,11 +95,11 @@ newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a) deriving (Functor, Applicative, Monad) -runFormatM :: Bool -> Bool -> Bool -> Handle -> FormatM a -> IO a -runFormatM useColor produceHTML_ printCpuTime handle (FormatM action) = do +runFormatM :: Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a +runFormatM useColor produceHTML_ printCpuTime seed handle (FormatM action) = do time <- getPOSIXTime cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing - st <- newIORef (FormatterState handle useColor produceHTML_ False 0 0 0 [] cpuTime time) + st <- newIORef (FormatterState handle useColor produceHTML_ False 0 0 0 [] seed cpuTime time) evalStateT action st -- | Increase the counter for successful examples 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,14 +21,18 @@ import System.IO import System.Environment import System.Exit +import qualified Control.Exception as E -import Test.Hspec.Util (Path, safeEvaluate) +import System.Console.ANSI (hHideCursor, hShowCursor) +import qualified Test.QuickCheck as QC +import System.Random (newStdGen) + +import Test.Hspec.Util import Test.Hspec.Core.Type import Test.Hspec.Config 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. @@ -60,9 +64,10 @@ unless (configFastFail c && fails /= 0) $ do xs `each` f + eval :: IO Result -> FormatM (Either E.SomeException Result) eval | configDryRun c = \_ -> return (Right Success) - | otherwise = liftIO . safeEvaluate + | otherwise = liftIO . safeTry . fmap forceResult go :: [String] -> (Int, SpecTree) -> FormatM () go rGroups (n, SpecGroup group xs) = do @@ -110,6 +115,25 @@ r <- hspecWith c spec unless (summaryFailures r == 0) exitFailure +handleReRun :: Config -> IO Config +handleReRun c = do + if configReRun c + then do + readFailureReport c + else do + return c + +-- Add a StdGen to configQuickCheckArgs if there is none. That way the same +-- seed is used for all properties. This helps with --seed and --re-run. +ensureStdGen :: Config -> IO Config +ensureStdGen c = case QC.replay qcArgs of + Nothing -> do + stdGen <- newStdGen + return c {configQuickCheckArgs = qcArgs {QC.replay = Just (stdGen, 0)}} + _ -> return c + where + qcArgs = configQuickCheckArgs c + -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. -- @@ -119,30 +143,32 @@ hspecWith :: Config -> Spec -> IO Summary hspecWith c_ spec = do -- read failure report on --re-run - c <- if configReRun c_ - then do - readFailureReport c_ - else do - return c_ + c <- handleReRun c_ >>= ensureStdGen let formatter = configFormatter c h = configHandle c + seed = (stdGenToInteger . fst . fromJust . QC.replay . configQuickCheckArgs) c useColor <- doesUseColor h c - when useColor (hHideCursor h) - runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) h $ do - runFormatter useColor c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) `finally_` do - failedFormatter formatter - liftIO $ when useColor (hShowCursor h) - footerFormatter formatter + withHiddenCursor useColor h $ + runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do + runFormatter useColor c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) `finally_` do + failedFormatter formatter - -- dump failure report - xs <- map failureRecordPath <$> getFailMessages - liftIO $ writeFailureReport (show xs) + footerFormatter formatter - Summary <$> getTotalCount <*> getFailCount + -- dump failure report + xs <- map failureRecordPath <$> getFailMessages + liftIO $ writeFailureReport (seed, xs) + + Summary <$> getTotalCount <*> getFailCount where + withHiddenCursor :: Bool -> Handle -> IO a -> IO a + withHiddenCursor useColor h + | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) + | otherwise = id + doesUseColor :: Handle -> Config -> IO Bool doesUseColor h c = case configColorMode c of ColorAuto -> hIsTerminalDevice h 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 @@ -1,21 +1,25 @@ module Test.Hspec.Util ( quantify , lineBreaksAt -, safeEvaluate +, safeTry , Path , filterPredicate , formatRequirement , readMaybe , getEnv , strip +, stdGenToInteger +, stdGenFromInteger ) where +import Data.Int (Int32) import Data.List import Data.Maybe import Data.Char (isSpace) import Control.Applicative import qualified Control.Exception as E import qualified System.Environment as Environment +import System.Random (StdGen) -- | Create a more readable display of a quantity of something. -- @@ -33,13 +37,13 @@ quantify 1 s = "1 " ++ s quantify n s = show n ++ " " ++ s ++ "s" -safeEvaluate :: IO a -> IO (Either E.SomeException a) -safeEvaluate action = (Right <$> (action >>= E.evaluate)) `E.catches` [ +safeTry :: IO a -> IO (Either E.SomeException a) +safeTry action = (Right <$> (action >>= E.evaluate)) `E.catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT -- (ctrl-c). All AsyncExceptions are re-thrown (not just UserInterrupt) -- because all of them indicate severe conditions and should not occur during -- normal operation. - E.Handler $ \e -> E.throw (e :: E.AsyncException) + E.Handler $ \e -> E.throwIO (e :: E.AsyncException) , E.Handler $ \e -> (return . Left) (e :: E.SomeException) ] @@ -79,7 +83,7 @@ readMaybe = fmap fst . listToMaybe . reads getEnv :: String -> IO (Maybe String) -getEnv key = either (const Nothing) Just <$> safeEvaluate (Environment.getEnv key) +getEnv key = either (const Nothing) Just <$> safeTry (Environment.getEnv key) -- ensure that lines are not longer then given `n`, insert line beraks at word -- boundaries @@ -98,3 +102,17 @@ strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +-- | Converts a 'StdGen' into an 'Integer'. Assumes +-- StdGens to be encoded as two positive 'Int32's and +-- $show (StdGen a b) = show a ++ " " ++ show b$. +stdGenToInteger :: StdGen -> Integer +stdGenToInteger stdGen = + let [a, b] = map read . words $ show stdGen + in b * fromIntegral (maxBound :: Int32) + a + +-- | Inverse of 'stdGenToInteger'. +stdGenFromInteger :: Integer -> StdGen +stdGenFromInteger n = + let (a, b) = quotRem n (fromIntegral (maxBound :: Int32)) + in read (show b ++ " " ++ show a)