hspec-meta 1.5.4 → 1.6.0
raw patch · 14 files changed
+501/−274 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Test.Hspec.Meta: parallel :: Spec -> Spec
- Test.Hspec.Meta: it :: Example v => String -> v -> Spec
+ Test.Hspec.Meta: it :: Example a => String -> a -> Spec
Files
- LICENSE +18/−7
- hspec-discover/src/Config.hs +33/−0
- hspec-discover/src/Run.hs +34/−19
- hspec-meta.cabal +6/−4
- src/Test/Hspec.hs +11/−1
- src/Test/Hspec/Config.hs +51/−127
- src/Test/Hspec/Core/Type.hs +4/−4
- src/Test/Hspec/FailureReport.hs +13/−18
- src/Test/Hspec/Formatters.hs +19/−0
- src/Test/Hspec/Formatters/Internal.hs +5/−14
- src/Test/Hspec/HUnit.hs +2/−2
- src/Test/Hspec/Options.hs +136/−0
- src/Test/Hspec/Runner.hs +45/−78
- src/Test/Hspec/Runner/Eval.hs +124/−0
LICENSE view
@@ -1,10 +1,21 @@--Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-+Copyright (c) 2011-2013 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net>+Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info> -Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.-Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.-The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission.+Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions: -THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ hspec-discover/src/Config.hs view
@@ -0,0 +1,33 @@+module Config (+ Config (..)+, defaultConfig+, parseConfig+, usage+) where++import System.Console.GetOpt++data Config = Config {+ configNested :: Bool+, configFormatter :: Maybe String+} deriving (Eq, Show)++defaultConfig :: Config+defaultConfig = Config False Nothing++options :: [OptDescr (Config -> Config)]+options = [+ Option [] ["nested"] (NoArg $ \c -> c {configNested = True}) ""+ , Option [] ["formatter"] (ReqArg (\s c -> c {configFormatter = Just s}) "FORMATTER") ""+ ]++usage :: String -> String+usage prog = "\nUsage: " ++ prog ++ " SRC CUR DST [--nested] [--formatter=FORMATTER]\n"++parseConfig :: String -> [String] -> Either String Config+parseConfig prog args = case getOpt Permute options args of+ (opts, [], []) -> Right (foldl (flip id) defaultConfig opts)+ (_, _, err:_) -> formatError err+ (_, arg:_, _) -> formatError ("unexpected argument `" ++ arg ++ "'\n")+ where+ formatError err = Left (prog ++ ": " ++ err ++ usage prog)
hspec-discover/src/Run.hs view
@@ -14,39 +14,54 @@ import System.Directory import System.FilePath hiding (combine) +import Config+ instance IsString ShowS where fromString = showString run :: [String] -> IO ()-run args_ = case args_ of- src : _ : dst : args -> do- nested <- case args of- [] -> return False- ["--nested"] -> return True- _ -> exit- specs <- findSpecs src- writeFile dst (mkSpecModule src nested specs)- _ -> exit- where- exit = do- name <- getProgName- hPutStrLn stderr ("usage: " ++ name ++ " SRC CUR DST [--nested]")+run args_ = do+ name <- getProgName+ case args_ of+ src : _ : dst : args -> case parseConfig name args of+ Left err -> do+ hPutStrLn stderr err+ exitFailure+ Right c -> do+ specs <- findSpecs src+ writeFile dst (mkSpecModule src c specs)+ _ -> do+ hPutStrLn stderr (usage name) exitFailure -mkSpecModule :: FilePath -> Bool -> [SpecNode] -> String-mkSpecModule src nested nodes =+mkSpecModule :: FilePath -> Config -> [SpecNode] -> String+mkSpecModule src c nodes = ( "{-# LINE 1 " . shows src . " #-}" . showString "module Main where\n"- . showString "import Test.Hspec.Meta\n" . importList nodes- . showString "main :: IO ()\n"- . showString "main = hspec $ "+ . maybe driver (driverWithFormatter (null nodes)) (configFormatter c) . format nodes ) "\n" where format- | nested = formatSpecsNested+ | configNested c = formatSpecsNested | otherwise = formatSpecs++ driver =+ showString "import Test.Hspec.Meta\n"+ . showString "main :: IO ()\n"+ . showString "main = hspec $ "++driverWithFormatter :: Bool -> String -> ShowS+driverWithFormatter isEmpty f =+ (if isEmpty then id else "import Test.Hspec\n")+ . showString "import Test.Hspec.Runner\n"+ . showString "import qualified " . showString (moduleName f) . showString "\n"+ . showString "main :: IO ()\n"+ . showString "main = hspecWithFormatter " . showString f . showString " $ "++moduleName :: String -> String+moduleName = reverse . dropWhile (== '.') . dropWhile (/= '.') . reverse -- | Generate imports for a list of specs. importList :: [SpecNode] -> ShowS
hspec-meta.cabal view
@@ -1,6 +1,6 @@ name: hspec-meta-version: 1.5.4-license: BSD3+version: 1.6.0+license: MIT license-file: LICENSE copyright: (c) 2011-2013 Simon Hengel, (c) 2011-2012 Trystan Spangler,@@ -11,9 +11,8 @@ category: Testing stability: experimental bug-reports: https://github.com/hspec/hspec/issues-homepage: http://hspec.github.com/+homepage: http://hspec.github.io/ synopsis: A version of Hspec which is used to test Hspec itself- description: A stable version of Hspec which is used to test the in-development version of Hspec. @@ -72,7 +71,9 @@ Test.Hspec.Compat Test.Hspec.Core.Type Test.Hspec.Config+ Test.Hspec.Options Test.Hspec.FailureReport+ Test.Hspec.Runner.Eval Test.Hspec.Formatters.Internal Test.Hspec.Timer @@ -86,6 +87,7 @@ Main.hs other-modules: Run+ Config build-depends: base == 4.* , filepath
src/Test/Hspec.hs view
@@ -32,6 +32,7 @@ , example , pending , pendingWith+, parallel -- * Running a spec , hspec@@ -124,7 +125,7 @@ -- > describe "absolute" $ do -- > it "returns a positive number when given a negative number" $ -- > absolute (-1) == 1-it :: Example v => String -> v -> Spec+it :: Example a => String -> a -> Spec it label action = fromSpecList [Core.it label action] -- | This is a type restricted version of `id`. It can be used to get better@@ -141,3 +142,12 @@ -- > putStrLn example :: Expectation -> Expectation example = id++-- | Run examples of given spec in parallel.+parallel :: Spec -> Spec+parallel = fromSpecList . map go . runSpecM+ where+ go :: SpecTree -> SpecTree+ go spec = case spec of+ SpecItem _ r e -> SpecItem True r e+ SpecGroup d es -> SpecGroup d (map go es)
src/Test/Hspec/Config.hs view
@@ -1,21 +1,15 @@ module Test.Hspec.Config ( Config (..)-, ColorMode (..) , defaultConfig , getConfig , configAddFilter , configSetSeed---- exported to silence warnings-, Arg (..) ) where -import Control.Monad (unless) import Control.Applicative+import Data.List import System.IO import System.Exit-import System.Environment-import System.Console.GetOpt import qualified Test.QuickCheck as QC import Test.Hspec.Formatters @@ -24,11 +18,12 @@ -- for Monad (Either e) when base < 4.3 import Control.Monad.Trans.Error () +import Test.Hspec.Options+import Test.Hspec.FailureReport+ data Config = Config {- configVerbose :: Bool-, configDryRun :: Bool+ configDryRun :: Bool , configPrintCpuTime :: Bool-, configReRun :: Bool , configFastFail :: Bool -- |@@ -42,140 +37,69 @@ , 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 QC.stdArgs ColorAuto specdoc False stdout--formatters :: [(String, Formatter)]-formatters = [- ("specdoc", specdoc)- , ("progress", progress)- , ("failed-examples", failed_examples)- , ("silent", silent)- ]--formatHelp :: String-formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters)--type Result = Either NoConfig Config--data NoConfig = Help | InvalidArgument String String+defaultConfig = Config False False False Nothing QC.stdArgs ColorAuto specdoc False stdout -- | Add a filter predicate to config. If there is already a filter predicate, -- then combine them with `||`. configAddFilter :: (Path -> Bool) -> Config -> Config-configAddFilter p1 c = c {configFilterPredicate = Just p}- where- -- if there is already a predicate, we combine them with ||- p = maybe p1 (\p0 path -> p0 path || p1 path) mp- mp = configFilterPredicate c+configAddFilter p1 c = c {+ configFilterPredicate = Just p1 `filterOr` configFilterPredicate c+ } -setMaxSuccess :: Int -> Config -> Config-setMaxSuccess n c = c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.maxSuccess = n}}+filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)+filterOr p1_ p2_ = case (p1_, p2_) of+ (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path+ _ -> p1_ <|> p2_ 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")- , 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")- ]+mkConfig :: Maybe FailureReport -> Options -> Config+mkConfig mFailureReport opts = Config {+ configDryRun = optionsDryRun opts+ , configPrintCpuTime = optionsPrintCpuTime opts+ , configFastFail = optionsFastFail opts+ , configFilterPredicate = matchFilter `filterOr` rerunFilter+ , configQuickCheckArgs = qcArgs+ , configColorMode = optionsColorMode opts+ , configFormatter = optionsFormatter opts+ , configHtmlOutput = optionsHtmlOutput opts+ , configHandle = stdout+ } where- h = unlines . addLineBreaks-- 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}-- setColor mValue x = x >>= \c -> parseColor mValue >>= \v -> return c {configColorMode = v}+ qcArgs = maybe id setSeed mSeed args where- parseColor s = case s of- Nothing -> return ColorAlway- Just "auto" -> return ColorAuto- Just "never" -> return ColorNever- Just "always" -> return ColorAlway- Just v -> Left (InvalidArgument "color" v)--undocumentedOptions :: [OptDescr (Result -> Result)]-undocumentedOptions = [- Option "r" ["re-run"] (NoArg setReRun) "only re-run examples that previously failed"-- -- for compatibility with test-framework- , mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"+ args = maybe id setMaxSuccess mMaxSuccess QC.stdArgs - -- 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"+ mSeed = optionsSeed opts <|> (failureReportSeed <$> mFailureReport)+ mMaxSuccess = optionsMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) - -- now a noop- , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples"- ]- where- setReRun :: Result -> Result- setReRun x = x >>= \c -> return c {configReRun = True}+ setMaxSuccess :: Int -> QC.Args -> QC.Args+ setMaxSuccess n args = args {QC.maxSuccess = n} - setHtml :: Result -> Result- setHtml x = x >>= \c -> return c {configHtmlOutput = True}+ setSeed :: Integer -> QC.Args -> QC.Args+ setSeed n args = args {QC.replay = Just (stdGenFromInteger n, 0)} -getConfig :: IO Config-getConfig = do- (opts, args, errors) <- getOpt Permute (options ++ undocumentedOptions) <$> getArgs+ matchFilter = case optionsMatch opts of+ [] -> Nothing+ xs -> Just $ foldl1' (\p0 p1 path -> p0 path || p1 path) (map filterPredicate xs) - unless (null errors)- (tryHelp $ head errors)+ rerunFilter = flip elem . failureReportPaths <$> mFailureReport - unless (null args)- (tryHelp $ "unexpected argument `" ++ head args ++ "'\n")+getConfig :: Options -> String -> [String] -> IO Config+getConfig opts_ prog args = do+ case parseOptions opts_ prog args of+ Left (err, msg) -> exitWithMessage err msg+ Right opts -> do+ r <- if optionsRerun opts then readFailureReport else return Nothing+ return (mkConfig r opts) - case foldl (flip id) (Right defaultConfig) opts of- Left Help -> do- name <- getProgName- putStr $ usageInfo ("Usage: " ++ name ++ " [OPTION]...\n\nOPTIONS") options- exitSuccess- Left (InvalidArgument flag value) -> do- tryHelp $ "invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n"- Right config -> do- return config+exitWithMessage :: ExitCode -> String -> IO a+exitWithMessage err msg = do+ hPutStr h msg+ exitWith err where- tryHelp message = do- name <- getProgName- hPutStr stderr $ name ++ ": " ++ message ++ "Try `" ++ name ++ " --help' for more information.\n"- exitFailure+ h = case err of+ ExitSuccess -> stdout+ _ -> stderr
src/Test/Hspec/Core/Type.hs view
@@ -58,7 +58,7 @@ forceResult :: Result -> Result forceResult r = case r of- Success -> r `seq` r+ Success -> r Pending m -> r `seq` m `deepseq` r Fail m -> r `seq` m `deepseq` r @@ -74,7 +74,7 @@ -- | Internal representation of a spec. data SpecTree = SpecGroup String [SpecTree]- | SpecItem String (Params -> IO Result)+ | SpecItem Bool String (Params -> IO Result) -- | The @describe@ function combines a list of specs into a larger spec. describe :: String -> [SpecTree] -> SpecTree@@ -86,7 +86,7 @@ -- | Create a spec item. it :: Example a => String -> a -> SpecTree-it s e = SpecItem msg (`evaluateExample` e)+it s e = SpecItem False msg (`evaluateExample` e) where msg | null s = "(unspecified behavior)"@@ -106,7 +106,7 @@ ] instance Example Result where- evaluateExample _ r = return r+ evaluateExample _ = return instance Example QC.Property where evaluateExample c p = do
src/Test/Hspec/FailureReport.hs view
@@ -1,17 +1,20 @@ module Test.Hspec.FailureReport (- writeFailureReport+ FailureReport (..)+, writeFailureReport , readFailureReport ) where import System.IO import System.SetEnv-import qualified Test.QuickCheck as QC-import Test.Hspec.Config import Test.Hspec.Util (Path, safeTry, readMaybe, getEnv) -type Seed = Integer+data FailureReport = FailureReport {+ failureReportSeed :: Integer+, failureReportMaxSuccess :: Int+, failureReportPaths :: [Path]+} deriving (Eq, Show, Read) -writeFailureReport :: (Seed, [Path]) -> IO ()+writeFailureReport :: FailureReport -> IO () writeFailureReport x = do -- on Windows this can throw an exception when the input is too large, hence -- we use `safeTry` here@@ -20,19 +23,11 @@ onError err = do hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") -readFailureReport :: Config -> IO Config-readFailureReport c = do+readFailureReport :: IO (Maybe FailureReport)+readFailureReport = do mx <- getEnv "HSPEC_FAILURES" case mx >>= readMaybe of Nothing -> do- hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--re-run' is ignored!"- return 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)+ hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!"+ return Nothing+ x -> return x
src/Test/Hspec/Formatters.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} -- | -- Stability: experimental --@@ -46,6 +47,16 @@ -- ** Helpers , formatException++-- * Using custom formatters with @hspec-discover@+-- |+-- Anything that is an instance of `IsFormatter` can be used by+-- @hspec-discover@ as the default formatter for a spec. If you have a+-- formatter @myFormatter@ in the module @Custom.Formatters@ you can use it+-- by passing an additional argument to @hspec-discover@.+--+-- >{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --formatter=Custom.Formatters.myFormatter #-}+, IsFormatter (..) ) where import Data.Maybe@@ -87,6 +98,14 @@ , withFailColor ) +class IsFormatter a where+ toFormatter :: a -> IO Formatter++instance IsFormatter (IO Formatter) where+ toFormatter = id++instance IsFormatter Formatter where+ toFormatter = return silent :: Formatter silent = Formatter {
src/Test/Hspec/Formatters/Internal.hs view
@@ -27,7 +27,6 @@ -- * Functions for internal use , runFormatM-, liftIO , increaseSuccessCount , increasePendingCount , increaseFailCount@@ -42,7 +41,7 @@ import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) import System.Console.ANSI import Control.Monad.Trans.State hiding (gets, modify)-import qualified Control.Monad.IO.Class as IOClass+import Control.Monad.IO.Class import qualified System.CPUTime as CPUTime import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) @@ -53,20 +52,12 @@ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do- f <$> (get >>= IOClass.liftIO . readIORef)+ f <$> (get >>= liftIO . readIORef) -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do- get >>= IOClass.liftIO . (`modifyIORef'` f)---- | A lifted version of `IOClass.liftIO`------ This is meant for internal use only, and not part of the public API. This--- is also the reason why we do not make FormatM an instance MonadIO, so we--- have narrow control over the visibilty of this function.-liftIO :: IO a -> FormatM a-liftIO action = FormatM (IOClass.liftIO action)+ get >>= liftIO . (`modifyIORef'` f) data FormatterState = FormatterState { stateHandle :: Handle@@ -93,7 +84,7 @@ -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown. newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a)- deriving (Functor, Applicative, Monad)+ deriving (Functor, Applicative, Monad, MonadIO) runFormatM :: Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a runFormatM useColor produceHTML_ printCpuTime seed handle (FormatM action) = do@@ -131,7 +122,7 @@ getTotalCount = gets totalCount -- | Append to the list of accumulated failure messages.-addFailMessage :: Path -> (Either SomeException String) -> FormatM ()+addFailMessage :: Path -> Either SomeException String -> FormatM () addFailMessage p m = modify $ \s -> s {failMessages = FailureRecord p m : failMessages s} -- | Get the list of accumulated failure messages.
src/Test/Hspec/HUnit.hs view
@@ -4,7 +4,7 @@ fromHUnitTest ) where -import Data.List (intersperse)+import Data.List (intercalate) import qualified Test.HUnit as HU import Test.HUnit (Test (..)) @@ -20,7 +20,7 @@ return r where details :: String -> String- details = concat . intersperse "\n" . tail . init . lines+ details = intercalate "\n" . tail . init . lines -- | -- Convert a HUnit test suite to a spec. This can be used to run existing
+ src/Test/Hspec/Options.hs view
@@ -0,0 +1,136 @@+module Test.Hspec.Options (+ Options (..)+, ColorMode (..)+, defaultOptions+, parseOptions++-- exported to silence warnings+, Arg (..)+) where++import Data.List+import System.Exit+import System.Console.GetOpt+import Test.Hspec.Formatters++import Test.Hspec.Util++-- for Monad (Either e) when base < 4.3+import Control.Monad.Trans.Error ()++data Options = Options {+ optionsDryRun :: Bool+, optionsPrintCpuTime :: Bool+, optionsRerun :: Bool+, optionsFastFail :: Bool+, optionsMatch :: [String]+, optionsMaxSuccess :: Maybe Int+, optionsSeed :: Maybe Integer+, optionsColorMode :: ColorMode+, optionsFormatter :: Formatter+, optionsHtmlOutput :: Bool+}++addMatch :: String -> Options -> Options+addMatch s c = c {optionsMatch = s : optionsMatch c}++setMaxSuccess :: Int -> Options -> Options+setMaxSuccess n c = c {optionsMaxSuccess = Just n}++setSeed :: Integer -> Options -> Options+setSeed n c = c {optionsSeed = Just n}++data ColorMode = ColorAuto | ColorNever | ColorAlways+ deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options False False False False [] Nothing Nothing ColorAuto specdoc False++formatters :: [(String, Formatter)]+formatters = [+ ("specdoc", specdoc)+ , ("progress", progress)+ , ("failed-examples", failed_examples)+ , ("silent", silent)+ ]++formatHelp :: String+formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters)++type Result = Either NoConfig Options++data NoConfig = Help | InvalidArgument String String++data Arg a = Arg {+ argumentName :: String+, argumentParser :: String -> Maybe a+, argumentSetter :: a -> Options -> Options+}++mkOption :: [Char] -> String -> 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")+ , mkOption "m" "match" (Arg "PATTERN" return addMatch) (h "only run examples that match given PATTERN")+ , Option [] ["color"] (NoArg setColor) (h "colorize the output")+ , Option [] ["no-color"] (NoArg setNoColor) (h "do not colorize the output")+ , 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 setSeed) (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")+ , Option "r" ["rerun"] (NoArg setRerun) (h "only rerun examples that previously failed")+ ]+ where+ h = unlines . addLineBreaks++ readFormatter :: String -> Maybe Formatter+ readFormatter = (`lookup` formatters)++ setFormatter :: Formatter -> Options -> Options+ setFormatter f c = c {optionsFormatter = f}++ setPrintCpuTime x = x >>= \c -> return c {optionsPrintCpuTime = True}+ setDryRun x = x >>= \c -> return c {optionsDryRun = True}+ setFastFail x = x >>= \c -> return c {optionsFastFail = True}+ setRerun x = x >>= \c -> return c {optionsRerun = True}+ setNoColor x = x >>= \c -> return c {optionsColorMode = ColorNever}+ setColor x = x >>= \c -> return c {optionsColorMode = ColorAlways}++undocumentedOptions :: [OptDescr (Result -> Result)]+undocumentedOptions = [+ -- for compatibility with test-framework+ 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+ , 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+ setHtml :: Result -> Result+ setHtml x = x >>= \c -> return c {optionsHtmlOutput = True}++parseOptions :: Options -> String -> [String] -> Either (ExitCode, String) Options+parseOptions c prog args = case getOpt Permute (options ++ undocumentedOptions) args of+ (opts, [], []) -> case foldl' (flip id) (Right c) opts of+ Left Help -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") options)+ Left (InvalidArgument flag value) -> tryHelp ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n")+ Right x -> Right x+ (_, _, err:_) -> tryHelp err+ (_, arg:_, _) -> tryHelp ("unexpected argument `" ++ arg ++ "'\n")+ where+ tryHelp msg = Left (ExitFailure 1, prog ++ ": " ++ msg ++ "Try `" ++ prog ++ " --help' for more information.\n")
src/Test/Hspec/Runner.hs view
@@ -3,6 +3,7 @@ module Test.Hspec.Runner ( -- * Running a spec hspec+, hspecResult , hspecWith -- * Types@@ -12,6 +13,9 @@ , Path , defaultConfig , configAddFilter++-- * Internals+, hspecWithFormatter ) where import Control.Monad@@ -26,6 +30,7 @@ import System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC import System.Random (newStdGen)+import Control.Monad.IO.Class (liftIO) import Test.Hspec.Util import Test.Hspec.Core.Type@@ -33,8 +38,10 @@ import Test.Hspec.Formatters import Test.Hspec.Formatters.Internal import Test.Hspec.FailureReport-import Test.Hspec.Timer +import Test.Hspec.Options (Options(..), ColorMode(..), defaultOptions)+import Test.Hspec.Runner.Eval+ -- | Filter specs by given predicate. -- -- The predicate takes a list of "describe" labels and a "requirement".@@ -42,89 +49,29 @@ filterSpecs p = goSpecs [] where goSpecs :: [String] -> [SpecTree] -> [SpecTree]- goSpecs groups = catMaybes . map (goSpec groups)+ goSpecs groups = mapMaybe (goSpec groups) goSpec :: [String] -> SpecTree -> Maybe SpecTree goSpec groups spec = case spec of- SpecItem requirement _ -> guard (p (groups, requirement)) >> return spec+ SpecItem _ requirement _ -> guard (p (groups, requirement)) >> return spec SpecGroup group specs -> case goSpecs (groups ++ [group]) specs of [] -> Nothing xs -> Just (SpecGroup group xs) --- | Evaluate all examples of a given spec and produce a report.-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 ()- each [] _ = pure ()- each (x:xs) f = do- f x- fails <- getFailCount- 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 . safeTry . fmap forceResult-- go :: [String] -> (Int, SpecTree) -> FormatM ()- go rGroups (n, SpecGroup group xs) = do- exampleGroupStarted formatter n (reverse rGroups) group- zip [0..] xs `each` go (group : rGroups)- exampleGroupDone formatter- go rGroups (_, SpecItem requirement example) = do- progressHandler <- mkProgressHandler- result <- eval (example $ Params (configQuickCheckArgs c) progressHandler)- case result of- Right Success -> do- increaseSuccessCount- exampleSucceeded formatter path- Right (Pending reason) -> do- increasePendingCount- examplePending formatter path reason-- Right (Fail err) -> failed (Right err)- Left e -> failed (Left e)- where- path = (groups, requirement)- groups = reverse rGroups- failed err = do- increaseFailCount- 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.------ (see also `hspecWith`) hspec :: Spec -> IO ()-hspec spec = do- c <- getConfig- withArgs [] {- do not leak command-line arguments to examples -} $ do- r <- hspecWith c spec- unless (summaryFailures r == 0) exitFailure+hspec = hspecWithOptions defaultOptions -handleReRun :: Config -> IO Config-handleReRun c = do- if configReRun c- then do- readFailureReport c- else do- return c+-- | This function is used by @hspec-discover@. It is not part of the public+-- API and may change at any time.+hspecWithFormatter :: IsFormatter a => a -> Spec -> IO ()+hspecWithFormatter formatter spec = do+ f <- toFormatter formatter+ hspecWithOptions defaultOptions {optionsFormatter = f} spec -- 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.+-- seed is used for all properties. This helps with --seed and --rerun. ensureStdGen :: Config -> IO Config ensureStdGen c = case QC.replay qcArgs of Nothing -> do@@ -136,15 +83,31 @@ -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible.+hspecWithOptions :: Options -> Spec -> IO ()+hspecWithOptions opts spec = do+ prog <- getProgName+ args <- getArgs+ c <- getConfig opts prog args+ withArgs [] {- do not leak command-line arguments to examples -} $ do+ r <- hspecWith c spec+ unless (summaryFailures r == 0) exitFailure++-- | Run given spec and returns a summary of the test run. ----- /Note/: `hspecWith` does not exit with `exitFailure` on failing spec items.--- If you need this, you have to check the `Summary` yourself and act+-- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec+-- items. If you need this, you have to check the `Summary` yourself and act -- accordingly.+hspecResult :: Spec -> IO Summary+hspecResult = hspecWith defaultConfig++-- | Run given spec with custom options and returns a summary of the test run.+--+-- /Note/: `hspecWith` does not exit with `exitFailure` on failing spec+-- items. If you need this, you have to check the `Summary` yourself and act+-- accordingly. hspecWith :: Config -> Spec -> IO Summary hspecWith c_ spec = do- -- read failure report on --re-run- c <- handleReRun c_ >>= ensureStdGen-+ c <- ensureStdGen c_ let formatter = configFormatter c h = configHandle c seed = (stdGenToInteger . fst . fromJust . QC.replay . configQuickCheckArgs) c@@ -160,7 +123,11 @@ -- dump failure report xs <- map failureRecordPath <$> getFailMessages- liftIO $ writeFailureReport (seed, xs)+ liftIO $ writeFailureReport FailureReport {+ failureReportSeed = seed+ , failureReportMaxSuccess = QC.maxSuccess (configQuickCheckArgs c)+ , failureReportPaths = xs+ } Summary <$> getTotalCount <*> getFailCount where@@ -173,7 +140,7 @@ doesUseColor h c = case configColorMode c of ColorAuto -> hIsTerminalDevice h ColorNever -> return False- ColorAlway -> return True+ ColorAlways -> return True -- | Summary of a test run. data Summary = Summary {
+ src/Test/Hspec/Runner/Eval.hs view
@@ -0,0 +1,124 @@+module Test.Hspec.Runner.Eval (runFormatter) where++import Control.Monad+import qualified Control.Exception as E+import Control.Concurrent++import Control.Monad.IO.Class (liftIO)++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.Timer+import Data.Time.Clock.POSIX++-- | Evaluate all examples of a given spec and produce a report.+runFormatter :: Bool -> Config -> Formatter -> [SpecTree] -> FormatM ()+runFormatter useColor c formatter specs = do+ headerFormatter formatter+ chan <- liftIO newChan+ run chan useColor c formatter specs++data Message = Done | Run (FormatM ())++data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result)++run :: Chan Message -> Bool -> Config -> Formatter -> [SpecTree] -> FormatM ()+run chan useColor c formatter specs = do+ liftIO $ do+ forM_ (zip [0..] specs) (queueSpec [])+ writeChan chan Done+ processChan chan (configFastFail c)+ where+ defer = writeChan chan . Run++ queueSpec :: [String] -> (Int, SpecTree) -> IO ()+ queueSpec rGroups (n, SpecGroup group xs) = do+ defer (exampleGroupStarted formatter n (reverse rGroups) group)+ forM_ (zip [0..] xs) (queueSpec (group : rGroups))+ defer (exampleGroupDone formatter)+ queueSpec rGroups (_, SpecItem isParallelizable requirement e) =+ queueExample isParallelizable (reverse rGroups, requirement) e++ queueExample :: Bool -> Path -> (Params -> IO Result) -> IO ()+ queueExample isParallelizable path e+ | isParallelizable = runParallel+ | otherwise = defer runSequentially+ where+ runSequentially :: FormatM ()+ runSequentially = do+ progressHandler <- liftIO (mkProgressHandler reportProgress)+ result <- liftIO (evalExample e progressHandler)+ formatResult formatter path result++ runParallel = do+ mvar <- newEmptyMVar+ _ <- forkIO $ do+ progressHandler <- mkProgressHandler (replaceMVar mvar . ReportProgress)+ result <- evalExample e progressHandler+ replaceMVar mvar (ReportResult result)+ defer (evalReport mvar)+ where+ evalReport :: MVar Report -> FormatM ()+ evalReport mvar = do+ r <- liftIO (takeMVar mvar)+ case r of+ ReportProgress p -> do+ liftIO $ reportProgress p+ evalReport mvar+ ReportResult result -> formatResult formatter path result++ reportProgress :: (Int, Int) -> IO ()+ reportProgress = exampleProgress formatter (configHandle c) path++ mkProgressHandler :: (a -> IO ()) -> IO (a -> IO ())+ mkProgressHandler report+ | useColor = every 0.05 report+ | otherwise = return . const $ return ()++ evalExample :: (Params -> IO Result) -> (Progress -> IO ()) -> IO (Either E.SomeException Result)+ evalExample e progressHandler+ | configDryRun c = return (Right Success)+ | otherwise = (safeTry . fmap forceResult) (e $ Params (configQuickCheckArgs c) progressHandler)++replaceMVar :: MVar a -> a -> IO ()+replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p++processChan :: Chan Message -> Bool -> FormatM ()+processChan chan fastFail = go+ where+ go = do+ m <- liftIO (readChan chan)+ case m of+ Run action -> do+ action+ fails <- getFailCount+ unless (fastFail && fails /= 0) go+ Done -> return ()++formatResult :: Formatter -> ([String], String) -> Either E.SomeException Result -> FormatM ()+formatResult formatter path result = do+ case result of+ Right Success -> do+ increaseSuccessCount+ exampleSucceeded formatter path+ Right (Pending reason) -> do+ increasePendingCount+ examplePending formatter path reason+ Right (Fail err) -> failed (Right err)+ Left e -> failed (Left e)+ where+ failed err = do+ increaseFailCount+ addFailMessage path err+ exampleFailed formatter path err++-- | Execute given action at most every specified number of seconds.+every :: POSIXTime -> (a -> IO ()) -> IO (a -> IO ())+every seconds action = do+ timer <- newTimer seconds+ return $ \a -> do+ r <- timer+ when r (action a)