diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack --- --- hash: 82bf612e65db816a15de01c4c432597ef4492ceeb81f46063dcdd57b74ec523a name: hspec-core -version: 2.7.1 +version: 2.7.2 license: MIT license-file: LICENSE copyright: (c) 2011-2019 Simon Hengel, @@ -39,7 +37,7 @@ , array , base >=4.5.0.0 && <5 , call-stack - , clock + , clock >=0.7.1 , deepseq , directory , filepath @@ -92,12 +90,12 @@ cpp-options: -DTEST build-depends: HUnit ==1.6.* - , QuickCheck >=2.13.1 + , QuickCheck >=2.14 , ansi-terminal >=0.5 , array , base >=4.5.0.0 && <5 , call-stack - , clock + , clock >=0.7.1 , deepseq , directory , filepath diff --git a/src/Test/Hspec/Core/Clock.hs b/src/Test/Hspec/Core/Clock.hs --- a/src/Test/Hspec/Core/Clock.hs +++ b/src/Test/Hspec/Core/Clock.hs @@ -5,11 +5,13 @@ , getMonotonicTime , measure , sleep +, timeout ) where import Text.Printf import System.Clock import Control.Concurrent +import qualified System.Timeout as System newtype Seconds = Seconds Double deriving (Eq, Show, Num, Fractional, PrintfArg) @@ -31,3 +33,6 @@ sleep :: Seconds -> IO () sleep = threadDelay . toMicroseconds + +timeout :: Seconds -> IO a -> IO (Maybe a) +timeout = System.timeout . toMicroseconds diff --git a/src/Test/Hspec/Core/Formatters.hs b/src/Test/Hspec/Core/Formatters.hs --- a/src/Test/Hspec/Core/Formatters.hs +++ b/src/Test/Hspec/Core/Formatters.hs @@ -61,8 +61,11 @@ import Data.Maybe import Test.Hspec.Core.Util +import Test.Hspec.Core.Clock import Test.Hspec.Core.Spec (Location(..)) import Text.Printf +import Control.Monad.IO.Class +import Control.Exception -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. @@ -100,8 +103,6 @@ , missingChunk ) -import Test.Hspec.Core.Clock (Seconds(..)) - import Test.Hspec.Core.Formatters.Diff silent :: Formatter @@ -212,28 +213,38 @@ mapM_ indent preface b <- useDiff - let - chunks - | b = diff expected actual - | otherwise = [First expected, Second actual] - withFailColor $ write (indentation ++ "expected: ") - forM_ chunks $ \chunk -> case chunk of - Both a _ -> indented write a - First a -> indented extraChunk a - Second _ -> return () - writeLine "" + let threshold = 2 :: Seconds - withFailColor $ write (indentation ++ " but got: ") - forM_ chunks $ \chunk -> case chunk of - Both a _ -> indented write a - First _ -> return () - Second a -> indented missingChunk a - writeLine "" + mchunks <- liftIO $ if b + then timeout threshold (evaluate $ diff expected actual) + else return Nothing + + case mchunks of + Just chunks -> do + writeDiff chunks extraChunk missingChunk + Nothing -> do + writeDiff [First expected, Second actual] write write where indented output text = case break (== '\n') text of (xs, "") -> output xs (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys + + writeDiff chunks extra missing = do + withFailColor $ write (indentation ++ "expected: ") + forM_ chunks $ \ chunk -> case chunk of + Both a _ -> indented write a + First a -> indented extra a + Second _ -> return () + writeLine "" + + withFailColor $ write (indentation ++ " but got: ") + forM_ chunks $ \ chunk -> case chunk of + Both a _ -> indented write a + First _ -> return () + Second a -> indented missing a + writeLine "" + Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e writeLine "" diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -36,7 +36,6 @@ import System.Exit import qualified Control.Exception as E import Control.Exception -import qualified System.Timeout as System import System.IO.Silently import System.SetEnv import System.Directory @@ -94,9 +93,6 @@ noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = return () - -timeout :: Seconds -> IO a -> IO (Maybe a) -timeout = System.timeout . toMicroseconds shouldUseArgs :: HasCallStack => [String] -> (Args -> Bool) -> Expectation shouldUseArgs args p = do diff --git a/test/Test/Hspec/Core/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs --- a/test/Test/Hspec/Core/FormattersSpec.hs +++ b/test/Test/Hspec/Core/FormattersSpec.hs @@ -5,6 +5,7 @@ import Prelude () import Helper import Data.String +import Control.Monad.IO.Class import Control.Monad.Trans.Writer import qualified Control.Exception as E @@ -53,13 +54,13 @@ Plain x : xs -> color x : xs xs -> xs -interpret :: FormatM a -> [ColorizedText] +interpret :: FormatM a -> IO [ColorizedText] interpret = interpretWith environment -interpretWith :: Environment (Writer [ColorizedText]) -> FormatM a -> [ColorizedText] -interpretWith env = simplify . execWriter . H.interpretWith env +interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText] +interpretWith env = fmap simplify . execWriterT . H.interpretWith env -environment :: Environment (Writer [ColorizedText]) +environment :: Environment (WriterT [ColorizedText] IO) environment = Environment { environmentGetSuccessCount = return 0 , environmentGetPendingCount = return 0 @@ -69,14 +70,22 @@ , environmentGetRealTime = return 0 , environmentWrite = tell . return . Plain , environmentWriteTransient = tell . return . Transient -, environmentWithFailColor = \action -> let (a, r) = runWriter action in tell (colorize Failed r) >> return a -, environmentWithSuccessColor = \action -> let (a, r) = runWriter action in tell (colorize Succeeded r) >> return a -, environmentWithPendingColor = \action -> let (a, r) = runWriter action in tell (colorize Pending r) >> return a -, environmentWithInfoColor = \action -> let (a, r) = runWriter action in tell (colorize Info r) >> return a +, environmentWithFailColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Failed r) >> return a +, environmentWithSuccessColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Succeeded r) >> return a +, environmentWithPendingColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Pending r) >> return a +, environmentWithInfoColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Info r) >> return a , environmentUseDiff = return True , environmentExtraChunk = tell . return . Extra , environmentMissingChunk = tell . return . Missing -, environmentLiftIO = undefined +, environmentLiftIO = liftIO } testSpec :: H.Spec @@ -96,19 +105,19 @@ describe "exampleSucceeded" $ do it "marks succeeding examples with ." $ do - interpret (H.exampleSucceeded formatter undefined undefined) `shouldBe` [ + interpret (H.exampleSucceeded formatter undefined undefined) `shouldReturn` [ Succeeded "." ] describe "exampleFailed" $ do it "marks failing examples with F" $ do - interpret (H.exampleFailed formatter undefined undefined undefined) `shouldBe` [ + interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [ Failed "F" ] describe "examplePending" $ do it "marks pending examples with ." $ do - interpret (H.examplePending formatter undefined undefined undefined) `shouldBe` [ + interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [ Pending "." ] @@ -206,7 +215,7 @@ environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] } it "adds indentation" $ do - removeColors (interpretWith env action) `shouldBe` unlines [ + (removeColors <$> interpretWith env action) `shouldReturn` unlines [ "" , "Failures:" , "" @@ -238,7 +247,7 @@ context "without failures" $ do let env = environment {environmentGetSuccessCount = return 1} it "shows summary in green if there are no failures" $ do - interpretWith env action `shouldBe` [ + interpretWith env action `shouldReturn` [ "Finished in 0.0000 seconds\n" , Succeeded "1 example, 0 failures\n" ] @@ -246,7 +255,7 @@ context "with pending examples" $ do let env = environment {environmentGetPendingCount = return 1} it "shows summary in yellow if there are pending examples" $ do - interpretWith env action `shouldBe` [ + interpretWith env action `shouldReturn` [ "Finished in 0.0000 seconds\n" , Pending "1 example, 0 failures, 1 pending\n" ] @@ -254,7 +263,7 @@ context "with failures" $ do let env = environment {environmentGetFailMessages = return [undefined]} it "shows summary in red" $ do - interpretWith env action `shouldBe` [ + interpretWith env action `shouldReturn` [ "Finished in 0.0000 seconds\n" , Failed "1 example, 1 failure\n" ] @@ -262,7 +271,7 @@ context "with both failures and pending examples" $ do let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1} it "shows summary in red" $ do - interpretWith env action `shouldBe` [ + interpretWith env action `shouldReturn` [ "Finished in 0.0000 seconds\n" , Failed "2 examples, 1 failure, 1 pending\n" ] diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs --- a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs +++ b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs @@ -91,7 +91,7 @@ , "0" , "" , "Passed:" - , "28" + , "23" ] parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") @@ -100,11 +100,11 @@ context "without checkCoverage" $ do let p :: Int -> Property - p n = cover 10 (n == 23) "is 23" True + p n = cover 10 (n == 5) "is 5" True it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 100 "+++ OK, passed 100 tests.\n\nOnly 0% is 23, but expected 10%" QuickCheckSuccess + QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess it "includes verbose output" $ do let @@ -113,11 +113,11 @@ , "0" , "" , "Passed:" - , "28" + , "23" , "" , "+++ OK, passed 2 tests." , "" - , "Only 0% is 23, but expected 10%" + , "Only 0% is 5, but expected 10%" ] parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` QuickCheckResult 2 info QuickCheckSuccess @@ -133,20 +133,20 @@ , quickCheckFailureException = Nothing , quickCheckFailureReason = "Insufficient coverage" , quickCheckFailureCounterexample = [ - " 0.8% is 23" + " 0.9% is 23" , "" - , "Only 0.8% is 23, but expected 10.0%" + , "Only 0.9% is 23, but expected 10.0%" ] } it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 400 "" (QuickCheckFailure failure) + QuickCheckResult 800 "" (QuickCheckFailure failure) it "includes verbose output" $ do - let info = intercalate "\n\n" (replicate 399 "Passed:") + let info = intercalate "\n\n" (replicate 799 "Passed:") parseQuickCheckResult <$> qc (verbose . p) `shouldReturn` - QuickCheckResult 400 info (QuickCheckFailure failure) + QuickCheckResult 800 info (QuickCheckFailure failure) context "with Failure" $ do context "with single-line failure reason" $ do @@ -155,7 +155,7 @@ p = (< 1) err = "Falsified" - result = QuickCheckResult 3 "" (QuickCheckFailure $ QCFailure 1 Nothing err ["1"]) + result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result @@ -166,9 +166,18 @@ , "0" , "" , "Passed:" - , "-1" + , "0" , "" + , "Passed:" + , "-2" + , "" , "Failed:" + , "3" + , "" + , "Passed:" + , "0" + , "" + , "Failed:" , "2" , "" , "Passed:" @@ -189,7 +198,7 @@ p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err} err = "foo\nbar" - result = QuickCheckResult 3 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) + result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result @@ -200,7 +209,13 @@ , "0" , "" , "Passed:" - , "-1" + , "0" + , "" + , "Passed:" + , "-2" + , "" + , "Passed:" + , "3" , "" , "Failed:" , "2"