diff --git a/hspec-discover/src/Config.hs b/hspec-discover/src/Config.hs deleted file mode 100644 --- a/hspec-discover/src/Config.hs +++ /dev/null @@ -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=' 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) diff --git a/hspec-discover/src/Main.hs b/hspec-discover/src/Main.hs deleted file mode 100644 --- a/hspec-discover/src/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main (main) where - -import System.Environment - -import Run (run) - -main :: IO () -main = getArgs >>= run diff --git a/hspec-discover/src/Run.hs b/hspec-discover/src/Run.hs deleted file mode 100644 --- a/hspec-discover/src/Run.hs +++ /dev/null @@ -1,134 +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 -, moduleName -) 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 c -> do - when (configNested c) (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 c specs) - _ -> do - hPutStrLn stderr (usage name) - exitFailure - -mkSpecModule :: FilePath -> Config -> [Spec] -> String -mkSpecModule src c nodes = - ( "{-# LINE 1 " . shows src . " #-}\n" - . showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n" - . showString ("module " ++ module_ ++" where\n") - . importList nodes - . showString "import Test.Hspec.Discover\n" - . maybe driver driverWithFormatter (configFormatter c) - . showString "spec :: Spec\n" - . showString "spec = " - . formatSpecs nodes - ) "\n" - where - driver = - case configNoMain c of - False -> - showString "main :: IO ()\n" - . showString "main = hspec spec\n" - True -> "" - module_ = fromMaybe (if configNoMain c then pathToModule src else "Main") (configModuleName c) - pathToModule f = let - fileName = last $ splitDirectories f - m:ms = takeWhile (/='.') fileName - in - toUpper m:ms - - -driverWithFormatter :: String -> ShowS -driverWithFormatter f = - showString "import qualified " . showString (moduleName f) . showString "\n" - . showString "main :: IO ()\n" - . showString "main = hspecWithFormatter " . showString f . showString " spec\n" - -moduleName :: String -> String -moduleName = 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) diff --git a/hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder b/hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder deleted file mode 100644 --- a/hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder +++ /dev/null diff --git a/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs b/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs deleted file mode 100644 --- a/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs +++ /dev/null diff --git a/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs b/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs deleted file mode 100644 --- a/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs +++ /dev/null diff --git a/hspec-discover/test-data/nested-spec/FooSpec.hs b/hspec-discover/test-data/nested-spec/FooSpec.hs deleted file mode 100644 --- a/hspec-discover/test-data/nested-spec/FooSpec.hs +++ /dev/null diff --git a/hspec-discover/test/ConfigSpec.hs b/hspec-discover/test/ConfigSpec.hs deleted file mode 100644 --- a/hspec-discover/test/ConfigSpec.hs +++ /dev/null @@ -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= with --no-main" $ do - parse ["--no-main", "--formatter=foo"] `shouldBe` (Left . unlines) [ - "hspec-discover: option `--formatter=' 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"}) diff --git a/hspec-discover/test/RunSpec.hs b/hspec-discover/test/RunSpec.hs deleted file mode 100644 --- a/hspec-discover/test/RunSpec.hs +++ /dev/null @@ -1,115 +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 "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 "moduleName" $ do - it "returns the module name of an fully qualified identifier" $ do - moduleName "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 diff --git a/hspec-discover/test/Spec.hs b/hspec-discover/test/Spec.hs deleted file mode 100644 --- a/hspec-discover/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} diff --git a/hspec.cabal b/hspec.cabal --- a/hspec.cabal +++ b/hspec.cabal @@ -1,5 +1,5 @@ name: hspec -version: 1.12.4 +version: 2.0.0 license: MIT license-file: LICENSE copyright: (c) 2011-2014 Simon Hengel, @@ -30,120 +30,52 @@ 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 -Library +library ghc-options: -Wall hs-source-dirs: src build-depends: base == 4.* - , random - , tf-random - , setenv - , ansi-terminal >= 0.5 - , time + , hspec-core == 2.0.0 + , hspec-discover == 2.0.0 + , hspec-expectations == 0.6.1.* , transformers >= 0.2.2.0 - , deepseq - , HUnit >= 1.2.5 , QuickCheck >= 2.5.1 - , quickcheck-io - , hspec-expectations == 0.6.1.* - , async >= 2 exposed-modules: Test.Hspec - Test.Hspec.Core Test.Hspec.Runner 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 + Test.Hspec.Core default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 + ghc-options: + -Wall hs-source-dirs: - src, test + 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-core + , hspec - , hspec-meta >= 1.12 - , process , directory , stringbuilder - , ghc-paths + , hspec-meta >= 1.12 default-language: Haskell2010 test-suite example @@ -154,29 +86,9 @@ hs-source-dirs: example ghc-options: - -Wall -Werror + -Wall build-depends: base == 4.* , hspec , 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 default-language: Haskell2010 diff --git a/src/Test/Hspec.hs b/src/Test/Hspec.hs --- a/src/Test/Hspec.hs +++ b/src/Test/Hspec.hs @@ -9,6 +9,8 @@ module Test.Hspec ( -- * Types Spec +, SpecWith +, Arg , Example -- * Setting expectations @@ -22,54 +24,32 @@ , example , pending , pendingWith +, parallel +, runIO + +-- * Hooks +, ActionWith , before +, beforeWith , beforeAll , after +, after_ , afterAll +, afterAll_ , around -, parallel -, runIO +, around_ +, aroundWith -- * Running a spec , hspec ) where -import Control.Exception (finally) -import Control.Concurrent.MVar - -import Test.Hspec.Core.Type +import Test.Hspec.Core.Spec +import Test.Hspec.Core.Hooks 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 -> Spec -> Spec -describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . Core.specGroup label - --- | An alias for `describe`. -context :: String -> Spec -> Spec -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 a => String -> a -> Spec -it label action = fromSpecList [Core.specItem label action] - --- | An alias for `it`. -specify :: Example a => String -> a -> Spec -specify = it - --- | This is a type restricted version of `id`. It can be used to get better +-- | @example@ is a type restricted version of `id`. It can be used to get better -- error messages on type mismatches. -- -- Compare e.g. @@ -84,36 +64,10 @@ example :: Expectation -> Expectation example = id --- | Run spec items of given `Spec` in parallel. -parallel :: Spec -> Spec -parallel = mapSpecItem $ \item -> item {itemIsParallelizable = True} - --- | Run a custom action before every spec item. -before :: IO () -> Spec -> Spec -before action = around (action >>) - --- | Run a custom action before the first spec item. -beforeAll :: IO () -> Spec -> 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 after every spec item. -after :: IO () -> Spec -> Spec -after action = around (`finally` action) - --- | Run a custom action after the last spec item. -afterAll :: IO () -> Spec -> Spec -afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . SpecWithCleanup action +-- | @context@ is an alias for `describe`. +context :: String -> SpecWith a -> SpecWith a +context = describe --- | Run a custom action before and/or after every spec item. -around :: (IO () -> IO ()) -> Spec -> Spec -around a2 = mapSpecItem $ \item -> item {itemExample = \params a1 -> itemExample item params (a1 . a2)} +-- | @specify@ is an alias for `it`. +specify :: Example a => String -> a -> SpecWith (Arg a) +specify = it diff --git a/src/Test/Hspec/Compat.hs b/src/Test/Hspec/Compat.hs deleted file mode 100644 --- a/src/Test/Hspec/Compat.hs +++ /dev/null @@ -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 diff --git a/src/Test/Hspec/Config.hs b/src/Test/Hspec/Config.hs deleted file mode 100644 --- a/src/Test/Hspec/Config.hs +++ /dev/null @@ -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 diff --git a/src/Test/Hspec/Core.hs b/src/Test/Hspec/Core.hs --- a/src/Test/Hspec/Core.hs +++ b/src/Test/Hspec/Core.hs @@ -1,47 +1,18 @@ --- | --- 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(..) -, mapSpecItem -, modifyParams -, specGroup -, specItem - +-- | Stability: unstable +module Test.Hspec.Core {-# DEPRECATED "use \"Test.Hspec.Core.Spec\" instead" #-} ( + module Test.Hspec.Core.Spec -- * Deprecated functions , describe , it ) where -import Test.Hspec.Core.Type +import Test.Hspec.Core.Spec hiding (describe, it) -modifyParams :: (Params -> Params) -> Spec -> Spec -modifyParams f = mapSpecItem $ \item -> item {itemExample = \p -> (itemExample item) (f p)} {-# DEPRECATED describe "use `specGroup` instead" #-} -describe :: String -> [SpecTree] -> SpecTree +describe :: String -> [SpecTree a] -> SpecTree a describe = specGroup {-# DEPRECATED it "use `specItem` instead" #-} -it :: Example a => String -> a -> SpecTree +it :: Example a => String -> a -> SpecTree (Arg a) it = specItem diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/QuickCheckUtil.hs +++ /dev/null @@ -1,56 +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 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 :: (IO () -> IO ()) -> Property -> Property -#if MIN_VERSION_QuickCheck(2,7,0) -aroundProperty action (MkProperty p) = MkProperty $ MkProp . aroundRose action . unProp <$> p -#else -aroundProperty action p = MkProp . aroundRose action . unProp <$> p -#endif - -aroundRose :: (IO () -> IO ()) -> Rose QCP.Result -> Rose QCP.Result -aroundRose action r = ioRose $ do - ref <- newIORef (return QCP.succeeded) - action (reduceRose r >>= 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 diff --git a/src/Test/Hspec/Core/Type.hs b/src/Test/Hspec/Core/Type.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Type.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} -module Test.Hspec.Core.Type ( - Spec -, SpecM (..) -, runSpecM -, fromSpecList -, SpecTree (..) -, mapSpecTree -, Item (..) -, mapSpecItem -, Location (..) -, LocationAccuracy(..) -, Example (..) -, Result (..) -, Params (..) -, Progress -, ProgressCallback - -, specGroup -, specItem -, 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 = SpecM () - --- | A writer monad for `SpecTree` forests. -newtype SpecM a = SpecM (WriterT [SpecTree] IO a) - deriving (Functor, Applicative, Monad) - --- | Convert a `Spec` to a forest of `SpecTree`s. -runSpecM :: Spec -> IO [SpecTree] -runSpecM (SpecM specs) = execWriterT specs - --- | Create a `Spec` from a forest of `SpecTree`s. -fromSpecList :: [SpecTree] -> Spec -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). -runIO :: IO a -> SpecM a -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 = - SpecGroup String [SpecTree] - | SpecWithCleanup (IO ()) [SpecTree] - | SpecItem Item - -data Item = Item { - itemRequirement :: String -, itemLocation :: Maybe Location -, itemIsParallelizable :: Bool -, itemExample :: Params -> (IO () -> IO ()) -> ProgressCallback -> IO Result -} - -mapSpecTree :: (SpecTree -> SpecTree) -> Spec -> Spec -mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f - -mapSpecItem :: (Item -> Item) -> Spec -> Spec -mapSpecItem f = mapSpecTree go - where - go :: SpecTree -> SpecTree - go spec = case spec of - SpecGroup d xs -> SpecGroup d (map go xs) - SpecWithCleanup cleanup xs -> SpecWithCleanup 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) - --- | The @specGroup@ function combines a list of specs into a larger spec. -specGroup :: String -> [SpecTree] -> SpecTree -specGroup s = SpecGroup msg - where - msg - | null s = "(no description given)" - | otherwise = s - --- | The @specItem@ function creates a spec item. -specItem :: Example a => String -> a -> SpecTree -specItem s e = SpecItem $ Item requirement Nothing False (evaluateExample e) - where - requirement - | null s = "(unspecified behavior)" - | otherwise = s - --- | A type class for examples. -class Example a where - evaluateExample :: a -> Params -> (IO () -> IO ()) -> ProgressCallback -> IO Result - -instance Example Bool where - evaluateExample b _ _ _ = if b then return Success else return (Fail "") - -instance Example Expectation where - 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 - evaluateExample r _ _ _ = return r - -instance Example QC.Property where - 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 diff --git a/src/Test/Hspec/Discover.hs b/src/Test/Hspec/Discover.hs --- a/src/Test/Hspec/Discover.hs +++ b/src/Test/Hspec/Discover.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} 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 +, IsFormatter (..) , hspecWithFormatter , postProcessSpec , describe - , module Prelude ) where @@ -16,13 +17,20 @@ import Data.Traversable hiding (mapM) import Control.Monad.Trans.State -import Test.Hspec -import Test.Hspec.Core.Type -import Test.Hspec.Runner -import Test.Hspec.Runner.Tree +import Test.Hspec.Core.Spec +import Test.Hspec.Core.Runner import Test.Hspec.Formatters -import Test.Hspec.Util +import Test.Hspec.Core.Util (safeTry) +class IsFormatter a where + toFormatter :: a -> IO Formatter + +instance IsFormatter (IO Formatter) where + toFormatter = id + +instance IsFormatter Formatter where + toFormatter = return + hspecWithFormatter :: IsFormatter a => a -> Spec -> IO () hspecWithFormatter formatter spec = do f <- toFormatter formatter @@ -35,23 +43,23 @@ 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 + runIO (runSpecM spec) >>= fromSpecList . addLoctions lookupLoc -addLoctions :: (Int -> Int -> String -> Maybe Location) -> [Tree Item] -> [Tree Item] +addLoctions :: (Int -> Int -> String -> Maybe Location) -> [SpecTree a] -> [SpecTree a] addLoctions lookupLoc = map (fmap f) . enumerate where - f :: ((Int, Int), Item) -> Item + 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] -> [Tree ((Int, Int), Item)] +enumerate :: [SpecTree a] -> [Tree (ActionWith a) ((Int, Int), (Item a))] enumerate tree = (mapM (traverse addPosition) tree >>= mapM (traverse addTotal)) `evalState` [] where - addPosition :: Item -> EnumerateM (Int, Item) + addPosition :: Item a -> EnumerateM (Int, Item a) addPosition item = (,) <$> getOccurrence (itemRequirement item) <*> pure item - addTotal :: (Int, Item) -> EnumerateM ((Int, Int), Item) + addTotal :: (Int, Item a) -> EnumerateM ((Int, Int), Item a) addTotal (n, item) = do total <- getTotal (itemRequirement item) return ((n, total), item) diff --git a/src/Test/Hspec/FailureReport.hs b/src/Test/Hspec/FailureReport.hs deleted file mode 100644 --- a/src/Test/Hspec/FailureReport.hs +++ /dev/null @@ -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 diff --git a/src/Test/Hspec/Formatters.hs b/src/Test/Hspec/Formatters.hs --- a/src/Test/Hspec/Formatters.hs +++ b/src/Test/Hspec/Formatters.hs @@ -1,236 +1,2 @@ -{-# 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 "" +module Test.Hspec.Formatters (module Test.Hspec.Core.Formatters) where +import Test.Hspec.Core.Formatters diff --git a/src/Test/Hspec/Formatters/Internal.hs b/src/Test/Hspec/Formatters/Internal.hs deleted file mode 100644 --- a/src/Test/Hspec/Formatters/Internal.hs +++ /dev/null @@ -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 ("") *> action <* write "" - -withColor_ :: SGR -> FormatM a -> FormatM a -withColor_ color (FormatM action) = do - useColor <- gets stateUseColor - h <- gets stateHandle - - FormatM . StateT $ \st -> do - bracket_ - - -- set color - (when useColor $ hSetSGR h [color]) - - -- reset colors - (when useColor $ hSetSGR h [Reset]) - - -- run action - (runStateT action st) - --- | --- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is --- run even when a `UserInterrupt` occurs during @actionA@. -finally_ :: FormatM () -> FormatM () -> FormatM () -finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do - r <- try (execStateT actionA st) - case r of - Left e -> do - when (e == UserInterrupt) $ - runStateT actionB st >> return () - throwIO e - Right st_ -> do - runStateT actionB st_ - --- | Get the used CPU time since the test run has been started. -getCPUTime :: FormatM (Maybe Double) -getCPUTime = do - t1 <- liftIO CPUTime.getCPUTime - mt0 <- gets cpuStartTime - return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) - where - toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer)) - --- | Get the passed real time since the test run has been started. -getRealTime :: FormatM Double -getRealTime = do - t1 <- liftIO getPOSIXTime - t0 <- gets startTime - return (realToFrac $ t1 - t0) diff --git a/src/Test/Hspec/HUnit.hs b/src/Test/Hspec/HUnit.hs deleted file mode 100644 --- a/src/Test/Hspec/HUnit.hs +++ /dev/null @@ -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) -> specItem s e - TestLabel s (TestList xs) -> specGroup s (map go xs) - TestLabel s x -> specGroup s [go x] - TestList xs -> specGroup "" (map go xs) - TestCase e -> specItem "" e diff --git a/src/Test/Hspec/Options.hs b/src/Test/Hspec/Options.hs deleted file mode 100644 --- a/src/Test/Hspec/Options.hs +++ /dev/null @@ -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") diff --git a/src/Test/Hspec/QuickCheck.hs b/src/Test/Hspec/QuickCheck.hs --- a/src/Test/Hspec/QuickCheck.hs +++ b/src/Test/Hspec/QuickCheck.hs @@ -1,5 +1,3 @@ --- | --- Stability: provisional module Test.Hspec.QuickCheck ( -- * Params modifyMaxSuccess @@ -10,9 +8,9 @@ , prop ) where -import Test.QuickCheck import Test.Hspec -import Test.Hspec.Core (Params(..), modifyParams) +import Test.QuickCheck +import Test.Hspec.Core.QuickCheck -- | -- > prop ".." $ @@ -24,30 +22,3 @@ -- > .. 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)} diff --git a/src/Test/Hspec/Runner.hs b/src/Test/Hspec/Runner.hs --- a/src/Test/Hspec/Runner.hs +++ b/src/Test/Hspec/Runner.hs @@ -1,175 +1,2 @@ --- | --- 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] -> [Tree Item] -filterSpecs c = go [] - where - p :: Path -> Bool - p = fromMaybe (const True) (configFilterPredicate c) - - go :: [String] -> [Tree Item] -> [Tree Item] - go groups = mapMaybe (goSpec groups) - - goSpecs :: [String] -> [Tree Item] -> ([Tree Item] -> a) -> Maybe a - goSpecs groups specs ctor = case go groups specs of - [] -> Nothing - xs -> Just (ctor xs) - - goSpec :: [String] -> Tree Item -> Maybe (Tree Item) - 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) +module Test.Hspec.Runner (module Test.Hspec.Core.Runner) where +import Test.Hspec.Core.Runner diff --git a/src/Test/Hspec/Runner/Eval.hs b/src/Test/Hspec/Runner/Eval.hs deleted file mode 100644 --- a/src/Test/Hspec/Runner/Eval.hs +++ /dev/null @@ -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 id) - - 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 () diff --git a/src/Test/Hspec/Runner/Tree.hs b/src/Test/Hspec/Runner/Tree.hs deleted file mode 100644 --- a/src/Test/Hspec/Runner/Tree.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} -module Test.Hspec.Runner.Tree where - -import Control.Applicative -import Data.Foldable -import Data.Traversable -import Test.Hspec.Core.Type -import Data.Monoid - -data Tree a - = Node !String [Tree a] - | NodeWithCleanup (IO ()) [Tree a] - | Leaf a - deriving Functor - -instance Foldable Tree where -- Note: GHC 7.0.1 fails to derive this instance - foldMap = go - where - go :: Monoid m => (a -> m) -> Tree a -> m - go f t = case t of - Node _ xs -> foldMap (foldMap f) xs - NodeWithCleanup _ xs -> foldMap (foldMap f) xs - Leaf x -> f x - -instance Traversable Tree where -- Note: GHC 7.0.1 fails to derive this instance - sequenceA = go - where - go :: Applicative f => Tree (f a) -> f (Tree a) - go t = case t of - Node label xs -> Node label <$> sequenceA (map go xs) - NodeWithCleanup action xs -> NodeWithCleanup action <$> sequenceA (map go xs) - Leaf a -> Leaf <$> a - -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] -> Spec -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 diff --git a/src/Test/Hspec/Timer.hs b/src/Test/Hspec/Timer.hs deleted file mode 100644 --- a/src/Test/Hspec/Timer.hs +++ /dev/null @@ -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 diff --git a/src/Test/Hspec/Util.hs b/src/Test/Hspec/Util.hs deleted file mode 100644 --- a/src/Test/Hspec/Util.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Test.Hspec.Util ( - pluralize -, formatException -, lineBreaksAt -, safeTry -, Path -, filterPredicate -, formatRequirement -, strip -) where - -import Data.List -import Data.Char (isSpace) -import GHC.IO.Exception -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)" --- @ --- --- For `IOException`s the `IOErrorType` is included. -formatException :: E.SomeException -> String -formatException err@(E.SomeException e) = case E.fromException err of - Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")" - Nothing -> showType e ++ " (" ++ show e ++ ")" - where - showIOErrorType :: IOException -> String - showIOErrorType ioe = case ioe_type ioe of - AlreadyExists -> "AlreadyExists" - NoSuchThing -> "NoSuchThing" - ResourceBusy -> "ResourceBusy" - ResourceExhausted -> "ResourceExhausted" - EOF -> "EOF" - IllegalOperation -> "IllegalOperation" - PermissionDenied -> "PermissionDenied" - UserError -> "UserError" - UnsatisfiedConstraints -> "UnsatisfiedConstraints" - SystemError -> "SystemError" - ProtocolError -> "ProtocolError" - OtherError -> "OtherError" - InvalidArgument -> "InvalidArgument" - InappropriateType -> "InappropriateType" - HardwareFault -> "HardwareFault" - UnsupportedOperation -> "UnsupportedOperation" - TimeExpired -> "TimeExpired" - ResourceVanished -> "ResourceVanished" - Interrupted -> "Interrupted" - -safeTry :: 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 diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -1,102 +1,17 @@ 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 Control.Exception (finally) import System.Directory -import Data.Time.Clock.POSIX -import System.IO.Silently - +import System.IO 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 + action file `finally` removeFile file diff --git a/test/Mock.hs b/test/Mock.hs deleted file mode 100644 --- a/test/Mock.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/CompatSpec.hs b/test/Test/Hspec/CompatSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/CompatSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs +++ /dev/null @@ -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 - } diff --git a/test/Test/Hspec/Core/TypeSpec.hs b/test/Test/Hspec/Core/TypeSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/TypeSpec.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} -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 -import qualified Test.Hspec as H -import qualified Test.Hspec.Runner as H - -main :: IO () -main = hspec spec - -evaluateExample :: H.Example e => e -> IO H.Result -evaluateExample e = H.evaluateExample e defaultParams id noOpProgressCallback - -evaluateExampleWith :: H.Example 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 diff --git a/test/Test/Hspec/DiscoverSpec.hs b/test/Test/Hspec/DiscoverSpec.hs --- a/test/Test/Hspec/DiscoverSpec.hs +++ b/test/Test/Hspec/DiscoverSpec.hs @@ -6,14 +6,13 @@ 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.Core.Spec as H +import Test.Hspec.Core (Tree(..), Item(..), Location(..), LocationAccuracy(..), runSpecM) import qualified Test.Hspec.Discover as H infix 1 `shouldHaveLocation` -shouldHaveLocation :: Item -> (String, Int) -> Expectation +shouldHaveLocation :: Item a -> (String, Int) -> Expectation item `shouldHaveLocation` (src, line) = itemLocation item `shouldBe` Just (Location src line 0 BestEffort) main :: IO () @@ -31,7 +30,7 @@ "" strlit "baz" withFileContent c $ \src -> do - [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do + [Leaf item1, Leaf item2, Leaf item3] <- runSpecM . H.postProcessSpec src $ do H.it "foo" True H.it "bar" True H.it "baz" True @@ -46,7 +45,7 @@ strlit "foo" strlit "foo" withFileContent c $ \src -> do - [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do + [Leaf item1, Leaf item2, Leaf item3] <- runSpecM . H.postProcessSpec src $ do H.it "foo" True H.it "foo" True H.it "foo" True @@ -60,7 +59,7 @@ strlit "foo" strlit "foo" withFileContent c $ \src -> do - [Leaf item1, Leaf item2, Leaf item3] <- toTree . H.postProcessSpec src $ do + [Leaf item1, Leaf item2, Leaf item3] <- runSpecM . H.postProcessSpec src $ do H.it "foo" True H.it "foo" True H.it "foo" True diff --git a/test/Test/Hspec/FailureReportSpec.hs b/test/Test/Hspec/FailureReportSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/FailureReportSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/FormattersSpec.hs b/test/Test/Hspec/FormattersSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/FormattersSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/HUnitSpec.hs b/test/Test/Hspec/HUnitSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/HUnitSpec.hs +++ /dev/null @@ -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 ""] - - 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 "", Leaf "", Leaf ""] - - 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"]]] diff --git a/test/Test/Hspec/OptionsSpec.hs b/test/Test/Hspec/OptionsSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/OptionsSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/QuickCheckSpec.hs b/test/Test/Hspec/QuickCheckSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/QuickCheckSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/RunnerSpec.hs b/test/Test/Hspec/RunnerSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/RunnerSpec.hs +++ /dev/null @@ -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` "" - - it "marks successful examples with CSS class hspec-success" $ do - r <- capture_ . withArgs ["--html"] . H.hspec $ do - H.it "foo" True - r `shouldContain` "- foo\n" - - it "marks pending examples with CSS class hspec-pending" $ do - r <- capture_ . withArgs ["--html"] . H.hspec $ do - H.it "foo" H.pending - r `shouldContain` "- foo" - - it "marks failed examples with CSS class hspec-failure" $ do - r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do - H.it "foo" False - r `shouldContain` "- foo" - - describe "hspecResult" $ do - it "returns a summary of the test run" $ do - silence . H.hspecResult $ do - H.it "foo" True - H.it "foo" False - H.it "foo" False - H.it "foo" True - H.it "foo" True - `shouldReturn` H.Summary 5 2 - - it "treats uncaught exceptions as failure" $ do - silence . H.hspecResult $ do - H.it "foobar" throwException - `shouldReturn` H.Summary 1 1 - - it "uses the specdoc formatter by default" $ do - _:r:_ <- captureLines . H.hspecResult $ do - H.describe "Foo.Bar" $ do - H.it "some example" True - r `shouldBe` "Foo.Bar" - - it "can use a custom formatter" $ do - r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do - H.describe "Foo.Bar" $ do - H.it "some example" True - r `shouldBe` "" - - it "does not let escape error thunks from failure messages" $ do - r <- silence . H.hspecResult $ do - H.it "some example" (H.Fail $ "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) diff --git a/test/Test/Hspec/TimerSpec.hs b/test/Test/Hspec/TimerSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/TimerSpec.hs +++ /dev/null @@ -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 diff --git a/test/Test/Hspec/UtilSpec.hs b/test/Test/Hspec/UtilSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/UtilSpec.hs +++ /dev/null @@ -1,106 +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)" - - context "when used with an IOException" $ do - it "includes the IOErrorType" $ do - Left e <- E.try (readFile "foo") - formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))" - - describe "lineBreaksAt" $ do - it "inserts line breaks at word boundaries" $ do - lineBreaksAt 20 "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod" - `shouldBe` [ - "Lorem ipsum dolor" - , "sit amet," - , "consectetur" - , "adipisicing elit," - , "sed do eiusmod" - ] - - describe "safeTry" $ do - it "returns Right on success" $ do - Right e <- safeTry (return 23 :: IO Int) - e `shouldBe` 23 - - it "returns Left on exception" $ do - Left e <- safeTry throwException - show e `shouldBe` "foobar" - - it "evaluates result to weak head normal form" $ do - Left e <- safeTry (return 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" diff --git a/test/Test/HspecSpec.hs b/test/Test/HspecSpec.hs deleted file mode 100644 --- a/test/Test/HspecSpec.hs +++ /dev/null @@ -1,201 +0,0 @@ -module Test.HspecSpec (main, spec) where - -import Helper -import Mock -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 id 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 each spec item" $ do - mock <- newMock - silence $ H.hspec $ H.before (mockAction mock) $ do - H.it "foo" $ do - mockCounter mock `shouldReturn` 1 - H.it "bar" $ do - mockCounter mock `shouldReturn` 2 - mockCounter mock `shouldReturn` 2 - - context "when used multiple times" $ do - it "is evaluated outside in" $ do - ref <- newIORef (0 :: Int) - let action1 = do - readIORef ref `shouldReturn` 0 - modifyIORef ref succ - action2 = do - readIORef ref `shouldReturn` 1 - modifyIORef ref succ - silence $ H.hspec $ H.before action1 $ H.before action2 $ do - H.it "foo" $ do - readIORef ref `shouldReturn` 2 - - 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` [] - - describe "after" $ do - it "runs an action after each spec item" $ do - mock <- newMock - silence $ H.hspec $ H.after (mockAction mock) $ do - H.it "foo" $ do - mockCounter mock `shouldReturn` 0 - H.it "bar" $ do - mockCounter mock `shouldReturn` 1 - mockCounter mock `shouldReturn` 2 - - it "guarantees that action is run" $ do - mock <- newMock - silence . ignoreExitCode $ H.hspec $ H.after (mockAction mock) $ do - H.it "foo" $ do - ioError $ userError "foo" :: IO () - mockCounter mock `shouldReturn` 1 - - 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 each spec item with an action" $ do - ref <- newIORef (0 :: Int) - let action :: IO () -> IO () - action e = do - readIORef ref `shouldReturn` 0 - writeIORef ref 1 - e - readIORef ref `shouldReturn` 2 - writeIORef ref 3 - silence $ H.hspec $ H.around action $ do - H.it "foo" $ do - readIORef ref `shouldReturn` 1 - writeIORef ref 2 - readIORef ref `shouldReturn` 3 - where - runSpec :: H.Spec -> IO [String] - runSpec = captureLines . H.hspecResult