diff --git a/hspec2.cabal b/hspec2.cabal --- a/hspec2.cabal +++ b/hspec2.cabal @@ -1,5 +1,5 @@ name: hspec2 -version: 0.1.1 +version: 0.2.0 license: MIT license-file: LICENSE copyright: (c) 2011-2014 Simon Hengel, @@ -36,14 +36,15 @@ src build-depends: base == 4.* - , random == 1.0.* + , random + , tf-random , setenv , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 && < 0.4.0 , deepseq , HUnit >= 1.2.5 - , QuickCheck >= 2.5.1 + , QuickCheck >= 2.7 , quickcheck-io , hspec-expectations == 0.5.0.* exposed-modules: @@ -91,7 +92,8 @@ -Wall -Werror build-depends: base == 4.* - , random == 1.0.* + , random + , tf-random , setenv , silently >= 1.2.4 , ansi-terminal @@ -103,7 +105,7 @@ , quickcheck-io , hspec-expectations - , hspec-meta >= 1.8.0 + , hspec-meta >= 1.9.0 , process , ghc-paths 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 @@ -3,7 +3,7 @@ , defaultConfig , getConfig , configAddFilter -, configSetSeed +, configQuickCheckArgs ) where import Control.Applicative @@ -12,12 +12,12 @@ import System.IO import System.Exit import qualified Test.QuickCheck as QC +import Test.QuickCheck.Random (mkQCGen) import Test.Hspec.Formatters import Test.Hspec.Util --- for Monad (Either e) when base < 4.3 -import Control.Monad.Trans.Error () +import Control.Monad.Trans.Error () -- for Monad (Either e) when base < 4.3 import Test.Hspec.Options import Test.Hspec.FailureReport @@ -31,7 +31,10 @@ -- 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) -, configQuickCheckArgs :: QC.Args +, configQuickCheckSeed :: Maybe Integer +, configQuickCheckMaxSuccess :: Maybe Int +, configQuickCheckMaxDiscardRatio :: Maybe Int +, configQuickCheckMaxSize :: Maybe Int , configSmallCheckDepth :: Int , configColorMode :: ColorMode , configFormatter :: Formatter @@ -40,7 +43,7 @@ } defaultConfig :: Config -defaultConfig = Config False False False Nothing QC.stdArgs 5 ColorAuto specdoc False (Left stdout) +defaultConfig = Config False False False Nothing Nothing Nothing Nothing Nothing 5 ColorAuto specdoc False (Left stdout) -- | Add a filter predicate to config. If there is already a filter predicate, -- then combine them with `||`. @@ -54,16 +57,16 @@ (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)}} - mkConfig :: Maybe FailureReport -> Options -> Config mkConfig mFailureReport opts = Config { configDryRun = optionsDryRun opts , configPrintCpuTime = optionsPrintCpuTime opts , configFastFail = optionsFastFail opts , configFilterPredicate = matchFilter `filterOr` rerunFilter - , configQuickCheckArgs = qcArgs + , configQuickCheckSeed = mSeed + , configQuickCheckMaxSuccess = mMaxSuccess + , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio + , configQuickCheckMaxSize = mMaxSize , configSmallCheckDepth = fromMaybe (configSmallCheckDepth defaultConfig) (optionsDepth opts) , configColorMode = optionsColorMode opts , configFormatter = optionsFormatter opts @@ -71,17 +74,27 @@ , configHandle = maybe (configHandle defaultConfig) Right (optionsOutputFile opts) } where - qcArgs = ( - maybe id setSeed mSeed - . maybe id setMaxDiscardRatio mMaxDiscardRatio - . maybe id setMaxSize mMaxSize - . maybe id setMaxSuccess mMaxSuccess) QC.stdArgs mSeed = optionsSeed opts <|> (failureReportSeed <$> mFailureReport) mMaxSuccess = optionsMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) mMaxSize = optionsMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) mMaxDiscardRatio = optionsMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) + matchFilter = case optionsMatch opts of + [] -> Nothing + xs -> Just $ foldl1' (\p0 p1 path -> p0 path || p1 path) (map filterPredicate xs) + + rerunFilter = flip elem . failureReportPaths <$> mFailureReport + +configQuickCheckArgs :: Config -> QC.Args +configQuickCheckArgs c = qcArgs + where + qcArgs = ( + maybe id setSeed (configQuickCheckSeed c) + . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) + . maybe id setMaxSize (configQuickCheckMaxSize c) + . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) QC.stdArgs + setMaxSuccess :: Int -> QC.Args -> QC.Args setMaxSuccess n args = args {QC.maxSuccess = n} @@ -92,13 +105,7 @@ setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} setSeed :: Integer -> QC.Args -> QC.Args - setSeed n args = args {QC.replay = Just (stdGenFromInteger n, 0)} - - matchFilter = case optionsMatch opts of - [] -> Nothing - xs -> Just $ foldl1' (\p0 p1 path -> p0 path || p1 path) (map filterPredicate xs) - - rerunFilter = flip elem . failureReportPaths <$> mFailureReport + setSeed n args = args {QC.replay = Just (mkQCGen (fromIntegral n), 0)} getConfig :: Options -> String -> [String] -> IO Config getConfig opts_ prog args = do diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs --- a/src/Test/Hspec/Core/QuickCheckUtil.hs +++ b/src/Test/Hspec/Core/QuickCheckUtil.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE CPP #-} module Test.Hspec.Core.QuickCheckUtil where -import Data.IORef -import Test.QuickCheck hiding (Result(..)) -import Test.QuickCheck as QC -import Test.QuickCheck.Property hiding (Result(..)) -import Test.QuickCheck.Gen +import Control.Applicative +import Control.Exception +import Data.Int +import Data.IORef +import Test.QuickCheck hiding (Result(..)) +import Test.QuickCheck as QC +import Test.QuickCheck.Property hiding (Result(..)) +import Test.QuickCheck.Gen import qualified Test.QuickCheck.Property as QCP -import Test.QuickCheck.IO () +import Test.QuickCheck.IO () +import Test.QuickCheck.Random +import System.Random aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property -aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n +aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) @@ -23,9 +27,8 @@ 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 + QC.Failure {theException = me} -> (me >>= fromException) == Just UserInterrupt _ -> False + +newSeed :: IO Int +newSeed = fromIntegral <$> (fst . randomR (0, maxBound) <$> newQCGen :: IO Int32) 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 @@ -89,7 +89,7 @@ , itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } --- | An `IO` action that expects an argument of type a. +-- | An `IO` action that expects an argument of type @a@. type ActionWith a = a -> IO () mapSpecItem :: (Item a -> Item b) -> SpecWith a -> SpecWith b 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 @@ -29,16 +29,16 @@ 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.Compat (lookupEnv) -import Test.Hspec.Util (Path, stdGenToInteger) +import Test.Hspec.Util (Path) import Test.Hspec.Core.Type import Test.Hspec.Config import Test.Hspec.Formatters import Test.Hspec.Formatters.Internal import Test.Hspec.FailureReport +import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Options (Options(..), ColorMode(..), defaultOptions) import Test.Hspec.Runner.Tree @@ -70,16 +70,14 @@ 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 --rerun. -ensureStdGen :: Config -> IO Config -ensureStdGen c = case QC.replay qcArgs of +-- Add a seed to given config if there is none. That way the same seed is used +-- for all properties. This helps with --seed and --rerun. +ensureSeed :: Config -> IO Config +ensureSeed c = case configQuickCheckSeed c of Nothing -> do - stdGen <- newStdGen - return c {configQuickCheckArgs = qcArgs {QC.replay = Just (stdGen, 0)}} + seed <- newSeed + return c {configQuickCheckSeed = Just (fromIntegral seed)} _ -> return c - where - qcArgs = configQuickCheckArgs c -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. @@ -107,9 +105,10 @@ -- accordingly. hspecWith :: Config -> Spec -> IO Summary hspecWith c_ spec_ = withHandle c_ $ \h -> do - c <- ensureStdGen c_ + c <- ensureSeed c_ let formatter = configFormatter c - seed = (stdGenToInteger . fst . fromJust . QC.replay . configQuickCheckArgs) c + seed = (fromJust . configQuickCheckSeed) c + qcArgs = configQuickCheckArgs c spec | configDryRun c = mapSpecItem markSuccess spec_ | otherwise = spec_ @@ -127,9 +126,9 @@ xs <- map failureRecordPath <$> getFailMessages liftIO $ writeFailureReport FailureReport { failureReportSeed = seed - , failureReportMaxSuccess = QC.maxSuccess (configQuickCheckArgs c) - , failureReportMaxSize = QC.maxSize (configQuickCheckArgs c) - , failureReportMaxDiscardRatio = QC.maxDiscardRatio (configQuickCheckArgs c) + , failureReportMaxSuccess = QC.maxSuccess qcArgs + , failureReportMaxSize = QC.maxSize qcArgs + , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs , failureReportPaths = xs } 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 @@ -6,16 +6,12 @@ , filterPredicate , formatRequirement , strip -, stdGenToInteger -, stdGenFromInteger ) where -import Data.Int (Int32) import Data.List import Data.Char (isSpace) import Control.Applicative import qualified Control.Exception as E -import System.Random (StdGen) -- | Create a more readable display of a quantity of something. -- @@ -90,17 +86,3 @@ 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) diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -34,6 +34,7 @@ import Test.Hspec.Meta import Test.QuickCheck hiding (Result(..)) +import Test.QuickCheck.Random import qualified Test.Hspec as H import qualified Test.Hspec.Core as H (Params(..), Item(..), ProgressCallback, mapSpecItem) @@ -64,7 +65,7 @@ | otherwise = x defaultParams :: H.Params -defaultParams = H.Params (H.configQuickCheckArgs H.defaultConfig) (H.configSmallCheckDepth H.defaultConfig) +defaultParams = H.Params stdArgs {replay = Just (mkQCGen 23, 0)} (H.configSmallCheckDepth H.defaultConfig) noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = return () diff --git a/test/Test/Hspec/Core/TypeSpec.hs b/test/Test/Hspec/Core/TypeSpec.hs --- a/test/Test/Hspec/Core/TypeSpec.hs +++ b/test/Test/Hspec/Core/TypeSpec.hs @@ -15,10 +15,10 @@ main = hspec spec evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result -evaluateExample e = H.evaluateExample e (defaultParams {H.paramsQuickCheckArgs = (H.paramsQuickCheckArgs defaultParams) {replay = Just (read "", 0)}}) ($ ()) noOpProgressCallback +evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result -evaluateExampleWith action e = H.evaluateExample e (defaultParams {H.paramsQuickCheckArgs = (H.paramsQuickCheckArgs defaultParams) {replay = Just (read "", 0)}}) (action . ($ ())) noOpProgressCallback +evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback spec :: Spec spec = do @@ -73,7 +73,7 @@ it "shows what falsified it" $ do H.Fail r <- evaluateExample $ property $ \x y -> x + y == (x * y :: Int) r `shouldBe` intercalate "\n" [ - "Falsifiable (after 1 test and 2 shrinks): " + "Falsifiable (after 2 tests and 2 shrinks): " , "0" , "1" ] @@ -93,7 +93,7 @@ it "shows what falsified it" $ do H.Fail r <- evaluateExample $ property $ \x y -> x + y `shouldBe` (x * y :: Int) r `shouldBe` intercalate "\n" [ - "Falsifiable (after 1 test and 2 shrinks): " + "Falsifiable (after 2 tests and 2 shrinks): " , "expected: 0" , " but got: 1" , "0" 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 @@ -88,16 +88,14 @@ it "reuses the same seed" $ do let runSpec_ = (captureLines . ignoreExitCode . H.hspec) $ do H.it "foo" $ property $ (/= (26 :: Integer)) - - r0 <- withArgs ["--seed", "2413421499272008081"] runSpec_ + r0 <- withArgs ["--seed", "42"] runSpec_ r0 `shouldContain` [ - "Falsifiable (after 66 tests): " + "Falsifiable (after 31 tests): " , "26" ] - r1 <- withArgs ["-r"] runSpec_ r1 `shouldContain` [ - "Falsifiable (after 66 tests): " + "Falsifiable (after 31 tests): " , "26" ] @@ -294,11 +292,11 @@ context "with --seed" $ do it "uses specified seed" $ do - r <- captureLines . ignoreExitCode . withArgs ["--seed", "2413421499272008081"] . H.hspec $ do + r <- captureLines . ignoreExitCode . withArgs ["--seed", "42"] . H.hspec $ do H.it "foo" $ property (/= (26 :: Integer)) r `shouldContain` [ - "Falsifiable (after 66 tests): " + "Falsifiable (after 31 tests): " , "26" ] @@ -308,13 +306,13 @@ H.it "foo" $ property $ \n -> ((17 + 31 * n) `mod` 50) /= (23 :: Integer) r0 <- runSpec ["--seed", "23"] - r0 `shouldContain` "(after 88 tests)" + r0 `shouldContain` "(after 27 tests)" r1 <- runSpec ["--seed", "42"] - r1 `shouldContain` "(after 48 tests)" + r1 `shouldContain` "(after 31 tests)" r2 <- runSpec ["--rerun", "--seed", "23"] - r2 `shouldContain` "(after 88 tests)" + r2 `shouldContain` "(after 27 tests)" context "when given an invalid argument" $ do let run = withArgs ["--seed", "foo"] . H.hspec $ 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 @@ -1,9 +1,6 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.UtilSpec (main, spec) where import Helper -import Data.Int (Int32) -import System.Random (StdGen) import qualified Control.Exception as E import Test.Hspec.Util @@ -90,19 +87,3 @@ it "properly handles context after a subject that consists of several components" $ do formatRequirement (["Data", "List", "reverse", "when applied twice"], "reverses a list") `shouldBe` "Data.List.reverse, when applied twice, reverses a list" - - describe "stdGenToInteger" $ do - it "is inverse to stdGenFromInteger" $ property $ - \(NonNegative i) -> (stdGenToInteger . stdGenFromInteger) i `shouldBe` i - - describe "stdGenFromInteger" $ do - it "is inverse to stdGenToInteger" $ property $ - \stdGen -> (stdGenFromInteger . stdGenToInteger) stdGen `shouldBe` stdGen - -instance Eq StdGen where - a == b = show a == show b - -instance Arbitrary StdGen where - arbitrary = do - (Positive a, Positive b) <- arbitrary - return $ read (show (a :: Int32) ++ " " ++ show (b :: Int32))