diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2011-2014 Simon Hengel +Copyright (c) 2011-2012 Trystan Spangler +Copyright (c) 2011-2011 Greg Weber + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/example/Spec.hs b/example/Spec.hs new file mode 100644 --- /dev/null +++ b/example/Spec.hs @@ -0,0 +1,16 @@ +module Main (main, spec) where + +import Test.Hspec +import Test.QuickCheck + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "reverse" $ do + it "reverses a list" $ do + reverse [1 :: Int, 2, 3] `shouldBe` [3, 2, 1] + + it "gives the original list, if applied twice" $ property $ + \xs -> (reverse . reverse) xs == (xs :: [Int]) diff --git a/hspec-discover/src/Config.hs b/hspec-discover/src/Config.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/src/Config.hs @@ -0,0 +1,43 @@ +module Config ( + Config (..) +, defaultConfig +, parseConfig +, usage +) where + +import Data.Maybe +import System.Console.GetOpt + +data Config = Config { + configNested :: Bool +, configFormatter :: Maybe String +, configNoMain :: Bool +} deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config False Nothing False + +options :: [OptDescr (Config -> Config)] +options = [ + Option [] ["nested"] (NoArg $ \c -> c {configNested = True}) "" + , Option [] ["formatter"] (ReqArg (\s c -> c {configFormatter = Just s}) "FORMATTER") "" + , Option [] ["no-main"] (NoArg $ \c -> c {configNoMain = True}) "" + ] + +usage :: String -> String +usage prog = "\nUsage: " ++ prog ++ " SRC CUR DST [--formatter=FORMATTER] [--no-main]\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 new file mode 100644 --- /dev/null +++ b/hspec-discover/src/Main.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/hspec-discover/src/Run.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A preprocessor that finds and combines specs. +module Run ( + run + +-- exported for testing +, 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 + +type Spec = String + +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 . " #-}" + . showString ("module " ++ module_ ++" where\n") + . importList nodes + . maybe driver (driverWithFormatter (null nodes)) (configFormatter c) + . formatSpecs nodes + ) "\n" + where + driver = + showString "import Test.Hspec\n" + . case configNoMain c of + False -> + showString "main :: IO ()\n" + . showString "main = hspec $ " + True -> + showString "spec :: Spec\n" + . showString "spec = " + module_ = if configNoMain c then pathToModule src else "Main" + pathToModule f = let + fileName = last $ splitDirectories f + m:ms = takeWhile (/='.') fileName + in + toUpper m:ms + + +driverWithFormatter :: Bool -> String -> ShowS +driverWithFormatter isEmpty f = + (if isEmpty then id else "import Test.Hspec\n") + . showString "import Test.Hspec.Runner\n" + . showString "import qualified " . showString (moduleName f) . showString "\n" + . showString "main :: IO ()\n" + . showString "main = hspecWithFormatter " . showString f . showString " $ " + +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 name = "import qualified " . showString name . "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 name = "describe " . shows name . " " . showString name . "Spec.spec" + +findSpecs :: FilePath -> IO [Spec] +findSpecs src = do + let (dir, file) = splitFileName src + mapMaybe fileToSpec . filter (/= file) <$> getFilesRecursive dir + +fileToSpec :: FilePath -> Maybe String +fileToSpec f = intercalate "." . reverse <$> case reverse $ splitDirectories f of + x:xs -> case stripSuffix "Spec.hs" x <|> stripSuffix "Spec.lhs" x of + Nothing -> Nothing + Just "" -> Nothing + Just ys -> Just (ys : xs) + _ -> 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 new file mode 100644 --- /dev/null +++ b/hspec-discover/test-data/empty-dir/Foo/Bar/Baz/.placeholder diff --git a/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs b/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/test-data/nested-spec/Foo/Bar/BazSpec.hs diff --git a/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs b/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/test-data/nested-spec/Foo/BarSpec.hs diff --git a/hspec-discover/test-data/nested-spec/FooSpec.hs b/hspec-discover/test-data/nested-spec/FooSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/test-data/nested-spec/FooSpec.hs diff --git a/hspec-discover/test/ConfigSpec.hs b/hspec-discover/test/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/test/ConfigSpec.hs @@ -0,0 +1,47 @@ +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 [--formatter=FORMATTER] [--no-main]" + ] + + it "returns error message on unexpected argument" $ do + parse ["foo"] `shouldBe` (Left . unlines) [ + "hspec-discover: unexpected argument `foo'" + , "" + , "Usage: hspec-discover SRC CUR DST [--formatter=FORMATTER] [--no-main]" + ] + + 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 [--formatter=FORMATTER] [--no-main]" + ] + + 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 new file mode 100644 --- /dev/null +++ b/hspec-discover/test/RunSpec.hs @@ -0,0 +1,100 @@ +module RunSpec (main, spec) where + +import Test.Hspec.Meta + +import Control.Applicative +import System.IO +import System.Directory +import System.FilePath +import Data.List (intercalate, sort) + +import 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\" #-}module Main where" + , "import qualified Foo.Bar.BazSpec" + , "import qualified Foo.BarSpec" + , "import qualified FooSpec" + , "import Test.Hspec" + , "main :: IO ()" + , "main = hspec $ describe \"Foo.Bar.Baz\" Foo.Bar.BazSpec.spec >> describe \"Foo.Bar\" Foo.BarSpec.spec >> 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\" #-}module Main where" + , "import Test.Hspec" + , "main :: IO ()" + , "main = hspec $ 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 "Foo" + + it "rejects spec with empty name" $ do + fileToSpec "Spec.hs" `shouldBe` Nothing + + it "works for lhs files" $ do + fileToSpec "FooSpec.lhs" `shouldBe` Just "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 + fileToSpec ("Foo" "Bar" "BazSpec.hs") `shouldBe` Just "Foo.Bar.Baz" + + it "rejects spec with empty name" $ do + fileToSpec ("Foo" "Bar" "Spec.hs") `shouldBe` Nothing + + describe "findSpecs" $ do + it "finds specs" $ do + findSpecs "hspec-discover/test-data/nested-spec/Spec.hs" `shouldReturn` ["Foo.Bar.Baz","Foo.Bar","Foo"] + + describe "driverWithFormatter" $ do + it "generates a test driver that uses a custom formatter" $ do + driverWithFormatter False "Some.Module.formatter" "" `shouldBe` intercalate "\n" [ + "import Test.Hspec" + , "import Test.Hspec.Runner" + , "import qualified Some.Module" + , "main :: IO ()" + , "main = hspecWithFormatter Some.Module.formatter $ " + ] + + 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 ["Foo", "Bar"] "" `shouldBe` unlines [ + "import qualified FooSpec" + , "import qualified BarSpec" + ] diff --git a/hspec-discover/test/Spec.hs b/hspec-discover/test/Spec.hs new file mode 100644 --- /dev/null +++ b/hspec-discover/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} diff --git a/hspec2.cabal b/hspec2.cabal new file mode 100644 --- /dev/null +++ b/hspec2.cabal @@ -0,0 +1,170 @@ +name: hspec2 +version: 0.0.0 +license: MIT +license-file: LICENSE +copyright: (c) 2011-2014 Simon Hengel, + (c) 2011-2012 Trystan Spangler, + (c) 2011 Greg Weber +maintainer: Simon Hengel +build-type: Simple +cabal-version: >= 1.8 +category: Testing +stability: experimental +bug-reports: https://github.com/hspec/hspec/issues +homepage: http://hspec.github.io/ +synopsis: Alpha version of Hspec 2.0 +description: This is an alpha release of Hspec 2.0. + If you are looking for a stable solution for testing Haskell + code, use the 1.x series of Hspec: http://hspec.github.io/ + +-- find hspec-discover/test-data/ -type f +extra-source-files: + 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 + exposed: False + ghc-options: + -Wall + hs-source-dirs: + src + build-depends: + base == 4.* + , random == 1.0.* + , setenv + , ansi-terminal >= 0.5 + , time + , transformers >= 0.2.2.0 && < 0.4.0 + , deepseq + , HUnit >= 1.2.5 + , QuickCheck >= 2.5.1 + , quickcheck-io + , hspec-expectations == 0.5.0.* + exposed-modules: + Test.Hspec + Test.Hspec.Core + Test.Hspec.Runner + Test.Hspec.Formatters + Test.Hspec.HUnit + Test.Hspec.QuickCheck + 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 + +test-suite spec + type: + exitcode-stdio-1.0 + hs-source-dirs: + src, test + main-is: + Spec.hs + other-modules: + Mock + Helper + Test.HspecSpec + Test.Hspec.CompatSpec + Test.Hspec.Core.TypeSpec + 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 == 1.0.* + , setenv + , silently >= 1.2.4 + , ansi-terminal + , time + , transformers + , deepseq + , HUnit + , QuickCheck + , quickcheck-io + , hspec-expectations + + , hspec-meta >= 1.8.0 + , process + , ghc-paths + +test-suite doctests + main-is: + doctests.hs + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror -threaded + hs-source-dirs: + test + build-depends: + base == 4.* + , doctest >= 0.9.4.1 + +test-suite example + type: + exitcode-stdio-1.0 + main-is: + Spec.hs + hs-source-dirs: + example + ghc-options: + -Wall -Werror + build-depends: + base == 4.* + , hspec + , QuickCheck + +-- hspec-discover +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-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 diff --git a/src/Test/Hspec.hs b/src/Test/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec.hs @@ -0,0 +1,103 @@ +-- | +-- Stability: stable +-- +-- Hspec is a testing library for Haskell. +-- +-- This is the library reference for Hspec. +-- The contains more in-depth +-- documentation. +module Test.Hspec ( +-- * Types + Spec +, SpecWith +, Example + +-- * Setting expectations +, module Test.Hspec.Expectations + +-- * Defining a spec +, describe +, context +, it +, example +, pending +, pendingWith +, before +, after +, after_ +, around +, around_ +, parallel + +-- * Running a spec +, hspec +) where + +import Control.Exception (finally) + +import Test.Hspec.Core.Type hiding (describe, it) +import Test.Hspec.Runner +import Test.Hspec.HUnit () +import Test.Hspec.Expectations +import qualified Test.Hspec.Core as Core + +-- | Combine a list of specs into a larger spec. +describe :: String -> SpecWith a -> SpecWith a +describe label action = fromSpecList [Core.describe label (runSpecM action)] + +-- | An alias for `describe`. +context :: String -> SpecWith a -> SpecWith a +context = describe + +-- | Create a spec item. +-- +-- A spec item consists of: +-- +-- * a textual description of a desired behavior +-- +-- * an example for that behavior +-- +-- > describe "absolute" $ do +-- > it "returns a positive number when given a negative number" $ +-- > absolute (-1) == 1 +it :: Example e => String -> e -> SpecWith (Arg e) +it label action = fromSpecList [Core.it label action] + +-- | This is a type restricted version of `id`. It can be used to get better +-- error messages on type mismatches. +-- +-- Compare e.g. +-- +-- > it "exposes some behavior" $ example $ do +-- > putStrLn +-- +-- with +-- +-- > it "exposes some behavior" $ do +-- > putStrLn +example :: Expectation -> Expectation +example = id + +-- | Run examples of given spec in parallel. +parallel :: SpecWith a -> SpecWith a +parallel = mapSpecItem $ \item -> item {itemIsParallelizable = True} + +-- | Run a custom action before every spec item. +before :: IO a -> SpecWith a -> Spec +before action = around (action >>=) + +-- | Run a custom action after every spec item. +after :: (a -> IO ()) -> SpecWith a -> SpecWith a +after a2 = mapSpecItem $ \item -> item {itemExample = \params a1 -> itemExample item params (\f -> a1 (\a -> f a `finally` a2 a))} + +-- | Run a custom action after every spec item. +after_ :: IO () -> Spec -> Spec +after_ action = after $ \() -> action + +-- | Run a custom action before and/or after every spec item. +around :: ((a -> IO ()) -> IO ()) -> SpecWith a -> Spec +around a2 = mapSpecItem $ \item -> item {itemExample = \params a1 -> itemExample item params (\x -> a1 $ \() -> a2 x)} + +-- | Run a custom action before and/or after every spec item. +around_ :: (IO () -> IO ()) -> Spec -> Spec +around_ action = around $ action . ($ ()) diff --git a/src/Test/Hspec/Compat.hs b/src/Test/Hspec/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Compat.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Compat ( + showType +, showFullType +, readMaybe +, lookupEnv +, module Data.IORef +#if !MIN_VERSION_base(4,6,0) +, modifyIORef' +#endif +) where + +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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Config.hs @@ -0,0 +1,118 @@ +module Test.Hspec.Config ( + Config (..) +, defaultConfig +, getConfig +, configAddFilter +, configSetSeed +) where + +import Control.Applicative +import Data.List +import Data.Maybe +import System.IO +import System.Exit +import qualified Test.QuickCheck as QC +import Test.Hspec.Formatters + +import Test.Hspec.Util + +-- for Monad (Either e) when base < 4.3 +import Control.Monad.Trans.Error () + +import Test.Hspec.Options +import Test.Hspec.FailureReport + +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. +, configFilterPredicate :: Maybe (Path -> Bool) +, configQuickCheckArgs :: QC.Args +, configSmallCheckDepth :: Int +, configColorMode :: ColorMode +, configFormatter :: Formatter +, configHtmlOutput :: Bool +, configHandle :: Either Handle FilePath +} + +defaultConfig :: Config +defaultConfig = Config False False False Nothing QC.stdArgs 5 ColorAuto specdoc False (Left stdout) + +-- | 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 + } + +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_ + +configSetSeed :: Integer -> Config -> Config +configSetSeed n c = c {configQuickCheckArgs = (configQuickCheckArgs c) {QC.replay = Just (stdGenFromInteger n, 0)}} + +mkConfig :: Maybe FailureReport -> Options -> Config +mkConfig mFailureReport opts = Config { + configDryRun = optionsDryRun opts + , configPrintCpuTime = optionsPrintCpuTime opts + , configFastFail = optionsFastFail opts + , configFilterPredicate = matchFilter `filterOr` rerunFilter + , configQuickCheckArgs = qcArgs + , configSmallCheckDepth = fromMaybe (configSmallCheckDepth defaultConfig) (optionsDepth opts) + , configColorMode = optionsColorMode opts + , configFormatter = optionsFormatter opts + , configHtmlOutput = optionsHtmlOutput opts + , configHandle = maybe (configHandle defaultConfig) Right (optionsOutputFile opts) + } + where + qcArgs = ( + maybe id setSeed mSeed + . maybe id setMaxDiscardRatio mMaxDiscardRatio + . maybe id setMaxSize mMaxSize + . maybe id setMaxSuccess mMaxSuccess) QC.stdArgs + + mSeed = optionsSeed opts <|> (failureReportSeed <$> mFailureReport) + mMaxSuccess = optionsMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) + mMaxSize = optionsMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) + mMaxDiscardRatio = optionsMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) + + 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 (stdGenFromInteger n, 0)} + + matchFilter = case optionsMatch opts of + [] -> Nothing + xs -> Just $ foldl1' (\p0 p1 path -> p0 path || p1 path) (map filterPredicate xs) + + rerunFilter = flip elem . failureReportPaths <$> mFailureReport + +getConfig :: Options -> 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 optionsRerun 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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core.hs @@ -0,0 +1,32 @@ +-- | +-- 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 (..) +, Item (..) +, mapSpecItem +, modifyParams +, describe +, it +) where + +import Test.Hspec.Core.Type + +modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a +modifyParams f = mapSpecItem $ \item -> item {itemExample = \p -> (itemExample item) (f p)} diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheckUtil.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.QuickCheckUtil where + +import Data.IORef +import Test.QuickCheck hiding (Result(..)) +import Test.QuickCheck as QC +import Test.QuickCheck.Property hiding (Result(..)) +import Test.QuickCheck.Gen +import qualified Test.QuickCheck.Property as QCP +import Test.QuickCheck.IO () + +aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property +aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n + +aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop +aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) + +aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result +aroundRose action r = ioRose $ do + ref <- newIORef (return QCP.succeeded) + action $ \a -> reduceRose (r a) >>= writeIORef ref + readIORef ref + +isUserInterrupt :: QC.Result -> Bool +isUserInterrupt r = case r of +#if MIN_VERSION_QuickCheck(2,6,0) + QC.Failure {QC.interrupted = x} -> x +#else + QC.Failure {QC.reason = "Exception: 'user interrupt'"} -> True +#endif + _ -> False diff --git a/src/Test/Hspec/Core/Type.hs b/src/Test/Hspec/Core/Type.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Type.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-} +module Test.Hspec.Core.Type ( + Spec +, SpecWith +, SpecM (..) +, runSpecM +, fromSpecList +, SpecTree (..) +, Item (..) +, mapSpecItem +, Example (..) +, Result (..) +, Params (..) +, Progress +, ProgressCallback + +, describe +, it +, forceResult + +, pending +, pendingWith +) where + +import qualified Control.Exception as E +import Control.Applicative +import Control.Monad (when) +import Control.Monad.Trans.Writer (Writer, execWriter, tell) +import Data.Typeable (Typeable) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) + +import Test.Hspec.Compat +import Test.Hspec.Util +import Test.Hspec.Expectations +import Test.HUnit.Lang (HUnitFailure(..)) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.State as QC +import qualified Test.QuickCheck.Property as QCP +import qualified Test.QuickCheck.IO () + +import Test.Hspec.Core.QuickCheckUtil +import Control.DeepSeq (deepseq) + +type Spec = SpecWith () + +type SpecWith a = SpecM a () + +-- | A writer monad for `SpecTree` forests. +newtype SpecM a r = SpecM (Writer [SpecTree a] r) + deriving (Functor, Applicative, Monad) + +-- | Convert a `Spec` to a forest of `SpecTree`s. +runSpecM :: SpecWith a -> [SpecTree a] +runSpecM (SpecM specs) = execWriter specs + +-- | Create a `Spec` from a forest of `SpecTree`s. +fromSpecList :: [SpecTree a] -> SpecWith a +fromSpecList = SpecM . tell + +-- | 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 +} + +-- | Internal representation of a spec. +data SpecTree a = + SpecGroup String [SpecTree a] + | SpecItem String (Item a) + +data Item a = Item { + itemIsParallelizable :: Bool +, itemExample :: Params -> ((a -> IO ()) -> IO ()) -> ProgressCallback -> IO Result +} + +mapSpecItem :: (Item a -> Item b) -> SpecWith a -> SpecWith b +mapSpecItem f = fromSpecList . map go . runSpecM + where + go spec = case spec of + SpecItem r item -> SpecItem r (f item) + SpecGroup d es -> SpecGroup d (map go es) + +-- | The @describe@ function combines a list of specs into a larger spec. +describe :: String -> [SpecTree a] -> SpecTree a +describe s = SpecGroup msg + where + msg + | null s = "(no description given)" + | otherwise = s + +-- | Create a spec item. +it :: Example e => String -> e -> SpecTree (Arg e) +it s e = SpecItem msg $ Item False (evaluateExample e) + where + msg + | null s = "(unspecified behavior)" + | otherwise = s + +-- | A type class for examples. +class Example e where + type Arg e + evaluateExample :: e -> Params -> ((Arg e -> IO ()) -> IO ()) -> ProgressCallback -> IO Result + +instance Example Bool where + type Arg Bool = () + evaluateExample b _ _ _ = if b then return Success else return (Fail "") + +instance Example Expectation where + type Arg Expectation = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> Expectation) where + type Arg (a -> Expectation) = a + evaluateExample e _ action _ = (action e >> return Success) `E.catches` [ + E.Handler (\(HUnitFailure err) -> return (Fail err)) + , E.Handler (return :: Result -> IO Result) + ] + +instance Example Result where + type Arg Result = () + evaluateExample r _ _ _ = return r + +instance Example QC.Property where + type Arg QC.Property = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> QC.Property) where + type Arg (a -> QC.Property) = a + evaluateExample p c action progressCallback = do + r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) + when (isUserInterrupt r) $ do + E.throwIO E.UserInterrupt + + return $ + case r of + QC.Success {} -> Success + QC.Failure {QC.output = m} -> fromMaybe (Fail $ sanitizeFailureMessage m) (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 :: String -> String + sanitizeFailureMessage = strip . addFalsifiable . stripFailed + + 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 + | prefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m + | otherwise = Nothing + where + n = length prefix + prefix = "*** 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/FailureReport.hs b/src/Test/Hspec/FailureReport.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/FailureReport.hs @@ -0,0 +1,36 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Formatters.hs @@ -0,0 +1,234 @@ +{-# 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 +, 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.Compat +import Text.Printf +import Control.Monad (unless, forM_) +import Control.Applicative +import qualified Control.Exception as E +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 + + , 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 = \n nesting name -> do + + -- separate groups with an empty line + unless (n == 0) $ do + newParagraph + + writeLine (indentationFor nesting ++ name) + +, exampleGroupDone = do + newParagraph + +, 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 + newParagraph + + failures <- getFailMessages + + forM_ (zip [1..] failures) $ \x -> do + formatFailure x + writeLine "" + unless (null failures) $ do + write "Randomized with seed " >> usedSeed >>= writeLine . show + writeLine "" + where + formatFailure :: (Int, FailureRecord) -> FormatM () + formatFailure (n, FailureRecord path reason) = do + write (show n ++ ") ") + writeLine (formatRequirement path) + withFailColor $ do + unless (null err) $ do + writeLine err + where + err = either (("uncaught exception: " ++) . formatException) id reason + +-- | Convert an exception to a string. +-- +-- The type of the exception is included. Here is an example: +-- +-- >>> import Control.Applicative +-- >>> import Control.Exception +-- >>> either formatException show <$> (try . evaluate) (1 `div` 0) +-- "ArithException (divide by zero)" +formatException :: E.SomeException -> String +formatException (E.SomeException e) = showType e ++ " (" ++ show e ++ ")" + +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 "" diff --git a/src/Test/Hspec/Formatters/Internal.hs b/src/Test/Hspec/Formatters/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Formatters/Internal.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Formatters.Internal ( + +-- * Public API + Formatter (..) +, FormatM + +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, getCPUTime +, getRealTime + +, write +, writeLine +, newParagraph + +, 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 (when, unless) +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) + +-- | 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 +, lastIsEmptyLine :: Bool -- True, if last line was empty +, 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_ False 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 :: Path -> Either SomeException String -> FormatM () +addFailMessage p m = modify $ \s -> s {failMessages = FailureRecord p m : failMessages s} + +-- | Get the list of accumulated failure messages. +getFailMessages :: FormatM [FailureRecord] +getFailMessages = reverse `fmap` gets failMessages + +data FailureRecord = FailureRecord { + 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 :: Int -> [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 = do + f <- gets lastIsEmptyLine + unless f $ do + writeLine "" + setLastIsEmptyLine True + +setLastIsEmptyLine :: Bool -> FormatM () +setLastIsEmptyLine f = modify $ \s -> s {lastIsEmptyLine = f} + +-- | Append some output to the report. +write :: String -> FormatM () +write s = do + h <- gets stateHandle + liftIO $ IO.hPutStr h s + setLastIsEmptyLine False + +-- | 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 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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/HUnit.hs @@ -0,0 +1,23 @@ +module Test.Hspec.HUnit ( +-- * Interoperability with HUnit + fromHUnitTest +) where + +import Test.Hspec.Core.Type +import Test.HUnit (Test (..)) + +-- | +-- Convert a HUnit test suite to a spec. This can be used to run existing +-- HUnit tests with Hspec. +fromHUnitTest :: Test -> Spec +fromHUnitTest t = fromSpecList $ case t of + TestList xs -> map go xs + x -> [go x] + where + go :: Test -> SpecTree () + go t_ = case t_ of + TestLabel s (TestCase e) -> it s e + TestLabel s (TestList xs) -> describe s (map go xs) + TestLabel s x -> describe s [go x] + TestList xs -> describe "" (map go xs) + TestCase e -> it "" e diff --git a/src/Test/Hspec/Options.hs b/src/Test/Hspec/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Options.hs @@ -0,0 +1,157 @@ +module Test.Hspec.Options ( + Options (..) +, ColorMode (..) +, defaultOptions +, parseOptions + +-- exported to silence warnings +, Arg (..) +) where + +import Data.List +import System.Exit +import System.Console.GetOpt +import Test.Hspec.Formatters + +import Test.Hspec.Compat +import Test.Hspec.Util + +-- for Monad (Either e) when base < 4.3 +import Control.Monad.Trans.Error () + +data Options = Options { + optionsDryRun :: Bool +, optionsPrintCpuTime :: Bool +, optionsRerun :: Bool +, optionsFastFail :: Bool +, optionsMatch :: [String] +, optionsMaxSuccess :: Maybe Int +, optionsDepth :: Maybe Int +, optionsSeed :: Maybe Integer +, optionsMaxSize :: Maybe Int +, optionsMaxDiscardRatio :: Maybe Int +, optionsColorMode :: ColorMode +, optionsFormatter :: Formatter +, optionsHtmlOutput :: Bool +, optionsOutputFile :: Maybe FilePath +} + +addMatch :: String -> Options -> Options +addMatch s c = c {optionsMatch = s : optionsMatch c} + +setDepth :: Int -> Options -> Options +setDepth n c = c {optionsDepth = Just n} + +setMaxSuccess :: Int -> Options -> Options +setMaxSuccess n c = c {optionsMaxSuccess = Just n} + +setMaxSize :: Int -> Options -> Options +setMaxSize n c = c {optionsMaxSize = Just n} + +setMaxDiscardRatio :: Int -> Options -> Options +setMaxDiscardRatio n c = c {optionsMaxDiscardRatio = Just n} + +setSeed :: Integer -> Options -> Options +setSeed n c = c {optionsSeed = Just n} + +data ColorMode = ColorAuto | ColorNever | ColorAlways + deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options False False False False [] Nothing Nothing Nothing Nothing Nothing ColorAuto specdoc False Nothing + +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 Options + +data NoConfig = Help | InvalidArgument String String + +data Arg a = Arg { + argumentName :: String +, argumentParser :: String -> Maybe a +, argumentSetter :: a -> Options -> Options +} + +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 -> Options -> Options + setFormatter f c = c {optionsFormatter = f} + + setOutputFile :: String -> Options -> Options + setOutputFile file c = c {optionsOutputFile = Just file} + + setPrintCpuTime x = x >>= \c -> return c {optionsPrintCpuTime = True} + setDryRun x = x >>= \c -> return c {optionsDryRun = True} + setFastFail x = x >>= \c -> return c {optionsFastFail = True} + setRerun x = x >>= \c -> return c {optionsRerun = True} + setNoColor x = x >>= \c -> return c {optionsColorMode = ColorNever} + setColor x = x >>= \c -> return c {optionsColorMode = 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 {optionsHtmlOutput = True} + +parseOptions :: Options -> String -> [String] -> Either (ExitCode, String) Options +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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/QuickCheck.hs @@ -0,0 +1,59 @@ +-- | +-- Stability: provisional +module Test.Hspec.QuickCheck ( +-- * Params + modifyMaxSuccess +, modifyMaxDiscardRatio +, modifyMaxSize +-- * Re-exports from QuickCheck +-- | +-- Previous versions of Hspec provided a distinct `property` combinator, but +-- it's now possible to use QuickCheck's `property` instead. For backward +-- compatibility we now re-export QuickCheck's `property`, but it is advisable +-- to import it from "Test.QuickCheck" instead. +, property +-- * Shortcuts +, prop +) where + +import Test.QuickCheck +import Test.Hspec +import Test.Hspec.Core (Params(..), modifyParams) + +-- | +-- > prop ".." $ +-- > .. +-- +-- is a shortcut for +-- +-- > it ".." $ property $ +-- > .. +prop :: Testable prop => String -> prop -> Spec +prop s = it s . property + +-- | Use a modified `maxSuccess` for given spec. +modifyMaxSuccess :: (Int -> Int) -> Spec -> Spec +modifyMaxSuccess = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxSuccess = f (maxSuccess args)} + +-- | Use a modified `maxDiscardRatio` for given spec. +modifyMaxDiscardRatio :: (Int -> Int) -> Spec -> Spec +modifyMaxDiscardRatio = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxDiscardRatio = f (maxDiscardRatio args)} + +-- | Use a modified `maxSize` for given spec. +modifyMaxSize :: (Int -> Int) -> Spec -> Spec +modifyMaxSize = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxSize = f (maxSize args)} + +modifyArgs :: (Args -> Args) -> Spec -> Spec +modifyArgs = modifyParams . modify + where + modify :: (Args -> Args) -> Params -> Params + modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)} diff --git a/src/Test/Hspec/Runner.hs b/src/Test/Hspec/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Runner.hs @@ -0,0 +1,168 @@ +-- | +-- Stability: provisional +module Test.Hspec.Runner ( +-- * Running a spec + hspec +, hspecResult +, hspecWith + +-- * Types +, Summary (..) +, Config (..) +, ColorMode (..) +, Path +, defaultConfig +, configAddFilter + +-- * Internals +, hspecWithFormatter +) 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 System.Random (newStdGen) +import Control.Monad.IO.Class (liftIO) + +import Test.Hspec.Compat (lookupEnv) +import Test.Hspec.Util (Path, stdGenToInteger) +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.Options (Options(..), ColorMode(..), defaultOptions) +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 :: (Path -> Bool) -> [Tree a] -> [Tree a] +filterSpecs p = goSpecs [] + where + goSpecs groups = mapMaybe (goSpec groups) + + goSpec groups spec = case spec of + Leaf requirement _ -> guard (p (groups, requirement)) >> return spec + Node group specs -> case goSpecs (groups ++ [group]) specs of + [] -> Nothing + xs -> Just (Node group xs) + +-- | Run given spec and write a report to `stdout`. +-- Exit with `exitFailure` if at least one spec item fails. +hspec :: Spec -> IO () +hspec = hspecWithOptions defaultOptions + +-- | This function is used by @hspec-discover@. It is not part of the public +-- API and may change at any time. +hspecWithFormatter :: IsFormatter a => a -> Spec -> IO () +hspecWithFormatter formatter spec = do + f <- toFormatter formatter + hspecWithOptions defaultOptions {optionsFormatter = f} spec + +-- Add a StdGen to configQuickCheckArgs if there is none. That way the same +-- seed is used for all properties. This helps with --seed and --rerun. +ensureStdGen :: Config -> IO Config +ensureStdGen c = case QC.replay qcArgs of + Nothing -> do + stdGen <- newStdGen + return c {configQuickCheckArgs = qcArgs {QC.replay = Just (stdGen, 0)}} + _ -> return c + where + qcArgs = configQuickCheckArgs c + +-- | Run given spec with custom options. +-- This is similar to `hspec`, but more flexible. +hspecWithOptions :: Options -> Spec -> IO () +hspecWithOptions opts spec = do + prog <- getProgName + args <- getArgs + c <- getConfig opts prog args + withArgs [] {- do not leak command-line arguments to examples -} $ do + r <- hspecWith c 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 = hspecWith defaultConfig + +-- | Run given spec with custom options and returns a summary of the test run. +-- +-- /Note/: `hspecWith` does not exit with `exitFailure` on failing spec +-- items. If you need this, you have to check the `Summary` yourself and act +-- accordingly. +hspecWith :: Config -> Spec -> IO Summary +hspecWith c_ spec_ = withHandle c_ $ \h -> do + c <- ensureStdGen c_ + let formatter = configFormatter c + seed = (stdGenToInteger . fst . fromJust . QC.replay . configQuickCheckArgs) c + spec + | configDryRun c = mapSpecItem markSuccess spec_ + | otherwise = spec_ + + useColor <- doesUseColor h c + + withHiddenCursor useColor h $ + runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do + runFormatter useColor h c formatter (maybe id filterSpecs (configFilterPredicate c) $ (map toTree . runSpecM) spec) `finally_` do + failedFormatter formatter + + footerFormatter formatter + + -- dump failure report + xs <- map failureRecordPath <$> getFailMessages + liftIO $ writeFailureReport FailureReport { + failureReportSeed = seed + , failureReportMaxSuccess = QC.maxSuccess (configQuickCheckArgs c) + , failureReportMaxSize = QC.maxSize (configQuickCheckArgs c) + , failureReportMaxDiscardRatio = QC.maxDiscardRatio (configQuickCheckArgs c) + , 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 configHandle c of + Left h -> action h + Right path -> withFile path WriteMode action + +isDumb :: IO Bool +isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" + +markSuccess :: Item () -> Item () +markSuccess item = item {itemExample = evaluateExample Success} + +-- | 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) diff --git a/src/Test/Hspec/Runner/Eval.hs b/src/Test/Hspec/Runner/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Runner/Eval.hs @@ -0,0 +1,145 @@ +{-# 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 (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 specs + where + mkReportProgress :: IO (Path -> Progress -> IO ()) + mkReportProgress + | useColor = every 0.05 $ exampleProgress formatter h + | otherwise = return $ \_ _ -> return () + + specs = map (fmap (parallelize . fmap (applyNoOpAround . applyParams) . unwrapItem)) specs_ + + unwrapItem :: Item () -> (Bool, Params -> ((() -> IO ()) -> IO ()) -> ProgressCallback -> IO Result) + unwrapItem (Item isParallelizable e) = (isParallelizable, e) + + applyParams :: (Params -> a) -> a + applyParams = ($ params) + where + params = Params (configQuickCheckArgs c) (configSmallCheckDepth c) + + applyNoOpAround :: (((() -> IO ()) -> IO ()) -> b) -> b + applyNoOpAround = ($ ($ ())) + +-- | 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_ (zip [0..] specs) (queueSpec []) + writeChan chan Done + processMessages (readChan chan) (configFastFail c) + where + defer :: FormatM () -> IO () + defer = writeChan chan . Run + + queueSpec :: [String] -> (Int, EvalTree) -> IO () + queueSpec rGroups (n, Node group xs) = do + defer (exampleGroupStarted formatter n (reverse rGroups) group) + forM_ (zip [0..] xs) (queueSpec (group : rGroups)) + defer (exampleGroupDone formatter) + queueSpec rGroups (_, Leaf requirement e) = + queueExample (reverse rGroups, requirement) e + + queueExample :: Path -> (ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO () + queueExample path e = e reportProgress formatResult >>= defer + where + 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 (Right err) + Left err -> failed (Left err) + where + failed err = do + increaseFailCount + addFailMessage 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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Runner/Tree.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveFunctor #-} +module Test.Hspec.Runner.Tree where + +import Test.Hspec.Core.Type + +data Tree a + = Node String [Tree a] + | Leaf String a + deriving (Eq, Show, Functor) + +toTree :: SpecTree () -> Tree (Item ()) +toTree spec = case spec of + SpecGroup label specs -> Node label (map toTree specs) + SpecItem r item -> Leaf r item diff --git a/src/Test/Hspec/Timer.hs b/src/Test/Hspec/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Timer.hs @@ -0,0 +1,14 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Util.hs @@ -0,0 +1,106 @@ +module Test.Hspec.Util ( + pluralize +, lineBreaksAt +, safeTry +, Path +, filterPredicate +, formatRequirement +, strip +, stdGenToInteger +, stdGenFromInteger +) where + +import Data.Int (Int32) +import Data.List +import Data.Char (isSpace) +import Control.Applicative +import qualified Control.Exception as E +import System.Random (StdGen) + +-- | Create a more readable display of a quantity of something. +-- +-- Examples: +-- +-- >>> pluralize 0 "example" +-- "0 examples" +-- +-- >>> pluralize 1 "example" +-- "1 example" +-- +-- >>> pluralize 2 "example" +-- "2 examples" +pluralize :: Int -> String -> String +pluralize 1 s = "1 " ++ s +pluralize n s = show n ++ " " ++ s ++ "s" + +safeTry :: IO a -> IO (Either E.SomeException a) +safeTry action = (Right <$> (action >>= E.evaluate)) `E.catches` [ + -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT + -- (ctrl-c). All AsyncExceptions are re-thrown (not just UserInterrupt) + -- because all of them indicate severe conditions and should not occur during + -- normal operation. + E.Handler $ \e -> E.throwIO (e :: E.AsyncException) + + , E.Handler $ \e -> (return . Left) (e :: E.SomeException) + ] + +-- | +-- 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 + +-- | Converts a 'StdGen' into an 'Integer'. Assumes +-- StdGens to be encoded as two positive 'Int32's and +-- $show (StdGen a b) = show a ++ " " ++ show b$. +stdGenToInteger :: StdGen -> Integer +stdGenToInteger stdGen = + let [a, b] = map read . words $ show stdGen + in b * fromIntegral (maxBound :: Int32) + a + +-- | Inverse of 'stdGenToInteger'. +stdGenFromInteger :: Integer -> StdGen +stdGenFromInteger n = + let (a, b) = quotRem n (fromIntegral (maxBound :: Int32)) + in read (show b ++ " " ++ show a) diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,85 @@ +module Helper ( + module Test.Hspec.Meta +, module Test.QuickCheck +, module Control.Applicative +, module System.IO.Silently +, sleep +, timeout +, defaultParams +, noOpProgressCallback +, captureLines +, normalizeSummary + +, ignoreExitCode +, ignoreUserInterrupt + +, shouldStartWith +, shouldEndWith + +, shouldUseArgs +) 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 Data.Time.Clock.POSIX +import System.IO.Silently + +import Test.Hspec.Meta +import Test.QuickCheck hiding (Result(..)) + +import qualified Test.Hspec as H +import qualified Test.Hspec.Core as H (Params(..), Item(..), ProgressCallback, mapSpecItem) +import qualified Test.Hspec.Runner as H + +ignoreExitCode :: IO () -> IO () +ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () + +ignoreUserInterrupt :: IO () -> IO () +ignoreUserInterrupt action = action `E.catch` \e -> unless (e == E.UserInterrupt) (E.throwIO e) + +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 xs = map f xs + 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 (H.configQuickCheckArgs H.defaultConfig) (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) diff --git a/test/Mock.hs b/test/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Mock.hs @@ -0,0 +1,15 @@ +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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} diff --git a/test/Test/Hspec/CompatSpec.hs b/test/Test/Hspec/CompatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/CompatSpec.hs @@ -0,0 +1,33 @@ +{-# 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/TypeSpec.hs b/test/Test/Hspec/Core/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/TypeSpec.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Hspec.Core.TypeSpec (main, spec) where + +import Helper +import Mock +import Data.List +import Data.IORef +import Control.Exception (AsyncException(..), throwIO) + +import qualified Test.Hspec.Core.Type as H hiding (describe, it) +import qualified Test.Hspec as H +import qualified Test.Hspec.Runner as H + +main :: IO () +main = hspec spec + +evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result +evaluateExample e = H.evaluateExample e (defaultParams {H.paramsQuickCheckArgs = (H.paramsQuickCheckArgs defaultParams) {replay = Just (read "", 0)}}) ($ ()) noOpProgressCallback + +evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result +evaluateExampleWith action e = H.evaluateExample e (defaultParams {H.paramsQuickCheckArgs = (H.paramsQuickCheckArgs defaultParams) {replay = Just (read "", 0)}}) (action . ($ ())) noOpProgressCallback + +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 y -> x + y == (x * y :: Int) + r `shouldBe` intercalate "\n" [ + "Falsifiable (after 1 test and 2 shrinks): " + , "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` 200 + + context "when used with shouldBe" $ do + it "shows what falsified it" $ do + H.Fail r <- evaluateExample $ property $ \x y -> x + y `shouldBe` (x * y :: Int) + r `shouldBe` intercalate "\n" [ + "Falsifiable (after 1 test and 2 shrinks): " + , "expected: 0" + , " but got: 1" + , "0" + , "1" + ] + + it "propagates UserInterrupt" $ do + let p = property (throwIO UserInterrupt :: Expectation) + evaluateExample p `shouldThrow` (== UserInterrupt) + + it "propagates exceptions" $ do + pendingWith "this probably needs a patch to QuickCheck" + -- evaluateExample (property $ (error "foobar" :: Int -> Bool)) `shouldThrow` errorCall "foobar" + + 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/FailureReportSpec.hs b/test/Test/Hspec/FailureReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/FailureReportSpec.hs @@ -0,0 +1,39 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/FormattersSpec.hs @@ -0,0 +1,220 @@ +{-# 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(..)) +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.hspecWith H.defaultConfig {H.configFormatter = 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.hspecWith H.defaultConfig {H.configFormatter = 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.hspecWith H.defaultConfig {H.configFormatter = 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 "prints an empty line before each group" $ do + r <- runSpec $ do + H.describe "foo" $ do + H.it "example 1" True + H.it "example 2" True + H.describe "bar" $ do + H.it "example 3" True + H.it "example 4" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " - example 1" + , " - example 2" + , "" + , " bar" + , " - example 3" + , " - example 4" + , "" + , "Finished in 0.0000 seconds" + , "4 examples, 0 failures" + ] + + it "prints an empty line after each group" $ do + r <- runSpec $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "example 1" True + H.it "example 2" True + H.it "example 3" True + H.it "example 4" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " bar" + , " - example 1" + , " - example 2" + , "" + , " - example 3" + , " - example 4" + , "" + , "Finished in 0.0000 seconds" + , "4 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 "same as failed_examples" $ do + failed_examplesSpec H.progress + +failed_examplesSpec :: H.Formatter -> Spec +failed_examplesSpec formatter = do + let runSpec = captureLines . H.hspecWith H.defaultConfig {H.configFormatter = 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") + + 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.hspecWith 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.hspecWith 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.hspecWith 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.hspecWith 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 new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/HUnitSpec.hs @@ -0,0 +1,49 @@ +module Test.Hspec.HUnitSpec (main, spec) where + +import Helper + +import Test.Hspec.Core.Type (SpecTree(..), runSpecM) +import Test.Hspec.HUnit +import Test.HUnit + +main :: IO () +main = hspec spec + +-- SpecTree does not have an Eq nor a Show instance, hence we map it to `Tree`. +data Tree = Group String [Tree] | Example String + deriving (Eq, Show) + +shouldYield :: Test -> [Tree] -> Expectation +a `shouldYield` b = (convert . runSpecM . fromHUnitTest) a `shouldBe` b + where + convert :: [SpecTree ()] -> [Tree] + convert = map go + where + go :: SpecTree () -> Tree + go x = case x of + SpecGroup s xs -> Group s (map go xs) + SpecItem requirement _ -> Example requirement + +spec :: Spec +spec = do + describe "fromHUnitTest" $ do + let e = TestCase $ pure () + + it "works for a TestCase" $ do + e `shouldYield` [Example ""] + + it "works for a labeled TestCase" $ do + TestLabel "foo" e + `shouldYield` [Example "foo"] + + it "works for a TestCase with nested labels" $ do + (TestLabel "foo" . TestLabel "bar") e + `shouldYield` [Group "foo" [Example "bar"]] + + it "works for a flat TestList" $ do + TestList [e, e, e] + `shouldYield` [Example "", Example "", Example ""] + + it "works for a nested TestList" $ do + (TestLabel "foo" . TestLabel "bar" . TestList) [TestLabel "one" e, TestLabel "two" e, TestLabel "three" e] + `shouldYield` [Group "foo" [Group "bar" [Example "one", Example "two", Example "three"]]] diff --git a/test/Test/Hspec/OptionsSpec.hs b/test/Test/Hspec/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/OptionsSpec.hs @@ -0,0 +1,44 @@ +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 defaultOptions "my-spec" + + it "sets optionsColorMode to ColorAuto" $ do + optionsColorMode <$> parseOptions [] `shouldBe` Right ColorAuto + + context "with --no-color" $ do + it "sets optionsColorMode to ColorNever" $ do + optionsColorMode <$> parseOptions ["--no-color"] `shouldBe` Right ColorNever + + context "with --color" $ do + it "sets optionsColorMode to ColorAlways" $ do + optionsColorMode <$> parseOptions ["--color"] `shouldBe` Right ColorAlways + + context "with --out" $ do + it "sets optionsOutputFile" $ do + optionsOutputFile <$> 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 + optionsDepth <$> parseOptions ["--depth", "23"] `shouldBe` Right (Just 23) diff --git a/test/Test/Hspec/QuickCheckSpec.hs b/test/Test/Hspec/QuickCheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/QuickCheckSpec.hs @@ -0,0 +1,19 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/RunnerSpec.hs @@ -0,0 +1,393 @@ +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 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.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)] + +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 + let runSpec_ = (captureLines . ignoreExitCode . H.hspec) $ do + H.it "foo" $ property $ (/= (26 :: Integer)) + + r0 <- withArgs ["--seed", "2413421499272008081"] runSpec_ + r0 `shouldContain` [ + "Falsifiable (after 66 tests): " + , "26" + ] + + r1 <- withArgs ["-r"] runSpec_ + r1 `shouldContain` [ + "Falsifiable (after 66 tests): " + , "26" + ] + + 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 + r <- captureLines . ignoreUserInterrupt . withArgs ["--seed", "23"] . H.hspec $ do + H.it "foo" False + H.it "bar" $ do + E.throwIO E.UserInterrupt :: IO () + H.it "baz" True + normalizeSummary r `shouldBe` [ + "" + , "- foo FAILED [1]" + , "" + , "1) foo" + , "" + , "Randomized with seed 23" + , "" + ] + + it "throws UserInterrupt" $ do + silence . H.hspec $ do + H.it "foo" $ do + E.throwIO E.UserInterrupt :: IO () + `shouldThrow` (== 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 + it "produces a report" $ do + r <- captureLines . withArgs ["--dry-run"] . H.hspec $ 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 + _ <- captureLines . withArgs ["--dry-run"] . H.hspec $ do + H.it "foo" (mockAction e) + H.it "bar" False + mockCounter e `shouldReturn` 0 + + 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 <- captureLines . ignoreExitCode . withArgs ["--seed", "2413421499272008081"] . H.hspec $ do + H.it "foo" $ + property (/= (26 :: Integer)) + r `shouldContain` [ + "Falsifiable (after 66 tests): " + , "26" + ] + + context "when run with --rerun" $ do + it "takes precedence" $ do + let runSpec args = capture_ . ignoreExitCode . withArgs args . H.hspec $ do + H.it "foo" $ + property $ \n -> ((17 + 31 * n) `mod` 50) /= (23 :: Integer) + r0 <- runSpec ["--seed", "23"] + r0 `shouldContain` "(after 88 tests)" + + r1 <- runSpec ["--seed", "42"] + r1 `shouldContain` "(after 48 tests)" + + r2 <- runSpec ["--rerun", "--seed", "23"] + r2 `shouldContain` "(after 88 tests)" + + 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" (E.throwIO (E.ErrorCall "foobar") >> pure ()) + `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.hspecWith H.defaultConfig {H.configFormatter = 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 new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/TimerSpec.hs @@ -0,0 +1,29 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/UtilSpec.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Test.Hspec.UtilSpec (main, spec) where + +import Helper +import Data.Int (Int32) +import System.Random (StdGen) +import qualified Control.Exception as E + +import Test.Hspec.Util + +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 "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 (E.throwIO E.DivideByZero :: IO Int) + show e `shouldBe` "divide by zero" + + it "evaluates result to weak head normal form" $ do + Left e <- safeTry (return undefined) + show e `shouldBe` "Prelude.undefined" + + it "re-throws AsyncException" $ do + safeTry (E.throwIO E.UserInterrupt :: IO Int) `shouldThrow` (== 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" + + describe "stdGenToInteger" $ do + it "is inverse to stdGenFromInteger" $ property $ + \(NonNegative i) -> (stdGenToInteger . stdGenFromInteger) i `shouldBe` i + + describe "stdGenFromInteger" $ do + it "is inverse to stdGenToInteger" $ property $ + \stdGen -> (stdGenFromInteger . stdGenToInteger) stdGen `shouldBe` stdGen + +instance Eq StdGen where + a == b = show a == show b + +instance Arbitrary StdGen where + arbitrary = do + (Positive a, Positive b) <- arbitrary + return $ read (show (a :: Int32) ++ " " ++ show (b :: Int32)) diff --git a/test/Test/HspecSpec.hs b/test/Test/HspecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/HspecSpec.hs @@ -0,0 +1,226 @@ +module Test.HspecSpec (main, spec) where + +import Helper +import Data.IORef +import Data.List (isPrefixOf) + +import Test.Hspec.Core (SpecTree(..), Item(..), Result(..), runSpecM) +import qualified Test.Hspec as H +import qualified Test.Hspec.Runner as H (hspecResult) + +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 + let [SpecGroup foo [SpecGroup bar [SpecItem baz _]]] = runSpecM $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" True + (foo, bar, baz) `shouldBe` ("foo", "bar", "baz") + + context "when no description is given" $ do + it "uses a default description" $ do + let [SpecGroup d _] = runSpecM (H.describe "" (pure ())) + d `shouldBe` "(no description given)" + + describe "it" $ do + it "takes a description of a desired behavior" $ do + let [SpecItem requirement _] = runSpecM (H.it "whatever" True) + requirement `shouldBe` "whatever" + + it "takes an example of that behavior" $ do + let [SpecItem _ item] = runSpecM (H.it "whatever" True) + itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success + + context "when no description is given" $ do + it "uses a default description" $ do + let [SpecItem requirement _] = runSpecM (H.it "" True) + requirement `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 + let [SpecItem _ item] = runSpecM . H.parallel $ H.it "whatever" True + itemIsParallelizable item `shouldBe` True + + it "is applied recursively" $ do + let [SpecGroup _ [SpecGroup _ [SpecItem _ item]]] = runSpecM . H.parallel $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" True + itemIsParallelizable item `shouldBe` True + + describe "before" $ do + it "runs an action before every spec item" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "before" + , "foo" + , "before" + , "bar" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before outer") $ H.before (append "before inner") $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "before outer" + , "before inner" + , "foo" + ] + + context "when used with an action that returns a value" $ do + it "passes that value to the spec item" $ do + property $ \n -> do + silence $ H.hspec $ H.before (return n) $ do + H.it "foo" $ \m -> do + m `shouldBe` (n :: Int) + + context "when used with a QuickCheck property" $ do + it "runs action before every check of the property" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before") $ do + H.it "foo" $ property $ append "foo" + readIORef ref `shouldReturn` (take 200 . cycle) ["before", "foo"] + + describe "after" $ do + it "must be used with a before action" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (return "from before") $ H.after append $ do + H.it "foo" $ \_ -> do + append "foo" + readIORef ref `shouldReturn` [ + "foo" + , "from before" + ] + + describe "after_" $ do + it "runs an action after every spec item" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.after_ (append "after") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "foo" + , "after" + , "bar" + , "after" + ] + + it "guarantees that action is run" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence . ignoreExitCode $ H.hspec $ H.after_ (append "after") $ do + H.it "foo" $ do + ioError $ userError "foo" :: IO () + append "foo" + readIORef ref `shouldReturn` ["after"] + + context "when used multiple times" $ do + it "is evaluated inside out" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.after_ (append "after outer") $ H.after_ (append "after inner") $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "foo" + , "after inner" + , "after outer" + ] + + describe "around" $ do + it "wraps every spec item with an action" $ do + property $ \n -> do + silence $ H.hspec $ H.around ($ n) $ do + H.it "foo" $ \m -> do + m `shouldBe` (n :: Int) + + describe "around_" $ do + it "wraps every spec item with an action" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + action e = append "before" >> e >> append "after" + silence $ H.hspec $ H.around_ action $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "before" + , "foo" + , "after" + , "before" + , "bar" + , "after" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + actionOuter e = append "before outer" >> e >> append "after outer" + actionInner e = append "before inner" >> e >> append "after inner" + silence $ H.hspec $ H.around_ actionOuter $ H.around_ actionInner $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "before outer" + , "before inner" + , "foo" + , "after inner" + , "after outer" + ] + where + runSpec :: H.Spec -> IO [String] + runSpec = captureLines . H.hspecResult diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "-optP-include", "-optPdist/build/autogen/cabal_macros.h", "src/Test/Hspec/Util.hs", "src/Test/Hspec/Formatters.hs"]