diff --git a/hspec.cabal b/hspec.cabal --- a/hspec.cabal +++ b/hspec.cabal @@ -1,5 +1,5 @@ name: hspec -version: 1.4.3 +version: 1.4.4 license: BSD3 license-file: LICENSE copyright: (c) 2011-2012 Trystan Spangler, (c) 2011-2012 Simon Hengel, (c) 2011 Greg Weber @@ -51,7 +51,7 @@ base == 4.* , setenv , silently >= 1.1.1 - , ansi-terminal == 0.5.* + , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 && < 0.4.0 , HUnit >= 1.2.5 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 @@ -7,9 +7,17 @@ import Data.Typeable.Internal (tyConModule, tyConName) #endif - showType :: Typeable a => a -> String showType a = let t = typeRepTyCon (typeOf a) in +#if MIN_VERSION_base(4,4,0) + show t +#else + (reverse . takeWhile (/= '.') . reverse . show) t +#endif + + +showFullType :: Typeable a => a -> String +showFullType a = let t = typeRepTyCon (typeOf a) in #if MIN_VERSION_base(4,4,0) tyConModule t ++ "." ++ tyConName t #else 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 @@ -26,6 +26,7 @@ , configDryRun :: Bool , configPrintCpuTime :: Bool , configReRun :: Bool +, configFastFail :: Bool -- | -- A predicate that is used to filter the spec before it is run. Only examples @@ -41,7 +42,7 @@ data ColorMode = ColorAuto | ColorNever | ColorAlway defaultConfig :: Config -defaultConfig = Config False False False False Nothing defaultParams ColorAuto specdoc False stdout +defaultConfig = Config False False False False False Nothing defaultParams ColorAuto specdoc False stdout formatters :: [(String, Formatter)] formatters = [ @@ -52,7 +53,7 @@ ] formatHelp :: String -formatHelp = unlines ("Use a custom formatter. This can be one of:" : map ((" " ++) . fst) formatters) +formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters) type Result = Either NoConfig Config @@ -73,24 +74,31 @@ mapParams :: (Params -> Params) -> Config -> Config mapParams f c = c {configParams = f (configParams c)} +addLineBreaks :: String -> [String] +addLineBreaks = lineBreaksAt 44 + options :: [OptDescr (Result -> Result)] options = [ - Option [] ["help"] (NoArg (const $ Left Help)) "display this help and exit" - , Option "v" ["verbose"] (NoArg setVerbose) "do not suppress output to stdout when\nevaluating examples" - , Option "m" ["match"] (ReqArg setFilter "PATTERN") "only run examples that match given PATTERN" - , Option [] ["color"] (OptArg setColor "WHEN") "colorize the output. WHEN defaults to\n`always' or can be `never' or `auto'." + 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") "maximum number of successful tests before a\nQuickCheck property succeeds" - , Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary" - , Option [] ["dry-run"] (NoArg setDryRun) "pretend that everything passed; don't verify\nanything" + , 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") ] where + h = unlines . addLineBreaks + 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} setFormatter name x = x >>= \c -> case lookup name formatters of Nothing -> Left (InvalidArgument "format" name) 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 @@ -42,14 +42,16 @@ , withSuccessColor , withPendingColor , withFailColor + +-- ** Helpers +, formatException ) where import Data.Maybe import Test.Hspec.Util import Test.Hspec.Compat -import Data.List (intersperse) import Text.Printf -import Control.Monad (unless) +import Control.Monad (unless, forM_) import Control.Applicative import qualified Control.Exception as E @@ -149,20 +151,36 @@ defaultFailedFormatter :: FormatM () defaultFailedFormatter = do newParagraph - withFailColor $ do - failures <- map formatFailure . zip [1..] <$> getFailMessages - mapM_ writeLine (intersperse "" failures) - unless (null failures) (writeLine "") + + failures <- getFailMessages + + forM_ (zip [1..] failures) $ \x -> do + formatFailure x + writeLine "" where - formatFailure :: (Int, FailureRecord) -> String - formatFailure (i, FailureRecord path reason) = - show i ++ ") " ++ formatRequirement path ++ " FAILED" ++ err + formatFailure :: (Int, FailureRecord) -> FormatM () + formatFailure (n, FailureRecord path reason) = do + write (show n ++ ") ") + withFailColor $ do + write (formatRequirement path ++ " FAILED") + write $ case reason of + Right _ -> "\n" + Left _ -> " (uncaught exception)\n" + unless (null err) $ do + writeLine err where - err = case reason of - Left (E.SomeException e) -> " (uncaught exception)\n" ++ formatException e - Right e -> if null e then "" else "\n" ++ e + err = either formatException id reason - formatException e = showType e ++ " (" ++ show e ++ ")" +-- | Convert an exception to a string. +-- +-- The type of the exception is included. Here is an example: +-- +-- >>> import Control.Applicative +-- >>> import Control.Exception +-- >>> either formatException show <$> (try . evaluate) (1 `div` 0) +-- "ArithException (divide by zero)" +formatException :: E.SomeException -> String +formatException (E.SomeException e) = showType e ++ " (" ++ show e ++ ")" defaultFooter :: FormatM () defaultFooter = do 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 @@ -31,29 +31,32 @@ , increasePendingCount , increaseFailCount , addFailMessage +, finally_ ) where import qualified System.IO as IO import System.IO (Handle) import Control.Monad (when, unless) import Control.Applicative -import Control.Exception (SomeException, bracket_) +import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) import System.Console.ANSI import Control.Monad.Trans.State hiding (gets, modify) -import qualified Control.Monad.Trans.State as State 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) --- | A lifted version of `State.gets` +-- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a -gets f = FormatM (State.gets f) +gets f = FormatM $ do + f <$> (get >>= IOClass.liftIO . readIORef) --- | A lifted version of `State.modify` +-- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () -modify f = FormatM (State.modify f) +modify f = FormatM $ do + get >>= IOClass.liftIO . (`modifyIORef` f) -- | A lifted version of `IOClass.liftIO` -- @@ -80,14 +83,17 @@ totalCount :: FormatterState -> Int totalCount s = successCount s + pendingCount s + failCount s -newtype FormatM a = FormatM (StateT FormatterState IO a) +-- 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) runFormatM :: Bool -> Bool -> Bool -> Handle -> FormatM a -> IO a runFormatM useColor produceHTML_ printCpuTime handle (FormatM action) = do time <- getPOSIXTime cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing - evalStateT action (FormatterState handle useColor produceHTML_ False 0 0 0 [] cpuTime time) + st <- newIORef (FormatterState handle useColor produceHTML_ False 0 0 0 [] cpuTime time) + evalStateT action st -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () @@ -207,20 +213,35 @@ htmlSpan cls action = write ("") *> action <* write "" withColor_ :: SGR -> FormatM a -> FormatM a -withColor_ color (FormatM action) = FormatM . StateT $ \st -> do - let useColor = stateUseColor st - h = stateHandle st +withColor_ color (FormatM action) = do + useColor <- gets stateUseColor + h <- gets stateHandle - bracket_ + FormatM . StateT $ \st -> do + bracket_ - -- set color - (when useColor $ hSetSGR h [color]) + -- set color + (when useColor $ hSetSGR h [color]) - -- reset colors - (when useColor $ hSetSGR h [Reset]) + -- reset colors + (when useColor $ hSetSGR h [Reset]) - -- run action - (runStateT action st) + -- run action + (runStateT action st) + +-- | +-- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is +-- run even when a `UserInterrupt` occurs during @actionA@. +finally_ :: FormatM () -> FormatM () -> FormatM () +finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do + r <- try (execStateT actionA st) + case r of + Left e -> do + when (e == UserInterrupt) $ + runStateT actionB st >> return () + throwIO e + Right st_ -> do + runStateT actionB st_ -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Double) 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 @@ -48,8 +48,17 @@ -- | Evaluate all examples of a given spec and produce a report. runFormatter :: Config -> Formatter -> [SpecTree] -> FormatM () -runFormatter c formatter specs = headerFormatter formatter >> mapM_ (go []) (zip [0..] specs) +runFormatter 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 + silence_ | configVerbose c = id | otherwise = silence @@ -61,7 +70,7 @@ go :: [String] -> (Int, SpecTree) -> FormatM () go rGroups (n, SpecGroup group xs) = do exampleGroupStarted formatter n (reverse rGroups) group - mapM_ (go (group : rGroups)) (zip [0..] xs) + zip [0..] xs `each` go (group : rGroups) exampleGroupDone formatter go rGroups (_, SpecItem requirement example) = do result <- eval (example $ configParams c) @@ -115,8 +124,9 @@ useColor <- doesUseColor h c runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) h $ do - runFormatter c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) - failedFormatter formatter + runFormatter c formatter (maybe id filterSpecs (configFilterPredicate c) $ runSpecM spec) `finally_` + failedFormatter formatter + footerFormatter formatter -- dump failure report 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,5 +1,6 @@ module Test.Hspec.Util ( quantify +, lineBreaksAt , safeEvaluate , Path , filterPredicate @@ -78,3 +79,18 @@ getEnv :: String -> IO (Maybe String) getEnv key = either (const Nothing) Just <$> safeEvaluate (Environment.getEnv key) + +-- ensure that lines are not longer then given `n`, insert line beraks at word +-- boundaries +lineBreaksAt :: Int -> String -> [String] +lineBreaksAt n input = case words input of + [] -> [] + x:xs -> go (x, xs) + where + go :: (String, [String]) -> [String] + go c = case c of + (s, []) -> [s] + (s, y:ys) -> let r = s ++ " " ++ y in + if length r <= n + then go (r, ys) + else s : go (y, ys) diff --git a/test/Test/Hspec/CompatSpec.hs b/test/Test/Hspec/CompatSpec.hs --- a/test/Test/Hspec/CompatSpec.hs +++ b/test/Test/Hspec/CompatSpec.hs @@ -15,5 +15,9 @@ spec :: Spec spec = do describe "showType" $ do + it "shows unqualified name of type" $ do + showType SomeType `shouldBe` "SomeType" + + describe "showFullType (currently unused)" $ do it "shows fully qualified name of type" $ do - showType SomeType `shouldBe` "Test.Hspec.CompatSpec.SomeType" + showFullType SomeType `shouldBe` "Test.Hspec.CompatSpec.SomeType" diff --git a/test/Test/Hspec/FormattersSpec.hs b/test/Test/Hspec/FormattersSpec.hs --- a/test/Test/Hspec/FormattersSpec.hs +++ b/test/Test/Hspec/FormattersSpec.hs @@ -180,7 +180,7 @@ H.it "foobar" (undefined :: Bool) r `shouldContain` [ "1) foobar FAILED (uncaught exception)" - , "GHC.Exception.ErrorCall (Prelude.undefined)" + , "ErrorCall (Prelude.undefined)" ] it "prints all descriptions when a nested requirement fails" $ do diff --git a/test/Test/Hspec/RunnerSpec.hs b/test/Test/Hspec/RunnerSpec.hs --- a/test/Test/Hspec/RunnerSpec.hs +++ b/test/Test/Hspec/RunnerSpec.hs @@ -4,6 +4,7 @@ import System.IO.Silently import System.IO (stderr) import Control.Applicative +import Control.Monad (unless) import System.Environment (withArgs, withProgName, getArgs) import System.Exit import qualified Control.Exception as E @@ -20,6 +21,9 @@ ignoreExitCode :: IO () -> IO () ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () +ignoreUserInterrupt :: IO () -> IO () +ignoreUserInterrupt action = action `E.catch` \e -> unless (e == E.UserInterrupt) (E.throwIO e) + main :: IO () main = hspec spec @@ -58,6 +62,27 @@ getArgs `shouldReturn` [] `shouldReturn` () + context "when interrupted with ctrl-c" $ do + it "prints summary immediately" $ do + r <- captureLines . ignoreUserInterrupt . H.hspec $ do + H.it "foo" False + H.it "bar" $ do + E.throwIO E.UserInterrupt :: IO () + H.it "baz" True + normalizeSummary r `shouldBe` [ + "" + , "- foo FAILED [1]" + , "" + , "1) foo FAILED" + , "" + ] + + it "throws UserInterrupt" $ do + H.hspec $ do + H.it "foo" $ do + E.throwIO E.UserInterrupt :: IO () + `shouldThrow` (== E.UserInterrupt) + context "with --help" $ do let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure () it "prints help" $ do @@ -97,6 +122,39 @@ H.it "foo" (mockAction e) H.it "bar" False mockCounter e `shouldReturn` 0 + + context "with --fast-fail" $ do + it "stops after first failure" $ do + r <- captureLines . ignoreExitCode . withArgs ["--fast-fail"] . H.hspec $ do + H.it "foo" True + H.it "bar" False + H.it "baz" False + normalizeSummary r `shouldBe` [ + "" + , "- foo" + , "- bar FAILED [1]" + , "" + , "1) bar FAILED" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 1 failure" + ] + + it "works for nested specs" $ do + r <- captureLines . ignoreExitCode . withArgs ["--fast-fail"] . H.hspec $ do + H.describe "foo" $ do + H.it "bar" False + H.it "baz" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " - bar FAILED [1]" + , "" + , "1) foo bar FAILED" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] context "with --match" $ do it "only runs examples that match a given pattern" $ do diff --git a/test/Test/Hspec/UtilSpec.hs b/test/Test/Hspec/UtilSpec.hs --- a/test/Test/Hspec/UtilSpec.hs +++ b/test/Test/Hspec/UtilSpec.hs @@ -25,6 +25,17 @@ it "returns a plural word given the number 0" $ do quantify 0 "thing" `shouldBe` "0 things" + describe "lineBreaksAt" $ do + it "inserts line breaks at word boundaries" $ do + lineBreaksAt 20 "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod" + `shouldBe` [ + "Lorem ipsum dolor" + , "sit amet," + , "consectetur" + , "adipisicing elit," + , "sed do eiusmod" + ] + describe "safeEvaluate" $ do it "returns Right on success" $ do Right e <- safeEvaluate (return 23 :: IO Int) diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -3,4 +3,4 @@ import Test.DocTest main :: IO () -main = doctest ["-isrc", "src/Test/Hspec/Util.hs"] +main = doctest ["-isrc", "-optP-include", "-optPdist/build/autogen/cabal_macros.h", "src/Test/Hspec/Util.hs", "src/Test/Hspec/Formatters.hs"]