hspec-core-2.2.4/0000755000000000000000000000000012770132510011733 5ustar0000000000000000hspec-core-2.2.4/LICENSE0000644000000000000000000000226112770132510012741 0ustar0000000000000000Copyright (c) 2011-2015 Simon Hengel Copyright (c) 2011-2012 Trystan Spangler Copyright (c) 2011-2011 Greg Weber 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: 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-core-2.2.4/hspec-core.cabal0000644000000000000000000000623312770132510014753 0ustar0000000000000000-- This file has been generated from package.yaml by hpack version 0.14.1. -- -- see: https://github.com/sol/hpack name: hspec-core version: 2.2.4 license: MIT license-file: LICENSE copyright: (c) 2011-2015 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple cabal-version: >= 1.10 category: Testing stability: experimental bug-reports: https://github.com/hspec/hspec/issues homepage: http://hspec.github.io/ synopsis: A Testing Framework for Haskell description: This package exposes internal types and functions that can be used to extend Hspec's functionality. source-repository head type: git location: https://github.com/hspec/hspec subdir: hspec-core library hs-source-dirs: src ghc-options: -Wall build-depends: base >= 4.3 && < 5 , random , tf-random , setenv , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 , deepseq , HUnit >= 1.2.5 , QuickCheck >= 2.5.1 , quickcheck-io , hspec-expectations == 0.7.2.* , async >= 2 exposed-modules: Test.Hspec.Core.Spec Test.Hspec.Core.Hooks Test.Hspec.Core.Runner Test.Hspec.Core.Formatters Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules: Test.Hspec.Compat Test.Hspec.Config Test.Hspec.Core.Example Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Tree Test.Hspec.FailureReport Test.Hspec.Options Test.Hspec.Timer Paths_hspec_core default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test , src ghc-options: -Wall build-depends: base >= 4.3 && < 5 , random , tf-random , setenv , ansi-terminal >= 0.5 , time , transformers >= 0.2.2.0 , deepseq , HUnit >= 1.2.5 , QuickCheck >= 2.5.1 , quickcheck-io , hspec-expectations == 0.7.2.* , async >= 2 , hspec-meta >= 2.2.0 , silently >= 1.2.4 , process other-modules: Helper Mock Test.Hspec.CompatSpec Test.Hspec.Core.ExampleSpec Test.Hspec.Core.FormattersSpec Test.Hspec.Core.HooksSpec Test.Hspec.Core.QuickCheckUtilSpec Test.Hspec.Core.RunnerSpec Test.Hspec.Core.SpecSpec Test.Hspec.Core.UtilSpec Test.Hspec.FailureReportSpec Test.Hspec.OptionsSpec Test.Hspec.TimerSpec Test.Hspec.Compat Test.Hspec.Config Test.Hspec.Core.Example Test.Hspec.Core.Formatters Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Tree Test.Hspec.Core.Util Test.Hspec.FailureReport Test.Hspec.Options Test.Hspec.Timer default-language: Haskell2010 hspec-core-2.2.4/Setup.lhs0000644000000000000000000000011412770132510013537 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hspec-core-2.2.4/test/0000755000000000000000000000000012770132510012712 5ustar0000000000000000hspec-core-2.2.4/test/Spec.hs0000644000000000000000000000006112770132510014135 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} hspec-core-2.2.4/test/Helper.hs0000644000000000000000000000505212770132510014467 0ustar0000000000000000module Helper ( module Test.Hspec.Meta , module Test.Hspec.Compat , module Test.QuickCheck , module System.IO.Silently , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary , ignoreExitCode , ignoreUserInterrupt , throwException , shouldUseArgs , removeLocations ) where import Prelude () import Test.Hspec.Compat import Data.List import Data.Char import Control.Monad import System.Environment (withArgs) import System.Exit import Control.Concurrent import qualified Control.Exception as E import qualified System.Timeout as System import Data.Time.Clock.POSIX import System.IO.Silently import Test.Hspec.Meta import Test.QuickCheck hiding (Result(..)) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.QuickCheckUtil (mkGen) throwException :: IO () throwException = E.throwIO (E.ErrorCall "foobar") ignoreExitCode :: IO () -> IO () ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () ignoreUserInterrupt :: IO () -> IO () ignoreUserInterrupt action = E.catchJust (guard . (== E.UserInterrupt)) action return captureLines :: IO a -> IO [String] captureLines = fmap lines . capture_ -- replace times in summary with zeroes normalizeSummary :: [String] -> [String] normalizeSummary = map f where f x | "Finished in " `isPrefixOf` x = map g x | otherwise = x g x | isNumber x = '0' | otherwise = x defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}} noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = return () sleep :: POSIXTime -> IO () sleep = threadDelay . floor . (* 1000000) timeout :: POSIXTime -> IO a -> IO (Maybe a) timeout = System.timeout . floor . (* 1000000) shouldUseArgs :: [String] -> (Args -> Bool) -> Expectation shouldUseArgs args p = do spy <- newIORef (H.paramsQuickCheckArgs defaultParams) let interceptArgs item = item {H.itemExample = \params action progressCallback -> writeIORef spy (H.paramsQuickCheckArgs params) >> H.itemExample item params action progressCallback} spec = H.mapSpecItem_ interceptArgs $ H.it "foo" False (silence . ignoreExitCode . withArgs args . H.hspec) spec readIORef spy >>= (`shouldSatisfy` p) removeLocations :: H.SpecWith a -> H.SpecWith a removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing}) hspec-core-2.2.4/test/Mock.hs0000644000000000000000000000046712770132510014146 0ustar0000000000000000module Mock where import Prelude () import Test.Hspec.Compat newtype Mock = Mock (IORef Int) newMock :: IO Mock newMock = Mock <$> newIORef 0 mockAction :: Mock -> IO () mockAction (Mock ref) = modifyIORef ref succ mockCounter :: Mock -> IO Int mockCounter (Mock ref) = readIORef ref hspec-core-2.2.4/test/Test/0000755000000000000000000000000012770132510013631 5ustar0000000000000000hspec-core-2.2.4/test/Test/Hspec/0000755000000000000000000000000012770132510014673 5ustar0000000000000000hspec-core-2.2.4/test/Test/Hspec/CompatSpec.hs0000644000000000000000000000154612770132510017273 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.CompatSpec (main, spec) where import Helper import System.SetEnv import Data.Typeable data SomeType = SomeType deriving Typeable main :: IO () main = hspec spec 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 showFullType SomeType `shouldBe` "Test.Hspec.CompatSpec.SomeType" describe "lookupEnv" $ do it "returns value of specified environment variable" $ do setEnv "FOO" "bar" lookupEnv "FOO" `shouldReturn` Just "bar" it "returns Nothing if specified environment variable is not set" $ do unsetEnv "FOO" lookupEnv "FOO" `shouldReturn` Nothing hspec-core-2.2.4/test/Test/Hspec/FailureReportSpec.hs0000644000000000000000000000101512770132510020622 0ustar0000000000000000module Test.Hspec.FailureReportSpec (main, spec) where import Helper import System.IO import qualified Control.Exception as E import Test.Hspec.FailureReport main :: IO () main = hspec spec spec :: Spec spec = do describe "writeFailureReport" $ do it "prints a warning on unexpected exceptions" $ do r <- hCapture_ [stderr] $ writeFailureReport (E.throw (E.ErrorCall "some error")) r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" hspec-core-2.2.4/test/Test/Hspec/TimerSpec.hs0000644000000000000000000000114412770132510017122 0ustar0000000000000000module Test.Hspec.TimerSpec (main, spec) where import Helper import Test.Hspec.Timer main :: IO () main = hspec spec spec :: Spec spec = do describe "timer action returned by newTimer" $ do let dt = 0.01 it "returns False" $ do timer <- newTimer dt timer `shouldReturn` False context "after specified time" $ do it "returns True" $ do timer <- newTimer dt sleep dt timer `shouldReturn` True timer `shouldReturn` False sleep dt sleep dt timer `shouldReturn` True timer `shouldReturn` False hspec-core-2.2.4/test/Test/Hspec/OptionsSpec.hs0000644000000000000000000000375312770132510017505 0ustar0000000000000000module Test.Hspec.OptionsSpec (main, spec) where import Control.Monad import Helper import System.Exit import qualified Test.Hspec.Options as Options import Test.Hspec.Options hiding (parseOptions) main :: IO () main = hspec spec fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft _ = error "fromLeft: No left value!" spec :: Spec spec = do describe "parseOptions" $ do let parseOptions = Options.parseOptions defaultConfig "my-spec" it "sets configColorMode to ColorAuto" $ do configColorMode <$> parseOptions [] `shouldBe` Right ColorAuto context "with --no-color" $ do it "sets configColorMode to ColorNever" $ do configColorMode <$> parseOptions ["--no-color"] `shouldBe` Right ColorNever context "with --color" $ do it "sets configColorMode to ColorAlways" $ do configColorMode <$> parseOptions ["--color"] `shouldBe` Right ColorAlways context "with --out" $ do it "sets configOutputFile" $ do either (const Nothing) Just . configOutputFile <$> parseOptions ["--out", "foo"] `shouldBe` Right (Just "foo") context "with --qc-max-success" $ do context "when given an invalid argument" $ do it "returns an error message" $ do fromLeft (parseOptions ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n") context "with --depth" $ do it "sets depth parameter for SmallCheck" $ do configSmallCheckDepth <$> parseOptions ["--depth", "23"] `shouldBe` Right 23 context "with --jobs" $ do it "sets number of concurrent jobs" $ do configConcurrentJobs <$> parseOptions ["--jobs=23"] `shouldBe` Right (Just 23) it "rejects values < 1" $ do let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" void (parseOptions ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) hspec-core-2.2.4/test/Test/Hspec/Core/0000755000000000000000000000000012770132510015563 5ustar0000000000000000hspec-core-2.2.4/test/Test/Hspec/Core/QuickCheckUtilSpec.hs0000644000000000000000000000154612770132510021610 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Test.Hspec.Core.QuickCheckUtilSpec (main, spec) where import Helper import Test.QuickCheck import Test.Hspec.Core.QuickCheckUtil main :: IO () main = hspec spec spec :: Spec spec = do describe "formatNumbers" $ do it "includes number of tests" $ do formatNumbers (failure 1 0) `shouldBe` "(after 1 test)" it "pluralizes number of tests" $ do formatNumbers (failure 3 0) `shouldBe` "(after 3 tests)" it "includes number of shrinks" $ do formatNumbers (failure 3 1) `shouldBe` "(after 3 tests and 1 shrink)" it "pluralizes number of shrinks" $ do formatNumbers (failure 3 3) `shouldBe` "(after 3 tests and 3 shrinks)" where failure tests shrinks = Failure { numTests = tests , numShrinks = shrinks } hspec-core-2.2.4/test/Test/Hspec/Core/ExampleSpec.hs0000644000000000000000000001216212770132510020327 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} module Test.Hspec.Core.ExampleSpec (main, spec) where import Helper import Mock import Data.List import qualified Control.Exception as E import qualified Test.Hspec.Core.Example as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H main :: IO () main = hspec spec evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result 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 (action . ($ ())) noOpProgressCallback spec :: Spec spec = do describe "evaluateExample" $ do context "for Bool" $ do it "returns Success on True" $ do evaluateExample True `shouldReturn` H.Success it "returns Fail on False" $ do evaluateExample False `shouldReturn` H.Fail Nothing "" it "propagates exceptions" $ do evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" context "for Expectation" $ do it "returns Success if all expectations hold" $ do evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success it "returns Fail if an expectation does not hold" $ do H.Fail _ msg <- evaluateExample (23 `shouldBe` (42 :: Int)) msg `shouldEndWith` "expected: 42\n but got: 23" it "propagates exceptions" $ do evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" it "runs provided action around expectation" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do n <- readIORef ref e readIORef ref `shouldReturn` succ n modifyIORef ref succ evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` H.Success readIORef ref `shouldReturn` 2 context "when used with `pending`" $ do it "returns Pending" $ do evaluateExample (H.pending) `shouldReturn` H.Pending Nothing context "when used with `pendingWith`" $ do it "includes the optional reason" $ do evaluateExample (H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") context "for Property" $ do it "returns Success if property holds" $ do evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` H.Success it "returns Fail if property does not hold" $ do H.Fail _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int) return () it "shows what falsified it" $ do H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False r `shouldBe` intercalate "\n" [ "Falsifiable (after 1 test): " , "0" , "1" ] it "runs provided action around each single check of the property" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do n <- readIORef ref e readIORef ref `shouldReturn` succ n modifyIORef ref succ H.Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) readIORef ref `shouldReturn` 2000 it "pretty-prints exceptions" $ do H.Fail _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool)) r `shouldBe` intercalate "\n" [ #if MIN_VERSION_QuickCheck(2,7,0) "uncaught exception: ErrorCall (foobar) (after 1 test)" #else "Exception: 'foobar' (after 1 test): " #endif , "0" ] context "when used with shouldBe" $ do it "shows what falsified it" $ do H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int) r `shouldStartWith` "Falsifiable (after 1 test): \n" r `shouldEndWith` intercalate "\n" [ "expected: 42" , " but got: 23" , "0" , "1" ] context "when used with `pending`" $ do it "returns Pending" $ do evaluateExample (property H.pending) `shouldReturn` H.Pending Nothing context "when used with `pendingWith`" $ do it "includes the optional reason" $ do evaluateExample (property $ H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") describe "Expectation" $ do context "as a QuickCheck property" $ do it "can be quantified" $ do e <- newMock silence . H.hspec $ do H.it "some behavior" $ property $ \xs -> do mockAction e (reverse . reverse) xs `shouldBe` (xs :: [Int]) mockCounter e `shouldReturn` 100 it "can be used with expectations/HUnit assertions" $ do silence . H.hspecResult $ do H.describe "readIO" $ do H.it "is inverse to show" $ property $ \x -> do (readIO . show) x `shouldReturn` (x :: Int) `shouldReturn` H.Summary 1 0 hspec-core-2.2.4/test/Test/Hspec/Core/HooksSpec.hs0000644000000000000000000002627212770132510020026 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (main, spec) where import Prelude () import Helper import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Hooks as H main :: IO () main = hspec spec runSilent :: H.Spec -> IO () runSilent = silence . H.hspec mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do ref <- newIORef ([] :: [String]) let rec n = modifyIORef ref (++ [n]) return (rec, readIORef ref) spec :: Spec spec = do describe "before" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> do rec (value ++ " foo") H.it "bar" $ \value -> do rec (value ++ " bar") retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] context "when used multiple times" $ do it "is evaluated outside in" $ do pending context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] context "when used multiple times" $ do it "is evaluated outside in" $ do pending describe "before_" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` ["before", "foo", "before", "bar"] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` ["outer", "inner", "foo"] context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 200 . cycle) ["before", "foo"] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 300 . cycle) ["outer", "inner", "foo"] describe "beforeWith" $ do it "transforms spec argument" $ do (rec, retrieve) <- mkAppend let action :: Int -> IO String action = return . show runSilent $ H.before (return 23) $ H.beforeWith action $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["23"] it "can be used multiple times" $ do let action1 :: Int -> IO Int action1 = return . succ action2 :: Int -> IO String action2 = return . show action3 :: String -> IO String action3 = return . ("foo " ++) (rec, retrieve) <- mkAppend runSilent $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["foo 24"] describe "beforeAll" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do H.it "foo" $ \value -> do rec $ "foo " ++ value H.it "bar" $ \value -> do rec $ "bar " ++ value retrieve `shouldReturn` [ "beforeAll" , "foo value" , "bar value" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do return () retrieve `shouldReturn` [] context "when used multiple times" $ do it "is evaluated outside in" $ do pending describe "beforeAll_" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll_ (rec "beforeAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "beforeAll_" , "foo" , "bar" ] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "outer" , "inner" , "foo" , "bar" ] describe "after" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "from before" , "before" , "bar" , "from before" ] it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend silence . ignoreExitCode . H.hspec $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do ioError $ userError "foo" :: IO () rec "foo" retrieve `shouldReturn` ["before", "from before"] context "when used multiple times" $ do it "is evaluated inside out" $ do pending describe "after_" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.after_ (rec "after") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "foo" , "after" , "bar" , "after" ] it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend silence . ignoreExitCode $ H.hspec $ H.after_ (rec "after") $ do H.it "foo" $ do ioError $ userError "foo" :: IO () rec "foo" retrieve `shouldReturn` ["after"] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend runSilent $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "foo" , "after inner" , "after outer" ] describe "afterAll" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "before" , "bar" , "before" , "from before" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do return () retrieve `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do r <- runSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do H.it "foo" $ \a -> a `shouldBe` "from before" r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") describe "afterAll_" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "before" , "bar" , "before" , "afterAll_" ] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend runSilent $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "foo" , "after inner" , "after outer" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.afterAll_ (rec "afterAll_") $ do return () retrieve `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do r <- runSpec $ do H.afterAll_ throwException $ do H.it "foo" True r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") describe "around" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e "from around" >> rec "after" runSilent $ H.around action $ do H.it "foo" $ rec . ("foo " ++) H.it "bar" $ rec . ("bar " ++) retrieve `shouldReturn` [ "before" , "foo from around" , "after" , "before" , "bar from around" , "after" ] context "when used multiple times" $ do it "is evaluated outside in" $ do pending describe "around_" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e >> rec "after" runSilent $ H.around_ action $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "after" , "before" , "bar" , "after" ] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend let actionOuter e = rec "before outer" >> e >> rec "after outer" actionInner e = rec "before inner" >> e >> rec "after inner" runSilent $ H.around_ actionOuter $ H.around_ actionInner $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "before outer" , "before inner" , "foo" , "after inner" , "after outer" ] describe "aroundWith" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action :: H.ActionWith String -> H.ActionWith Int action e = e . show runSilent $ H.before (return 23) $ H.aroundWith action $ do H.it "foo" rec retrieve `shouldReturn` ["23"] where runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult hspec-core-2.2.4/test/Test/Hspec/Core/FormattersSpec.hs0000644000000000000000000002102112770132510021054 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.FormattersSpec (main, spec) where import Prelude () import Helper import qualified Control.Exception as E import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H #ifndef mingw32_HOST_OS import System.Console.ANSI #endif main :: IO () main = hspec spec testSpec :: H.Spec testSpec = do H.describe "Example" $ do H.it "success" (H.Success) H.it "fail 1" (H.Fail Nothing "fail message") H.it "pending" (H.pendingWith "pending message") H.it "fail 2" (H.Fail Nothing "") H.it "exceptions" (undefined :: H.Result) H.it "fail 3" (H.Fail Nothing "") spec :: Spec spec = do describe "silent" $ do let runSpec = fmap fst . capture . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} it "produces no output" $ do runSpec testSpec `shouldReturn` "" describe "failed_examples" $ do failed_examplesSpec H.failed_examples describe "progress" $ do let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.progress} it "produces '..F...FF.F' style output" $ do r <- runSpec testSpec head r `shouldBe` ".F.FFF" context "same as failed_examples" $ do failed_examplesSpec H.progress describe "specdoc" $ do let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.specdoc} it "displays a header for each thing being described" $ do _:x:_ <- runSpec testSpec x `shouldBe` "Example" it "displays one row for each behavior" $ do r <- runSpec $ do H.describe "List as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True H.describe "Maybe as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True normalizeSummary r `shouldBe` [ "" , "List as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "Maybe as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "" , "Finished in 0.0000 seconds" , "6 examples, 0 failures" ] it "outputs an empty line at the beginning (even for non-nested specs)" $ do r <- runSpec $ do H.it "example 1" True H.it "example 2" True normalizeSummary r `shouldBe` [ "" , "example 1" , "example 2" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] it "displays a row for each successfull, failed, or pending example" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " fail 1 FAILED [1]") r `shouldSatisfy` any (== " success") it "displays a '#' with an additional message for pending examples" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " # PENDING: pending message") context "with an empty group" $ do it "omits that group from the report" $ do r <- runSpec $ do H.describe "foo" $ do H.it "example 1" True H.describe "bar" $ do return () H.describe "baz" $ do H.it "example 2" True normalizeSummary r `shouldBe` [ "" , "foo" , " example 1" , "baz" , " example 2" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] context "same as failed_examples" $ do failed_examplesSpec H.progress failed_examplesSpec :: H.Formatter -> Spec failed_examplesSpec formatter = do let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} it "summarizes the time it takes to finish" $ do r <- runSpec (return ()) normalizeSummary r `shouldSatisfy` any (== "Finished in 0.0000 seconds") context "displays a detailed list of failures" $ do it "prints all requirements that are not met" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " 1) Example fail 1") it "prints the exception type for requirements that fail due to an uncaught exception" $ do r <- runSpec $ do H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool) r `shouldContain` [ " 1) foobar" , " uncaught exception: ErrorCall (baz)" ] it "prints all descriptions when a nested requirement fails" $ do r <- runSpec $ H.describe "foo" $ do H.describe "bar" $ do H.it "baz" False r `shouldSatisfy` any (== " 1) foo.bar baz") context "when a failed example has a source location" $ do let bestEffortExplanation = "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." it "includes the source locations above the error messages" $ do let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldContain` [" test/FooSpec.hs:23: ", " 1) foo"] context "when source location is exact" $ do it "includes that source locations" $ do let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldSatisfy` any (== " test/FooSpec.hs:23: ") it "does not include 'best-effort' explanation" $ do let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldSatisfy` all (/= bestEffortExplanation) context "when source location is best-effort" $ do it "marks that source location as 'best-effort'" $ do let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldSatisfy` any (== " test/FooSpec.hs:23: (best-effort)") it "includes 'best-effort' explanation" $ do let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldSatisfy` any (== bestEffortExplanation) it "summarizes the number of examples and failures" $ do r <- runSpec testSpec r `shouldSatisfy` any (== "6 examples, 4 failures, 1 pending") -- Windows has no support for ANSI escape codes. The Console API is used for -- colorized output, hence the following tests do not work on Windows. #ifndef mingw32_HOST_OS it "shows summary in green if there are no failures" $ do r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do H.it "foobar" True r `shouldSatisfy` any (== (green ++ "1 example, 0 failures" ++ reset)) it "shows summary in yellow if there are pending examples" $ do r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do H.it "foobar" H.pending r `shouldSatisfy` any (== (yellow ++ "1 example, 0 failures, 1 pending" ++ reset)) it "shows summary in red if there are failures" $ do r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do H.it "foobar" False r `shouldSatisfy` any (== (red ++ "1 example, 1 failure" ++ reset)) it "shows summary in red if there are both failures and pending examples" $ do r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do H.it "foo" False H.it "bar" H.pending r `shouldSatisfy` any (== (red ++ "2 examples, 1 failure, 1 pending" ++ reset)) where green = setSGRCode [SetColor Foreground Dull Green] yellow = setSGRCode [SetColor Foreground Dull Yellow] red = setSGRCode [SetColor Foreground Dull Red] reset = setSGRCode [Reset] #endif hspec-core-2.2.4/test/Test/Hspec/Core/SpecSpec.hs0000644000000000000000000000512612770132510017630 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Test.Hspec.Core.SpecSpec (main, spec) where import Prelude () import Helper import Test.Hspec.Core.Spec (Item(..), Result(..)) import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.Spec (Tree(..), runSpecM) import qualified Test.Hspec.Core.Spec as H main :: IO () main = hspec spec runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult spec :: Spec spec = do describe "describe" $ do it "can be nested" $ do [Node foo [Node bar [Leaf _]]] <- runSpecM $ do H.describe "foo" $ do H.describe "bar" $ do H.it "baz" True (foo, bar) `shouldBe` ("foo", "bar") context "when no description is given" $ do it "uses a default description" $ do [Node d _] <- runSpecM (H.describe "" (pure ())) d `shouldBe` "(no description given)" describe "it" $ do it "takes a description of a desired behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) itemRequirement item `shouldBe` "whatever" it "takes an example of that behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success #ifdef HAS_SOURCE_LOCATIONS it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) let location = H.Location __FILE__ (pred $ __LINE__) 32 H.ExactLocation itemLocation item `shouldBe` Just location #endif context "when no description is given" $ do it "uses a default description" $ do [Leaf item] <- runSpecM (H.it "" True) itemRequirement item `shouldBe` "(unspecified behavior)" describe "pending" $ do it "specifies a pending example" $ do r <- runSpec $ do H.it "foo" H.pending r `shouldSatisfy` any (== " # PENDING: No reason given") describe "pendingWith" $ do it "specifies a pending example with a reason for why it's pending" $ do r <- runSpec $ do H.it "foo" $ do H.pendingWith "for some reason" r `shouldSatisfy` any (== " # PENDING: for some reason") describe "parallel" $ do it "marks examples for parallel execution" $ do [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" True itemIsParallelizable item `shouldBe` True it "is applied recursively" $ do [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do H.describe "foo" $ do H.describe "bar" $ do H.it "baz" True itemIsParallelizable item `shouldBe` True hspec-core-2.2.4/test/Test/Hspec/Core/RunnerSpec.hs0000644000000000000000000004011512770132510020204 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.RunnerSpec (main, spec) where import Prelude () import Helper import System.IO (stderr) import Control.Monad (replicateM_) import System.Environment (withArgs, withProgName, getArgs) import System.Exit import Control.Concurrent import qualified Control.Exception as E import Mock import System.SetEnv import Test.Hspec.FailureReport (FailureReport(..)) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H (silent) import qualified Test.Hspec.Core.QuickCheck as H import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H main :: IO () main = hspec spec quickCheckOptions :: [([Char], Args -> Int)] quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] runPropFoo :: [String] -> IO String runPropFoo args = unlines . normalizeSummary . lines <$> do capture_ . ignoreExitCode . withArgs args . H.hspec . H.modifyMaxSuccess (const 1000000) $ do H.it "foo" $ do property (/= (23 :: Int)) spec :: Spec spec = do describe "hspec" $ do it "runs a spec" $ do silence . H.hspec $ do H.it "foobar" True `shouldReturn` () it "exits with exitFailure if not all examples pass" $ do silence . H.hspec $ do H.it "foobar" False `shouldThrow` (== ExitFailure 1) it "allows output to stdout" $ do r <- captureLines . H.hspec $ do H.it "foobar" $ do putStrLn "baz" r `shouldSatisfy` elem "baz" it "prints an error message on unrecognized command-line options" $ do withProgName "myspec" . withArgs ["--foo"] $ do hSilence [stderr] (H.hspec $ pure ()) `shouldThrow` (== ExitFailure 1) fst `fmap` hCapture [stderr] (ignoreExitCode (H.hspec $ pure ())) `shouldReturn` unlines [ "myspec: unrecognized option `--foo'" , "Try `myspec --help' for more information." ] it "stores a failure report in the environment" $ do silence . ignoreExitCode . withArgs ["--seed", "23"] . H.hspec $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" True H.it "example 2" False H.describe "baz" $ do H.it "example 3" False lookupEnv "HSPEC_FAILURES" `shouldReturn` (Just . show) FailureReport { failureReportSeed = 23 , failureReportMaxSuccess = 100 , failureReportMaxSize = 100 , failureReportMaxDiscardRatio = 10 , failureReportPaths = [ (["foo", "bar"], "example 2") , (["baz"], "example 3") ] } describe "with --rerun" $ do let runSpec = (captureLines . ignoreExitCode . H.hspec) $ do H.it "example 1" True H.it "example 2" False H.it "example 3" False H.it "example 4" True H.it "example 5" False it "reruns examples that previously failed" $ do r0 <- runSpec r0 `shouldSatisfy` elem "5 examples, 3 failures" r1 <- withArgs ["--rerun"] runSpec r1 `shouldSatisfy` elem "3 examples, 3 failures" it "reuses the same seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun"] `shouldReturn` r forM_ quickCheckOptions $ \(flag, accessor) -> do it ("reuses same " ++ flag) $ do [flag, "23"] `shouldUseArgs` ((== 23) . accessor) ["--rerun"] `shouldUseArgs` ((== 23) . accessor) context "when no examples failed previously" $ do it "runs all examples" $ do let run = capture_ . H.hspec $ do H.it "example 1" True H.it "example 2" True H.it "example 3" True r0 <- run r0 `shouldContain` "3 examples, 0 failures" r1 <- withArgs ["--rerun"] run r1 `shouldContain` "3 examples, 0 failures" context "when there is no failure report in the environment" $ do it "runs everything" $ do unsetEnv "HSPEC_FAILURES" r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do unsetEnv "HSPEC_FAILURES" r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" context "when parsing of failure report fails" $ do it "runs everything" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" it "does not leak command-line flags to examples" $ do silence . withArgs ["--verbose"] $ do H.hspec $ do H.it "foobar" $ do getArgs `shouldReturn` [] `shouldReturn` () context "when interrupted with ctrl-c" $ do it "prints summary immediately" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do r <- captureLines . ignoreUserInterrupt . withArgs ["--seed", "23"] . H.hspec . removeLocations $ do H.it "foo" False H.it "bar" $ do putMVar sync () threadDelay 1000000 H.it "baz" True putMVar mvar r takeMVar sync throwTo threadId E.UserInterrupt r <- takeMVar mvar normalizeSummary r `shouldBe` [ "" , "foo FAILED [1]" , "" , "Failures:" , "" , " 1) foo" , "" , "Randomized with seed 23" , "" ] it "throws UserInterrupt" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do silence . H.hspec $ do H.it "foo" $ do putMVar sync () threadDelay 1000000 `E.catch` putMVar mvar takeMVar sync throwTo threadId E.UserInterrupt takeMVar mvar `shouldReturn` E.UserInterrupt context "with --help" $ do let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure () it "prints help" $ do r <- (captureLines . ignoreExitCode) printHelp r `shouldStartWith` ["Usage: spec [OPTION]..."] silence printHelp `shouldThrow` (== ExitSuccess) it "constrains lines to 80 characters" $ do r <- (captureLines . ignoreExitCode) printHelp r `shouldSatisfy` all ((<= 80) . length) r `shouldSatisfy` any ((78 <=) . length) context "with --dry-run" $ do let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec it "produces a report" $ do r <- withDryRun $ do H.it "foo" True H.it "bar" True normalizeSummary r `shouldBe` [ "" , "foo" , "bar" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] it "does not verify anything" $ do e <- newMock _ <- withDryRun $ do H.it "foo" (mockAction e) H.it "bar" False mockCounter e `shouldReturn` 0 it "ignores afterAll-hooks" $ do ref <- newIORef False _ <- withDryRun $ do H.afterAll_ (writeIORef ref True) $ do H.it "bar" True readIORef ref `shouldReturn` False context "with --fail-fast" $ do it "stops after first failure" $ do r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do H.it "foo" True H.it "bar" False H.it "baz" False normalizeSummary r `shouldBe` [ "" , "foo" , "bar FAILED [1]" , "" , "Failures:" , "" , " 1) bar" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "2 examples, 1 failure" ] it "works for nested specs" $ do r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do H.describe "foo" $ do H.it "bar" False H.it "baz" True normalizeSummary r `shouldBe` [ "" , "foo" , " bar FAILED [1]" , "" , "Failures:" , "" , " 1) foo bar" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "with --match" $ do it "only runs examples that match a given pattern" $ do e1 <- newMock e2 <- newMock e3 <- newMock silence . withArgs ["-m", "/bar/example"] . H.hspec $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" $ mockAction e1 H.it "example 2" $ mockAction e2 H.describe "baz" $ do H.it "example 3" $ mockAction e3 (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 1, 0) it "only runs examples that match a given pattern (-m and --skip combined)" $ do e1 <- newMock e2 <- newMock e3 <- newMock e4 <- newMock silence . withArgs ["-m", "/bar/example", "--skip", "example 3"] . H.hspec $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" $ mockAction e1 H.it "example 2" $ mockAction e2 H.it "example 3" $ mockAction e3 H.describe "baz" $ do H.it "example 4" $ mockAction e4 (,,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 <*> mockCounter e4 `shouldReturn` (1, 1, 0, 0) it "can be given multiple times" $ do e1 <- newMock e2 <- newMock e3 <- newMock silence . withArgs ["-m", "foo", "-m", "baz"] . H.hspec $ do H.describe "foo" $ do H.it "example 1" $ mockAction e1 H.describe "bar" $ do H.it "example 2" $ mockAction e2 H.describe "baz" $ do H.it "example 3" $ mockAction e3 (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) context "with --format" $ do it "uses specified formatter" $ do r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do H.it "foo" True H.it "bar" True H.it "baz" False H.it "qux" True r `shouldContain` "..F." context "when given an invalid argument" $ do it "prints an error message to stderr" $ do r <- hCapture_ [stderr] . ignoreExitCode . withArgs ["--format", "foo"] . H.hspec $ do H.it "foo" True r `shouldContain` "invalid argument `foo' for `--format'" context "with --qc-max-success" $ do it "tries QuickCheck properties specified number of times" $ do m <- newMock silence . withArgs ["--qc-max-success", "23"] . H.hspec $ do H.it "foo" $ property $ \(_ :: Int) -> do mockAction m mockCounter m `shouldReturn` 23 context "when run with --rerun" $ do it "takes precedence" $ do ["--qc-max-success", "23"] `shouldUseArgs` ((== 23) . QC.maxSuccess) ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` ((== 42) . QC.maxSuccess) context "with --qc-max-size" $ do it "passes specified size to QuickCheck properties" $ do ["--qc-max-size", "23"] `shouldUseArgs` ((== 23) . QC.maxSize) context "with --qc-max-discard" $ do it "uses specified discard ratio to QuickCheck properties" $ do ["--qc-max-discard", "23"] `shouldUseArgs` ((== 23) . QC.maxDiscardRatio) context "with --seed" $ do it "uses specified seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--seed", "42"] `shouldReturn` r context "when run with --rerun" $ do it "takes precedence" $ do r <- runPropFoo ["--seed", "23"] _ <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun", "--seed", "23"] `shouldReturn` r context "when given an invalid argument" $ do let run = withArgs ["--seed", "foo"] . H.hspec $ do H.it "foo" True it "prints an error message to stderr" $ do r <- hCapture_ [stderr] (ignoreExitCode run) r `shouldContain` "invalid argument `foo' for `--seed'" it "exits with exitFailure" $ do hSilence [stderr] run `shouldThrow` (== ExitFailure 1) context "with --print-cpu-time" $ do it "includes used CPU time in summary" $ do r <- capture_ $ withArgs ["--print-cpu-time"] (H.hspec $ pure ()) (normalizeSummary . lines) r `shouldContain` ["Finished in 0.0000 seconds, used 0.0000 seconds of CPU time"] context "with --html" $ do it "produces HTML output" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" True r `shouldContain` "" it "marks successful examples with CSS class hspec-success" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" True r `shouldContain` "foo\n" it "marks pending examples with CSS class hspec-pending" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" H.pending r `shouldContain` "foo" it "marks failed examples with CSS class hspec-failure" $ do r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do H.it "foo" False r `shouldContain` "foo" describe "hspecResult" $ do it "returns a summary of the test run" $ do silence . H.hspecResult $ do H.it "foo" True H.it "foo" False H.it "foo" False H.it "foo" True H.it "foo" True `shouldReturn` H.Summary 5 2 it "treats uncaught exceptions as failure" $ do silence . H.hspecResult $ do H.it "foobar" throwException `shouldReturn` H.Summary 1 1 it "uses the specdoc formatter by default" $ do _:r:_ <- captureLines . H.hspecResult $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` "Foo.Bar" it "can use a custom formatter" $ do r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` "" it "does not let escape error thunks from failure messages" $ do r <- silence . H.hspecResult $ do H.it "some example" (H.Fail Nothing $ "foobar" ++ undefined) r `shouldBe` H.Summary 1 1 it "runs specs in parallel" $ do let n = 10 t = 0.01 dt = t * (fromIntegral n / 2) r <- timeout dt . silence . withArgs ["-j", show n] . H.hspecResult . H.parallel $ do replicateM_ n (H.it "foo" $ sleep t) r `shouldBe` Just (H.Summary n 0) context "with -j" $ do it "limits parallelism" $ do currentRef <- newIORef (0 :: Int) highRef <- newIORef 0 let n = 10 t = 0.01 j = 2 start = do current <- atomicModifyIORef currentRef $ \x -> let y = succ x in (y, y) atomicModifyIORef highRef $ \x -> (max x current, ()) stop = atomicModifyIORef currentRef $ \x -> (pred x, ()) r <- withArgs ["-j", show j] . H.hspecResult . H.parallel $ do replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t r `shouldBe` H.Summary n 0 high <- readIORef highRef high `shouldBe` j hspec-core-2.2.4/test/Test/Hspec/Core/UtilSpec.hs0000644000000000000000000000775612770132510017666 0ustar0000000000000000module Test.Hspec.Core.UtilSpec (main, spec) where import Helper import Control.Concurrent import qualified Control.Exception as E import Test.Hspec.Core.Util main :: IO () main = hspec spec spec :: Spec spec = do describe "pluralize" $ do it "returns singular when used with 1" $ do pluralize 1 "thing" `shouldBe` "1 thing" it "returns plural when used with number greater 1" $ do pluralize 2 "thing" `shouldBe` "2 things" it "returns plural when used with 0" $ do pluralize 0 "thing" `shouldBe` "0 things" describe "formatException" $ do it "converts exception to string" $ do formatException (E.toException E.DivideByZero) `shouldBe` "ArithException (divide by zero)" context "when used with an IOException" $ do it "includes the IOErrorType" $ do Left e <- E.try (readFile "foo") formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))" 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 "safeTry" $ do it "returns Right on success" $ do Right e <- safeTry (return 23 :: IO Int) e `shouldBe` 23 it "returns Left on exception" $ do Left e <- safeTry throwException show e `shouldBe` "foobar" it "evaluates result to weak head normal form" $ do Left e <- safeTry (return $ E.throw $ E.ErrorCall "foo") show e `shouldBe` "foo" it "does not catch asynchronous exceptions" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do safeTry (putMVar sync () >> threadDelay 1000000) >> return () `E.catch` putMVar mvar takeMVar sync throwTo threadId E.UserInterrupt readMVar mvar `shouldReturn` E.UserInterrupt describe "filterPredicate" $ do it "tries to match a pattern against a path" $ do let p = filterPredicate "foo/bar/example 1" p (["foo", "bar"], "example 1") `shouldBe` True p (["foo", "bar"], "example 2") `shouldBe` False it "is ambiguous" $ do let p = filterPredicate "foo/bar/baz" p (["foo", "bar"], "baz") `shouldBe` True p (["foo"], "bar/baz") `shouldBe` True it "succeeds on a partial match" $ do let p = filterPredicate "bar/baz" p (["foo", "bar", "baz"], "example 1") `shouldBe` True it "succeeds with a pattern that matches the message give in the failure list" $ do let p = filterPredicate "ModuleA.ModuleB.foo does something" p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True describe "formatRequirement" $ do it "creates a sentence from a subject and a requirement" $ do formatRequirement (["reverse"], "reverses a list") `shouldBe` "reverse reverses a list" it "creates a sentence from a subject and a requirement when the subject consits of multiple words" $ do formatRequirement (["The reverse function"], "reverses a list") `shouldBe` "The reverse function reverses a list" it "returns the requirement if no subject is given" $ do formatRequirement ([], "reverses a list") `shouldBe` "reverses a list" it "inserts context separated by commas" $ do formatRequirement (["reverse", "when applied twice"], "reverses a list") `shouldBe` "reverse, when applied twice, reverses a list" it "joins components of a subject with a dot" $ do formatRequirement (["Data", "List", "reverse"], "reverses a list") `shouldBe` "Data.List.reverse reverses a list" 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" hspec-core-2.2.4/src/0000755000000000000000000000000012770132510012522 5ustar0000000000000000hspec-core-2.2.4/src/Test/0000755000000000000000000000000012770132510013441 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/0000755000000000000000000000000012770132510014503 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/Compat.hs0000644000000000000000000000551012770132510016263 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Compat ( getDefaultConcurrentJobs , showType , showFullType , readMaybe , lookupEnv , module Data.IORef , module Prelude , module Control.Applicative , module Data.Foldable , module Data.Traversable , module Data.Monoid #if !MIN_VERSION_base(4,6,0) , modifyIORef' #endif ) where import Control.Applicative import Data.Foldable import Data.Traversable import Data.Monoid import Prelude hiding ( all , and , any , concat , concatMap , elem , foldl , foldl1 , foldr , foldr1 , mapM , mapM_ , maximum , minimum , notElem , or , product , sequence , sequence_ , sum ) #if !MIN_VERSION_base(4,3,0) import Control.Monad.Trans.Error () -- for Monad (Either e) #endif import Data.Typeable (Typeable, typeOf, typeRepTyCon) import Text.Read import Data.IORef import System.Environment #if MIN_VERSION_base(4,4,0) import Data.Typeable.Internal (tyConModule, tyConName) import Control.Concurrent #endif #if !MIN_VERSION_base(4,6,0) import qualified Text.ParserCombinators.ReadP as P #endif getDefaultConcurrentJobs :: IO Int #if MIN_VERSION_base(4,4,0) getDefaultConcurrentJobs = getNumCapabilities #else getDefaultConcurrentJobs = return 1 #endif #if !MIN_VERSION_base(4,6,0) -- |Strict version of 'modifyIORef' modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do x <- readIORef ref let x' = f x x' `seq` writeIORef ref x' -- | Parse a string using the 'Read' instance. -- Succeeds if there is exactly one valid result. -- A 'Left' value indicates a parse error. readEither :: Read a => String -> Either String a readEither s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of [x] -> Right x [] -> Left "Prelude.read: no parse" _ -> Left "Prelude.read: ambiguous parse" where read' = do x <- readPrec lift P.skipSpaces return x -- | Parse a string using the 'Read' instance. -- Succeeds if there is exactly one valid result. readMaybe :: Read a => String -> Maybe a readMaybe s = case readEither s of Left _ -> Nothing Right a -> Just a -- | Return the value of the environment variable @var@, or @Nothing@ if -- there is no such value. -- -- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. lookupEnv :: String -> IO (Maybe String) lookupEnv k = lookup k `fmap` getEnvironment #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 show t #endif hspec-core-2.2.4/src/Test/Hspec/Timer.hs0000644000000000000000000000053012770132510016115 0ustar0000000000000000module Test.Hspec.Timer where import Data.IORef import Data.Time.Clock.POSIX newTimer :: POSIXTime -> IO (IO Bool) newTimer delay = do ref <- getPOSIXTime >>= newIORef return $ do t0 <- readIORef ref t1 <- getPOSIXTime if delay < t1 - t0 then writeIORef ref t1 >> return True else return False hspec-core-2.2.4/src/Test/Hspec/Config.hs0000644000000000000000000000565312770132510016255 0ustar0000000000000000module Test.Hspec.Config ( Config (..) , ColorMode(..) , defaultConfig , getConfig , configAddFilter , configQuickCheckArgs ) where import Control.Applicative import System.IO import System.Exit import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util import Test.Hspec.Options import Test.Hspec.FailureReport import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Example (Params(..), defaultParams) -- | 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 p1 `filterOr` configFilterPredicate c } mkConfig :: Maybe FailureReport -> Config -> Config mkConfig mFailureReport opts = opts { configFilterPredicate = matchFilter `filterOr` rerunFilter , configQuickCheckSeed = mSeed , configQuickCheckMaxSuccess = mMaxSuccess , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio , configQuickCheckMaxSize = mMaxSize } where mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport) mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) matchFilter = configFilterPredicate opts rerunFilter = case failureReportPaths <$> mFailureReport of Just [] -> Nothing Just xs -> Just (`elem` xs) Nothing -> Nothing 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)) (paramsQuickCheckArgs defaultParams) setMaxSuccess :: Int -> QC.Args -> QC.Args setMaxSuccess n args = args {QC.maxSuccess = n} setMaxSize :: Int -> QC.Args -> QC.Args setMaxSize n args = args {QC.maxSize = n} setMaxDiscardRatio :: Int -> QC.Args -> QC.Args setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} setSeed :: Integer -> QC.Args -> QC.Args setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} getConfig :: Config -> 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 configRerun opts then readFailureReport else return Nothing return (mkConfig r opts) exitWithMessage :: ExitCode -> String -> IO a exitWithMessage err msg = do hPutStr h msg exitWith err where h = case err of ExitSuccess -> stdout _ -> stderr hspec-core-2.2.4/src/Test/Hspec/FailureReport.hs0000644000000000000000000000315512770132510017626 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.FailureReport ( FailureReport (..) , writeFailureReport , readFailureReport ) where #ifndef __GHCJS__ import System.SetEnv import Test.Hspec.Core.Util (safeTry) #endif import System.IO import Test.Hspec.Compat import Test.Hspec.Core.Util (Path) data FailureReport = FailureReport { failureReportSeed :: Integer , failureReportMaxSuccess :: Int , failureReportMaxSize :: Int , failureReportMaxDiscardRatio :: Int , failureReportPaths :: [Path] } deriving (Eq, Show, Read) writeFailureReport :: FailureReport -> IO () #ifdef __GHCJS__ writeFailureReport _ = return () -- ghcjs currently does not support setting environment variables -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report -- into the environment is a non-essential feature we just disable this to be -- able to run hspec test-suites with ghcjs at all. Should be reverted once -- the issue is fixed. #else writeFailureReport x = do -- on Windows this can throw an exception when the input is too large, hence -- 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 ++ ")") #endif readFailureReport :: IO (Maybe FailureReport) readFailureReport = do mx <- lookupEnv "HSPEC_FAILURES" case mx >>= readMaybe of Nothing -> do hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!" return Nothing x -> return x hspec-core-2.2.4/src/Test/Hspec/Options.hs0000644000000000000000000002041312770132510016472 0ustar0000000000000000module Test.Hspec.Options ( Config(..) , ColorMode (..) , defaultConfig , filterOr , parseOptions ) where import Prelude () import Control.Monad import Test.Hspec.Compat import System.IO import System.Exit import System.Console.GetOpt import Test.Hspec.Core.Formatters import Test.Hspec.Core.Util import Test.Hspec.Core.Example (Params(..), defaultParams) data Config = Config { configDryRun :: Bool , configPrintCpuTime :: Bool , configFastFail :: Bool -- | -- A predicate that is used to filter the spec before it is run. Only examples -- that satisfy the predicate are run. , configRerun :: Bool , configFilterPredicate :: Maybe (Path -> Bool) , configSkipPredicate :: Maybe (Path -> Bool) , configQuickCheckSeed :: Maybe Integer , configQuickCheckMaxSuccess :: Maybe Int , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int , configSmallCheckDepth :: Int , configColorMode :: ColorMode , configFormatter :: Maybe Formatter , configHtmlOutput :: Bool , configOutputFile :: Either Handle FilePath , configConcurrentJobs :: Maybe Int } defaultConfig :: Config defaultConfig = Config { configDryRun = False , configPrintCpuTime = False , configFastFail = False , configRerun = False , configFilterPredicate = Nothing , configSkipPredicate = Nothing , configQuickCheckSeed = Nothing , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing , configSmallCheckDepth = paramsSmallCheckDepth defaultParams , configColorMode = ColorAuto , configFormatter = Nothing , configHtmlOutput = False , configOutputFile = Left stdout , configConcurrentJobs = Nothing } 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_ addMatch :: String -> Config -> Config addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} addSkip :: String -> Config -> Config addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} setDepth :: Int -> Config -> Config setDepth n c = c {configSmallCheckDepth = n} setMaxSuccess :: Int -> Config -> Config setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} setMaxSize :: Int -> Config -> Config setMaxSize n c = c {configQuickCheckMaxSize = Just n} setMaxDiscardRatio :: Int -> Config -> Config setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n} data ColorMode = ColorAuto | ColorNever | ColorAlways deriving (Eq, Show) 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 data Arg a = Arg { _argumentName :: String , _argumentParser :: String -> Maybe a , _argumentSetter :: a -> Config -> Config } 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") , mkOption [] "skip" (Arg "PATTERN" return addSkip) (h "skip 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 "o" "out" (Arg "FILE" return setOutputFile) (h "write output to a file instead of STDOUT") , mkOption [] "depth" (Arg "N" readMaybe setDepth) (h "maximum depth of generated test values for SmallCheck properties") , mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) (h "maximum number of successful tests before a QuickCheck property succeeds") , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) (h "size to use for the biggest test cases") , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up") , 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 "rerun all examples that failed in the previously test run (only works in GHCi)") , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) (h "run at most N parallelizable tests simultaneously (default: number of available processors)") ] where h = unlines . addLineBreaks readFormatter :: String -> Maybe Formatter readFormatter = (`lookup` formatters) readMaxJobs :: String -> Maybe Int readMaxJobs s = do n <- readMaybe s guard $ n > 0 return n setFormatter :: Formatter -> Config -> Config setFormatter f c = c {configFormatter = Just f} setOutputFile :: String -> Config -> Config setOutputFile file c = c {configOutputFile = Right file} setMaxJobs :: Int -> Config -> Config setMaxJobs n c = c {configConcurrentJobs = Just n} setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True} setDryRun x = x >>= \c -> return c {configDryRun = True} setFastFail x = x >>= \c -> return c {configFastFail = True} setRerun x = x >>= \c -> return c {configRerun = True} setNoColor x = x >>= \c -> return c {configColorMode = ColorNever} setColor x = x >>= \c -> return c {configColorMode = 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 {configHtmlOutput = True} parseOptions :: Config -> String -> [String] -> Either (ExitCode, String) Config 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") hspec-core-2.2.4/src/Test/Hspec/Core/0000755000000000000000000000000012770132510015373 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/Core/QuickCheck.hs0000644000000000000000000000230212770132510017736 0ustar0000000000000000-- | Stability: provisional module Test.Hspec.Core.QuickCheck ( modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize ) where import Test.QuickCheck import Test.Hspec.Core.Spec -- | Use a modified `maxSuccess` for given spec. modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSuccess = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxSuccess = f (maxSuccess args)} -- | Use a modified `maxDiscardRatio` for given spec. modifyMaxDiscardRatio :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxDiscardRatio = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxDiscardRatio = f (maxDiscardRatio args)} -- | Use a modified `maxSize` for given spec. modifyMaxSize :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSize = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxSize = f (maxSize args)} modifyArgs :: (Args -> Args) -> SpecWith a -> SpecWith a modifyArgs = modifyParams . modify where modify :: (Args -> Args) -> Params -> Params modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)} hspec-core-2.2.4/src/Test/Hspec/Core/Example.hs0000644000000000000000000001220112770132510017316 0ustar0000000000000000{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} module Test.Hspec.Core.Example ( Example (..) , Params (..) , defaultParams , ActionWith , Progress , ProgressCallback , Result (..) , Location (..) , LocationAccuracy (..) ) where import Data.Maybe (fromMaybe) import Data.List (isPrefixOf) import qualified Test.HUnit.Lang as HUnit import qualified Control.Exception as E import Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import Test.Hspec.Expectations (Expectation) import qualified Test.QuickCheck.State as QC import qualified Test.QuickCheck.Property as QCP import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util import Test.Hspec.Compat -- | A type class for examples class Example e where type Arg e #if __GLASGOW_HASKELL__ >= 704 type Arg e = () #endif evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result data Params = Params { paramsQuickCheckArgs :: QC.Args , paramsSmallCheckDepth :: Int } deriving (Show) defaultParams :: Params defaultParams = Params { paramsQuickCheckArgs = QC.stdArgs , paramsSmallCheckDepth = 5 } type Progress = (Int, Int) type ProgressCallback = Progress -> IO () -- | An `IO` action that expects an argument of type @a@ type ActionWith a = a -> IO () -- | The result of running an example data Result = Success | Pending (Maybe String) | Fail (Maybe Location) String deriving (Eq, Show, Read, Typeable) instance E.Exception Result -- | @Location@ is used to represent source locations. data Location = Location { locationFile :: FilePath , locationLine :: Int , locationColumn :: Int , locationAccuracy :: LocationAccuracy } deriving (Eq, Show, Read) -- | A marker for source locations data LocationAccuracy = -- | The source location is accurate ExactLocation | -- | The source location was determined on a best-effort basis and my be -- wrong or inaccurate BestEffort deriving (Eq, Show, Read) instance Example Bool where type Arg Bool = () evaluateExample b _ _ _ = if b then return Success else return (Fail Nothing "") instance Example Expectation where type Arg Expectation = () evaluateExample e = evaluateExample (\() -> e) hunitFailureToResult :: HUnit.HUnitFailure -> Result hunitFailureToResult e = case e of #if MIN_VERSION_HUnit(1,3,0) HUnit.HUnitFailure mLoc err -> Fail location err where location = case mLoc of Nothing -> Nothing Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation #else HUnit.HUnitFailure err -> Fail Nothing err #endif instance Example (a -> Expectation) where type Arg (a -> Expectation) = a evaluateExample e _ action _ = (action e >> return Success) `E.catches` [ E.Handler (return . hunitFailureToResult) , E.Handler (return :: Result -> IO Result) ] instance Example Result where type Arg Result = () evaluateExample r _ _ _ = return r instance Example QC.Property where type Arg QC.Property = () evaluateExample e = evaluateExample (\() -> e) instance Example (a -> QC.Property) where type Arg (a -> QC.Property) = a evaluateExample p c action progressCallback = do r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) return $ case r of QC.Success {} -> Success QC.Failure {QC.output = m} -> fromMaybe (Fail Nothing $ sanitizeFailureMessage r) (parsePending m) QC.GaveUp {QC.numTests = n} -> Fail Nothing ("Gave up after " ++ pluralize n "test" ) QC.NoExpectedFailure {} -> Fail Nothing ("No expected failure") #if MIN_VERSION_QuickCheck(2,8,0) QC.InsufficientCoverage {} -> Fail Nothing ("Insufficient coverage") #endif where qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) sanitizeFailureMessage :: QC.Result -> String sanitizeFailureMessage r = let m = QC.output r in strip $ #if MIN_VERSION_QuickCheck(2,7,0) case QC.theException r of Just e -> let numbers = formatNumbers r in "uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs _ -> m Nothing -> #endif (addFalsifiable . stripFailed) m addFalsifiable :: String -> String addFalsifiable m | "(after " `isPrefixOf` m = "Falsifiable " ++ m | otherwise = m stripFailed :: String -> String stripFailed m | prefix `isPrefixOf` m = drop n m | otherwise = m where prefix = "*** Failed! " n = length prefix parsePending :: String -> Maybe Result parsePending m | exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m | otherwise = Nothing where n = length exceptionPrefix exceptionPrefix = "*** Failed! Exception: '" hspec-core-2.2.4/src/Test/Hspec/Core/Util.hs0000644000000000000000000000771112770132510016652 0ustar0000000000000000-- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions pluralize , strip , lineBreaksAt -- * Working with paths , Path , formatRequirement , filterPredicate -- * Working with exception , safeTry , formatException ) where import Data.List import Data.Char (isSpace) import GHC.IO.Exception import Control.Exception import Control.Concurrent.Async import Test.Hspec.Compat (showType) -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given -- @count@ is 1. -- -- Examples: -- -- >>> pluralize 0 "example" -- "0 examples" -- -- >>> pluralize 1 "example" -- "1 example" -- -- >>> pluralize 2 "example" -- "2 examples" pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s" -- | Strip leading and trailing whitespace strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse -- | -- ensure that lines are not longer then given `n`, insert line breaks 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) -- | -- A `Path` represents the location of an example within the spec tree. -- -- It consists of a list of group descriptions and a requirement description. type Path = ([String], String) -- | -- Try to create a proper English sentence from a path by applying some -- heuristics. formatRequirement :: Path -> String formatRequirement (groups, requirement) = groups_ ++ requirement where groups_ = case break (any isSpace) groups of ([], ys) -> join ys (xs, ys) -> join (intercalate "." xs : ys) join xs = case xs of [x] -> x ++ " " ys -> concatMap (++ ", ") ys -- | A predicate that can be used to filter a spec tree. filterPredicate :: String -> Path -> Bool filterPredicate pattern path@(groups, requirement) = pattern `isInfixOf` plain || pattern `isInfixOf` formatted where plain = intercalate "/" (groups ++ [requirement]) formatted = formatRequirement path -- | The function `formatException` converts an exception to a string. -- -- This is different from `show`. The type of the exception is included, e.g.: -- -- >>> formatException (toException DivideByZero) -- "ArithException (divide by zero)" -- -- For `IOException`s the `IOErrorType` is included, as well. formatException :: SomeException -> String formatException err@(SomeException e) = case fromException err of Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")" Nothing -> showType e ++ " (" ++ show e ++ ")" where showIOErrorType :: IOException -> String showIOErrorType ioe = case ioe_type ioe of AlreadyExists -> "AlreadyExists" NoSuchThing -> "NoSuchThing" ResourceBusy -> "ResourceBusy" ResourceExhausted -> "ResourceExhausted" EOF -> "EOF" IllegalOperation -> "IllegalOperation" PermissionDenied -> "PermissionDenied" UserError -> "UserError" UnsatisfiedConstraints -> "UnsatisfiedConstraints" SystemError -> "SystemError" ProtocolError -> "ProtocolError" OtherError -> "OtherError" InvalidArgument -> "InvalidArgument" InappropriateType -> "InappropriateType" HardwareFault -> "HardwareFault" UnsupportedOperation -> "UnsupportedOperation" TimeExpired -> "TimeExpired" ResourceVanished -> "ResourceVanished" Interrupted -> "Interrupted" -- | @safeTry@ evaluates given action and returns its result. If an exception -- occurs, the exception is returned instead. Unlike `try` it is agnostic to -- asynchronous exceptions. safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch hspec-core-2.2.4/src/Test/Hspec/Core/QuickCheckUtil.hs0000644000000000000000000000336212770132510020603 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.QuickCheckUtil where import Prelude () import Test.Hspec.Compat import Data.Int 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 () #if MIN_VERSION_QuickCheck(2,7,0) import Test.QuickCheck.Random #endif import System.Random import Test.Hspec.Core.Util aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property #if MIN_VERSION_QuickCheck(2,7,0) aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n #else aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n #endif aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result aroundRose action r = ioRose $ do ref <- newIORef (return QCP.succeeded) action $ \a -> reduceRose (r a) >>= writeIORef ref readIORef ref formatNumbers :: Result -> String formatNumbers r = "(after " ++ pluralize (numTests r) "test" ++ shrinks ++ ")" where shrinks | 0 < numShrinks r = " and " ++ pluralize (numShrinks r) "shrink" | otherwise = "" newSeed :: IO Int newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> #if MIN_VERSION_QuickCheck(2,7,0) newQCGen #else newStdGen #endif #if MIN_VERSION_QuickCheck(2,7,0) mkGen :: Int -> QCGen mkGen = mkQCGen #else mkGen :: Int -> StdGen mkGen = mkStdGen #endif hspec-core-2.2.4/src/Test/Hspec/Core/Hooks.hs0000644000000000000000000000532512770132510017017 0ustar0000000000000000-- | Stability: provisional module Test.Hspec.Core.Hooks ( before , before_ , beforeWith , beforeAll , beforeAll_ , after , after_ , afterAll , afterAll_ , around , around_ , aroundWith ) where import Control.Exception (finally) import Control.Concurrent.MVar import Test.Hspec.Core.Spec -- | Run a custom action before every spec item. before :: IO a -> SpecWith a -> Spec before action = around (action >>=) -- | Run a custom action before every spec item. before_ :: IO () -> SpecWith a -> SpecWith a before_ action = around_ (action >>) -- | Run a custom action before every spec item. beforeWith :: (b -> IO a) -> SpecWith a -> SpecWith b beforeWith action = aroundWith $ \e x -> action x >>= e -- | Run a custom action before the first spec item. beforeAll :: IO a -> SpecWith a -> Spec beforeAll action spec = do mvar <- runIO (newMVar Nothing) before (memoize mvar action) spec -- | Run a custom action before the first spec item. beforeAll_ :: IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do mvar <- runIO (newMVar Nothing) before_ (memoize mvar action) spec memoize :: MVar (Maybe a) -> IO a -> IO a memoize mvar action = modifyMVar mvar $ \ma -> case ma of Just a -> return (ma, a) Nothing -> do a <- action return (Just a, a) -- | Run a custom action after every spec item. after :: ActionWith a -> SpecWith a -> SpecWith a after action = aroundWith $ \e x -> e x `finally` action x -- | Run a custom action after every spec item. after_ :: IO () -> SpecWith a -> SpecWith a after_ action = after $ \_ -> action -- | Run a custom action before and/or after every spec item. around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec around action = aroundWith $ \e () -> action e -- | Run a custom action after the last spec item. afterAll :: ActionWith a -> SpecWith a -> SpecWith a afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action -- | Run a custom action after the last spec item. afterAll_ :: IO () -> SpecWith a -> SpecWith a afterAll_ action = afterAll (\_ -> action) -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a around_ action = aroundWith $ \e a -> action (e a) -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundWith action = mapAround (. action) mapAround :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> SpecWith a -> SpecWith b mapAround f = mapSpecItem (untangle f) $ \i@Item{itemExample = e} -> i{itemExample = (. f) . e} untangle :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> ActionWith a -> ActionWith b untangle f g = \b -> f ($ b) g hspec-core-2.2.4/src/Test/Hspec/Core/Spec.hs0000644000000000000000000000453112770132510016624 0ustar0000000000000000{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,8,1) #define HAS_SOURCE_LOCATIONS {-# LANGUAGE ImplicitParams #-} #endif -- | -- Stability: unstable -- -- This module provides access to Hspec's internals. It is less stable than -- other parts of the API. For most users @Test.Hspec@ is more suitable! module Test.Hspec.Core.Spec ( -- * Defining a spec describe , it , pending , pendingWith , parallel -- * The @SpecM@ monad , module Test.Hspec.Core.Spec.Monad -- * A type class for examples , module Test.Hspec.Core.Example -- * Internal representation of a spec tree , module Test.Hspec.Core.Tree ) where #ifdef HAS_SOURCE_LOCATIONS import GHC.Stack #endif import qualified Control.Exception as E import Test.Hspec.Expectations (Expectation) import Test.Hspec.Core.Example import Test.Hspec.Core.Tree import Test.Hspec.Core.Spec.Monad -- | The @describe@ function combines a list of specs into a larger spec. describe :: String -> SpecWith a -> SpecWith a describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label -- | The @it@ function creates a spec item. -- -- A spec item consists of: -- -- * a textual description of a desired behavior -- -- * an example for that behavior -- -- > describe "absolute" $ do -- > it "returns a positive number when given a negative number" $ -- > absolute (-1) == 1 #ifdef HAS_SOURCE_LOCATIONS it :: (?loc :: CallStack, Example a) => String -> a -> SpecWith (Arg a) #else it :: Example a => String -> a -> SpecWith (Arg a) #endif it label action = fromSpecList [specItem label action] -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True} -- | `pending` can be used to indicate that an example is /pending/. -- -- If you want to textually specify a behavior but do not have an example yet, -- use this: -- -- > describe "fancyFormatter" $ do -- > it "can format text in a way that everyone likes" $ -- > pending pending :: Expectation pending = E.throwIO (Pending Nothing) -- | -- `pendingWith` is similar to `pending`, but it takes an additional string -- argument that can be used to specify the reason for why it's pending. pendingWith :: String -> Expectation pendingWith = E.throwIO . Pending . Just hspec-core-2.2.4/src/Test/Hspec/Core/Formatters.hs0000644000000000000000000001372612770132510020066 0ustar0000000000000000-- | -- Stability: experimental -- -- This module contains formatters that can be used with -- `Test.Hspec.Runner.hspecWith`. module Test.Hspec.Core.Formatters ( -- * Formatters silent , specdoc , progress , failed_examples -- * Implementing a custom Formatter -- | -- A formatter is a set of actions. Each action is evaluated when a certain -- situation is encountered during a test run. -- -- Actions live in the `FormatM` monad. It provides access to the runner state -- and primitives for appending to the generated report. , Formatter (..) , FormatM -- ** Accessing the runner state , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , getCPUTime , getRealTime -- ** Appending to the gerenated report , write , writeLine , newParagraph -- ** Dealing with colors , withInfoColor , withSuccessColor , withPendingColor , withFailColor -- ** Helpers , formatException ) where import Prelude () import Test.Hspec.Compat import Data.Maybe import Test.Hspec.Core.Util import Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..)) import Text.Printf import Control.Monad (when, unless) import System.IO (hPutStr, hFlush) -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. -- -- Everything imported here has to be re-exported, so that users can implement -- their own formatters. import Test.Hspec.Core.Formatters.Internal ( Formatter (..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , getCPUTime , getRealTime , write , writeLine , newParagraph , withInfoColor , withSuccessColor , withPendingColor , withFailColor ) silent :: Formatter silent = Formatter { headerFormatter = return () , exampleGroupStarted = \_ _ -> return () , exampleGroupDone = return () , exampleProgress = \_ _ _ -> return () , exampleSucceeded = \_ -> return () , exampleFailed = \_ _ -> return () , examplePending = \_ _ -> return () , failedFormatter = return () , footerFormatter = return () } specdoc :: Formatter specdoc = silent { headerFormatter = do writeLine "" , exampleGroupStarted = \nesting name -> do writeLine (indentationFor nesting ++ name) , exampleProgress = \h _ p -> do hPutStr h (formatProgress p) hFlush h , exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do writeLine $ indentationFor nesting ++ requirement , exampleFailed = \(nesting, requirement) _ -> withFailColor $ do n <- getFailCount writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]" , examplePending = \(nesting, requirement) reason -> withPendingColor $ do writeLine $ indentationFor nesting ++ requirement ++ "\n # PENDING: " ++ fromMaybe "No reason given" reason , failedFormatter = defaultFailedFormatter , footerFormatter = defaultFooter } where indentationFor nesting = replicate (length nesting * 2) ' ' formatProgress (current, total) | total == 0 = show current ++ "\r" | otherwise = show current ++ "/" ++ show total ++ "\r" progress :: Formatter progress = silent { exampleSucceeded = \_ -> withSuccessColor $ write "." , exampleFailed = \_ _ -> withFailColor $ write "F" , examplePending = \_ _ -> withPendingColor $ write "." , failedFormatter = defaultFailedFormatter , footerFormatter = defaultFooter } failed_examples :: Formatter failed_examples = silent { failedFormatter = defaultFailedFormatter , footerFormatter = defaultFooter } defaultFailedFormatter :: FormatM () defaultFailedFormatter = do writeLine "" failures <- getFailMessages unless (null failures) $ do writeLine "Failures:" writeLine "" forM_ (zip [1..] failures) $ \x -> do formatFailure x writeLine "" when (hasBestEffortLocations failures) $ do withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." writeLine "" write "Randomized with seed " >> usedSeed >>= writeLine . show writeLine "" where hasBestEffortLocations :: [FailureRecord] -> Bool hasBestEffortLocations = any p where p :: FailureRecord -> Bool p failure = (locationAccuracy <$> failureRecordLocation failure) == Just BestEffort formatFailure :: (Int, FailureRecord) -> FormatM () formatFailure (n, FailureRecord mLoc path reason) = do forM_ mLoc $ \loc -> do withInfoColor $ writeLine (formatLoc loc) write (" " ++ show n ++ ") ") writeLine (formatRequirement path) withFailColor $ do forM_ (lines err) $ \x -> do writeLine (" " ++ x) where err = either (("uncaught exception: " ++) . formatException) id reason formatLoc (Location file line _column accuracy) = " " ++ file ++ ":" ++ show line ++ ":" ++ message where message = case accuracy of ExactLocation -> " " -- NOTE: Vim's default 'errorformat' -- requires a non-empty message. This is -- why we use a single space as message -- here. BestEffort -> " (best-effort)" defaultFooter :: FormatM () defaultFooter = do writeLine =<< (++) <$> (printf "Finished in %1.4f seconds" <$> getRealTime) <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime) fails <- getFailCount pending <- getPendingCount total <- getTotalCount let c | fails /= 0 = withFailColor | pending /= 0 = withPendingColor | otherwise = withSuccessColor c $ do write $ pluralize total "example" write (", " ++ pluralize fails "failure") unless (pending == 0) $ write (", " ++ show pending ++ " pending") writeLine "" hspec-core-2.2.4/src/Test/Hspec/Core/Runner.hs0000644000000000000000000001425712770132510017211 0ustar0000000000000000{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,6,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif -- | -- Stability: provisional module Test.Hspec.Core.Runner ( -- * Running a spec hspec , hspecWith , hspecResult , hspecWithResult -- * Types , Summary (..) , Config (..) , ColorMode (..) , Path , defaultConfig , configAddFilter ) where import Prelude () import Test.Hspec.Compat import Control.Monad import Data.Maybe import System.IO import System.Environment (getProgName, getArgs, withArgs) import System.Exit import qualified Control.Exception as E import Control.Concurrent import System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC import Control.Monad.IO.Class (liftIO) import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Spec import Test.Hspec.Config import Test.Hspec.Core.Formatters import Test.Hspec.Core.Formatters.Internal import Test.Hspec.FailureReport import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Runner.Eval -- | Filter specs by given predicate. -- -- The predicate takes a list of "describe" labels and a "requirement". filterSpecs :: Config -> [SpecTree a] -> [SpecTree a] filterSpecs c = go [] where p :: Path -> Bool p path = (fromMaybe (const True) (configFilterPredicate c) path) && not (fromMaybe (const False) (configSkipPredicate c) path) go :: [String] -> [SpecTree a] -> [SpecTree a] go groups = mapMaybe (goSpec groups) goSpecs :: [String] -> [SpecTree a] -> ([SpecTree a] -> b) -> Maybe b goSpecs groups specs ctor = case go groups specs of [] -> Nothing xs -> Just (ctor xs) goSpec :: [String] -> SpecTree a -> Maybe (SpecTree a) goSpec groups spec = case spec of Leaf item -> guard (p (groups, itemRequirement item)) >> return spec Node group specs -> goSpecs (groups ++ [group]) specs (Node group) NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action) applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()] applyDryRun c | configDryRun c = map (removeCleanup . fmap markSuccess) | otherwise = id where markSuccess :: Item () -> Item () markSuccess item = item {itemExample = evaluateExample Success} removeCleanup :: SpecTree () -> SpecTree () removeCleanup spec = case spec of Node x xs -> Node x (map removeCleanup xs) NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs) leaf@(Leaf _) -> leaf -- | Run given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails. hspec :: Spec -> IO () hspec = hspecWith defaultConfig -- 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 seed <- newSeed return c {configQuickCheckSeed = Just (fromIntegral seed)} _ -> return c -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO () hspecWith conf spec = do r <- hspecWithResult conf spec unless (summaryFailures r == 0) exitFailure -- | Run given spec and returns a summary of the test run. -- -- /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 = hspecWithResult defaultConfig -- | Run given spec with custom options and returns a summary of the test run. -- -- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary hspecWithResult conf spec = do prog <- getProgName args <- getArgs c <- getConfig conf prog args >>= ensureSeed withArgs [] {- do not leak command-line arguments to examples -} $ withHandle c $ \h -> do let formatter = fromMaybe specdoc (configFormatter c) seed = (fromJust . configQuickCheckSeed) c qcArgs = configQuickCheckArgs c jobsSem <- newQSem =<< case configConcurrentJobs c of Nothing -> getDefaultConcurrentJobs Just maxJobs -> return maxJobs useColor <- doesUseColor h c filteredSpec <- filterSpecs c . applyDryRun c <$> runSpecM spec withHiddenCursor useColor h $ runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do runFormatter jobsSem useColor h c formatter filteredSpec `finally_` do failedFormatter formatter footerFormatter formatter -- dump failure report xs <- map failureRecordPath <$> getFailMessages liftIO $ writeFailureReport FailureReport { failureReportSeed = seed , failureReportMaxSuccess = QC.maxSuccess qcArgs , failureReportMaxSize = QC.maxSize qcArgs , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs , failureReportPaths = 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 <*> (not <$> isDumb) ColorNever -> return False ColorAlways -> return True withHandle :: Config -> (Handle -> IO a) -> IO a withHandle c action = case configOutputFile c of Left h -> action h Right path -> withFile path WriteMode action isDumb :: IO Bool isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" -- | Summary of a test run. data Summary = Summary { summaryExamples :: Int , summaryFailures :: Int } deriving (Eq, Show) instance Monoid Summary where mempty = Summary 0 0 (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) hspec-core-2.2.4/src/Test/Hspec/Core/Tree.hs0000644000000000000000000000622012770132510016626 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,8,1) #define HAS_SOURCE_LOCATIONS {-# LANGUAGE ImplicitParams #-} #endif -- | -- Stability: unstable module Test.Hspec.Core.Tree ( SpecTree , Tree (..) , Item (..) , specGroup , specItem ) where #ifdef HAS_SOURCE_LOCATIONS #if !MIN_VERSION_base(4,9,0) import GHC.SrcLoc #endif import GHC.Stack #endif import Prelude () import Test.Hspec.Compat import Test.Hspec.Core.Example -- | Internal tree data structure data Tree c a = Node String [Tree c a] | NodeWithCleanup c [Tree c a] | Leaf a deriving Functor instance Foldable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance foldMap = go where go :: Monoid m => (a -> m) -> Tree c a -> m go f t = case t of Node _ xs -> foldMap (foldMap f) xs NodeWithCleanup _ xs -> foldMap (foldMap f) xs Leaf x -> f x instance Traversable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance sequenceA = go where go :: Applicative f => Tree c (f a) -> f (Tree c a) go t = case t of Node label xs -> Node label <$> sequenceA (map go xs) NodeWithCleanup action xs -> NodeWithCleanup action <$> sequenceA (map go xs) Leaf a -> Leaf <$> a -- | A tree is used to represent a spec internally. The tree is parametrize -- over the type of cleanup actions and the type of the actual spec items. type SpecTree a = Tree (ActionWith a) (Item a) -- | -- @Item@ is used to represent spec items internally. A spec item consists of: -- -- * a textual description of a desired behavior -- * an example for that behavior -- * additional meta information -- -- Everything that is an instance of the `Example` type class can be used as an -- example, including QuickCheck properties, Hspec expectations and HUnit -- assertions. data Item a = Item { -- | Textual description of behavior itemRequirement :: String -- | Source location of the spec item , itemLocation :: Maybe Location -- | A flag that indicates whether it is safe to evaluate this spec item in -- parallel with other spec items , itemIsParallelizable :: Bool -- | Example for behavior , itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } -- | The @specGroup@ function combines a list of specs into a larger spec. specGroup :: String -> [SpecTree a] -> SpecTree a specGroup s = Node msg where msg | null s = "(no description given)" | otherwise = s -- | The @specItem@ function creates a spec item. #ifdef HAS_SOURCE_LOCATIONS specItem :: (?loc :: CallStack, Example a) => String -> a -> SpecTree (Arg a) #else specItem :: Example a => String -> a -> SpecTree (Arg a) #endif specItem s e = Leaf $ Item requirement location False (evaluateExample e) where requirement | null s = "(unspecified behavior)" | otherwise = s location :: Maybe Location #ifdef HAS_SOURCE_LOCATIONS location = case reverse (getCallStack ?loc) of (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation) _ -> Nothing #else location = Nothing #endif hspec-core-2.2.4/src/Test/Hspec/Core/Formatters/0000755000000000000000000000000012770132510017521 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/Core/Formatters/Internal.hs0000644000000000000000000001772712770132510021647 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Formatters.Internal ( -- * Public API Formatter (..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , getCPUTime , getRealTime , write , writeLine , newParagraph , withInfoColor , withSuccessColor , withPendingColor , withFailColor -- * Functions for internal use , runFormatM , increaseSuccessCount , increasePendingCount , increaseFailCount , addFailMessage , finally_ ) where import Prelude () import Test.Hspec.Compat import qualified System.IO as IO import System.IO (Handle) import Control.Monad import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) import System.Console.ANSI import Control.Monad.Trans.State hiding (gets, modify) import Control.Monad.IO.Class import qualified System.CPUTime as CPUTime import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Spec (Progress, Location) -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do f <$> (get >>= liftIO . readIORef) -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do get >>= liftIO . (`modifyIORef'` f) data FormatterState = FormatterState { stateHandle :: Handle , stateUseColor :: Bool , produceHTML :: Bool , successCount :: Int , 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 -- 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, MonadIO) 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_ 0 0 0 [] seed cpuTime time) evalStateT action st -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s} -- | Increase the counter for pending examples increasePendingCount :: FormatM () increasePendingCount = modify $ \s -> s {pendingCount = succ $ pendingCount s} -- | Increase the counter for failed examples increaseFailCount :: FormatM () increaseFailCount = modify $ \s -> s {failCount = succ $ failCount s} -- | Get the number of successful examples encountered so far. getSuccessCount :: FormatM Int getSuccessCount = gets successCount -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int getPendingCount = gets pendingCount -- | Get the number of failed examples encountered so far. getFailCount :: FormatM Int getFailCount = gets failCount -- | Get the total number of examples encountered so far. getTotalCount :: FormatM Int getTotalCount = gets totalCount -- | Append to the list of accumulated failure messages. addFailMessage :: Maybe Location -> Path -> Either SomeException String -> FormatM () addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s} -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets failMessages data FailureRecord = FailureRecord { failureRecordLocation :: Maybe Location , failureRecordPath :: Path , failureRecordMessage :: Either SomeException String } data Formatter = Formatter { headerFormatter :: FormatM () -- | evaluated before each test group -- -- The given number indicates the position within the parent group. , exampleGroupStarted :: [String] -> String -> FormatM () , exampleGroupDone :: FormatM () -- | used to notify the progress of the currently evaluated example -- -- /Note/: This is only called when interactive/color mode. , exampleProgress :: Handle -> Path -> Progress -> IO () -- | evaluated after each successful example , exampleSucceeded :: Path -> FormatM () -- | evaluated after each failed example , exampleFailed :: Path -> Either SomeException String -> FormatM () -- | evaluated after each pending example , examplePending :: Path -> Maybe String -> FormatM () -- | evaluated after a test run , failedFormatter :: FormatM () -- | evaluated after `failuresFormatter` , footerFormatter :: FormatM () } -- | Append an empty line to the report. -- -- Calling this multiple times has the same effect as calling it once. newParagraph :: FormatM () newParagraph = writeLine "" {-# DEPRECATED newParagraph "use @writeLine \"\"@ instead" #-} -- | Append some output to the report. write :: String -> FormatM () write s = do h <- gets stateHandle liftIO $ IO.hPutStr h s -- | The same as `write`, but adds a newline character. writeLine :: String -> FormatM () writeLine s = write s >> write "\n" -- | Set output color to red, run given action, and finally restore the default -- color. withFailColor :: FormatM a -> FormatM a withFailColor = withColor (SetColor Foreground Dull Red) "hspec-failure" -- | Set output color to green, run given action, and finally restore the -- default color. withSuccessColor :: FormatM a -> FormatM a withSuccessColor = withColor (SetColor Foreground Dull Green) "hspec-success" -- | Set output color to yellow, run given action, and finally restore the -- default color. withPendingColor :: FormatM a -> FormatM a withPendingColor = withColor (SetColor Foreground Dull Yellow) "hspec-pending" -- | Set output color to cyan, run given action, and finally restore the -- default color. withInfoColor :: FormatM a -> FormatM a withInfoColor = withColor (SetColor Foreground Dull Cyan) "hspec-info" -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do r <- gets produceHTML (if r then htmlSpan cls else withColor_ color) action htmlSpan :: String -> FormatM a -> FormatM a htmlSpan cls action = write ("") *> action <* write "" withColor_ :: SGR -> FormatM a -> FormatM a withColor_ color (FormatM action) = do useColor <- gets stateUseColor h <- gets stateHandle FormatM . StateT $ \st -> do bracket_ -- set color (when useColor $ hSetSGR h [color]) -- reset colors (when useColor $ hSetSGR h [Reset]) -- 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) getCPUTime = do t1 <- liftIO CPUTime.getCPUTime mt0 <- gets cpuStartTime return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) where toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer)) -- | Get the passed real time since the test run has been started. getRealTime :: FormatM Double getRealTime = do t1 <- liftIO getPOSIXTime t0 <- gets startTime return (realToFrac $ t1 - t0) hspec-core-2.2.4/src/Test/Hspec/Core/Runner/0000755000000000000000000000000012770132510016644 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/Core/Runner/Eval.hs0000644000000000000000000001375412770132510020101 0ustar0000000000000000{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,6,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif module Test.Hspec.Core.Runner.Eval (runFormatter) where import Prelude () import Test.Hspec.Compat import Control.Monad (unless, when) import qualified Control.Exception as E import Control.Concurrent import System.IO (Handle) import Control.Monad.IO.Class (liftIO) import Control.DeepSeq (deepseq) import Data.Time.Clock.POSIX import Test.Hspec.Core.Util import Test.Hspec.Core.Spec import Test.Hspec.Config import Test.Hspec.Core.Formatters import Test.Hspec.Core.Formatters.Internal import Test.Hspec.Timer type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -- | Evaluate all examples of a given spec and produce a report. runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () runFormatter jobsSem useColor h c formatter specs = do headerFormatter formatter chan <- liftIO newChan reportProgress <- liftIO mkReportProgress run chan reportProgress c formatter (toEvalTree specs) where mkReportProgress :: IO (Path -> Progress -> IO ()) mkReportProgress | useColor = every 0.05 $ exampleProgress formatter h | otherwise = return $ \_ _ -> return () toEvalTree :: [SpecTree ()] -> [EvalTree] toEvalTree = map (fmap f) where f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize jobsSem isParallelizable $ e params ($ ())) params :: Params params = Params (configQuickCheckArgs c) (configSmallCheckDepth c) -- | Execute given action at most every specified number of seconds. every :: POSIXTime -> (a -> b -> IO ()) -> IO (a -> b -> IO ()) every seconds action = do timer <- newTimer seconds return $ \a b -> do r <- timer when r (action a b) type FormatResult = Either E.SomeException Result -> FormatM () parallelize :: QSem -> Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) parallelize jobsSem isParallelizable e | isParallelizable = runParallel jobsSem e | otherwise = runSequentially e runSequentially :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) runSequentially e reportProgress formatResult = return $ do result <- liftIO $ evalExample (e reportProgress) formatResult result data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) runParallel :: QSem -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) runParallel jobsSem e reportProgress formatResult = do mvar <- newEmptyMVar _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do let progressCallback = replaceMVar mvar . ReportProgress result <- evalExample (e progressCallback) replaceMVar mvar (ReportResult result) return $ 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 result replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p evalExample :: IO Result -> IO (Either E.SomeException Result) evalExample e = safeTry $ forceResult <$> e where forceResult :: Result -> Result forceResult r = case r of Success -> r Pending m -> m `deepseq` r Fail _ m -> m `deepseq` r data Message = Done | Run (FormatM ()) run :: Chan Message -> (Path -> ProgressCallback) -> Config -> Formatter -> [EvalTree] -> FormatM () run chan reportProgress_ c formatter specs = do liftIO $ do forM_ specs (queueSpec []) writeChan chan Done processMessages (readChan chan) (configFastFail c) where defer :: FormatM () -> IO () defer = writeChan chan . Run runCleanup :: IO () -> Path -> FormatM () runCleanup action path = do r <- liftIO $ safeTry action either (failed Nothing path . Left) return r queueSpec :: [String] -> EvalTree -> IO () queueSpec rGroups (Node group xs) = do defer (exampleGroupStarted formatter (reverse rGroups) group) forM_ xs (queueSpec (group : rGroups)) defer (exampleGroupDone formatter) queueSpec rGroups (NodeWithCleanup action xs) = do forM_ xs (queueSpec rGroups) defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook")) queueSpec rGroups (Leaf e) = queueExample (reverse rGroups) e queueExample :: [String] -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO () queueExample groups (requirement, loc, e) = e reportProgress formatResult >>= defer where path :: Path path = (groups, requirement) reportProgress = reportProgress_ path formatResult :: Either E.SomeException Result -> FormatM () formatResult result = do case result of Right Success -> do increaseSuccessCount exampleSucceeded formatter path Right (Pending reason) -> do increasePendingCount examplePending formatter path reason Right (Fail loc_ err) -> failed (loc_ <|> loc) path (Right err) Left err -> failed loc path (Left err) failed loc path err = do increaseFailCount addFailMessage loc path err exampleFailed formatter path err processMessages :: IO Message -> Bool -> FormatM () processMessages getMessage fastFail = go where go = liftIO getMessage >>= \m -> case m of Run action -> do action fails <- getFailCount unless (fastFail && fails /= 0) go Done -> return () hspec-core-2.2.4/src/Test/Hspec/Core/Spec/0000755000000000000000000000000012770132510016265 5ustar0000000000000000hspec-core-2.2.4/src/Test/Hspec/Core/Spec/Monad.hs0000644000000000000000000000413012770132510017655 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad ( Spec , SpecWith , SpecM (..) , runSpecM , fromSpecList , runIO , mapSpecTree , mapSpecItem , mapSpecItem_ , modifyParams ) where import Prelude () import Test.Hspec.Compat import Control.Monad.Trans.Writer import Control.Monad.IO.Class (liftIO) import Test.Hspec.Core.Example import Test.Hspec.Core.Tree type Spec = SpecWith () type SpecWith a = SpecM a () -- | A writer monad for `SpecTree` forests newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r) deriving (Functor, Applicative, Monad) -- | Convert a `Spec` to a forest of `SpecTree`s. runSpecM :: SpecWith a -> IO [SpecTree a] runSpecM (SpecM specs) = execWriterT specs -- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a fromSpecList = SpecM . tell -- | Run an IO action while constructing the spec tree. -- -- `SpecM` is a monad to construct a spec tree, without executing any spec -- items. @runIO@ allows you to run IO actions during this construction phase. -- The IO action is always run when the spec tree is constructed (e.g. even -- when @--dry-run@ is specified). -- If you do not need the result of the IO action to construct the spec tree, -- `Test.Hspec.Core.Hooks.beforeAll` may be more suitable for your use case. runIO :: IO r -> SpecM a r runIO = SpecM . liftIO mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecWith a -> SpecWith b mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem g f = mapSpecTree go where go spec = case spec of Node d xs -> Node d (map go xs) NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs) Leaf item -> Leaf (f item) mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a mapSpecItem_ = mapSpecItem id modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)}