hspec2 0.5.1 → 0.6.0
raw patch · 48 files changed
+25/−4139 lines, 48 filesdep +hspecdep +hspec-discoverdep −HUnitdep −QuickCheckdep −ansi-terminaldep ~base
Dependencies added: hspec, hspec-discover
Dependencies removed: HUnit, QuickCheck, ansi-terminal, async, deepseq, directory, filepath, ghc-paths, hspec-expectations, hspec-meta, hspec2, process, quickcheck-io, random, setenv, silently, stringbuilder, tf-random, time, transformers
Dependency ranges changed: base
Files
- changelog +0/−1
- example/Spec.hs +0/−16
- hspec-discover/src/Config.hs +0/−45
- hspec-discover/src/Main.hs +0/−8
- hspec-discover/src/Run.hs +0/−139
- hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder +0/−0
- hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs +0/−0
- hspec-discover/test-data/nested-spec/Foo/BarSpec.hs +0/−0
- hspec-discover/test-data/nested-spec/FooSpec.hs +0/−0
- hspec-discover/test/ConfigSpec.hs +0/−47
- hspec-discover/test/RunSpec.hs +0/−119
- hspec-discover/test/Spec.hs +0/−1
- hspec2.cabal +5/−137
- src/Test/Hspec.hs +3/−161
- src/Test/Hspec/Compat.hs +0/−83
- src/Test/Hspec/Config.hs +0/−82
- src/Test/Hspec/Core.hs +4/−37
- src/Test/Hspec/Core/QuickCheckUtil.hs +0/−60
- src/Test/Hspec/Core/Type.hs +0/−248
- src/Test/Hspec/Discover.hs +4/−82
- src/Test/Hspec/FailureReport.hs +0/−36
- src/Test/Hspec/Formatters.hs +3/−236
- src/Test/Hspec/Formatters/Internal.hs +0/−262
- src/Test/Hspec/HUnit.hs +0/−23
- src/Test/Hspec/Options.hs +0/−178
- src/Test/Hspec/QuickCheck.hs +3/−53
- src/Test/Hspec/Runner.hs +3/−175
- src/Test/Hspec/Runner/Eval.hs +0/−152
- src/Test/Hspec/Runner/Tree.hs +0/−31
- src/Test/Hspec/Timer.hs +0/−14
- src/Test/Hspec/Util.hs +0/−82
- test/Helper.hs +0/−102
- test/HelperSpec.hs +0/−18
- test/Mock.hs +0/−15
- test/Spec.hs +0/−1
- test/Test/Hspec/CompatSpec.hs +0/−33
- test/Test/Hspec/Core/QuickCheckUtilSpec.hs +0/−31
- test/Test/Hspec/Core/TypeSpec.hs +0/−136
- test/Test/Hspec/DiscoverSpec.hs +0/−72
- test/Test/Hspec/FailureReportSpec.hs +0/−39
- test/Test/Hspec/FormattersSpec.hs +0/−228
- test/Test/Hspec/HUnitSpec.hs +0/−45
- test/Test/Hspec/OptionsSpec.hs +0/−44
- test/Test/Hspec/QuickCheckSpec.hs +0/−19
- test/Test/Hspec/RunnerSpec.hs +0/−399
- test/Test/Hspec/TimerSpec.hs +0/−29
- test/Test/Hspec/UtilSpec.hs +0/−101
- test/Test/HspecSpec.hs +0/−319
− changelog
@@ -1,1 +0,0 @@-See https://github.com/hspec/hspec/blob/master/CHANGES.markdown
− example/Spec.hs
@@ -1,16 +0,0 @@-module Main (main, spec) where--import Test.Hspec-import Test.QuickCheck--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "reverse" $ do- it "reverses a list" $ do- reverse [1 :: Int, 2, 3] `shouldBe` [3, 2, 1]-- it "gives the original list, if applied twice" $ property $- \xs -> (reverse . reverse) xs == (xs :: [Int])
− hspec-discover/src/Config.hs
@@ -1,45 +0,0 @@-module Config (- Config (..)-, defaultConfig-, parseConfig-, usage-) where--import Data.Maybe-import System.Console.GetOpt--data Config = Config {- configNested :: Bool-, configFormatter :: Maybe String-, configNoMain :: Bool-, configModuleName :: Maybe String-} deriving (Eq, Show)--defaultConfig :: Config-defaultConfig = Config False Nothing False Nothing--options :: [OptDescr (Config -> Config)]-options = [- Option [] ["nested"] (NoArg $ \c -> c {configNested = True}) ""- , Option [] ["formatter"] (ReqArg (\s c -> c {configFormatter = Just s}) "FORMATTER") ""- , Option [] ["module-name"] (ReqArg (\s c -> c {configModuleName = Just s}) "NAME") ""- , Option [] ["no-main"] (NoArg $ \c -> c {configNoMain = True}) ""- ]--usage :: String -> String-usage prog = "\nUsage: " ++ prog ++ " SRC CUR DST [--module-name=NAME]\n"--parseConfig :: String -> [String] -> Either String Config-parseConfig prog args = case getOpt Permute options args of- (opts, [], []) -> let- c = (foldl (flip id) defaultConfig opts)- in- if (configNoMain c && isJust (configFormatter c))- then- formatError "option `--formatter=<fmt>' does not make sense with `--no-main'\n"- else- Right c- (_, _, err:_) -> formatError err- (_, arg:_, _) -> formatError ("unexpected argument `" ++ arg ++ "'\n")- where- formatError err = Left (prog ++ ": " ++ err ++ usage prog)
− hspec-discover/src/Main.hs
@@ -1,8 +0,0 @@-module Main (main) where--import System.Environment--import Run (run)--main :: IO ()-main = getArgs >>= run
− hspec-discover/src/Run.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | A preprocessor that finds and combines specs.-module Run (- run---- exported for testing-, Spec(..)-, importList-, fileToSpec-, findSpecs-, getFilesRecursive-, driverWithFormatter-, moduleNameFromId-, pathToModule-) where-import Control.Monad-import Control.Applicative-import Data.List-import Data.Char-import Data.Maybe-import Data.String-import System.Environment-import System.Exit-import System.IO-import System.Directory (doesDirectoryExist, getDirectoryContents, doesFileExist)-import System.FilePath hiding (combine)--import Config--instance IsString ShowS where- fromString = showString--data Spec = Spec {- specFile :: FilePath-, specModule :: String-} deriving (Eq, Show)--run :: [String] -> IO ()-run args_ = do- name <- getProgName- case args_ of- src : _ : dst : args -> case parseConfig name args of- Left err -> do- hPutStrLn stderr err- exitFailure- Right conf -> do- when (configNested conf) (hPutStrLn stderr "hspec-discover: WARNING - The `--nested' flag is deprecated and will be removed in a future release!")- specs <- findSpecs src- writeFile dst (mkSpecModule src conf specs)- _ -> do- hPutStrLn stderr (usage name)- exitFailure--mkSpecModule :: FilePath -> Config -> [Spec] -> String-mkSpecModule src conf nodes =- ( "{-# LINE 1 " . shows src . " #-}\n"- . showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"- . showString ("module " ++ moduleName src conf ++" where\n")- . importList nodes- . showString "import Test.Hspec.Discover\n"- . maybe driver driverWithFormatter (configFormatter conf)- . showString "spec :: Spec\n"- . showString "spec = "- . formatSpecs nodes- ) "\n"- where- driver =- case configNoMain conf of- False ->- showString "main :: IO ()\n"- . showString "main = hspec spec\n"- True -> ""--moduleName :: FilePath -> Config -> String-moduleName src conf = fromMaybe (if configNoMain conf then pathToModule src else "Main") (configModuleName conf)---- | Derive module name from specified path.-pathToModule :: FilePath -> String-pathToModule f = toUpper m:ms- where- fileName = last $ splitDirectories f- m:ms = takeWhile (/='.') fileName--driverWithFormatter :: String -> ShowS-driverWithFormatter f =- showString "import qualified " . showString (moduleNameFromId f) . showString "\n"- . showString "main :: IO ()\n"- . showString "main = hspecWithFormatter " . showString f . showString " spec\n"---- | Return module name of a fully qualified identifier.-moduleNameFromId :: String -> String-moduleNameFromId = reverse . dropWhile (== '.') . dropWhile (/= '.') . reverse---- | Generate imports for a list of specs.-importList :: [Spec] -> ShowS-importList = foldr (.) "" . map f- where- f :: Spec -> ShowS- f spec = "import qualified " . showString (specModule spec) . "Spec\n"---- | Combine a list of strings with (>>).-sequenceS :: [ShowS] -> ShowS-sequenceS = foldr (.) "" . intersperse " >> "---- | Convert a list of specs to code.-formatSpecs :: [Spec] -> ShowS-formatSpecs xs- | null xs = "return ()"- | otherwise = sequenceS (map formatSpec xs)---- | Convert a spec to code.-formatSpec :: Spec -> ShowS-formatSpec (Spec file name) = "postProcessSpec " . shows file . " (describe " . shows name . " " . showString name . "Spec.spec)"--findSpecs :: FilePath -> IO [Spec]-findSpecs src = do- let (dir, file) = splitFileName src- mapMaybe (fileToSpec dir) . filter (/= file) <$> getFilesRecursive dir--fileToSpec :: FilePath -> FilePath -> Maybe Spec-fileToSpec dir file = case reverse $ splitDirectories file of- x:xs -> case stripSuffix "Spec.hs" x <|> stripSuffix "Spec.lhs" x of- Just name | (not . null) name -> Just . Spec (dir </> file) $ (intercalate "." . reverse) (name : xs)- _ -> Nothing- _ -> Nothing- where- stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]- stripSuffix suffix str = reverse <$> stripPrefix (reverse suffix) (reverse str)--getFilesRecursive :: FilePath -> IO [FilePath]-getFilesRecursive baseDir = sort <$> go []- where- go :: FilePath -> IO [FilePath]- go dir = do- c <- map (dir </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (baseDir </> dir)- dirs <- filterM (doesDirectoryExist . (baseDir </>)) c >>= mapM go- files <- filterM (doesFileExist . (baseDir </>)) c- return (files ++ concat dirs)
− hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder
− hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs
− hspec-discover/test-data/nested-spec/Foo/BarSpec.hs
− hspec-discover/test-data/nested-spec/FooSpec.hs
− hspec-discover/test/ConfigSpec.hs
@@ -1,47 +0,0 @@-module ConfigSpec (main, spec) where--import Test.Hspec.Meta--import Config--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "parseConfig" $ do- let parse = parseConfig "hspec-discover"-- it "recognizes --nested" $ do- parse ["--nested"] `shouldBe` Right (defaultConfig {configNested = True})-- it "recognizes --formatter" $ do- parse ["--formatter", "someFormatter"] `shouldBe` Right (defaultConfig {configFormatter = Just "someFormatter"})-- it "recognizes --no-main" $ do- parse ["--no-main"] `shouldBe` Right (defaultConfig {configNoMain = True})-- it "returns error message on unrecognized option" $ do- parse ["--foo"] `shouldBe` (Left . unlines) [- "hspec-discover: unrecognized option `--foo'"- , ""- , "Usage: hspec-discover SRC CUR DST [--module-name=NAME]"- ]-- it "returns error message on unexpected argument" $ do- parse ["foo"] `shouldBe` (Left . unlines) [- "hspec-discover: unexpected argument `foo'"- , ""- , "Usage: hspec-discover SRC CUR DST [--module-name=NAME]"- ]-- it "returns error message on --formatter=<fmt> with --no-main" $ do- parse ["--no-main", "--formatter=foo"] `shouldBe` (Left . unlines) [- "hspec-discover: option `--formatter=<fmt>' does not make sense with `--no-main'"- , ""- , "Usage: hspec-discover SRC CUR DST [--module-name=NAME]"- ]-- context "when option is given multiple times" $ do- it "gives the last occurrence precedence" $ do- parse ["--formatter", "foo", "--formatter", "bar"] `shouldBe` Right (defaultConfig {configFormatter = Just "bar"})
− hspec-discover/test/RunSpec.hs
@@ -1,119 +0,0 @@-module RunSpec (main, spec) where--import Test.Hspec.Meta--import Control.Applicative-import System.IO-import System.Directory-import System.FilePath-import Data.List (sort)--import Run hiding (Spec)-import qualified Run--main :: IO ()-main = hspec spec--withTempFile :: (FilePath -> IO a) -> IO a-withTempFile action = do- dir <- getTemporaryDirectory- (file, h) <- openTempFile dir ""- hClose h- action file <* removeFile file---spec :: Spec-spec = do- describe "run" $ do- it "generates test driver" $ withTempFile $ \f -> do- run ["hspec-discover/test-data/nested-spec/Spec.hs", "", f]- readFile f `shouldReturn` unlines [- "{-# LINE 1 \"hspec-discover/test-data/nested-spec/Spec.hs\" #-}"- , "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}"- , "module Main where"- , "import qualified Foo.Bar.BazSpec"- , "import qualified Foo.BarSpec"- , "import qualified FooSpec"- , "import Test.Hspec.Discover"- , "main :: IO ()"- , "main = hspec spec"- , "spec :: Spec"- , "spec = " ++ unwords [- "postProcessSpec \"hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs\" (describe \"Foo.Bar.Baz\" Foo.Bar.BazSpec.spec)"- , ">> postProcessSpec \"hspec-discover/test-data/nested-spec/Foo/BarSpec.hs\" (describe \"Foo.Bar\" Foo.BarSpec.spec)"- , ">> postProcessSpec \"hspec-discover/test-data/nested-spec/FooSpec.hs\" (describe \"Foo\" FooSpec.spec)"- ]- ]-- it "generates test driver for an empty directory" $ withTempFile $ \f -> do- run ["hspec-discover/test-data/empty-dir/Spec.hs", "", f]- readFile f `shouldReturn` unlines [- "{-# LINE 1 \"hspec-discover/test-data/empty-dir/Spec.hs\" #-}"- , "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}"- , "module Main where"- , "import Test.Hspec.Discover"- , "main :: IO ()"- , "main = hspec spec"- , "spec :: Spec"- , "spec = return ()"- ]-- describe "pathToModule" $ do- it "derives module name from a given path" $ do- pathToModule "test/Spec.hs" `shouldBe` "Spec"-- describe "getFilesRecursive" $ do- it "recursively returns all file entries of a given directory" $ do- getFilesRecursive "hspec-discover/test-data" `shouldReturn` sort [- "empty-dir/Foo/Bar/Baz/.placeholder"- , "nested-spec/Foo/Bar/BazSpec.hs"- , "nested-spec/Foo/BarSpec.hs"- , "nested-spec/FooSpec.hs"- ]-- describe "fileToSpec" $ do- it "converts path to spec name" $ do- fileToSpec "" "FooSpec.hs" `shouldBe` Just (spec_ "FooSpec.hs" "Foo")-- it "rejects spec with empty name" $ do- fileToSpec "" "Spec.hs" `shouldBe` Nothing-- it "works for lhs files" $ do- fileToSpec "" "FooSpec.lhs" `shouldBe` Just (spec_ "FooSpec.lhs" "Foo")-- it "returns Nothing for invalid spec name" $ do- fileToSpec "" "foo" `shouldBe` Nothing-- context "when path has directory component" $ do- it "converts path to spec name" $ do- let file = "Foo" </> "Bar" </> "BazSpec.hs"- fileToSpec "" file `shouldBe` Just (spec_ file "Foo.Bar.Baz")-- it "rejects spec with empty name" $ do- fileToSpec "" ("Foo" </> "Bar" </> "Spec.hs") `shouldBe` Nothing-- describe "findSpecs" $ do- it "finds specs" $ do- let dir = "hspec-discover/test-data/nested-spec"- findSpecs (dir </> "Spec.hs") `shouldReturn` [spec_ (dir </> "Foo/Bar/BazSpec.hs") "Foo.Bar.Baz", spec_ (dir </> "Foo/BarSpec.hs") "Foo.Bar", spec_ (dir </> "FooSpec.hs") "Foo"]-- describe "driverWithFormatter" $ do- it "generates a test driver that uses a custom formatter" $ do- driverWithFormatter "Some.Module.formatter" "" `shouldBe` unlines [- "import qualified Some.Module"- , "main :: IO ()"- , "main = hspecWithFormatter Some.Module.formatter spec"- ]-- describe "moduleNameFromId" $ do- it "returns the module name of a fully qualified identifier" $ do- moduleNameFromId "Some.Module.someId" `shouldBe` "Some.Module"-- describe "importList" $ do- it "generates imports for a list of specs" $ do- importList [spec_ "FooSpec.hs" "Foo", spec_ "BarSpec.hs" "Bar"] "" `shouldBe` unlines [- "import qualified FooSpec"- , "import qualified BarSpec"- ]- where- spec_ = Run.Spec
− hspec-discover/test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}
hspec2.cabal view
@@ -1,5 +1,5 @@ name: hspec2-version: 0.5.1+version: 0.6.0 license: MIT license-file: LICENSE copyright: (c) 2011-2014 Simon Hengel,@@ -17,15 +17,6 @@ If you are looking for a stable solution for testing Haskell code, use the 1.x series of Hspec: <http://hspec.github.io/> -extra-source-files:- changelog---- find hspec-discover/test-data/ -type f- hspec-discover/test-data/nested-spec/FooSpec.hs- hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs- hspec-discover/test-data/nested-spec/Foo/BarSpec.hs- hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder- source-repository head type: git location: https://github.com/hspec/hspec@@ -38,136 +29,13 @@ src build-depends: base == 4.*- , 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.6.1.*- , async >= 2+ , hspec-discover == 2.0.*+ , hspec == 2.0.* exposed-modules: Test.Hspec Test.Hspec.Core- Test.Hspec.Runner+ Test.Hspec.Discover Test.Hspec.Formatters- Test.Hspec.HUnit Test.Hspec.QuickCheck- Test.Hspec.Discover- other-modules:- Test.Hspec.Util- Test.Hspec.Compat- Test.Hspec.Core.Type- Test.Hspec.Core.QuickCheckUtil- Test.Hspec.Config- Test.Hspec.Options- Test.Hspec.FailureReport- Test.Hspec.Runner.Eval- Test.Hspec.Runner.Tree- Test.Hspec.Formatters.Internal- Test.Hspec.Timer- default-language: Haskell2010--executable hspec-discover- ghc-options:- -Wall- hs-source-dirs:- hspec-discover/src- main-is:- Main.hs- other-modules:- Run- Config- build-depends:- base == 4.*- , filepath- , directory- default-language: Haskell2010--test-suite spec- type:- exitcode-stdio-1.0- hs-source-dirs:- src, test- main-is:- Spec.hs- other-modules:- Mock- Helper- HelperSpec- Test.HspecSpec- Test.Hspec.CompatSpec- Test.Hspec.Core.QuickCheckUtilSpec- Test.Hspec.Core.TypeSpec- Test.Hspec.DiscoverSpec- Test.Hspec.FailureReportSpec- Test.Hspec.FormattersSpec- Test.Hspec.HUnitSpec- Test.Hspec.OptionsSpec- Test.Hspec.QuickCheckSpec- Test.Hspec.RunnerSpec- Test.Hspec.TimerSpec- Test.Hspec.UtilSpec- ghc-options:- -Wall -Werror- build-depends:- base == 4.*- , random- , tf-random- , setenv- , silently >= 1.2.4- , ansi-terminal- , time- , transformers- , deepseq- , HUnit- , QuickCheck- , quickcheck-io- , hspec-expectations- , async-- , hspec-meta == 1.12.1- , process- , directory- , stringbuilder- , ghc-paths- default-language: Haskell2010--test-suite example- type:- exitcode-stdio-1.0- main-is:- Spec.hs- hs-source-dirs:- example- ghc-options:- -Wall -Werror- build-depends:- base == 4.*- , hspec2- , QuickCheck- default-language: Haskell2010--test-suite hspec-discover-spec- type:- exitcode-stdio-1.0- ghc-options:- -Wall -Werror- hs-source-dirs:- hspec-discover/src- , hspec-discover/test- main-is:- Spec.hs- other-modules:- RunSpec- ConfigSpec- build-depends:- base == 4.*- , filepath- , directory- , hspec-meta+ Test.Hspec.Runner default-language: Haskell2010
src/Test/Hspec.hs view
@@ -1,161 +1,3 @@--- |--- Stability: stable------ Hspec is a testing framework for Haskell.------ This is the library reference for Hspec.--- The <http://hspec.github.io/ User's Manual> contains more in-depth--- documentation.-module Test.Hspec (--- * Types- Spec-, Arg-, SpecWith-, ActionWith-, Example---- * Setting expectations-, module Test.Hspec.Expectations---- * Defining a spec-, describe-, context-, it-, specify-, example-, pending-, pendingWith-, before-, beforeWith-, beforeAll-, beforeAllWith-, after-, after_-, afterAll-, afterAll_-, around-, around_-, aroundWith-, parallel-, runIO---- * Running a spec-, hspec-) where--import Control.Exception (finally)-import Control.Concurrent.MVar--import Test.Hspec.Core.Type hiding (describe, it)-import Test.Hspec.Runner-import Test.Hspec.HUnit ()-import Test.Hspec.Expectations-import qualified Test.Hspec.Core as Core---- | Combine a list of specs into a larger spec.-describe :: String -> SpecWith a -> SpecWith a-describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . Core.describe label---- | An alias for `describe`.-context :: String -> SpecWith a -> SpecWith a-context = describe---- | Create 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-it :: Example e => String -> e -> SpecWith (Arg e)-it label action = fromSpecList [Core.it label action]---- | An alias for `it`.-specify :: Example e => String -> e -> SpecWith (Arg e)-specify = it---- | This is a type restricted version of `id`. It can be used to get better--- error messages on type mismatches.------ Compare e.g.------ > it "exposes some behavior" $ example $ do--- > putStrLn------ with------ > it "exposes some behavior" $ do--- > putStrLn-example :: Expectation -> Expectation-example = id---- | Run spec items of given `Spec` in parallel.-parallel :: SpecWith a -> SpecWith a-parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True}---- | 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.-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)- let action_ = memoize mvar action- before 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 before all spec items.-beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b-beforeAllWith action spec = do- mvar <- runIO (newMVar Nothing)- let action_ = memoize mvar . action- aroundWith (\e x -> action_ x >>= e) spec---- | 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 () -> Spec -> Spec-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 . SpecWithCleanup action---- | Run a custom action after the last spec item.-afterAll_ :: IO () -> Spec -> Spec-afterAll_ action = afterAll (\() -> action)---- | Run a custom action before and/or after every spec item.-around_ :: (IO () -> IO ()) -> Spec -> Spec-around_ action = around $ action . ($ ())---- | 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+{-# LANGUAGE PackageImports #-}+module Test.Hspec (module Test.Hspec) where+import "hspec" Test.Hspec
− src/Test/Hspec/Compat.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Compat (- showType-, showFullType-, readMaybe-, lookupEnv-, module Data.IORef-#if !MIN_VERSION_base(4,6,0)-, modifyIORef'-#endif-) where--#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)-#endif--#if !MIN_VERSION_base(4,6,0)-import qualified Text.ParserCombinators.ReadP as P-#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
− src/Test/Hspec/Config.hs
@@ -1,82 +0,0 @@-module 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.Util-import Test.Hspec.Options-import Test.Hspec.FailureReport-import Test.Hspec.Core.QuickCheckUtil (mkGen)---- | 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 = flip elem . failureReportPaths <$> mFailureReport--configQuickCheckArgs :: Config -> QC.Args-configQuickCheckArgs c = qcArgs- where- qcArgs = (- maybe id setSeed (configQuickCheckSeed c)- . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)- . maybe id setMaxSize (configQuickCheckMaxSize c)- . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) QC.stdArgs-- setMaxSuccess :: Int -> QC.Args -> QC.Args- setMaxSuccess n args = args {QC.maxSuccess = n}-- 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
src/Test/Hspec/Core.hs view
@@ -1,37 +1,4 @@--- |--- Stability: experimental------ 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 (---- * A type class for examples- Example (..)-, Params (..)-, Progress-, ProgressCallback-, Result (..)---- * A writer monad for constructing specs-, SpecM-, runSpecM-, fromSpecList---- * Internal representation of a spec tree-, SpecTree (..)-, mapSpecTree-, Item (..)-, Location (..)-, LocationAccuracy(..)-, ActionWith-, mapSpecItem-, mapSpecItem_-, modifyParams-, describe-, it-) where--import Test.Hspec.Core.Type--modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a-modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core (module Test.Hspec.Core) where+import "hspec" Test.Hspec.Core
− src/Test/Hspec/Core/QuickCheckUtil.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Core.QuickCheckUtil where--import Control.Applicative-import Data.Int-import Data.IORef-import Test.QuickCheck hiding (Result(..))-import Test.QuickCheck as QC-import Test.QuickCheck.Property hiding (Result(..))-import Test.QuickCheck.Gen-import qualified Test.QuickCheck.Property as QCP-import Test.QuickCheck.IO ()---#if MIN_VERSION_QuickCheck(2,7,0)-import Test.QuickCheck.Random-#endif--import System.Random--import Test.Hspec.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
− src/Test/Hspec/Core/Type.hs
@@ -1,248 +0,0 @@-{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}-module Test.Hspec.Core.Type (- Spec-, SpecWith-, SpecM (..)-, runSpecM-, fromSpecList-, SpecTree (..)-, mapSpecTree-, Item (..)-, ActionWith-, mapSpecItem-, Location (..)-, LocationAccuracy(..)-, mapSpecItem_-, Example (..)-, Result (..)-, Params (..)-, Progress-, ProgressCallback--, describe-, it-, forceResult--, runIO--, pending-, pendingWith-) where--import qualified Control.Exception as E-import Control.Applicative-import Control.Monad.Trans.Writer-import Control.Monad.IO.Class (liftIO)-import Data.Typeable (Typeable)-import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe)--import Test.Hspec.Compat-import Test.Hspec.Util-import Test.Hspec.Expectations-import Test.HUnit.Lang (HUnitFailure(..))-import qualified Test.QuickCheck as QC-import qualified Test.QuickCheck.State as QC-import qualified Test.QuickCheck.Property as QCP-import qualified Test.QuickCheck.IO ()--import Test.Hspec.Core.QuickCheckUtil-import Control.DeepSeq (deepseq)--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.beforeAll` may be more suitable for your use case.-runIO :: IO r -> SpecM a r-runIO = SpecM . liftIO---- | The result of running an example.-data Result = Success | Pending (Maybe String) | Fail String- deriving (Eq, Show, Read, Typeable)--forceResult :: Result -> Result-forceResult r = case r of- Success -> r- Pending m -> m `deepseq` r- Fail m -> m `deepseq` r--instance E.Exception Result--type Progress = (Int, Int)-type ProgressCallback = Progress -> IO ()--data Params = Params {- paramsQuickCheckArgs :: QC.Args-, paramsSmallCheckDepth :: Int-} deriving (Show)---- | Internal representation of a spec.-data SpecTree a =- SpecGroup String [SpecTree a]- | SpecWithCleanup (ActionWith a) [SpecTree a]- | SpecItem (Item a)--data Item a = Item {- itemRequirement :: String-, itemLocation :: Maybe Location-, itemIsParallelizable :: Bool-, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result-}---- | An `IO` action that expects an argument of type @a@.-type ActionWith a = a -> IO ()--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- SpecGroup d xs -> SpecGroup d (map go xs)- SpecWithCleanup cleanup xs -> SpecWithCleanup (g cleanup) (map go xs)- SpecItem item -> SpecItem (f item)--data LocationAccuracy = ExactLocation | BestEffort- deriving (Eq, Show)--data Location = Location {- locationFile :: String-, locationLine :: Int-, locationColumn :: Int-, locationAccuracy :: LocationAccuracy-} deriving (Eq, Show)--mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a-mapSpecItem_ = mapSpecItem id---- | The @describe@ function combines a list of specs into a larger spec.-describe :: String -> [SpecTree a] -> SpecTree a-describe s = SpecGroup msg- where- msg- | null s = "(no description given)"- | otherwise = s---- | Create a spec item.-it :: Example a => String -> a -> SpecTree (Arg a)-it s e = SpecItem $ Item requirement Nothing False (evaluateExample e)- where- requirement- | null s = "(unspecified behavior)"- | otherwise = s---- | A type class for examples.-class Example e where- type Arg e- evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result--instance Example Bool where- type Arg Bool = ()- evaluateExample b _ _ _ = if b then return Success else return (Fail "")--instance Example Expectation where- type Arg Expectation = ()- evaluateExample e = evaluateExample (\() -> e)--instance Example (a -> Expectation) where- type Arg (a -> Expectation) = a- evaluateExample e _ action _ = (action e >> return Success) `E.catches` [- E.Handler (\(HUnitFailure err) -> return (Fail err))- , 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 $ sanitizeFailureMessage r) (parsePending m)- QC.GaveUp {QC.numTests = n} -> Fail ("Gave up after " ++ pluralize n "test" )- QC.NoExpectedFailure {} -> Fail ("No expected failure")- 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: '"---- | Specifies a pending example.------ 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)---- | Specifies a pending example with a reason for why it's pending.------ > describe "fancyFormatter" $ do--- > it "can format text in a way that everyone likes" $--- > pendingWith "waiting for clarification from the designers"-pendingWith :: String -> Expectation-pendingWith = E.throwIO . Pending . Just
src/Test/Hspec/Discover.hs view
@@ -1,82 +1,4 @@-module Test.Hspec.Discover {-# WARNING- "This module is used by @hspec-discover@. It is not part of the public API and may change at any time."- #-} (Spec, hspec, hspecWithFormatter, postProcessSpec, describe) where--import Control.Applicative-import Data.Maybe-import Data.List-import Data.Traversable hiding (mapM)-import Control.Monad.Trans.State--import Test.Hspec-import Test.Hspec.Core.Type hiding (describe)-import Test.Hspec.Runner-import Test.Hspec.Runner.Tree-import Test.Hspec.Formatters-import Test.Hspec.Util--hspecWithFormatter :: IsFormatter a => a -> Spec -> IO ()-hspecWithFormatter formatter spec = do- f <- toFormatter formatter- hspecWith defaultConfig {configFormatter = Just f} spec--postProcessSpec :: FilePath -> Spec -> Spec-postProcessSpec = locationHeuristicFromFile--locationHeuristicFromFile :: FilePath -> Spec -> Spec-locationHeuristicFromFile file spec = do- mInput <- either (const Nothing) Just <$> (runIO . safeTry . readFile) file- let lookupLoc = maybe (\_ _ _ -> Nothing) (lookupLocation file) mInput- runIO (toTree spec) >>= fromTree . addLoctions lookupLoc--addLoctions :: (Int -> Int -> String -> Maybe Location) -> [Tree (Item a)] -> [Tree (Item a)]-addLoctions lookupLoc = map (fmap f) . enumerate- where- f :: ((Int, Int), Item a) -> Item a- f ((n, total), item) = item {itemLocation = itemLocation item <|> lookupLoc n total (itemRequirement item)}--type EnumerateM = State [(String, Int)]--enumerate :: [Tree (Item a)] -> [Tree ((Int, Int), (Item a))]-enumerate tree = (mapM (traverse addPosition) tree >>= mapM (traverse addTotal)) `evalState` []- where- addPosition :: Item a -> EnumerateM (Int, Item a)- addPosition item = (,) <$> getOccurrence (itemRequirement item) <*> pure item-- addTotal :: (Int, Item a) -> EnumerateM ((Int, Int), Item a)- addTotal (n, item) = do- total <- getTotal (itemRequirement item)- return ((n, total), item)-- getTotal :: String -> EnumerateM Int- getTotal requirement = do- gets $ fromMaybe err . lookup requirement- where- err = error ("Test.Hspec.Discover.getTotal: No entry for requirement " ++ show requirement ++ "!")-- getOccurrence :: String -> EnumerateM Int- getOccurrence requirement = do- xs <- get- let n = maybe 1 succ (lookup requirement xs)- put ((requirement, n) : filter ((/= requirement) . fst) xs)- return n--lookupLocation :: FilePath -> String -> Int -> Int -> String -> Maybe Location-lookupLocation file input n total requirement = loc- where- loc :: Maybe Location- loc = Location file <$> line <*> pure 0 <*> pure BestEffort-- line :: Maybe Int- line = case occurrences of- xs | length xs == total -> Just (xs !! pred n)- _ -> Nothing-- occurrences :: [Int]- occurrences = map fst (filter p inputLines)- where- p :: (Int, String) -> Bool- p = isInfixOf (show requirement) . snd-- inputLines :: [(Int, String)]- inputLines = zip [1..] (lines input)+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Discover (module Test.Hspec.Discover) where+import "hspec" Test.Hspec.Discover
− src/Test/Hspec/FailureReport.hs
@@ -1,36 +0,0 @@-module Test.Hspec.FailureReport (- FailureReport (..)-, writeFailureReport-, readFailureReport-) where--import System.IO-import System.SetEnv-import Test.Hspec.Compat-import Test.Hspec.Util (Path, safeTry)--data FailureReport = FailureReport {- failureReportSeed :: Integer-, failureReportMaxSuccess :: Int-, failureReportMaxSize :: Int-, failureReportMaxDiscardRatio :: Int-, failureReportPaths :: [Path]-} deriving (Eq, Show, Read)--writeFailureReport :: FailureReport -> IO ()-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 ++ ")")--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
src/Test/Hspec/Formatters.hs view
@@ -1,236 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}--- |--- Stability: experimental------ This module contains formatters that can be used with--- `Test.Hspec.Runner.hspecWith`.-module Test.Hspec.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---- * Using custom formatters with @hspec-discover@--- |--- Anything that is an instance of `IsFormatter` can be used by--- @hspec-discover@ as the default formatter for a spec. If you have a--- formatter @myFormatter@ in the module @Custom.Formatters@ you can use it--- by passing an additional argument to @hspec-discover@.------ >{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --formatter=Custom.Formatters.myFormatter #-}-, IsFormatter (..)-) where--import Data.Maybe-import Test.Hspec.Util-import Test.Hspec.Core.Type (Location(..), LocationAccuracy(..))-import Text.Printf-import Control.Monad (when, unless)-import Data.Foldable (forM_)-import Control.Applicative-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.Formatters.Internal (- Formatter (..)- , FormatM-- , getSuccessCount- , getPendingCount- , getFailCount- , getTotalCount-- , FailureRecord (..)- , getFailMessages- , usedSeed-- , getCPUTime- , getRealTime-- , write- , writeLine- , newParagraph-- , withInfoColor- , withSuccessColor- , withPendingColor- , withFailColor- )--class IsFormatter a where- toFormatter :: a -> IO Formatter--instance IsFormatter (IO Formatter) where- toFormatter = id--instance IsFormatter Formatter where- toFormatter = return--silent :: Formatter-silent = Formatter {- 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-- 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 ""-- unless (null failures) $ do- 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- write (show n ++ ") ")- writeLine (formatRequirement path)- withFailColor $ do- unless (null err) $ do- writeLine err- forM_ mLoc $ \loc -> do- writeLine ""- withInfoColor $ writeLine (formatLoc loc)- where- err = either (("uncaught exception: " ++) . formatException) id reason- formatLoc (Location file line _column accuracy) = "# " ++ file ++ ":" ++ show line ++ bestEffortMarking- where- bestEffortMarking = case accuracy of- ExactLocation -> ""- 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 ""+{-# LANGUAGE PackageImports #-}+module Test.Hspec.Formatters (module Test.Hspec.Formatters) where+import "hspec" Test.Hspec.Formatters
− src/Test/Hspec/Formatters/Internal.hs
@@ -1,262 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Test.Hspec.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 qualified System.IO as IO-import System.IO (Handle)-import Control.Monad-import Control.Applicative-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.Util (Path)-import Test.Hspec.Compat-import Test.Hspec.Core.Type (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 to color 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 ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"--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)
− src/Test/Hspec/HUnit.hs
@@ -1,23 +0,0 @@-module Test.Hspec.HUnit (--- * Interoperability with HUnit- fromHUnitTest-) where--import Test.Hspec.Core.Type-import Test.HUnit (Test (..))---- |--- Convert a HUnit test suite to a spec. This can be used to run existing--- HUnit tests with Hspec.-fromHUnitTest :: Test -> Spec-fromHUnitTest t = fromSpecList $ case t of- TestList xs -> map go xs- x -> [go x]- where- go :: Test -> SpecTree ()- go t_ = case t_ of- TestLabel s (TestCase e) -> it s e- TestLabel s (TestList xs) -> describe s (map go xs)- TestLabel s x -> describe s [go x]- TestList xs -> describe "<unlabeled>" (map go xs)- TestCase e -> it "<unlabeled>" e
− src/Test/Hspec/Options.hs
@@ -1,178 +0,0 @@-module Test.Hspec.Options (- Config(..)-, ColorMode (..)-, defaultConfig-, filterOr-, parseOptions-) where--import Control.Applicative-import Data.List-import System.IO-import System.Exit-import System.Console.GetOpt--import Test.Hspec.Formatters-import Test.Hspec.Compat-import Test.Hspec.Util--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)-, 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-}--defaultConfig :: Config-defaultConfig = Config {- configDryRun = False-, configPrintCpuTime = False-, configFastFail = False-, configRerun = False-, configFilterPredicate = Nothing-, configQuickCheckSeed = Nothing-, configQuickCheckMaxSuccess = Nothing-, configQuickCheckMaxDiscardRatio = Nothing-, configQuickCheckMaxSize = Nothing-, configSmallCheckDepth = 5-, configColorMode = ColorAuto-, configFormatter = Nothing-, configHtmlOutput = False-, configOutputFile = Left stdout-}--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}--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")- , 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)")- ]- where- h = unlines . addLineBreaks-- readFormatter :: String -> Maybe Formatter- readFormatter = (`lookup` formatters)-- setFormatter :: Formatter -> Config -> Config- setFormatter f c = c {configFormatter = Just f}-- setOutputFile :: String -> Config -> Config- setOutputFile file c = c {configOutputFile = Right file}-- 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")
src/Test/Hspec/QuickCheck.hs view
@@ -1,53 +1,3 @@--- |--- Stability: provisional-module Test.Hspec.QuickCheck (--- * Params- modifyMaxSuccess-, modifyMaxDiscardRatio-, modifyMaxSize---- * Shortcuts-, prop-) where--import Test.QuickCheck-import Test.Hspec-import Test.Hspec.Core (Params(..), modifyParams)---- |--- > prop ".." $--- > ..------ is a shortcut for------ > it ".." $ property $--- > ..-prop :: Testable prop => String -> prop -> Spec-prop s = it s . property---- | Use a modified `maxSuccess` for given spec.-modifyMaxSuccess :: (Int -> Int) -> Spec -> Spec-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) -> Spec -> Spec-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) -> Spec -> Spec-modifyMaxSize = modifyArgs . modify- where- modify :: (Int -> Int) -> Args -> Args- modify f args = args {maxSize = f (maxSize args)}--modifyArgs :: (Args -> Args) -> Spec -> Spec-modifyArgs = modifyParams . modify- where- modify :: (Args -> Args) -> Params -> Params- modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)}+{-# LANGUAGE PackageImports #-}+module Test.Hspec.QuickCheck (module Test.Hspec.QuickCheck) where+import "hspec" Test.Hspec.QuickCheck
src/Test/Hspec/Runner.hs view
@@ -1,175 +1,3 @@--- |--- Stability: provisional-module Test.Hspec.Runner (--- * Running a spec- hspec-, hspecWith-, hspecResult-, hspecWithResult---- * Types-, Summary (..)-, Config (..)-, ColorMode (..)-, Path-, defaultConfig-, configAddFilter-) where--import Control.Monad-import Control.Applicative-import Data.Monoid-import Data.Maybe-import System.IO-import System.Environment (getProgName, getArgs, withArgs)-import System.Exit-import qualified Control.Exception as E--import System.Console.ANSI (hHideCursor, hShowCursor)-import qualified Test.QuickCheck as QC-import Control.Monad.IO.Class (liftIO)--import Test.Hspec.Compat (lookupEnv)-import Test.Hspec.Util (Path)-import Test.Hspec.Core.Type-import Test.Hspec.Config-import Test.Hspec.Formatters-import Test.Hspec.Formatters.Internal-import Test.Hspec.FailureReport-import Test.Hspec.Core.QuickCheckUtil--import Test.Hspec.Runner.Tree-import Test.Hspec.Runner.Eval---- | Filter specs by given predicate.------ The predicate takes a list of "describe" labels and a "requirement".-filterSpecs :: Config -> [Tree (Item a)] -> [Tree (Item a)]-filterSpecs c = go []- where- p :: Path -> Bool- p = fromMaybe (const True) (configFilterPredicate c)-- go :: [String] -> [Tree (Item a)] -> [Tree (Item a)]- go groups = mapMaybe (goSpec groups)-- goSpecs :: [String] -> [Tree (Item a)] -> ([Tree (Item a)] -> b) -> Maybe b- goSpecs groups specs ctor = case go groups specs of- [] -> Nothing- xs -> Just (ctor xs)-- goSpec :: [String] -> Tree (Item a) -> Maybe (Tree (Item 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 -> [Tree (Item ())] -> [Tree (Item ())]-applyDryRun c- | configDryRun c = map (removeCleanup . fmap markSuccess)- | otherwise = id- where- markSuccess :: Item () -> Item ()- markSuccess item = item {itemExample = evaluateExample Success}-- removeCleanup :: Tree (Item ()) -> Tree (Item ())- 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-- useColor <- doesUseColor h c-- filteredSpec <- filterSpecs c . applyDryRun c <$> toTree spec-- withHiddenCursor useColor h $- runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do- runFormatter 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)+{-# LANGUAGE PackageImports #-}+module Test.Hspec.Runner (module Test.Hspec.Runner) where+import "hspec" Test.Hspec.Runner
− src/Test/Hspec/Runner/Eval.hs
@@ -1,152 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Test.Hspec.Runner.Eval (runFormatter) where--import Control.Applicative-import Control.Monad-import qualified Control.Exception as E-import Control.Concurrent-import System.IO (Handle)--import Control.Monad.IO.Class (liftIO)--import Test.Hspec.Util-import Test.Hspec.Runner.Tree-import Test.Hspec.Core.Type-import Test.Hspec.Config-import Test.Hspec.Formatters-import Test.Hspec.Formatters.Internal-import Test.Hspec.Timer-import Data.Time.Clock.POSIX--type EvalTree = Tree (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ()))---- | Evaluate all examples of a given spec and produce a report.-runFormatter :: Bool -> Handle -> Config -> Formatter -> [Tree (Item ())] -> FormatM ()-runFormatter 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 :: [Tree (Item ())] -> [EvalTree]- toEvalTree = map (fmap f)- where- f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ()))- f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize 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 :: Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())-parallelize isParallelizable e- | isParallelizable = runParallel 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 :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())-runParallel e reportProgress formatResult = do- mvar <- newEmptyMVar- _ <- forkIO $ 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--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 err) -> failed 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 ()
− src/Test/Hspec/Runner/Tree.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Test.Hspec.Runner.Tree where--import Control.Applicative-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Test.Hspec.Core.Type--data Tree a- = Node !String [Tree a]- | NodeWithCleanup (IO ()) [Tree a]- | Leaf a- deriving (Functor, Foldable, Traversable)--toTree :: Spec -> IO [Tree (Item ())]-toTree spec = map f <$> runSpecM spec- where- f :: SpecTree () -> Tree (Item ())- f x = case x of- SpecGroup label xs -> Node label (map f xs)- SpecWithCleanup cleanup xs -> NodeWithCleanup (cleanup ()) (map f xs)- SpecItem item -> Leaf item--fromTree :: [Tree (Item ())] -> SpecWith ()-fromTree = fromSpecList . map go- where- go :: Tree (Item ()) -> SpecTree ()- go x = case x of- Node label xs -> SpecGroup label (map go xs)- NodeWithCleanup action xs -> SpecWithCleanup (\() -> action) (map go xs)- Leaf item -> SpecItem item
− src/Test/Hspec/Timer.hs
@@ -1,14 +0,0 @@-module 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
− src/Test/Hspec/Util.hs
@@ -1,82 +0,0 @@-module Test.Hspec.Util (- pluralize-, formatException-, lineBreaksAt-, safeTry-, Path-, filterPredicate-, formatRequirement-, strip-) where--import Data.List-import Data.Char (isSpace)-import qualified Control.Exception as E-import Control.Concurrent.Async--import Test.Hspec.Compat (showType)--pluralize :: Int -> String -> String-pluralize 1 s = "1 " ++ s-pluralize n s = show n ++ " " ++ s ++ "s"---- | Convert an exception to a string.------ This is different from `show`. The type of the exception is included, e.g.--- `E.ArithException` is turned into:------ @--- "ArithException (divide by zero)"--- @-formatException :: E.SomeException -> String-formatException (E.SomeException e) = showType e ++ " (" ++ show e ++ ")"--safeTry :: IO a -> IO (Either E.SomeException a)-safeTry action = withAsync (action >>= E.evaluate) waitCatch---- |--- A tuple that represents the location of an example within a spec.------ It consists of a list of group descriptions and a requirement description.-type Path = ([String], String)---- | A predicate that can be used to filter specs.-filterPredicate :: String -> Path -> Bool-filterPredicate pattern path@(groups, requirement) =- pattern `isInfixOf` plain- || pattern `isInfixOf` formatted- where- plain = intercalate "/" (groups ++ [requirement])- formatted = formatRequirement path---- |--- 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---- 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)--strip :: String -> String-strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
− test/Helper.hs
@@ -1,102 +0,0 @@-module Helper (- module Test.Hspec.Meta-, module Test.QuickCheck-, module Control.Applicative-, module System.IO.Silently-, sleep-, timeout-, defaultParams-, noOpProgressCallback-, captureLines-, normalizeSummary--, ignoreExitCode-, ignoreUserInterrupt-, throwException--, shouldStartWith-, shouldEndWith--, shouldUseArgs--, withFileContent-) where--import Data.List-import Data.Char-import Data.IORef-import Control.Monad-import Control.Applicative-import System.Environment (withArgs)-import System.Exit-import Control.Concurrent-import qualified Control.Exception as E-import qualified System.Timeout as System-import System.IO-import System.Directory-import Data.Time.Clock.POSIX-import System.IO.Silently--import Test.Hspec.Meta-import Test.QuickCheck hiding (Result(..))--import qualified Test.Hspec as H-import qualified Test.Hspec.Core as H (Params(..), Item(..), ProgressCallback, mapSpecItem_)-import qualified Test.Hspec.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_--shouldStartWith :: (Eq a, Show a) => [a] -> [a] -> Expectation-x `shouldStartWith` y = x `shouldSatisfy` isPrefixOf y--shouldEndWith :: (Eq a, Show a) => [a] -> [a] -> Expectation-x `shouldEndWith` y = x `shouldSatisfy` isSuffixOf y---- 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.Params stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000} (H.configSmallCheckDepth H.defaultConfig)--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)--withFileContent :: String -> (FilePath -> IO a) -> IO a-withFileContent input action = do- dir <- getTemporaryDirectory- (file, h) <- openTempFile dir "temp"- hPutStr h input- hClose h- action file `E.finally` removeFile file
− test/HelperSpec.hs
@@ -1,18 +0,0 @@-module HelperSpec (main, spec) where--import Helper-import System.IO.Error (isDoesNotExistError)--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "withFileContent" $ do- it "creates a file with specified content and runs specified action" $ do- withFileContent "foo" $ \file -> do- readFile file `shouldReturn` "foo"-- it "removes file after action has been run" $ do- file <- withFileContent "foo" return- readFile file `shouldThrow` isDoesNotExistError
− test/Mock.hs
@@ -1,15 +0,0 @@-module Mock where--import Control.Applicative-import Data.IORef--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
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}
− test/Test/Hspec/CompatSpec.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Test.Hspec.CompatSpec (main, spec) where--import Helper-import System.SetEnv--import Test.Hspec.Compat-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
− test/Test/Hspec/Core/QuickCheckUtilSpec.hs
@@ -1,31 +0,0 @@-{-# 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- }
− test/Test/Hspec/Core/TypeSpec.hs
@@ -1,136 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}-module Test.Hspec.Core.TypeSpec (main, spec) where--import Helper-import Mock-import Data.List-import Data.IORef--import qualified Test.Hspec.Core.Type as H hiding (describe, it)-import qualified Test.Hspec as H-import qualified Test.Hspec.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 ""-- 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- evaluateExample (23 `shouldBe` (42 :: Int)) `shouldReturn` H.Fail "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 $ modifyIORef ref succ)- readIORef ref `shouldReturn` 2000-- it "pretty-prints exceptions" $ do- H.Fail r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (error "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 `shouldBe` intercalate "\n" [- "Falsifiable (after 1 test): "- , "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
− test/Test/Hspec/DiscoverSpec.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-module Test.Hspec.DiscoverSpec (main, spec) where--import Helper-import Data.String-import Data.String.Builder--import qualified Test.Hspec as H (it)-import Test.Hspec.Core (Item(..), Location(..), LocationAccuracy(..))-import Test.Hspec.Runner.Tree-import qualified Test.Hspec.Discover as H--infix 1 `shouldHaveLocation`--shouldHaveLocation :: Item a -> (String, Int) -> Expectation-item `shouldHaveLocation` (src, line) = itemLocation item `shouldBe` Just (Location src line 0 BestEffort)--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "postProcessSpec" $ do- it "adds heuristic source locations" $ do- let c = build $ do- ""- strlit "foo"- ""- strlit "bar"- ""- strlit "baz"- withFileContent c $ \src -> do- [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do- H.it "foo" True- H.it "bar" True- H.it "baz" True- item1 `shouldHaveLocation` (src, 2)- item2 `shouldHaveLocation` (src, 4)- item3 `shouldHaveLocation` (src, 6)-- context "when same requirement is used multiple times" $ do- it "assigns locations sequentially" $ do- let c = build $ do- strlit "foo"- strlit "foo"- strlit "foo"- withFileContent c $ \src -> do- [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do- H.it "foo" True- H.it "foo" True- H.it "foo" True- item1 `shouldHaveLocation` (src, 1)- item2 `shouldHaveLocation` (src, 2)- item3 `shouldHaveLocation` (src, 3)-- context "when a requirement occurs more often in the spec tree than in the source file" $ do- it "assigns Nothing" $ do- let c = build $ do- strlit "foo"- strlit "foo"- withFileContent c $ \src -> do- [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do- H.it "foo" True- H.it "foo" True- H.it "foo" True- itemLocation item1 `shouldBe` Nothing- itemLocation item2 `shouldBe` Nothing- itemLocation item3 `shouldBe` Nothing- where- strlit :: String -> Builder- strlit = fromString . show
− test/Test/Hspec/FailureReportSpec.hs
@@ -1,39 +0,0 @@-module Test.Hspec.FailureReportSpec (main, spec) where--import Helper--import System.IO-import Test.Hspec.FailureReport-import GHC.Paths (ghc)-import System.Process-import System.Exit--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "writeFailureReport" $ do- it "prints a warning on unexpected exceptions" $ do- r <- hCapture_ [stderr] $ writeFailureReport (error "some error")- r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n"-- -- GHCi needs to keep the environment on :reload, so that we can store- -- failures there. Otherwise --rerun would not be very useful. So we add a- -- test for that.- describe "GHCi" $ do- it "keeps environment variables on :reload" $ do- let flags = ["-v0", "--interactive", "-ignore-dot-ghci"]- (Just hIn, Just hOut, Nothing, processHandle) <- createProcess $ (proc ghc flags) {- std_in = CreatePipe- , std_out = CreatePipe- }- hPutStrLn hIn "import System.SetEnv"- hPutStrLn hIn "setEnv \"FOO\" \"bar\""- hPutStrLn hIn ":reload"- hPutStrLn hIn "import System.Environment"- hPutStrLn hIn "getEnv \"FOO\""- hClose hIn- r <- hGetContents hOut- length r `seq` r `shouldBe` "\"bar\"\n"- waitForProcess processHandle `shouldReturn` ExitSuccess
− test/Test/Hspec/FormattersSpec.hs
@@ -1,228 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.FormattersSpec (main, spec) where--import Helper--import qualified Test.Hspec as H-import qualified Test.Hspec.Core as H (Result(..), Location(..), LocationAccuracy(..), Item(..), mapSpecItem_)-import qualified Test.Hspec.Runner as H-import qualified Test.Hspec.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 "fail message")- H.it "pending" (H.pendingWith "pending message")- H.it "fail 2" (H.Fail "")- H.it "exceptions" (undefined :: H.Result)- H.it "fail 3" (H.Fail "")--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" (undefined :: Bool)- r `shouldContain` [- "1) foobar"- , "uncaught exception: ErrorCall (Prelude.undefined)"- ]-- 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."-- 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
− test/Test/Hspec/HUnitSpec.hs
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Test.Hspec.HUnitSpec (main, spec) where--import Helper hiding (example)--import Test.Hspec.Core (Item(..))-import Test.Hspec.Runner.Tree-import Test.Hspec.HUnit-import Test.HUnit--main :: IO ()-main = hspec spec--shouldYield :: Test -> [Tree String] -> Expectation-a `shouldYield` b = map (Blind . fmap itemRequirement) <$> toTree (fromHUnitTest a) `shouldReturn` map Blind b--instance Eq a => Eq (Tree a) where- x == y = case (x, y) of- (Node s1 xs, Node s2 ys) -> s1 == s2 && xs == ys- (Leaf x1, Leaf x2) -> x1 == x2- _ -> False--spec :: Spec-spec = do- describe "fromHUnitTest" $ do- let e = TestCase $ pure ()-- it "works for a TestCase" $ do- e `shouldYield` [Leaf "<unlabeled>"]-- it "works for a labeled TestCase" $ do- TestLabel "foo" e- `shouldYield` [Leaf "foo"]-- it "works for a TestCase with nested labels" $ do- (TestLabel "foo" . TestLabel "bar") e- `shouldYield` [Node "foo" [Leaf "bar"]]-- it "works for a flat TestList" $ do- TestList [e, e, e]- `shouldYield` [Leaf "<unlabeled>", Leaf "<unlabeled>", Leaf "<unlabeled>"]-- it "works for a nested TestList" $ do- (TestLabel "foo" . TestLabel "bar" . TestList) [TestLabel "one" e, TestLabel "two" e, TestLabel "three" e]- `shouldYield` [Node "foo" [Node "bar" [Leaf "one", Leaf "two", Leaf "three"]]]
− test/Test/Hspec/OptionsSpec.hs
@@ -1,44 +0,0 @@-module Test.Hspec.OptionsSpec (main, spec) where--import Helper-import System.Exit--import Test.Hspec.Options hiding (parseOptions)-import qualified Test.Hspec.Options as Options--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
− test/Test/Hspec/QuickCheckSpec.hs
@@ -1,19 +0,0 @@-module Test.Hspec.QuickCheckSpec (main, spec) where--import Helper--import qualified Test.Hspec as H-import qualified Test.Hspec.Runner as H-import qualified Test.Hspec.QuickCheck as H--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "prop" $ do- it "is a shortcut to use properties as examples" $ do- silence . H.hspecResult $ do- H.describe "read" $ do- H.prop "is inverse to show" $ \x -> (read . show) x == (x :: Int)- `shouldReturn` H.Summary 1 0
− test/Test/Hspec/RunnerSpec.hs
@@ -1,399 +0,0 @@-module Test.Hspec.RunnerSpec (main, spec) where--import Helper-import System.IO (stderr)-import Control.Monad-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.Compat--import Test.Hspec.FailureReport (FailureReport(..))-import qualified Test.Hspec as H-import qualified Test.Hspec.Runner as H-import qualified Test.Hspec.Core as H (Result(..))-import qualified Test.Hspec.Formatters as H (silent)-import qualified Test.Hspec.QuickCheck as H--import qualified Test.QuickCheck as QC--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 ["-r"] `shouldReturn` r-- forM_ quickCheckOptions $ \(flag, accessor) -> do- it ("reuses same " ++ flag) $ do- [flag, "23"] `shouldUseArgs` ((== 23) . accessor)- ["--rerun"] `shouldUseArgs` ((== 23) . accessor)-- context "when there is no failure report in the environment" $ do- it "runs everything" $ do- unsetEnv "HSPEC_FAILURES"- r <- hSilence [stderr] $ withArgs ["-r"] runSpec- r `shouldSatisfy` elem "5 examples, 3 failures"-- it "prints a warning to stderr" $ do- unsetEnv "HSPEC_FAILURES"- r <- hCapture_ [stderr] $ withArgs ["-r"] 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 ["-r"] 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 ["-r"] 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 $ 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]"- , ""- , "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 $ do- H.it "foo" True- H.it "bar" False- H.it "baz" False- normalizeSummary r `shouldBe` [- ""- , "- foo"- , "- bar FAILED [1]"- , ""- , "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 $ do- H.describe "foo" $ do- H.it "bar" False- H.it "baz" True- normalizeSummary r `shouldBe` [- ""- , "foo"- , " - bar FAILED [1]"- , ""- , "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 "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 $ 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` "</span>"-- it "marks successful examples with CSS class hspec-success" $ do- r <- capture_ . withArgs ["--html"] . H.hspec $ do- H.it "foo" True- r `shouldContain` "<span class=\"hspec-success\">- foo\n</span>"-- it "marks pending examples with CSS class hspec-pending" $ do- r <- capture_ . withArgs ["--html"] . H.hspec $ do- H.it "foo" H.pending- r `shouldContain` "<span class=\"hspec-pending\">- 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` "<span class=\"hspec-failure\">- 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 $ "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 . H.hspecResult . H.parallel $ do- replicateM_ n (H.it "foo" $ sleep t)- r `shouldBe` Just (H.Summary n 0)
− test/Test/Hspec/TimerSpec.hs
@@ -1,29 +0,0 @@-module 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
− test/Test/Hspec/UtilSpec.hs
@@ -1,101 +0,0 @@-module Test.Hspec.UtilSpec (main, spec) where--import Helper-import Control.Concurrent-import qualified Control.Exception as E--import Test.Hspec.Util--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- describe "pluralize" $ do- it "returns an amount and a word given an amount and word" $ do- pluralize 1 "thing" `shouldBe` "1 thing"-- it "returns a singular word given the number 1" $ do- pluralize 1 "thing" `shouldBe` "1 thing"-- it "returns a plural word given a number greater than 1" $ do- pluralize 2 "thing" `shouldBe` "2 things"-- it "returns a plural word given the number 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)"-- 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 undefined)- show e `shouldBe` "Prelude.undefined"-- 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"
− test/Test/HspecSpec.hs
@@ -1,319 +0,0 @@-module Test.HspecSpec (main, spec) where--import Helper-import Data.IORef-import Data.List (isPrefixOf)--import Test.Hspec.Core (Item(..), Result(..))-import qualified Test.Hspec as H-import qualified Test.Hspec.Runner as H (hspecResult)--import Test.Hspec.Runner.Tree--main :: IO ()-main = hspec spec--spec :: Spec-spec = do- 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 "describe" $ do- let testSpec = do- H.describe "some subject" $ do- H.it "foo" True- H.it "bar" True- H.it "baz" True- it "takes a description of what the behavior is for" $ do- r <- runSpec testSpec- r `shouldSatisfy` any (== "some subject")-- it "groups behaviors for what's being described" $ do- r <- filter (isPrefixOf " - ") `fmap` runSpec testSpec- length r `shouldBe` 3-- it "can be nested" $ do- [Node foo [Node bar [Leaf _]]] <- toTree $ 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 _] <- toTree (H.describe "" (pure ()))- d `shouldBe` "(no description given)"-- describe "it" $ do- it "takes a description of a desired behavior" $ do- [Leaf item] <- toTree (H.it "whatever" True)- itemRequirement item `shouldBe` "whatever"-- it "takes an example of that behavior" $ do- [Leaf item] <- toTree (H.it "whatever" True)- itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success-- context "when no description is given" $ do- it "uses a default description" $ do- [Leaf item] <- toTree (H.it "" True)- itemRequirement item `shouldBe` "(unspecified behavior)"-- describe "example" $ do- it "fixes the type of an expectation" $ do- r <- runSpec $ do- H.it "foo" $ H.example $ do- pure ()- r `shouldSatisfy` any (== "1 example, 0 failures")-- describe "parallel" $ do- it "marks examples for parallel execution" $ do- [Leaf item] <- toTree . H.parallel $ H.it "whatever" True- itemIsParallelizable item `shouldBe` True-- it "is applied recursively" $ do- [Node _ [Node _ [Leaf item]]] <- toTree . H.parallel $ do- H.describe "foo" $ do- H.describe "bar" $ do- H.it "baz" True- itemIsParallelizable item `shouldBe` True-- describe "before" $ do- it "runs an action before every spec item" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.before (append "before") $ do- H.it "foo" $ do- append "foo"- H.it "bar" $ do- append "bar"- readIORef ref `shouldReturn` [- "before"- , "foo"- , "before"- , "bar"- ]-- context "when used multiple times" $ do- it "is evaluated outside in" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.before (append "before outer") $ H.before (append "before inner") $ do- H.it "foo" $ do- append "foo"- readIORef ref `shouldReturn` [- "before outer"- , "before inner"- , "foo"- ]-- context "when used with an action that returns a value" $ do- it "passes that value to the spec item" $ do- property $ \n -> do- silence $ H.hspec $ H.before (return n) $ do- H.it "foo" $ \m -> do- m `shouldBe` (n :: Int)-- context "when used with a QuickCheck property" $ do- it "runs action before every check of the property" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.before (append "before") $ do- H.it "foo" $ property $ append "foo"- readIORef ref `shouldReturn` (take 200 . cycle) ["before", "foo"]-- describe "beforeWith" $ do- it "runs an action before every spec item" $ do- let action :: Int -> IO String- action n = return (show n)- property $ \n -> do- silence $ H.hspec $ H.before (return n) $ H.beforeWith action $ do- H.it "foo" $ (`shouldBe` show n)-- describe "beforeAll" $ do- it "runs an action before the first spec item" $ do- ref <- newIORef []- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.beforeAll (append "beforeAll") $ do- H.it "foo" $ do- append "foo"- H.it "bar" $ do- append "bar"- readIORef ref `shouldReturn` [- "beforeAll"- , "foo"- , "bar"- ]-- context "when used with an empty list of examples" $ do- it "does not run specified action" $ do- ref <- newIORef []- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.beforeAll (append "beforeAll") $ do- return ()- readIORef ref `shouldReturn` []-- context "when used with an action that returns a value" $ do- it "passes that value to the spec item" $ do- property $ \n -> do- silence $ H.hspec $ H.beforeAll (return n) $ do- H.it "foo" $ \m -> do- m `shouldBe` (n :: Int)-- describe "beforeAllWith" $ do- it "runs an action before the first spec item" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.before (return 23) $ H.beforeAllWith (\n -> append "beforeAllWith" >> return (succ n :: Int)) $ do- H.it "foo" $ \n -> do- append ("foo " ++ show n)- H.it "bar" $ \n -> do- append ("bar " ++ show n)- readIORef ref `shouldReturn` [- "beforeAllWith"- , "foo 24"- , "bar 24"- ]-- describe "after" $ do- it "must be used with a before action" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.before (return "from before") $ H.after append $ do- H.it "foo" $ \_ -> do- append "foo"- readIORef ref `shouldReturn` [- "foo"- , "from before"- ]-- describe "after_" $ do- it "runs an action after every spec item" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.after_ (append "after") $ do- H.it "foo" $ do- append "foo"- H.it "bar" $ do- append "bar"- readIORef ref `shouldReturn` [- "foo"- , "after"- , "bar"- , "after"- ]-- it "guarantees that action is run" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence . ignoreExitCode $ H.hspec $ H.after_ (append "after") $ do- H.it "foo" $ do- ioError $ userError "foo" :: IO ()- append "foo"- readIORef ref `shouldReturn` ["after"]-- context "when used multiple times" $ do- it "is evaluated inside out" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.after_ (append "after outer") $ H.after_ (append "after inner") $ do- H.it "foo" $ do- append "foo"- readIORef ref `shouldReturn` [- "foo"- , "after inner"- , "after outer"- ]-- describe "afterAll_" $ do- it "runs an action after the last spec item" $ do- ref <- newIORef []- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.afterAll_ (append "afterAll") $ do- H.it "foo" $ do- append "foo"- H.it "bar" $ do- append "bar"- readIORef ref `shouldReturn` [- "foo"- , "bar"- , "afterAll"- ]-- context "when used with an empty list of examples" $ do- it "does not run specified action" $ do- ref <- newIORef []- let append n = modifyIORef ref (++ return n)- silence $ H.hspec $ H.afterAll_ (append "afterAll") $ do- return ()- readIORef ref `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- property $ \n -> do- silence $ H.hspec $ H.around ($ n) $ do- H.it "foo" $ \m -> do- m `shouldBe` (n :: Int)-- describe "around_" $ do- it "wraps every spec item with an action" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- action e = append "before" >> e >> append "after"- silence $ H.hspec $ H.around_ action $ do- H.it "foo" $ do- append "foo"- H.it "bar" $ do- append "bar"- readIORef ref `shouldReturn` [- "before"- , "foo"- , "after"- , "before"- , "bar"- , "after"- ]-- context "when used multiple times" $ do- it "is evaluated outside in" $ do- ref <- newIORef ([] :: [String])- let append n = modifyIORef ref (++ return n)- actionOuter e = append "before outer" >> e >> append "after outer"- actionInner e = append "before inner" >> e >> append "after inner"- silence $ H.hspec $ H.around_ actionOuter $ H.around_ actionInner $ do- H.it "foo" $ do- append "foo"- readIORef ref `shouldReturn` [- "before outer"- , "before inner"- , "foo"- , "after inner"- , "after outer"- ]-- describe "aroundWith" $ do- it "wraps every spec item with an action" $ do- let action :: H.ActionWith String -> H.ActionWith Int- action e n = e (show n)- property $ \n -> do- silence $ H.hspec $ H.before (return n) $ H.aroundWith action $ do- H.it "foo" $ (`shouldBe` show n)- where- runSpec :: H.Spec -> IO [String]- runSpec = captureLines . H.hspecResult