diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2015 Simon Hengel +Copyright (c) 2011-2026 Simon Hengel Copyright (c) 2011-2012 Trystan Spangler Copyright (c) 2011-2011 Greg Weber diff --git a/help.txt b/help.txt new file mode 100644 --- /dev/null +++ b/help.txt @@ -0,0 +1,68 @@ +Usage: spec [OPTION]... + +OPTIONS + --help display this help and exit + --ignore-dot-hspec do not read options from ~/.hspec and .hspec + -m PATTERN --match=PATTERN only run examples that match given PATTERN + --skip=PATTERN skip examples that match given PATTERN + +RUNNER OPTIONS + --[no-]dry-run pretend that everything passed; don't + verify anything + --[no-]focused-only do not run anything, unless there are + focused spec items + --[no-]fail-on=ITEMS empty: fail if all spec items have been + filtered + focused: fail on focused spec items + pending: fail on pending spec items + empty-description: fail on empty + descriptions + --[no-]strict same as --fail-on=focused,pending + --[no-]fail-fast abort on first failure + --[no-]randomize randomize execution order + -r --[no-]rerun rerun all examples that failed in the + previous test run (only works in + combination with --failure-report or in + GHCi) + --failure-report=FILE read/write a failure report for use with + --rerun + --[no-]rerun-all-on-success run the whole test suite after a previously + failing rerun succeeds for the first time + (only works in combination with --rerun) + -j N --jobs=N run at most N parallelizable tests + simultaneously (default: number of + available processors) + --seed=N used seed for --randomize and QuickCheck + properties + +FORMATTER OPTIONS + -f NAME --format=NAME use a custom formatter; this can be one of + checks, specdoc, progress, failed-examples or + silent + --[no-]color colorize the output + --[no-]unicode output unicode + --[no-]diff show colorized diffs + --diff-context=N output N lines of diff context (default: 3) + use a value of 'full' to see the full context + --diff-command=CMD use an external diff command + example: --diff-command="git diff" + --[no-]pretty try to pretty-print diff values + --show-exceptions use `show` when formatting exceptions + --display-exceptions use `displayException` when formatting + exceptions + --[no-]times report times for individual spec items + --print-cpu-time include used CPU time in summary + -p[N] --print-slow-items[=N] print the N slowest spec items (default: 10) + --[no-]expert be less verbose + +OPTIONS FOR QUICKCHECK + -a N --qc-max-success=N maximum number of successful tests before a + QuickCheck property succeeds + --qc-max-discard=N maximum number of discarded tests per successful + test before giving up + --qc-max-size=N size to use for the biggest test cases + --qc-max-shrinks=N maximum number of shrinks to perform before giving + up (a value of 0 turns shrinking off) + +OPTIONS FOR SMALLCHECK + --depth=N maximum depth of generated test values for SmallCheck properties diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -1,21 +1,26 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: hspec-core -version: 2.2.4 +version: 2.11.17 license: MIT license-file: LICENSE -copyright: (c) 2011-2015 Simon Hengel, +copyright: (c) 2011-2026 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple -cabal-version: >= 1.10 +extra-source-files: + version.yaml + help.txt category: Testing stability: experimental bug-reports: https://github.com/hspec/hspec/issues -homepage: http://hspec.github.io/ +author: Simon Hengel +homepage: https://hspec.github.io/ synopsis: A Testing Framework for Haskell description: This package exposes internal types and functions that can be used to extend Hspec's functionality. @@ -27,96 +32,222 @@ library hs-source-dirs: src - ghc-options: -Wall + vendor + ghc-options: -Wall -fno-warn-incomplete-uni-patterns build-depends: - base >= 4.3 && < 5 + HUnit ==1.6.* + , QuickCheck >=2.13.1 && <2.19 + , ansi-terminal >=0.6.2 + , array + , base >=4.9.0.0 && <5 + , call-stack >=0.2.0 + , containers + , deepseq + , directory + , filepath + , haskell-lexer + , hspec-expectations ==0.8.4.* + , process + , quickcheck-io >=0.2.0 , random - , tf-random - , setenv - , ansi-terminal >= 0.5 , time - , transformers >= 0.2.2.0 - , deepseq - , HUnit >= 1.2.5 - , QuickCheck >= 2.5.1 - , quickcheck-io - , hspec-expectations == 0.7.2.* - , async >= 2 + , transformers >=0.2.2.0 exposed-modules: + Test.Hspec.Core.Extension + Test.Hspec.Core.Extension.Item + Test.Hspec.Core.Extension.Spec + Test.Hspec.Core.Extension.Tree + Test.Hspec.Core.Extension.Option + Test.Hspec.Core.Extension.Config Test.Hspec.Core.Spec Test.Hspec.Core.Hooks Test.Hspec.Core.Runner + Test.Hspec.Core.Format Test.Hspec.Core.Formatters + Test.Hspec.Core.Formatters.V1 + Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules: - Test.Hspec.Compat - Test.Hspec.Config + GetOpt.Declarative + GetOpt.Declarative.Environment + GetOpt.Declarative.Interpret + GetOpt.Declarative.Types + GetOpt.Declarative.Util + Test.Hspec.Core.Annotations + Test.Hspec.Core.Clock + Test.Hspec.Core.Compat + Test.Hspec.Core.Config + Test.Hspec.Core.Config.Definition + Test.Hspec.Core.Config.Options Test.Hspec.Core.Example + Test.Hspec.Core.Example.Location + Test.Hspec.Core.Extension.Config.Type + Test.Hspec.Core.FailureReport + Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Internal - Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.Formatters.Pretty + Test.Hspec.Core.Formatters.Pretty.Parser + Test.Hspec.Core.Formatters.Pretty.Unicode + Test.Hspec.Core.Formatters.V1.Free + Test.Hspec.Core.Formatters.V1.Internal + Test.Hspec.Core.Formatters.V1.Monad + Test.Hspec.Core.QuickCheck.Util Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Runner.JobQueue + Test.Hspec.Core.Runner.PrintSlowSpecItems + Test.Hspec.Core.Runner.Result + Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec.Monad + Test.Hspec.Core.Timer Test.Hspec.Core.Tree - Test.Hspec.FailureReport - Test.Hspec.Options - Test.Hspec.Timer + Data.Algorithm.Diff Paths_hspec_core default-language: Haskell2010 + if impl(ghc) + other-modules: + Control.Concurrent.Async + hs-source-dirs: + vendor/async-2.2.5/ + cpp-options: -DENABLE_SPEC_HOOK_ARGS + if impl(ghc >= 8.4.1) + build-depends: + stm >=2.2 + else + other-modules: + Control.Concurrent.STM.TMVar + hs-source-dirs: + vendor/stm-2.5.0.1/ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: + src + vendor test - , src - ghc-options: -Wall + ghc-options: -Wall -fno-warn-incomplete-uni-patterns + cpp-options: -DTEST build-depends: - base >= 4.3 && < 5 - , random - , tf-random - , setenv - , ansi-terminal >= 0.5 - , time - , transformers >= 0.2.2.0 + HUnit ==1.6.* + , QuickCheck >=2.14 + , ansi-terminal >=0.6.2 + , array + , base >=4.9.0.0 && <5 + , base-orphans + , call-stack >=0.2.0 + , containers , deepseq - , HUnit >= 1.2.5 - , QuickCheck >= 2.5.1 - , quickcheck-io - , hspec-expectations == 0.7.2.* - , async >= 2 - , hspec-meta >= 2.2.0 - , silently >= 1.2.4 + , directory + , filepath + , haskell-lexer + , hspec-expectations ==0.8.4.* + , hspec-meta ==2.11.17 , process + , quickcheck-io >=0.2.0 + , random + , silently >=1.2.4 + , temporary + , time + , transformers >=0.2.2.0 + build-tool-depends: + hspec-meta:hspec-meta-discover other-modules: - Helper - Mock - Test.Hspec.CompatSpec - Test.Hspec.Core.ExampleSpec - Test.Hspec.Core.FormattersSpec - Test.Hspec.Core.HooksSpec - Test.Hspec.Core.QuickCheckUtilSpec - Test.Hspec.Core.RunnerSpec - Test.Hspec.Core.SpecSpec - Test.Hspec.Core.UtilSpec - Test.Hspec.FailureReportSpec - Test.Hspec.OptionsSpec - Test.Hspec.TimerSpec - Test.Hspec.Compat - Test.Hspec.Config + GetOpt.Declarative + GetOpt.Declarative.Environment + GetOpt.Declarative.Interpret + GetOpt.Declarative.Types + GetOpt.Declarative.Util + Test.Hspec.Core.Annotations + Test.Hspec.Core.Clock + Test.Hspec.Core.Compat + Test.Hspec.Core.Config + Test.Hspec.Core.Config.Definition + Test.Hspec.Core.Config.Options Test.Hspec.Core.Example + Test.Hspec.Core.Example.Location + Test.Hspec.Core.Extension + Test.Hspec.Core.Extension.Config + Test.Hspec.Core.Extension.Config.Type + Test.Hspec.Core.Extension.Item + Test.Hspec.Core.Extension.Option + Test.Hspec.Core.Extension.Spec + Test.Hspec.Core.Extension.Tree + Test.Hspec.Core.FailureReport + Test.Hspec.Core.Format Test.Hspec.Core.Formatters + Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Internal + Test.Hspec.Core.Formatters.Pretty + Test.Hspec.Core.Formatters.Pretty.Parser + Test.Hspec.Core.Formatters.Pretty.Unicode + Test.Hspec.Core.Formatters.V1 + Test.Hspec.Core.Formatters.V1.Free + Test.Hspec.Core.Formatters.V1.Internal + Test.Hspec.Core.Formatters.V1.Monad + Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck - Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.QuickCheck.Util Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Runner.JobQueue + Test.Hspec.Core.Runner.PrintSlowSpecItems + Test.Hspec.Core.Runner.Result + Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad + Test.Hspec.Core.Timer Test.Hspec.Core.Tree Test.Hspec.Core.Util - Test.Hspec.FailureReport - Test.Hspec.Options - Test.Hspec.Timer + Data.Algorithm.Diff + GetOpt.Declarative.EnvironmentSpec + GetOpt.Declarative.UtilSpec + Helper + Mock + SpecHook + Test.Hspec.Core.AnnotationsSpec + Test.Hspec.Core.ClockSpec + Test.Hspec.Core.CompatSpec + Test.Hspec.Core.Config.DefinitionSpec + Test.Hspec.Core.Config.OptionsSpec + Test.Hspec.Core.ConfigSpec + Test.Hspec.Core.Example.LocationSpec + Test.Hspec.Core.ExampleSpec + Test.Hspec.Core.FailureReportSpec + Test.Hspec.Core.FormatSpec + Test.Hspec.Core.Formatters.DiffSpec + Test.Hspec.Core.Formatters.InternalSpec + Test.Hspec.Core.Formatters.Pretty.ParserSpec + Test.Hspec.Core.Formatters.Pretty.UnicodeSpec + Test.Hspec.Core.Formatters.PrettySpec + Test.Hspec.Core.Formatters.V1Spec + Test.Hspec.Core.Formatters.V2Spec + Test.Hspec.Core.HooksSpec + Test.Hspec.Core.QuickCheck.UtilSpec + Test.Hspec.Core.Runner.EvalSpec + Test.Hspec.Core.Runner.JobQueueSpec + Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec + Test.Hspec.Core.Runner.ResultSpec + Test.Hspec.Core.RunnerSpec + Test.Hspec.Core.ShuffleSpec + Test.Hspec.Core.SpecSpec + Test.Hspec.Core.TimerSpec + Test.Hspec.Core.TreeSpec + Test.Hspec.Core.UtilSpec + Paths_hspec_core default-language: Haskell2010 + if impl(ghc) + other-modules: + Control.Concurrent.Async + hs-source-dirs: + vendor/async-2.2.5/ + cpp-options: -DENABLE_SPEC_HOOK_ARGS + if impl(ghc >= 8.4.1) + build-depends: + stm >=2.2 + else + other-modules: + Control.Concurrent.STM.TMVar + hs-source-dirs: + vendor/stm-2.5.0.1/ diff --git a/src/GetOpt/Declarative.hs b/src/GetOpt/Declarative.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt/Declarative.hs @@ -0,0 +1,5 @@ +module GetOpt.Declarative (module GetOpt.Declarative) where +import Prelude () +import GetOpt.Declarative.Types as GetOpt.Declarative +import GetOpt.Declarative.Interpret as GetOpt.Declarative +import GetOpt.Declarative.Environment as GetOpt.Declarative diff --git a/src/GetOpt/Declarative/Environment.hs b/src/GetOpt/Declarative/Environment.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt/Declarative/Environment.hs @@ -0,0 +1,51 @@ +module GetOpt.Declarative.Environment ( + InvalidValue(..) +, parseEnvironmentOptions +, parseEnvironmentOption +) where + +import Prelude () +import Test.Hspec.Core.Compat +import Data.Char + +import GetOpt.Declarative.Types + +data InvalidValue = InvalidValue String String + deriving (Eq, Show) + +parseEnvironmentOptions :: String -> [(String, String)] -> config -> [Option config] -> ([InvalidValue], config) +parseEnvironmentOptions prefix env = foldr f . (,) [] + where + f :: Option config -> ([InvalidValue], config) -> ([InvalidValue], config) + f option (errs, config) = case parseEnvironmentOption prefix env config option of + Left err -> (err : errs, config) + Right c -> (errs, c) + +parseEnvironmentOption :: String -> [(String, String)] -> config -> Option config -> Either InvalidValue config +parseEnvironmentOption prefix env config option = case lookup name env of + Nothing -> Right config + Just value -> case optionSetter option of + NoArg setter -> case value of + "yes" -> Right $ setter config + _ -> invalidValue + Flag setter -> case value of + "yes" -> Right $ setter True config + "no" -> Right $ setter False config + _ -> invalidValue + OptArg _ setter -> case setter (Just value) config of + Just c -> Right c + Nothing -> invalidValue + Arg _ setter -> case setter value config of + Just c -> Right c + Nothing -> invalidValue + where + invalidValue = Left (InvalidValue name value) + where + name = envVarName prefix option + +envVarName :: String -> Option config -> String +envVarName prefix option = prefix ++ '_' : map f (optionName option) + where + f c = case c of + '-' -> '_' + _ -> toUpper c diff --git a/src/GetOpt/Declarative/Interpret.hs b/src/GetOpt/Declarative/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt/Declarative/Interpret.hs @@ -0,0 +1,96 @@ +module GetOpt.Declarative.Interpret ( + ParseResult(..) +, parseCommandLineOptions +, parse +, interpretOptions +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt) +import qualified System.Console.GetOpt as GetOpt + +import GetOpt.Declarative.Types +import GetOpt.Declarative.Util (mkUsageInfo) + +data InvalidArgument = InvalidArgument String String + +data ParseResult config = Help String | Failure String | Success config + +parseCommandLineOptions :: [(String, [Option config])] -> String -> [String] -> config -> ParseResult config +parseCommandLineOptions opts prog args config = case parseWithHelp (concatMap snd options) config args of + Nothing -> Help usage + Just (Right c) -> Success c + Just (Left err) -> Failure $ prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n" + where + options = addHelpFlag $ map (fmap interpretOptions) opts + + documentedOptions = addHelpFlag $ map (fmap $ interpretOptions . filter optionDocumented) opts + + usage :: String + usage = "Usage: " ++ prog ++ " [OPTION]...\n\n" + ++ intercalate "\n" (map (uncurry mkUsageInfo) documentedOptions) + +addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])] +addHelpFlag opts = case opts of + (section, xs) : ys -> (section, GetOpt.Option [] ["help"] (GetOpt.NoArg help) "display this help and exit" : noHelp xs) : map (fmap noHelp) ys + [] -> [] + where + help = Nothing + + noHelp :: [OptDescr a] -> [OptDescr (Maybe a)] + noHelp = map (fmap Just) + +parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config) +parseWithHelp options config args = case getOpt Permute options args of + (opts, [], []) | _ : _ <- [() | Nothing <- opts] -> Nothing + (opts, xs, ys) -> Just $ interpretResult config (catMaybes opts, xs, ys) + +parse :: [OptDescr (config -> Either InvalidArgument config)] -> config -> [String] -> Either String config +parse options config = interpretResult config . getOpt Permute options + +interpretResult :: config -> ([config -> Either InvalidArgument config], [String], [String]) -> Either String config +interpretResult config = interpretGetOptResult >=> foldResult config + +foldResult :: config -> [config -> Either InvalidArgument config] -> Either String config +foldResult config opts = either (Left . renderInvalidArgument) return $ foldlM (flip id) config opts + +renderInvalidArgument :: InvalidArgument -> String +renderInvalidArgument (InvalidArgument name value) = "invalid argument `" ++ value ++ "' for `--" ++ name ++ "'" + +interpretGetOptResult :: ([a], [String], [String]) -> Either String [a] +interpretGetOptResult result = case result of + (opts, [], []) -> Right opts + (_, _, err:_) -> Left (init err) + (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") + +interpretOptions :: [Option config] -> [OptDescr (config -> Either InvalidArgument config)] +interpretOptions = concatMap interpretOption + +interpretOption :: Option config -> [OptDescr (config -> Either InvalidArgument config)] +interpretOption (Option name shortcut argDesc help _) = case argDesc of + NoArg setter -> [option $ GetOpt.NoArg (Right . setter)] + + Flag setter -> [ + option (arg True) + , GetOpt.Option [] ["no-" ++ name] (arg False) ("do not " ++ help) + ] + where + arg v = GetOpt.NoArg (Right . setter v) + + OptArg argName setter -> [option $ GetOpt.OptArg arg argName] + where + arg mInput c = case setter mInput c of + Just c_ -> Right c_ + Nothing -> case mInput of + Just input -> invalid input + Nothing -> Right c + + Arg argName setter -> [option (GetOpt.ReqArg arg argName)] + where + arg input = maybe (invalid input) Right . setter input + + where + invalid = Left . InvalidArgument name + option arg = GetOpt.Option (maybeToList shortcut) [name] arg help diff --git a/src/GetOpt/Declarative/Types.hs b/src/GetOpt/Declarative/Types.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt/Declarative/Types.hs @@ -0,0 +1,18 @@ +module GetOpt.Declarative.Types where + +import Prelude () +import Test.Hspec.Core.Compat + +data Option config = Option { + optionName :: String +, optionShortcut :: Maybe Char +, optionSetter :: OptionSetter config +, optionHelp :: String +, optionDocumented :: Bool +} + +data OptionSetter config = + NoArg (config -> config) + | Flag (Bool -> config -> config) + | OptArg String (Maybe String -> config -> Maybe config) + | Arg String (String -> config -> Maybe config) diff --git a/src/GetOpt/Declarative/Util.hs b/src/GetOpt/Declarative/Util.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt/Declarative/Util.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module GetOpt.Declarative.Util (mkUsageInfo) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.Console.GetOpt + +import Test.Hspec.Core.Util + +modifyHelp :: (String -> String) -> OptDescr a -> OptDescr a +modifyHelp modify (Option s n a help) = Option s n a (modify help) + +mkUsageInfo :: String -> [OptDescr a] -> String +mkUsageInfo title = usageInfo title . addLineBreaksForHelp . condenseNoOptions + +addLineBreaksForHelp :: [OptDescr a] -> [OptDescr a] +addLineBreaksForHelp options = map (modifyHelp addLineBreaks) options + where + withoutHelpWidth = maxLength . usageInfo "" . map removeHelp + helpWidth = 80 - withoutHelpWidth options + + addLineBreaks = unlines . lineBreaksAt helpWidth + + maxLength = maximum . map length . lines + removeHelp = modifyHelp (const "") + +condenseNoOptions :: [OptDescr a] -> [OptDescr a] +condenseNoOptions options = case options of + Option short [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) -> + Option short ["[no-]" ++ optionA] arg help : condenseNoOptions ys + x : xs -> x : condenseNoOptions xs + [] -> [] diff --git a/src/Test/Hspec/Compat.hs b/src/Test/Hspec/Compat.hs deleted file mode 100644 --- a/src/Test/Hspec/Compat.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP #-} -module Test.Hspec.Compat ( - getDefaultConcurrentJobs -, showType -, showFullType -, readMaybe -, lookupEnv -, module Data.IORef - -, module Prelude -, module Control.Applicative -, module Data.Foldable -, module Data.Traversable -, module Data.Monoid - -#if !MIN_VERSION_base(4,6,0) -, modifyIORef' -#endif -) where - -import Control.Applicative -import Data.Foldable -import Data.Traversable -import Data.Monoid - -import Prelude hiding ( - all - , and - , any - , concat - , concatMap - , elem - , foldl - , foldl1 - , foldr - , foldr1 - , mapM - , mapM_ - , maximum - , minimum - , notElem - , or - , product - , sequence - , sequence_ - , sum - ) - -#if !MIN_VERSION_base(4,3,0) -import Control.Monad.Trans.Error () -- for Monad (Either e) -#endif - -import Data.Typeable (Typeable, typeOf, typeRepTyCon) -import Text.Read -import Data.IORef -import System.Environment - -#if MIN_VERSION_base(4,4,0) -import Data.Typeable.Internal (tyConModule, tyConName) -import Control.Concurrent -#endif - -#if !MIN_VERSION_base(4,6,0) -import qualified Text.ParserCombinators.ReadP as P -#endif - -getDefaultConcurrentJobs :: IO Int -#if MIN_VERSION_base(4,4,0) -getDefaultConcurrentJobs = getNumCapabilities -#else -getDefaultConcurrentJobs = return 1 -#endif - -#if !MIN_VERSION_base(4,6,0) --- |Strict version of 'modifyIORef' -modifyIORef' :: IORef a -> (a -> a) -> IO () -modifyIORef' ref f = do - x <- readIORef ref - let x' = f x - x' `seq` writeIORef ref x' - --- | Parse a string using the 'Read' instance. --- Succeeds if there is exactly one valid result. --- A 'Left' value indicates a parse error. -readEither :: Read a => String -> Either String a -readEither s = - case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = - do x <- readPrec - lift P.skipSpaces - return x - --- | Parse a string using the 'Read' instance. --- Succeeds if there is exactly one valid result. -readMaybe :: Read a => String -> Maybe a -readMaybe s = case readEither s of - Left _ -> Nothing - Right a -> Just a - --- | Return the value of the environment variable @var@, or @Nothing@ if --- there is no such value. --- --- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. -lookupEnv :: String -> IO (Maybe String) -lookupEnv k = lookup k `fmap` getEnvironment -#endif - -showType :: Typeable a => a -> String -showType a = let t = typeRepTyCon (typeOf a) in -#if MIN_VERSION_base(4,4,0) - show t -#else - (reverse . takeWhile (/= '.') . reverse . show) t -#endif - - -showFullType :: Typeable a => a -> String -showFullType a = let t = typeRepTyCon (typeOf a) in -#if MIN_VERSION_base(4,4,0) - tyConModule t ++ "." ++ tyConName t -#else - show t -#endif diff --git a/src/Test/Hspec/Config.hs b/src/Test/Hspec/Config.hs deleted file mode 100644 --- a/src/Test/Hspec/Config.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Test.Hspec.Config ( - Config (..) -, ColorMode(..) -, defaultConfig -, getConfig -, configAddFilter -, configQuickCheckArgs -) where - -import Control.Applicative -import System.IO -import System.Exit -import qualified Test.QuickCheck as QC - -import Test.Hspec.Core.Util -import Test.Hspec.Options -import Test.Hspec.FailureReport -import Test.Hspec.Core.QuickCheckUtil (mkGen) -import Test.Hspec.Core.Example (Params(..), defaultParams) - --- | Add a filter predicate to config. If there is already a filter predicate, --- then combine them with `||`. -configAddFilter :: (Path -> Bool) -> Config -> Config -configAddFilter p1 c = c { - configFilterPredicate = Just p1 `filterOr` configFilterPredicate c - } - -mkConfig :: Maybe FailureReport -> Config -> Config -mkConfig mFailureReport opts = opts { - configFilterPredicate = matchFilter `filterOr` rerunFilter - , configQuickCheckSeed = mSeed - , configQuickCheckMaxSuccess = mMaxSuccess - , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio - , configQuickCheckMaxSize = mMaxSize - } - where - - mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport) - mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) - mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) - mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) - - matchFilter = configFilterPredicate opts - - rerunFilter = case failureReportPaths <$> mFailureReport of - Just [] -> Nothing - Just xs -> Just (`elem` xs) - Nothing -> Nothing - -configQuickCheckArgs :: Config -> QC.Args -configQuickCheckArgs c = qcArgs - where - qcArgs = ( - maybe id setSeed (configQuickCheckSeed c) - . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) - . maybe id setMaxSize (configQuickCheckMaxSize c) - . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) - - setMaxSuccess :: Int -> QC.Args -> QC.Args - setMaxSuccess n args = args {QC.maxSuccess = n} - - setMaxSize :: Int -> QC.Args -> QC.Args - setMaxSize n args = args {QC.maxSize = n} - - setMaxDiscardRatio :: Int -> QC.Args -> QC.Args - setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} - - setSeed :: Integer -> QC.Args -> QC.Args - setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} - -getConfig :: Config -> String -> [String] -> IO Config -getConfig opts_ prog args = do - case parseOptions opts_ prog args of - Left (err, msg) -> exitWithMessage err msg - Right opts -> do - r <- if configRerun opts then readFailureReport else return Nothing - return (mkConfig r opts) - -exitWithMessage :: ExitCode -> String -> IO a -exitWithMessage err msg = do - hPutStr h msg - exitWith err - where - h = case err of - ExitSuccess -> stdout - _ -> stderr diff --git a/src/Test/Hspec/Core/Annotations.hs b/src/Test/Hspec/Core/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Annotations.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hspec.Core.Annotations ( + Annotations +, setValue +, getValue +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Typeable +import Data.Dynamic +import Data.Map (Map) +import qualified Data.Map as Map + +newtype Annotations = Annotations (Map TypeRep Dynamic) + deriving ( +#if MIN_VERSION_base(4,11,0) + Semigroup, +#endif + Monoid) + +setValue :: Typeable value => value -> Annotations -> Annotations +setValue value (Annotations values) = Annotations $ Map.insert (typeOf value) (toDyn value) values + +getValue :: forall value. Typeable value => Annotations -> Maybe value +getValue (Annotations values) = Map.lookup (typeOf (undefined :: value)) values >>= fromDynamic diff --git a/src/Test/Hspec/Core/Clock.hs b/src/Test/Hspec/Core/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Clock.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Clock ( + Seconds(..) +, toMilliseconds +, toMicroseconds +, getMonotonicTime +, measure +, sleep +, timeout +) where + +#if MIN_VERSION_base(4,11,0) && !defined(__MHS__) +#define HAS_GET_MONOTONIC_TIME +#endif + +import Prelude () +import Test.Hspec.Core.Compat + +import Text.Printf +import Control.Concurrent +import qualified System.Timeout as System + +#ifdef HAS_GET_MONOTONIC_TIME +import qualified GHC.Clock as GHC +#else +import Data.Time.Clock.POSIX +#endif + +newtype Seconds = Seconds Double + deriving (Eq, Show, Ord, Num, Fractional, PrintfArg) + +toMilliseconds :: Seconds -> Int +toMilliseconds (Seconds s) = floor (s * 1000) + +toMicroseconds :: Seconds -> Int +toMicroseconds (Seconds s) = floor (s * 1000000) + +getMonotonicTime :: IO Seconds +#ifdef HAS_GET_MONOTONIC_TIME +getMonotonicTime = Seconds <$> GHC.getMonotonicTime +#else +getMonotonicTime = do + t <- getPOSIXTime + return $ Seconds (realToFrac t) +#endif + +measure :: IO a -> IO (Seconds, a) +measure action = do + t0 <- getMonotonicTime + a <- action + t1 <- getMonotonicTime + return (t1 - t0, a) + +sleep :: Seconds -> IO () +sleep = threadDelay . toMicroseconds + +timeout :: Seconds -> IO a -> IO (Maybe a) +timeout = System.timeout . toMicroseconds diff --git a/src/Test/Hspec/Core/Compat.hs b/src/Test/Hspec/Core/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Compat.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Compat ( + module Imports +, module Test.Hspec.Core.Compat +, Typeable +) where + +import Control.Exception as Imports +import Control.Arrow as Imports ((>>>), (&&&), first, second) +import Control.Applicative as Imports +import Control.Monad as Imports hiding ( + mapM + , mapM_ + , forM + , forM_ + , msum + , sequence + , sequence_ + ) +import Data.Maybe as Imports +import Data.Foldable as Imports +import GHC.Stack as Imports (HasCallStack, withFrozenCallStack) + +import System.IO +import System.Exit +import System.Environment + +#if MIN_VERSION_base(4,11,0) +import Data.Functor as Imports ((<&>)) +#endif + +import Data.Traversable as Imports +#ifndef __MHS__ +import Data.Monoid as Imports hiding (First) +#else +import Data.Monoid as Imports (Endo(..), Sum(..)) +#endif +import Data.List as Imports ( + stripPrefix + , isPrefixOf + , isInfixOf + , isSuffixOf + , intercalate + , inits + , tails + , sortBy + , sortOn + ) + +import Prelude as Imports hiding ( + all + , and + , any + , concat + , concatMap + , elem + , foldl + , foldl1 + , foldr + , foldr1 + , mapM + , mapM_ + , maximum + , minimum + , notElem + , or + , product + , sequence + , sequence_ + , sum + , length + , null + ) + +import Data.Typeable +import Data.IORef as Imports + +#if MIN_VERSION_base(4,12,0) +import GHC.ResponseFile as Imports (unescapeArgs) +#else +import Data.Char +#endif + +import Text.Read as Imports (readMaybe) +import System.Environment as Imports (lookupEnv) + + +import Data.Bool as Imports (bool) + +import Control.Concurrent + +#ifndef __MHS__ +import GHC.IO.Exception +#else +import System.IO.Error +#endif + ( ioe_type, IOErrorType(..) ) + +isUnsupportedOperation :: IOError -> Bool +isUnsupportedOperation e = ioe_type e == UnsupportedOperation + +showType :: Typeable a => a -> String +showType = show . typeRepTyCon . typeOf + +getDefaultConcurrentJobs :: IO Int +getDefaultConcurrentJobs = getNumCapabilities + +guarded :: Alternative m => (a -> Bool) -> a -> m a +guarded p a = if p a then pure a else empty + +#if !MIN_VERSION_base(4,11,0) +infixl 1 <&> +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) +#endif + +endsWith :: Eq a => [a] -> [a] -> Bool +endsWith = flip isSuffixOf + +pass :: Applicative m => m () +pass = pure () + +die :: String -> IO a +die err = do + name <- getProgName + hPutStrLn stderr $ name <> ": " <> err + exitFailure + +#if !MIN_VERSION_base(4,12,0) +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as +#endif + +unicodeOutputSupported :: Handle -> IO Bool +unicodeOutputSupported _h = do +#ifndef __MHS__ + (== Just "UTF-8") . fmap show <$> hGetEncoding _h +#else + return True + +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath = return +#endif diff --git a/src/Test/Hspec/Core/Config.hs b/src/Test/Hspec/Core/Config.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Config.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Config ( + Config (..) +, ColorMode(..) +, UnicodeMode(..) +, defaultConfig +, readConfig +, configAddFilter +, configQuickCheckArgs + +, readFailureReportOnRerun +, applyFailureReport +#ifdef TEST +, readConfigFiles +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.IO +import System.IO.Error +import System.Exit +import System.FilePath +import System.Directory +import System.Environment (getProgName, getEnvironment) +import qualified Test.QuickCheck as QC + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Config.Options +import Test.Hspec.Core.Config.Definition +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.QuickCheck.Util (mkGen) +import Test.Hspec.Core.Example (Params(..), defaultParams) +import qualified Test.Hspec.Core.Formatters.V2 as V2 + +defaultConfig :: Config +defaultConfig = mkDefaultConfig $ map (fmap V2.formatterToFormat) [ + ("checks", V2.checks) + , ("specdoc", V2.specdoc) + , ("progress", V2.progress) + , ("failed-examples", V2.failed_examples) + , ("silent", V2.silent) + ] + +-- | 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 + } + +applyFailureReport :: Maybe FailureReport -> Config -> Config +applyFailureReport mFailureReport config = config { + configFilterPredicate = matchFilter `filterOr` rerunFilter + , configSeed = mSeed + , configQuickCheckMaxSuccess = mMaxSuccess + , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio + , configQuickCheckMaxSize = mMaxSize + } + where + + mSeed = getSeed config <|> (failureReportSeed <$> mFailureReport) + mMaxSuccess = configQuickCheckMaxSuccess config <|> (failureReportMaxSuccess <$> mFailureReport) + mMaxSize = configQuickCheckMaxSize config <|> (failureReportMaxSize <$> mFailureReport) + mMaxDiscardRatio = configQuickCheckMaxDiscardRatio config <|> (failureReportMaxDiscardRatio <$> mFailureReport) + + matchFilter = configFilterPredicate config + + rerunFilter = case failureReportPaths <$> mFailureReport of + Just [] -> Nothing + Just xs -> Just (`elem` xs) + Nothing -> Nothing + +configQuickCheckArgs :: Config -> QC.Args +configQuickCheckArgs c = qcArgs + where + qcArgs = ( + maybe id setSeed (configSeed c) + . maybe id setMaxShrinks (configQuickCheckMaxShrinks c) + . maybe id setMaxSize (configQuickCheckMaxSize c) + . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) + . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) + + setMaxSuccess :: Int -> QC.Args -> QC.Args + setMaxSuccess n args = args {QC.maxSuccess = n} + + setMaxDiscardRatio :: Int -> QC.Args -> QC.Args + setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} + + setMaxSize :: Int -> QC.Args -> QC.Args + setMaxSize n args = args {QC.maxSize = n} + + setMaxShrinks :: Int -> QC.Args -> QC.Args + setMaxShrinks n args = args {QC.maxShrinks = n} + + setSeed :: Integer -> QC.Args -> QC.Args + setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} + +-- | +-- `readConfig` parses config options from several sources and constructs a +-- `Config` value. It takes options from: +-- +-- 1. @~/.hspec@ (a config file in the user's home directory) +-- 1. @.hspec@ (a config file in the current working directory) +-- 1. [environment variables starting with @HSPEC_@](https://hspec.github.io/options.html#specifying-options-through-environment-variables) +-- 1. the provided list of command-line options (the second argument to @readConfig@) +-- +-- (precedence from low to high) +-- +-- When parsing fails then @readConfig@ writes an error message to `stderr` and +-- exits with `exitFailure`. +-- +-- When @--help@ is provided as a command-line option then @readConfig@ writes +-- a help message to `stdout` and exits with `exitSuccess`. +-- +-- A common way to use @readConfig@ is: +-- +-- @ +-- `System.Environment.getArgs` >>= readConfig `defaultConfig` +-- @ +readConfig :: Config -> [String] -> IO Config +readConfig opts_ args = do + prog <- getProgName + configFiles <- do + ignore <- ignoreConfigFile opts_ args + case ignore of + True -> return [] + False -> readConfigFiles + env <- getEnvironment + let envVar = words <$> lookup envVarName env + case parseOptions opts_ prog configFiles envVar env args of + Left (err, msg) -> exitWithMessage err msg + Right (warnings, opts) -> do + mapM_ (hPutStrLn stderr) warnings + return opts + +readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) +readFailureReportOnRerun config + | configRerun config = readFailureReport config + | otherwise = return Nothing + +readConfigFiles :: IO [ConfigFile] +readConfigFiles = do + global <- readGlobalConfigFile + local <- readLocalConfigFile + return $ catMaybes [global, local] + +readGlobalConfigFile :: IO (Maybe ConfigFile) +readGlobalConfigFile = do + mHome <- tryJust (guard . unavailable) getHomeDirectory + case mHome of + Left _ -> return Nothing + Right home -> readConfigFile (home ".hspec") + where + unavailable :: IOError -> Bool + unavailable e = isDoesNotExistError e || isUnsupportedOperation e + +readLocalConfigFile :: IO (Maybe ConfigFile) +readLocalConfigFile = do + mName <- tryJust (guard . isDoesNotExistError) (canonicalizePath ".hspec") + case mName of + Left _ -> return Nothing + Right name -> readConfigFile name + +readConfigFile :: FilePath -> IO (Maybe ConfigFile) +readConfigFile name = do + exists <- doesFileExist name + if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing + +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/Config/Definition.hs b/src/Test/Hspec/Core/Config/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Config/Definition.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Config.Definition ( + Config(..) +, ColorMode(..) +, UnicodeMode(..) +, mkDefaultConfig + +, filterOr + +, setConfigAnnotation +, getConfigAnnotation + +, addExtensionOptions +, getExtensionOptions + +, getSeed +, getFormatter + +, commandLineOnlyOptions +, formatterOptions +, smallCheckOptions +, quickCheckOptions +, runnerOptions + +, flag +, option + +#ifdef TEST +, splitOn +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO (openTempFile, hClose) +import System.Process (system) + +import Test.Hspec.Core.Annotations (Annotations) +import qualified Test.Hspec.Core.Annotations as Annotations + +import Test.Hspec.Core.Format (Format, FormatConfig) +import Test.Hspec.Core.Formatters.Pretty (pretty2) +import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 +import qualified Test.Hspec.Core.Formatters.V1.Internal as V1 (formatterToFormat) +import Test.Hspec.Core.Util + +import GetOpt.Declarative + +setConfigAnnotation :: Typeable value => value -> Config -> Config +setConfigAnnotation value config = config { configAnnotations = Annotations.setValue value $ configAnnotations config } + +getConfigAnnotation :: Typeable value => Config -> Maybe value +getConfigAnnotation = Annotations.getValue . configAnnotations + +newtype ExtensionOptions = ExtensionOptions { unExtensionOptions :: [(String, [Option Config])] } + +addExtensionOptions :: String -> [Option Config] -> Config -> Config +addExtensionOptions section opts config = setExtensionOptions ((section, opts) : getExtensionOptions config) config + +setExtensionOptions :: [(String, [Option Config])] -> Config -> Config +setExtensionOptions = setConfigAnnotation . ExtensionOptions + +getExtensionOptions :: Config -> [(String, [Option Config])] +getExtensionOptions = maybe [] unExtensionOptions . getConfigAnnotation + +getFormatter :: Config -> Maybe (FormatConfig -> IO Format) +getFormatter config = configFormat config <|> V1.formatterToFormat <$> configFormatter config + +getSeed :: Config -> Maybe Integer +getSeed config = configSeed config <|> configQuickCheckSeed config + +data ColorMode = ColorAuto | ColorNever | ColorAlways + deriving (Eq, Show) + +data UnicodeMode = UnicodeAuto | UnicodeNever | UnicodeAlways + deriving (Eq, Show) + +data Config = Config { + configIgnoreConfigFile :: Bool +, configDryRun :: Bool +, configFocusedOnly :: Bool +, configFailOnEmpty :: Bool +, configFailOnFocused :: Bool +, configFailOnPending :: Bool +, configFailOnEmptyDescription :: Bool +, configPrintSlowItems :: Maybe Int +, configPrintCpuTime :: Bool +, configFailFast :: Bool +, configRandomize :: Bool +, configSeed :: Maybe Integer +, configQuickCheckSeed :: Maybe Integer +, configFailureReport :: Maybe FilePath +, configRerun :: Bool +, configRerunAllOnSuccess :: 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) +, configSkipPredicate :: Maybe (Path -> Bool) +, configQuickCheckMaxSuccess :: Maybe Int +, configQuickCheckMaxDiscardRatio :: Maybe Int +, configQuickCheckMaxSize :: Maybe Int +, configQuickCheckMaxShrinks :: Maybe Int +, configSmallCheckDepth :: Maybe Int +, configColorMode :: ColorMode +, configUnicodeMode :: UnicodeMode +, configDiff :: Bool +, configDiffContext :: Maybe Int + +-- | +-- An action that is used to print diffs. The first argument is the value of +-- `configDiffContext`. The remaining two arguments are the @expected@ and +-- @actual@ value. +-- +-- @since 2.10.6 +, configExternalDiff :: Maybe (Maybe Int -> String -> String -> IO ()) + +, configPrettyPrint :: Bool +, configPrettyPrintFunction :: Bool -> String -> String -> (String, String) +, configFormatException :: SomeException -> String -- ^ @since 2.11.5 +, configTimes :: Bool +, configExpertMode :: Bool -- ^ @since 2.11.2 +, configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 +, configFormat :: Maybe (FormatConfig -> IO Format) +, configFormatter :: Maybe V1.Formatter +, configHtmlOutput :: Bool +, configConcurrentJobs :: Maybe Int +, configAnnotations :: Annotations +} +{-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-} +{-# DEPRECATED configQuickCheckSeed "Use `configSeed` instead." #-} + +mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config +mkDefaultConfig formatters = Config { + configIgnoreConfigFile = False +, configDryRun = False +, configFocusedOnly = False +, configFailOnEmpty = False +, configFailOnFocused = False +, configFailOnPending = False +, configFailOnEmptyDescription = False +, configPrintSlowItems = Nothing +, configPrintCpuTime = False +, configFailFast = False +, configRandomize = False +, configSeed = Nothing +, configQuickCheckSeed = Nothing +, configFailureReport = Nothing +, configRerun = False +, configRerunAllOnSuccess = False +, configFilterPredicate = Nothing +, configSkipPredicate = Nothing +, configQuickCheckMaxSuccess = Nothing +, configQuickCheckMaxDiscardRatio = Nothing +, configQuickCheckMaxSize = Nothing +, configQuickCheckMaxShrinks = Nothing +, configSmallCheckDepth = Nothing +, configColorMode = ColorAuto +, configUnicodeMode = UnicodeAuto +, configDiff = True +, configDiffContext = Just defaultDiffContext +, configExternalDiff = Nothing +, configPrettyPrint = True +, configPrettyPrintFunction = pretty2 +, configFormatException = formatExceptionWith show +, configTimes = False +, configExpertMode = False +, configAvailableFormatters = formatters +, configFormat = Nothing +, configFormatter = Nothing +, configHtmlOutput = False +, configConcurrentJobs = Nothing +, configAnnotations = mempty +} + +defaultDiffContext :: Int +defaultDiffContext = 3 + +externalDiff :: String -> String -> String -> IO () +externalDiff command expected actual = do + tmp <- getTemporaryDirectory + withTempFile tmp "hspec-expected" expected $ \ expectedFile -> do + withTempFile tmp "hspec-actual" actual $ \ actualFile -> do + void . system $ unwords [command, expectedFile, actualFile] + +withTempFile :: FilePath -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempFile dir file contents action = do + bracket (openTempFile dir file) (removeFile . fst) $ \ (path, h) -> do + hClose h + writeFile path contents + action path + +option :: String -> OptionSetter config -> String -> Option config +option name arg help = Option name Nothing arg help True + +flag :: String -> (Bool -> config -> config) -> String -> Option config +flag name setter = option name (Flag setter) + +mkOptionNoArg :: String -> Maybe Char -> (Config -> Config) -> String -> Option Config +mkOptionNoArg name shortcut setter help = Option name shortcut (NoArg setter) help True + +mkOption :: String -> Maybe Char -> OptionSetter Config -> String -> Option Config +mkOption name shortcut arg help = Option name shortcut arg help True + +undocumented :: Option config -> Option config +undocumented opt = opt {optionDocumented = False} + +argument :: String -> (String -> Maybe a) -> (a -> config -> config) -> OptionSetter config +argument name parser setter = Arg name $ \ input c -> flip setter c <$> parser input + +formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config] +formatterOptions formatters = [ + mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat + , flag "color" setColor "colorize the output" + , flag "unicode" setUnicode "output unicode" + , flag "diff" setDiff "show colorized diffs" + , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [ + "output N lines of diff context (default: " <> show defaultDiffContext <> ")" + , "use a value of 'full' to see the full context" + ] + , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\"" + , flag "pretty" setPretty "try to pretty-print diff values" + , mkOptionNoArg "show-exceptions" Nothing setShowException "use `show` when formatting exceptions" + , mkOptionNoArg "display-exceptions" Nothing setDisplayException "use `displayException` when formatting exceptions" + + , flag "times" setTimes "report times for individual spec items" + , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary" + , printSlowItemsOption + , flag "expert" setExpertMode "be less verbose" + + -- undocumented for now, as we probably want to change this to produce a + -- standalone HTML report in the future + , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output" + ] + where + setDiffCommand :: String -> Config -> Config + setDiffCommand command config = config { + configExternalDiff = case strip command of + "" -> Nothing + _ -> Just $ \ _context -> externalDiff command + } + + setHtml config = config {configHtmlOutput = True} + + helpForFormat :: String + helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) + + readFormatter :: String -> Maybe (FormatConfig -> IO Format) + readFormatter = (`lookup` formatters) + + setFormatter :: (FormatConfig -> IO Format) -> Config -> Config + setFormatter f c = c {configFormat = Just f} + + setColor :: Bool -> Config -> Config + setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} + + setUnicode :: Bool -> Config -> Config + setUnicode v config = config {configUnicodeMode = if v then UnicodeAlways else UnicodeNever} + + setDiff :: Bool -> Config -> Config + setDiff v config = config {configDiff = v} + + readDiffContext :: String -> Maybe (Maybe Int) + readDiffContext input = case input of + "full" -> Just Nothing + _ -> case readMaybe input of + Nothing -> Nothing + mn -> Just (find (>= 0) mn) + + setDiffContext :: Maybe Int -> Config -> Config + setDiffContext value c = c { configDiffContext = value } + + setPretty :: Bool -> Config -> Config + setPretty v config = config {configPrettyPrint = v} + + setShowException :: Config -> Config + setShowException config = config {configFormatException = formatExceptionWith show} + + setDisplayException :: Config -> Config + setDisplayException config = config {configFormatException = formatExceptionWith displayException} + + setTimes :: Bool -> Config -> Config + setTimes v config = config {configTimes = v} + + setPrintCpuTime config = config {configPrintCpuTime = True} + + setExpertMode :: Bool -> Config -> Config + setExpertMode v config = config {configExpertMode = v} + +printSlowItemsOption :: Option Config +printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True + where + name = "print-slow-items" + + setter :: Maybe Int -> Config -> Config + setter v c = c {configPrintSlowItems = v} + + arg :: Maybe String -> Config -> Maybe Config + arg = maybe (Just . (setter $ Just 10)) parseArg + + parseArg :: String -> Config -> Maybe Config + parseArg input c = case readMaybe input of + Nothing -> Nothing + mn -> Just (setter (find (> 0) mn) c) + +smallCheckOptions :: [Option Config] +smallCheckOptions = [ + option "depth" (argument "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties" + ] + +setDepth :: Int -> Config -> Config +setDepth n c = c {configSmallCheckDepth = Just n} + +quickCheckOptions :: [Option Config] +quickCheckOptions = [ + Option "qc-max-success" (Just 'a') (argument "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" True + , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up" + , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases" + , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)" + + -- for compatibility with test-framework + , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" + ] + +setMaxSuccess :: Int -> Config -> Config +setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} + +setMaxDiscardRatio :: Int -> Config -> Config +setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} + +setMaxSize :: Int -> Config -> Config +setMaxSize n c = c {configQuickCheckMaxSize = Just n} + +setMaxShrinks :: Int -> Config -> Config +setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n} + +setSeed :: Integer -> Config -> Config +setSeed n c = c {configSeed = Just n} + +data FailOn = + FailOnEmpty + | FailOnFocused + | FailOnPending + | FailOnEmptyDescription + deriving (Bounded, Enum) + +allFailOnItems :: [FailOn] +allFailOnItems = [minBound .. maxBound] + +showFailOn :: FailOn -> String +showFailOn item = case item of + FailOnEmpty -> "empty" + FailOnFocused -> "focused" + FailOnPending -> "pending" + FailOnEmptyDescription -> "empty-description" + +readFailOn :: String -> Maybe FailOn +readFailOn = (`lookup` items) + where + items = map (showFailOn &&& id) allFailOnItems + +splitOn :: Char -> String -> [String] +splitOn sep = go + where + go xs = case break (== sep) xs of + ("", "") -> [] + (y, "") -> [y] + (y, _ : ys) -> y : go ys + +runnerOptions :: [Option Config] +runnerOptions = [ + flag "dry-run" setDryRun "pretend that everything passed; don't verify anything" + , flag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" + + , undocumented $ flag "fail-on-focused" setFailOnFocused "fail on focused spec items" + , undocumented $ flag "fail-on-pending" setFailOnPending "fail on pending spec items" + + , mkOption "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn + , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn + , flag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict + + , flag "fail-fast" setFailFast "abort on first failure" + , flag "randomize" setRandomize "randomize execution order" + , (flag "rerun" setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)") {optionShortcut = Just 'r'} + , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun" + , flag "rerun-all-on-success" setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" + , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" + , option "seed" (argument "N" readMaybe setSeed) "used seed for --randomize and QuickCheck properties" + ] + where + strict = [FailOnFocused, FailOnPending] + + readFailOnItems :: String -> Maybe [FailOn] + readFailOnItems = mapM readFailOn . splitOn ',' + + showFailOnItems :: [FailOn] -> String + showFailOnItems = intercalate "," . map showFailOn + + helpForFailOn :: String + helpForFailOn = unlines . flip map allFailOnItems $ \ item -> + showFailOn item <> ": " <> help item + where + help item = case item of + FailOnEmpty -> "fail if all spec items have been filtered" + FailOnFocused -> "fail on focused spec items" + FailOnPending -> "fail on pending spec items" + FailOnEmptyDescription -> "fail on empty descriptions" + + setFailOnItems :: Bool -> [FailOn] -> Config -> Config + setFailOnItems value = flip $ foldr (`setItem` value) + where + setItem item = case item of + FailOnEmpty -> setFailOnEmpty + FailOnFocused -> setFailOnFocused + FailOnPending -> setFailOnPending + FailOnEmptyDescription -> setFailOnEmptyDescription + + readMaxJobs :: String -> Maybe Int + readMaxJobs s = do + n <- readMaybe s + guard $ n > 0 + return n + + setFailureReport :: String -> Config -> Config + setFailureReport file c = c {configFailureReport = Just file} + + setMaxJobs :: Int -> Config -> Config + setMaxJobs n c = c {configConcurrentJobs = Just n} + + setDryRun :: Bool -> Config -> Config + setDryRun value config = config {configDryRun = value} + + setFocusedOnly :: Bool -> Config -> Config + setFocusedOnly value config = config {configFocusedOnly = value} + + setFailOnEmpty :: Bool -> Config -> Config + setFailOnEmpty value config = config {configFailOnEmpty = value} + + setFailOnFocused :: Bool -> Config -> Config + setFailOnFocused value config = config {configFailOnFocused = value} + + setFailOnPending :: Bool -> Config -> Config + setFailOnPending value config = config {configFailOnPending = value} + + setFailOnEmptyDescription :: Bool -> Config -> Config + setFailOnEmptyDescription value config = config {configFailOnEmptyDescription = value} + + setStrict :: Bool -> Config -> Config + setStrict = (`setFailOnItems` strict) + + setFailFast :: Bool -> Config -> Config + setFailFast value config = config {configFailFast = value} + + setRandomize :: Bool -> Config -> Config + setRandomize value config = config {configRandomize = value} + + setRerun :: Bool -> Config -> Config + setRerun value config = config {configRerun = value} + + setRerunAllOnSuccess :: Bool -> Config -> Config + setRerunAllOnSuccess value config = config {configRerunAllOnSuccess = value} + +commandLineOnlyOptions :: [Option Config] +commandLineOnlyOptions = [ + mkOptionNoArg "ignore-dot-hspec" Nothing setIgnoreConfigFile "do not read options from ~/.hspec and .hspec" + , mkOption "match" (Just 'm') (argument "PATTERN" return addMatch) "only run examples that match given PATTERN" + , option "skip" (argument "PATTERN" return addSkip) "skip examples that match given PATTERN" + ] + where + setIgnoreConfigFile config = config {configIgnoreConfigFile = True} + +addMatch :: String -> Config -> Config +addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} + +addSkip :: String -> Config -> Config +addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} + +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_ + +formatOrList :: [String] -> String +formatOrList xs = case xs of + [] -> "" + x : ys -> (case ys of + [] -> x + _ : [] -> x ++ " or " + _ : _ : _ -> x ++ ", ") ++ formatOrList ys diff --git a/src/Test/Hspec/Core/Config/Options.hs b/src/Test/Hspec/Core/Config/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Config/Options.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Config.Options ( + ConfigFile +, envVarName +, ignoreConfigFile +, parseOptions +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.Exit + +import Test.Hspec.Core.Config.Definition +import qualified GetOpt.Declarative as Declarative +import GetOpt.Declarative.Interpret (parse, interpretOptions, ParseResult(..)) + +type ConfigFile = (FilePath, [String]) +type EnvVar = [String] + +envVarName :: String +envVarName = "HSPEC_OPTIONS" + +commandLineOptions :: Config -> [(String, [Declarative.Option Config])] +commandLineOptions config = + ("OPTIONS", commandLineOnlyOptions) + : otherOptions config + +otherOptions :: Config -> [(String, [Declarative.Option Config])] +otherOptions config = [ + ("RUNNER OPTIONS", runnerOptions) + , ("FORMATTER OPTIONS", formatterOptions formatters) + , ("OPTIONS FOR QUICKCHECK", quickCheckOptions) + , ("OPTIONS FOR SMALLCHECK", smallCheckOptions) + ] ++ extensionOptions + where + formatters = configAvailableFormatters config + extensionOptions = getExtensionOptions config + +ignoreConfigFile :: Config -> [String] -> IO Bool +ignoreConfigFile config args = do + ignore <- lookupEnv "IGNORE_DOT_HSPEC" + case ignore of + Just _ -> return True + Nothing -> case parseCommandLineOptions "" args config of + Right c -> return (configIgnoreConfigFile c) + _ -> return False + +parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [(String, String)] -> [String] -> Either (ExitCode, String) ([String], Config) +parseOptions config prog configFiles envVar env args = do + foldM (parseFileOptions prog) config configFiles + >>= maybe return (parseEnvVarOptions prog) envVar + >>= parseEnvironmentOptions env + >>= traverse (parseCommandLineOptions prog args) + +parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config +parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions config) prog args config of + Success c -> Right c + Help message -> Left (ExitSuccess, message) + Failure message -> Left (ExitFailure 1, message) + +parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config) +parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions config) of + (warnings, c) -> Right (map formatWarning warnings, c) + where + formatWarning (Declarative.InvalidValue name value) = "invalid value `" ++ value ++ "' for environment variable " ++ name + +parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config +parseFileOptions prog config (name, args) = + parseOtherOptions prog ("in config file " ++ name) args config + +parseEnvVarOptions :: String -> EnvVar -> Config -> Either (ExitCode, String) Config +parseEnvVarOptions prog = + parseOtherOptions prog ("from environment variable " ++ envVarName) + +parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config +parseOtherOptions prog source args config = case parse (interpretOptions options) config args of + Right c -> Right c + Left err -> failure err + where + options :: [Declarative.Option Config] + options = filter Declarative.optionDocumented $ concatMap snd (otherOptions config) + + failure err = Left (ExitFailure 1, prog ++ ": " ++ message) + where + message = unlines $ case lines err of + [x] -> [x ++ " " ++ source] + xs -> xs ++ [source] diff --git a/src/Test/Hspec/Core/Example.hs b/src/Test/Hspec/Core/Example.hs --- a/src/Test/Hspec/Core/Example.hs +++ b/src/Test/Hspec/Core/Example.hs @@ -1,161 +1,273 @@ -{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + module Test.Hspec.Core.Example ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Example (..) +#ifndef ENABLE_SPEC_HOOK_ARGS +, Arg +#endif , Params (..) , defaultParams , ActionWith , Progress , ProgressCallback -, Result (..) +, Result(..) +, ResultStatus (..) , Location (..) -, LocationAccuracy (..) +, FailureReason (..) +, safeEvaluate +, safeEvaluateExample +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, safeEvaluateResultStatus +, exceptionToResultStatus +, toLocation +, hunitFailureToResult ) where -import Data.Maybe (fromMaybe) -import Data.List (isPrefixOf) +import Prelude () +import Test.Hspec.Core.Compat + import qualified Test.HUnit.Lang as HUnit -import qualified Control.Exception as E -import Data.Typeable (Typeable) + +import Data.CallStack (SrcLoc(..)) + +import Control.DeepSeq import qualified Test.QuickCheck as QC import Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC -import qualified Test.QuickCheck.Property as QCP - -import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util -import Test.Hspec.Compat +import Test.Hspec.Core.QuickCheck.Util (liftHook) +import Test.Hspec.Core.Example.Location --- | A type class for examples +#ifdef ENABLE_SPEC_HOOK_ARGS +-- | A type class for examples, that is to say, test bodies as used in +-- `Test.Hspec.Core.Spec.it` and similar functions. class Example e where + -- | The argument type that is needed to run this `Example`. + -- If `Arg` is @()@, no argument is required and the `Example` can be run + -- as-is. + -- + -- The value of `Arg` is the difference between `Test.Hspec.Core.Spec.Spec` + -- (aka @`Test.Hspec.Core.Hspec.SpecWith` ()@), which can be executed, and + -- @`Test.Hspec.Core.Spec.SpecWith` a@, which cannot be executed without + -- turning it into `Test.Hspec.Core.Spec.Spec` first. + -- + -- To supply an argument to examples, use the functions in + -- "Test.Hspec.Core.Hooks" such as `Test.Hspec.Core.Hooks.around', + -- `Test.Hspec.Core.Hooks.before', `Test.Hspec.Core.Hooks.mapSubject' and + -- similar. type Arg e -#if __GLASGOW_HASKELL__ >= 704 type Arg e = () +#else +type Arg e = () + +-- | A type class for examples, that is to say, test bodies as used in +-- `Test.Hspec.Core.Spec.it` and similar functions. +class Example e where #endif - evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result + -- | Evaluates an example. + -- + -- `evaluateExample` is expected to execute the test body inside the IO action + -- passed to the hook. It's often necessary to use an `IORef` to pass data + -- out like whether the test succeeded to the outer IO action so it can be + -- returned as a `Result`. + -- + -- Example: + -- + -- @ + -- newtype MyAction = MyAction (Int -> IO Bool) + -- + -- instance Example MyAction where + -- type Arg MyAction = Int + -- + -- evaluateExample (MyAction act) _params hook _progress = do + -- result <- newIORef (Result "" Success) + -- hook $ \arg -> do + -- -- e.g. determines if arg is 42 + -- ok <- act arg + -- let result' = Result "" $ if ok then Success else Failure Nothing NoReason + -- writeIORef result result' + -- readIORef result + -- @ + evaluateExample + :: e + -- ^ The example being evaluated + -> Params + -- ^ QuickCheck/SmallCheck settings + -> (ActionWith (Arg e) -> IO ()) + -- ^ Hook: takes an @`ActionWith` (`Arg` e)@, namely, the IO action to run + -- the test body, obtains @`Arg` e@ from somewhere, then executes the test + -- body (or possibly decides not to execute it!). + -- + -- This is used to implement `Test.Hspec.Core.Hooks.around` and similar + -- hook functionality. + -> ProgressCallback + -- ^ Callback for composite tests like QuickCheck to report their progress. + -> IO Result + +-- | QuickCheck and SmallCheck related parameters. data Params = Params { paramsQuickCheckArgs :: QC.Args -, paramsSmallCheckDepth :: Int +, paramsSmallCheckDepth :: Maybe Int } deriving (Show) defaultParams :: Params defaultParams = Params { paramsQuickCheckArgs = QC.stdArgs -, paramsSmallCheckDepth = 5 +, paramsSmallCheckDepth = Nothing } +-- | @(CurrentItem, TotalItems)@ tuple. type Progress = (Int, Int) +-- | Callback used by composite test items that contain many tests to report +-- their progress towards finishing them all. +-- +-- This is used, for example, to report how many QuickCheck examples are finished. type ProgressCallback = Progress -> IO () --- | An `IO` action that expects an argument of type @a@ +-- | An `IO` action that expects an argument of type @a@. +-- +-- This type is what `Example`s are ultimately unlifted into for execution. type ActionWith a = a -> IO () -- | The result of running an example -data Result = Success | Pending (Maybe String) | Fail (Maybe Location) String - deriving (Eq, Show, Read, Typeable) +data Result = Result { + resultInfo :: String +, resultStatus :: ResultStatus +} deriving Show -instance E.Exception Result +data ResultStatus = + Success + | Pending (Maybe Location) (Maybe String) + | Failure (Maybe Location) FailureReason + deriving Show --- | @Location@ is used to represent source locations. -data Location = Location { - locationFile :: FilePath -, locationLine :: Int -, locationColumn :: Int -, locationAccuracy :: LocationAccuracy -} deriving (Eq, Show, Read) +data FailureReason = + NoReason + | Reason String + | ColorizedReason String + | ExpectedButGot (Maybe String) String String + | Error (Maybe String) SomeException + deriving Show --- | A marker for source locations -data LocationAccuracy = - -- | The source location is accurate - ExactLocation | - -- | The source location was determined on a best-effort basis and my be - -- wrong or inaccurate - BestEffort - deriving (Eq, Show, Read) +instance NFData FailureReason where + rnf reason = case reason of + NoReason -> () + Reason r -> r `deepseq` () + ColorizedReason r -> r `deepseq` () + ExpectedButGot p e a -> p `deepseq` e `deepseq` a `deepseq` () + Error m e -> m `deepseq` show e `deepseq` () -instance Example Bool where - type Arg Bool = () - evaluateExample b _ _ _ = if b then return Success else return (Fail Nothing "") +instance Exception ResultStatus -instance Example Expectation where - type Arg Expectation = () - evaluateExample e = evaluateExample (\() -> e) +forceResult :: Result -> Result +forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r -hunitFailureToResult :: HUnit.HUnitFailure -> Result -hunitFailureToResult e = case e of -#if MIN_VERSION_HUnit(1,3,0) - HUnit.HUnitFailure mLoc err -> Fail location err - where - location = case mLoc of - Nothing -> Nothing - Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation -#else - HUnit.HUnitFailure err -> Fail Nothing err -#endif +forceResultStatus :: ResultStatus -> ResultStatus +forceResultStatus r = case r of + Success -> r + Pending _ m -> m `deepseq` r + Failure _ m -> m `deepseq` r -instance Example (a -> Expectation) where - type Arg (a -> Expectation) = a - evaluateExample e _ action _ = (action e >> return Success) `E.catches` [ - E.Handler (return . hunitFailureToResult) - , E.Handler (return :: Result -> IO Result) - ] +safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result +safeEvaluateExample example params around = safeEvaluate . evaluateExample example params around +safeEvaluate :: IO Result -> IO Result +safeEvaluate action = do + r <- safeTry $ forceResult <$> action + case r of + Left e -> Result "" <$> exceptionToResultStatus e + Right result -> return result + +safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus +safeEvaluateResultStatus action = do + r <- safeTry $ forceResultStatus <$> action + case r of + Left e -> exceptionToResultStatus e + Right status -> return status + +exceptionToResultStatus :: SomeException -> IO ResultStatus +exceptionToResultStatus = safeEvaluateResultStatus . pure . toResultStatus + where + toResultStatus :: SomeException -> ResultStatus + toResultStatus e + | Just result <- fromException e = result + | Just hunit <- fromException e = hunitFailureToResult Nothing hunit + | otherwise = Failure Nothing $ Error Nothing e + instance Example Result where +#ifdef ENABLE_SPEC_HOOK_ARGS type Arg Result = () - evaluateExample r _ _ _ = return r +#endif + evaluateExample e = evaluateExample (\() -> e) -instance Example QC.Property where - type Arg QC.Property = () +#ifdef ENABLE_SPEC_HOOK_ARGS +instance Example (a -> Result) where + type Arg (a -> Result) = a +#else +instance Example (() -> Result) where +#endif + evaluateExample example _params hook _callback = do + liftHook (Result "" Success) hook (evaluate . example) + +instance Example Bool where +#ifdef ENABLE_SPEC_HOOK_ARGS + type Arg Bool = () +#endif evaluateExample e = evaluateExample (\() -> e) -instance Example (a -> QC.Property) where - type Arg (a -> QC.Property) = a - evaluateExample p c action progressCallback = do - r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) - return $ - case r of - QC.Success {} -> Success - QC.Failure {QC.output = m} -> fromMaybe (Fail Nothing $ sanitizeFailureMessage r) (parsePending m) - QC.GaveUp {QC.numTests = n} -> Fail Nothing ("Gave up after " ++ pluralize n "test" ) - QC.NoExpectedFailure {} -> Fail Nothing ("No expected failure") -#if MIN_VERSION_QuickCheck(2,8,0) - QC.InsufficientCoverage {} -> Fail Nothing ("Insufficient coverage") +#ifdef ENABLE_SPEC_HOOK_ARGS +instance Example (a -> Bool) where + type Arg (a -> Bool) = a +#else +instance Example (() -> Bool) where #endif + evaluateExample p _params hook _callback = do + liftHook (Result "" Success) hook (evaluate . example) where - qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ - \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) + example a + | p a = Result "" Success + | otherwise = Result "" $ Failure Nothing NoReason - sanitizeFailureMessage :: QC.Result -> String - sanitizeFailureMessage r = let m = QC.output r in strip $ -#if MIN_VERSION_QuickCheck(2,7,0) - case QC.theException r of - Just e -> let numbers = formatNumbers r in - "uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of - x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs - _ -> m - Nothing -> +instance Example Expectation where +#ifdef ENABLE_SPEC_HOOK_ARGS + type Arg Expectation = () #endif - (addFalsifiable . stripFailed) m - - addFalsifiable :: String -> String - addFalsifiable m - | "(after " `isPrefixOf` m = "Falsifiable " ++ m - | otherwise = m + evaluateExample e = evaluateExample (\() -> e) - stripFailed :: String -> String - stripFailed m - | prefix `isPrefixOf` m = drop n m - | otherwise = m - where - prefix = "*** Failed! " - n = length prefix +hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus +hunitFailureToResult pre e = case e of + HUnit.HUnitFailure mLoc err -> + case err of + HUnit.Reason reason -> Failure location (Reason $ addPre reason) + HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot (addPreMaybe preface) expected actual) + where + addPreMaybe :: Maybe String -> Maybe String + addPreMaybe xs = case (pre, xs) of + (Just x, Just y) -> Just (x ++ "\n" ++ y) + _ -> pre <|> xs + where + location = case mLoc of + Nothing -> Nothing + Just loc -> Just $ toLocation loc + where + addPre :: String -> String + addPre xs = case pre of + Just x -> x ++ "\n" ++ xs + Nothing -> xs - parsePending :: String -> Maybe Result - parsePending m - | exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m - | otherwise = Nothing - where - n = length exceptionPrefix +toLocation :: SrcLoc -> Location +toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) - exceptionPrefix = "*** Failed! Exception: '" +#ifdef ENABLE_SPEC_HOOK_ARGS +instance Example (a -> Expectation) where + type Arg (a -> Expectation) = a +#else +instance Example (() -> Expectation) where +#endif + evaluateExample e _params hook _ = hook e >> return (Result "" Success) diff --git a/src/Test/Hspec/Core/Example/Location.hs b/src/Test/Hspec/Core/Example/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Example/Location.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Test.Hspec.Core.Example.Location ( + Location(..) +, extractLocation + +#ifdef TEST +, parseBacktraces +, parseAssertionFailed +, parseCallStack +, parseLocation +, parseSourceSpan + +, workaroundForIssue19236 +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Char +import GHC.IO.Exception + +#if MIN_VERSION_base(4,21,0) +import Control.Exception.Context +#endif + +#ifdef mingw32_HOST_OS +import System.FilePath +#endif + +-- | @Location@ is used to represent source locations. +data Location = Location { + locationFile :: FilePath +, locationLine :: Int +, locationColumn :: Int +} deriving (Eq, Show, Read) + +extractLocation :: SomeException -> Maybe Location +#ifdef __MHS__ +extractLocation _ = Nothing +#else +extractLocation e = + locationFromErrorCall e + <|> locationFromPatternMatchFail e + <|> locationFromRecConError e + <|> locationFromIOException e + <|> locationFromNoMethodError e +#if !MIN_VERSION_base(4,21,0) + <|> locationFromAssertionFailed e +#else + <|> locationFromSomeException e + +locationFromSomeException :: SomeException -> Maybe Location +locationFromSomeException = someExceptionContext >>> locationFromExceptionContext + +locationFromExceptionContext :: ExceptionContext -> Maybe Location +locationFromExceptionContext = displayExceptionContext >>> parseBacktraces +#endif + +_ignoreUnusedWarning = (parseBacktraces, locationFromAssertionFailed) + +parseBacktraces :: String -> Maybe Location +parseBacktraces = + lines + >>> dropWhile (/= "HasCallStack backtrace:") >>> drop 1 + >>> takeWhile (isPrefixOf " ") + >>> parseCallStack + +locationFromNoMethodError :: SomeException -> Maybe Location +locationFromNoMethodError e = case fromException e of + Just (NoMethodError s) -> listToMaybe (words s) >>= parseSourceSpan + Nothing -> Nothing + +locationFromAssertionFailed :: SomeException -> Maybe Location +locationFromAssertionFailed e = case fromException e of + Just (AssertionFailed loc) -> parseAssertionFailed loc + Nothing -> Nothing + +parseAssertionFailed :: String -> Maybe Location +parseAssertionFailed loc = parseCallStack (lines loc) <|> parseSourceSpan loc + +locationFromErrorCall :: SomeException -> Maybe Location +locationFromErrorCall e = case fromException e of +#if MIN_VERSION_base(4,21,0) + Just (ErrorCall _) -> Nothing +#else + Just (ErrorCallWithLocation err loc) -> + parseCallStack (lines loc) <|> + fromPatternMatchFailureInDoExpression err +#endif + Nothing -> Nothing + +locationFromPatternMatchFail :: SomeException -> Maybe Location +locationFromPatternMatchFail e = case fromException e of + Just (PatternMatchFail s) -> listToMaybe (words s) >>= parseSourceSpan + Nothing -> Nothing + +locationFromRecConError :: SomeException -> Maybe Location +locationFromRecConError e = case fromException e of + Just (RecConError s) -> listToMaybe (words s) >>= parseSourceSpan + Nothing -> Nothing + +locationFromIOException :: SomeException -> Maybe Location +locationFromIOException e = case fromException e of + Just (IOError {ioe_type = UserError, ioe_description = xs}) -> fromPatternMatchFailureInDoExpression xs + Just _ -> Nothing + Nothing -> Nothing + +fromPatternMatchFailureInDoExpression :: String -> Maybe Location +fromPatternMatchFailureInDoExpression input = +#if MIN_VERSION_base(4,16,0) + stripPrefix "Pattern match failure in 'do' block at " input >>= parseSourceSpan +#else + stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan +#endif + +parseCallStack :: [String] -> Maybe Location +parseCallStack input = case reverse input of + [] -> Nothing + line : _ -> findLocation line + where + findLocation xs = case xs of + [] -> Nothing + _ : ys -> case stripPrefix prefix xs of + Just zs -> parseLocation (takeWhile (not . isSpace) zs) + Nothing -> findLocation ys + prefix = ", called at " + +parseLocation :: String -> Maybe Location +parseLocation input = case fmap breakColon (breakColon input) of + (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column + +parseSourceSpan :: String -> Maybe Location +parseSourceSpan input = case breakColon input of + (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated) + where + lineAndColumn :: String + lineAndColumn = takeWhile (/= '-') xs + + tuple :: Maybe (Int, Int) + tuple = readMaybe lineAndColumn + + colonSeparated :: Maybe (Int, Int) + colonSeparated = case breakColon lineAndColumn of + (l, c) -> (,) <$> readMaybe l <*> readMaybe c + +breakColon :: String -> (String, String) +breakColon = fmap (drop 1) . break (== ':') + +mkLocation :: FilePath -> Int -> Int -> Location +mkLocation file line column = Location (workaroundForIssue19236 file) line column + +workaroundForIssue19236 :: FilePath -> FilePath -- https://gitlab.haskell.org/ghc/ghc/-/issues/19236 +workaroundForIssue19236 = +#ifdef mingw32_HOST_OS + joinPath . splitDirectories +#else + id +#endif +#endif diff --git a/src/Test/Hspec/Core/Extension.hs b/src/Test/Hspec/Core/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +-- | Stability: unstable +module Test.Hspec.Core.Extension {-# WARNING "This API is experimental." #-} ( +-- * Lifecycle of a test run +{- | +A test run goes through four distinct phases: + +1. A tree of spec items and a default `Config` are constructed in `SpecM`. +2. Command-line options are parsed. This transforms the default `Config` that was constructed in phase 1. +3. The tree of spec items is transformed in various ways, depending on specific `Config` values. +4. Each spec item is executed and its result is reported to the user. + +An extension can directly influence phase 1, and indirectly influence phases 2-4. + +When writing extensions the following imports are recommended: + +@ +import "Test.Hspec.Core.Extension" +import "Test.Hspec.Core.Extension.Config" qualified as Config +import "Test.Hspec.Core.Extension.Option" qualified as Option +import "Test.Hspec.Core.Extension.Item" qualified as Item +import "Test.Hspec.Core.Extension.Spec" qualified as Spec +import "Test.Hspec.Core.Extension.Tree" qualified as Tree +@ +-} + +-- ** Phase 1: Constructing a spec tree +{- | +- An extension can use @Spec.`Test.Hspec.Core.Extension.Spec.mapItems`@ to transform spec items in phase 1. + + * @Item.`setAnnotation`@ can be used to add custom metadata to a spec `Item`. + +- An extension can use `modifyConfig` to modify the default config. + + * @Config.`Test.Hspec.Core.Extension.Config.setAnnotation`@ can be used to add custom metadata to the default `Config`. +-} + runIO +, modifyConfig + +-- ** Phase 2: Parsing command-line options +{- | +An extension can use `registerOptions` during phase 1 to register custom command-line options, and as a consequence indirectly influence this phase. + +* Options can use @Config.`Test.Hspec.Core.Extension.Config.setAnnotation`@ to add custom metadata to the `Config`. +-} +, Option +, registerOptions + +-- ** Phase 3: Transforming the spec tree +{- | +An extension can use `registerTransformation` during phase 1 to indirectly influence this phase. +-} +, registerTransformation + +-- ** Phase 4: Reporting results +{- | +An extension can register a [custom formatter](https://hspec.github.io/extending-hspec-formatter.html) in phase 1 to indirectly influence this phase. +-} + +-- * Types +{- | +Operations on these types are provided by the following modules respectively: + +* "Test.Hspec.Core.Extension.Config" +* "Test.Hspec.Core.Extension.Item" +* "Test.Hspec.Core.Extension.Spec" +* "Test.Hspec.Core.Extension.Tree" +-} +, Config +, Item +, SpecM +, SpecWith +, SpecTree +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import qualified Data.CallStack as CallStack + +import qualified GetOpt.Declarative as Declarative +import Test.Hspec.Core.Spec (SpecM, SpecWith, runIO, modifyConfig) +import qualified Test.Hspec.Core.Spec as Core +import qualified Test.Hspec.Core.Config.Definition as Core + +import Test.Hspec.Core.Extension.Config (Config) +import qualified Test.Hspec.Core.Extension.Config.Type as Config +import Test.Hspec.Core.Extension.Option +import Test.Hspec.Core.Extension.Item +import Test.Hspec.Core.Extension.Tree + +registerOptions :: HasCallStack => [Option] -> SpecWith a +registerOptions = Core.modifyConfig . Core.addExtensionOptions section . map liftOption + where + section = "OPTIONS FOR " <> package + package = maybe "main" (CallStack.srcLocPackage . snd) CallStack.callSite + + liftOption :: Option -> Declarative.Option Core.Config + liftOption = Config.unOption + +{- | +Register a transformation that transforms the spec tree in phase 3. + +The registered transformation can use: + +- @Tree.`mapItems`@ to modify spec items +- @Tree.`filterItems`@ to discard spec items +- @Config.`Test.Hspec.Core.Extension.Config.getAnnotation`@ to access custom config metadata +- @Item.`getAnnotation`@ to access custom item metadata +-} +registerTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> SpecWith a +registerTransformation = modifyConfig . Config.addSpecTransformation diff --git a/src/Test/Hspec/Core/Extension/Config.hs b/src/Test/Hspec/Core/Extension/Config.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Config.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Extension.Config {-# WARNING "This API is experimental." #-} ( +-- * Types + Config(..) +, Path +, ColorMode(..) +, UnicodeMode(..) + +-- * Operations +, setAnnotation +, getAnnotation +) where + +import Prelude () + +import Test.Hspec.Core.Format +import Test.Hspec.Core.Config.Definition (ColorMode(..), UnicodeMode(..)) + +import Test.Hspec.Core.Extension.Config.Type diff --git a/src/Test/Hspec/Core/Extension/Config/Type.hs b/src/Test/Hspec/Core/Extension/Config/Type.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Config/Type.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Extension.Config.Type ( + Option(..) +, Config(..) + +, setAnnotation +, getAnnotation + +, addSpecTransformation +, applySpecTransformation +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import qualified GetOpt.Declarative as Declarative + +import Test.Hspec.Core.Config.Definition (Config(..)) +import qualified Test.Hspec.Core.Config.Definition as Core + +import Test.Hspec.Core.Extension.Tree (SpecTree) + +newtype Option = Option { unOption :: Declarative.Option Config } + +setAnnotation :: Typeable value => value -> Config -> Config +setAnnotation = Core.setConfigAnnotation + +getAnnotation :: Typeable value => Config -> Maybe value +getAnnotation = Core.getConfigAnnotation + +newtype SpecTransformation = SpecTransformation { unSpecTransformation :: Config -> [SpecTree] -> [SpecTree] } + +setSpecTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> Config -> Config +setSpecTransformation = setAnnotation . SpecTransformation + +getSpecTransformation :: Config -> Config -> [SpecTree] -> [SpecTree] +getSpecTransformation = maybe (\ _ -> id) unSpecTransformation . getAnnotation + +addSpecTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> Config -> Config +addSpecTransformation f config = setSpecTransformation (\ c -> f c . getSpecTransformation config c) config + +applySpecTransformation :: Core.Config -> [SpecTree] -> [SpecTree] +applySpecTransformation config = getSpecTransformation config config diff --git a/src/Test/Hspec/Core/Extension/Item.hs b/src/Test/Hspec/Core/Extension/Item.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Item.hs @@ -0,0 +1,46 @@ +module Test.Hspec.Core.Extension.Item {-# WARNING "This API is experimental." #-} ( +-- * Types + Item(..) +, Location(..) +, Params(..) +, ActionWith +, Progress +, ProgressCallback +, Result(..) +, ResultStatus(..) +, FailureReason(..) + +-- * Operations +, isFocused +, pending +, pendingWith +, setAnnotation +, getAnnotation +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Spec hiding (pending, pendingWith) +import Test.Hspec.Core.Tree + +isFocused :: Item a -> Bool +isFocused = itemIsFocused + +pending :: Item a -> Item a +pending item = item { itemExample = \ _params _hook _progress -> result } + where + result :: IO Result + result = return $ Result "" (Pending Nothing Nothing) + +pendingWith :: String -> Item a -> Item a +pendingWith reason item = item { itemExample = \ _params _hook _progress -> result } + where + result :: IO Result + result = return $ Result "" (Pending Nothing (Just reason)) + +setAnnotation :: Typeable value => value -> Item a -> Item a +setAnnotation = setItemAnnotation + +getAnnotation :: Typeable value => Item a -> Maybe value +getAnnotation = getItemAnnotation diff --git a/src/Test/Hspec/Core/Extension/Option.hs b/src/Test/Hspec/Core/Extension/Option.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Option.hs @@ -0,0 +1,27 @@ +module Test.Hspec.Core.Extension.Option {-# WARNING "This API is experimental." #-} ( + Option +, flag +, argument +, noArgument +, optionalArgument +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import qualified GetOpt.Declarative as Declarative +import qualified Test.Hspec.Core.Config.Definition as Core + +import Test.Hspec.Core.Extension.Config.Type (Option(..), Config) + +flag :: String -> (Bool -> Config -> Config) -> String -> Option +flag name setter = Option . Core.flag name setter + +argument :: String -> String -> (String -> Config -> Maybe Config) -> String -> Option +argument name argumentName setter = Option . Core.option name (Declarative.Arg argumentName setter) + +optionalArgument :: String -> String -> (Maybe String -> Config -> Maybe Config) -> String -> Option +optionalArgument name argumentName setter = Option . Core.option name (Declarative.OptArg argumentName setter) + +noArgument :: String -> (Config -> Config) -> String -> Option +noArgument name setter help = Option $ Declarative.Option name Nothing (Declarative.NoArg setter) help False diff --git a/src/Test/Hspec/Core/Extension/Spec.hs b/src/Test/Hspec/Core/Extension/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Spec.hs @@ -0,0 +1,10 @@ +module Test.Hspec.Core.Extension.Spec {-# WARNING "This API is experimental." #-} ( + mapItems +) where + +import Prelude () + +import Test.Hspec.Core.Spec + +mapItems :: (Item a -> Item b) -> SpecWith a -> SpecWith b +mapItems = mapSpecItem_ diff --git a/src/Test/Hspec/Core/Extension/Tree.hs b/src/Test/Hspec/Core/Extension/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Extension/Tree.hs @@ -0,0 +1,19 @@ +module Test.Hspec.Core.Extension.Tree {-# WARNING "This API is experimental." #-} ( + SpecTree +, mapItems +, filterItems +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Spec hiding (SpecTree) +import qualified Test.Hspec.Core.Spec as Core + +type SpecTree = Core.SpecTree () + +mapItems :: (Item () -> Item ()) -> [SpecTree] -> [SpecTree] +mapItems = map . fmap + +filterItems :: (Item () -> Bool) -> [SpecTree] -> [SpecTree] +filterItems = filterForest diff --git a/src/Test/Hspec/Core/FailureReport.hs b/src/Test/Hspec/Core/FailureReport.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/FailureReport.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.FailureReport ( + FailureReport (..) +, writeFailureReport +, readFailureReport +) where + +#if !defined(__GHCJS__) && !defined(__MHS__) +-- ghcjs currently does not support setting environment variables +-- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report +-- into the environment is a non-essential feature we just disable this to be +-- able to run hspec test-suites with ghcjs at all. Should be reverted once +-- the issue is fixed. +#define HAS_SET_ENV +#endif + + +import Prelude () +import Test.Hspec.Core.Compat + +#ifdef HAS_SET_ENV +import System.Environment (setEnv) +import Test.Hspec.Core.Util (safeTry) +#endif + +import System.IO +import System.Directory +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Config.Definition (Config(..)) + +data FailureReport = FailureReport { + failureReportSeed :: Integer +, failureReportMaxSuccess :: Int +, failureReportMaxSize :: Int +, failureReportMaxDiscardRatio :: Int +, failureReportPaths :: [Path] +} deriving (Eq, Show, Read) + +writeFailureReport :: Config -> FailureReport -> IO () +writeFailureReport config report = case configFailureReport config of + Just file -> writeFile file (show report) + Nothing -> do +#ifdef HAS_SET_ENV + -- on Windows this can throw an exception when the input is too large, hence + -- we use `safeTry` here + safeTry (setEnv "HSPEC_FAILURES" $ show report) >>= either onError return + where + onError err = do + hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") +#else + pass +#endif + +readFailureReport :: Config -> IO (Maybe FailureReport) +readFailureReport config = case configFailureReport config of + Just file -> do + exists <- doesFileExist file + if exists + then do + r <- readFile file + let report = readMaybe r + when (report == Nothing) $ do + hPutStrLn stderr ("WARNING: Could not read failure report from file " ++ show file ++ "!") + return report + else return Nothing + Nothing -> 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 + report -> return report diff --git a/src/Test/Hspec/Core/Format.hs b/src/Test/Hspec/Core/Format.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Format.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +-- | +-- Stability: unstable +-- +-- This is an unstable API. Use +-- [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) +-- instead. +module Test.Hspec.Core.Format +-- {-# WARNING "Use [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) instead." #-} +( + Format +, FormatConfig(..) +, defaultFormatConfig +, Event(..) +, Progress +, Path +, Location(..) +, Seconds(..) +, Item(..) +, Result(..) +, FailureReason(..) +, monadic +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Concurrent +import Control.Concurrent.Async (Async, async) +import qualified Control.Concurrent.Async as Async +import Control.Monad.IO.Class + +import Test.Hspec.Core.Example (Progress, Location(..), FailureReason(..)) +import Test.Hspec.Core.Util (Path, formatExceptionWith) +import Test.Hspec.Core.Clock (Seconds(..)) + +type Format = Event -> IO () + +data Item = Item { + itemLocation :: Maybe Location +, itemDuration :: Seconds +, itemInfo :: String +, itemResult :: Result +} deriving Show + +data Result = + Success + | Pending (Maybe Location) (Maybe String) + | Failure (Maybe Location) FailureReason + deriving Show + +data Event = + Started + | GroupStarted Path + | GroupDone Path + | Progress Path Progress + | ItemStarted Path + | ItemDone Path Item + | Done [(Path, Item)] + deriving Show + +data FormatConfig = FormatConfig { + formatConfigUseColor :: Bool +, formatConfigReportProgress :: Bool +, formatConfigOutputUnicode :: Bool +, formatConfigUseDiff :: Bool +, formatConfigDiffContext :: Maybe Int +, formatConfigExternalDiff :: Maybe (String -> String -> IO ()) +, formatConfigPrettyPrint :: Bool +, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) +, formatConfigFormatException :: SomeException -> String -- ^ @since 2.11.5 +, formatConfigPrintTimes :: Bool +, formatConfigHtmlOutput :: Bool +, formatConfigPrintCpuTime :: Bool +, formatConfigUsedSeed :: Integer +, formatConfigExpectedTotalCount :: Int +, formatConfigExpertMode :: Bool +} + +{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-} + +-- ^ @since 2.11.5 +defaultFormatConfig :: FormatConfig +defaultFormatConfig = FormatConfig { + formatConfigUseColor = False +, formatConfigReportProgress = False +, formatConfigOutputUnicode = False +, formatConfigUseDiff = False +, formatConfigDiffContext = Nothing +, formatConfigExternalDiff = Nothing +, formatConfigPrettyPrint = False +, formatConfigPrettyPrintFunction = Nothing +, formatConfigFormatException = formatExceptionWith show +, formatConfigPrintTimes = False +, formatConfigHtmlOutput = False +, formatConfigPrintCpuTime = False +, formatConfigUsedSeed = 0 +, formatConfigExpectedTotalCount = 0 +, formatConfigExpertMode = False +} + +data Signal = Ok | NotOk SomeException + +monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format +monadic run format = do + mvar <- newEmptyMVar + done <- newEmptyMVar + + let + putEvent :: Event -> IO () + putEvent = putMVar mvar + + takeEvent :: MonadIO m => m Event + takeEvent = liftIO $ takeMVar mvar + + signal :: MonadIO m => Signal -> m () + signal = liftIO . putMVar done + + wait :: IO Signal + wait = takeMVar done + + go = do + event <- takeEvent + format event + case event of + Done {} -> pass + _ -> do + signal Ok + go + + worker <- async $ do + (run go >> signal Ok) `catch` (signal . NotOk) + + return $ \ event -> do + running <- asyncRunning worker + when running $ do + putEvent event + r <- wait + case r of + Ok -> pass + NotOk err -> do + Async.wait worker + throwIO err + +asyncRunning :: Async () -> IO Bool +asyncRunning worker = maybe True (const False) <$> Async.poll worker diff --git a/src/Test/Hspec/Core/Formatters.hs b/src/Test/Hspec/Core/Formatters.hs --- a/src/Test/Hspec/Core/Formatters.hs +++ b/src/Test/Hspec/Core/Formatters.hs @@ -1,222 +1,5 @@ --- | --- Stability: experimental --- --- This module contains formatters that can be used with --- `Test.Hspec.Runner.hspecWith`. -module Test.Hspec.Core.Formatters ( - --- * Formatters - silent -, specdoc -, progress -, failed_examples - --- * Implementing a custom Formatter --- | --- A formatter is a set of actions. Each action is evaluated when a certain --- situation is encountered during a test run. --- --- Actions live in the `FormatM` monad. It provides access to the runner state --- and primitives for appending to the generated report. -, Formatter (..) -, FormatM - --- ** Accessing the runner state -, getSuccessCount -, getPendingCount -, getFailCount -, getTotalCount - -, FailureRecord (..) -, getFailMessages -, usedSeed - -, getCPUTime -, getRealTime - --- ** Appending to the gerenated report -, write -, writeLine -, newParagraph - --- ** Dealing with colors -, withInfoColor -, withSuccessColor -, withPendingColor -, withFailColor - --- ** Helpers -, formatException -) where - -import Prelude () -import Test.Hspec.Compat - -import Data.Maybe -import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..)) -import Text.Printf -import Control.Monad (when, unless) -import System.IO (hPutStr, hFlush) - --- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make --- sure, that we only use the public API to implement formatters. --- --- Everything imported here has to be re-exported, so that users can implement --- their own formatters. -import Test.Hspec.Core.Formatters.Internal ( - Formatter (..) - , FormatM - - , getSuccessCount - , getPendingCount - , getFailCount - , getTotalCount - - , FailureRecord (..) - , getFailMessages - , usedSeed - - , getCPUTime - , getRealTime - - , write - , writeLine - , newParagraph - - , withInfoColor - , withSuccessColor - , withPendingColor - , withFailColor - ) - -silent :: Formatter -silent = Formatter { - headerFormatter = return () -, exampleGroupStarted = \_ _ -> return () -, exampleGroupDone = return () -, exampleProgress = \_ _ _ -> return () -, exampleSucceeded = \_ -> return () -, exampleFailed = \_ _ -> return () -, examplePending = \_ _ -> return () -, failedFormatter = return () -, footerFormatter = return () -} - - -specdoc :: Formatter -specdoc = silent { - - headerFormatter = do - writeLine "" - -, exampleGroupStarted = \nesting name -> do - writeLine (indentationFor nesting ++ name) - -, exampleProgress = \h _ p -> do - hPutStr h (formatProgress p) - hFlush h - -, exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do - writeLine $ indentationFor nesting ++ requirement - -, exampleFailed = \(nesting, requirement) _ -> withFailColor $ do - n <- getFailCount - writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]" - -, examplePending = \(nesting, requirement) reason -> withPendingColor $ do - writeLine $ indentationFor nesting ++ requirement ++ "\n # PENDING: " ++ fromMaybe "No reason given" reason - -, failedFormatter = defaultFailedFormatter - -, footerFormatter = defaultFooter -} where - indentationFor nesting = replicate (length nesting * 2) ' ' - formatProgress (current, total) - | total == 0 = show current ++ "\r" - | otherwise = show current ++ "/" ++ show total ++ "\r" - - -progress :: Formatter -progress = silent { - exampleSucceeded = \_ -> withSuccessColor $ write "." -, exampleFailed = \_ _ -> withFailColor $ write "F" -, examplePending = \_ _ -> withPendingColor $ write "." -, failedFormatter = defaultFailedFormatter -, footerFormatter = defaultFooter -} - - -failed_examples :: Formatter -failed_examples = silent { - failedFormatter = defaultFailedFormatter -, footerFormatter = defaultFooter -} - -defaultFailedFormatter :: FormatM () -defaultFailedFormatter = do - writeLine "" - - failures <- getFailMessages - - unless (null failures) $ do - writeLine "Failures:" - writeLine "" - - forM_ (zip [1..] failures) $ \x -> do - formatFailure x - writeLine "" - - when (hasBestEffortLocations failures) $ do - withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." - writeLine "" - - write "Randomized with seed " >> usedSeed >>= writeLine . show - writeLine "" - where - hasBestEffortLocations :: [FailureRecord] -> Bool - hasBestEffortLocations = any p - where - p :: FailureRecord -> Bool - p failure = (locationAccuracy <$> failureRecordLocation failure) == Just BestEffort - - formatFailure :: (Int, FailureRecord) -> FormatM () - formatFailure (n, FailureRecord mLoc path reason) = do - forM_ mLoc $ \loc -> do - withInfoColor $ writeLine (formatLoc loc) - write (" " ++ show n ++ ") ") - writeLine (formatRequirement path) - withFailColor $ do - forM_ (lines err) $ \x -> do - writeLine (" " ++ x) - where - err = either (("uncaught exception: " ++) . formatException) id reason - formatLoc (Location file line _column accuracy) = " " ++ file ++ ":" ++ show line ++ ":" ++ message - where - message = case accuracy of - ExactLocation -> " " -- NOTE: Vim's default 'errorformat' - -- requires a non-empty message. This is - -- why we use a single space as message - -- here. - BestEffort -> " (best-effort)" - -defaultFooter :: FormatM () -defaultFooter = do - - writeLine =<< (++) - <$> (printf "Finished in %1.4f seconds" - <$> getRealTime) <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime) - - fails <- getFailCount - pending <- getPendingCount - total <- getTotalCount - - let c | fails /= 0 = withFailColor - | pending /= 0 = withPendingColor - | otherwise = withSuccessColor - c $ do - write $ pluralize total "example" - write (", " ++ pluralize fails "failure") - unless (pending == 0) $ - write (", " ++ show pending ++ " pending") - writeLine "" +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Formatters +{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-} +(module V1) where +import Test.Hspec.Core.Formatters.V1 as V1 diff --git a/src/Test/Hspec/Core/Formatters/Diff.hs b/src/Test/Hspec/Core/Formatters/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Diff.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +module Test.Hspec.Core.Formatters.Diff ( + Diff (..) +, diff + +, LineDiff(..) +, lineDiff + +, splitLines + +#ifdef TEST +, partition +, breakList +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Char +import qualified Data.Algorithm.Diff as Diff + +data Diff = First String | Second String | Both String + deriving (Eq, Show) + +data LineDiff = + LinesFirst [String] + | LinesSecond [String] + | LinesBoth [String] + | SingleLineDiff [Diff] + | LinesOmitted Int + deriving (Eq, Show) + +lineDiff :: Maybe Int -> String -> String -> [LineDiff] +lineDiff context expected actual = maybe id applyContext context $ singleLineDiffs diffs + where + diffs :: [LineDiff] + diffs = Diff.getGroupedDiff expectedLines actualLines <&> \ case + Diff.First xs -> LinesFirst xs + Diff.Second xs -> LinesSecond xs + Diff.Both xs _ -> LinesBoth xs + + expectedLines :: [String] + expectedLines = splitLines expected + + actualLines :: [String] + actualLines = splitLines actual + +singleLineDiffs :: [LineDiff] -> [LineDiff] +singleLineDiffs = go + where + go = \ case + [] -> [] + LinesFirst [first_] : LinesSecond [second_] : xs -> SingleLineDiff (diff first_ second_) : go xs + x : xs -> x : go xs + +splitLines :: String -> [String] +splitLines = go + where + go :: String -> [String] + go xs = case break (== '\n') xs of + (ys, '\n' : zs) -> ys : go zs + _ -> [xs] + +data TrimMode = FirstChunk | Chunk | LastChunk + +applyContext :: Int -> [LineDiff] -> [LineDiff] +applyContext context = \ diffs -> case diffs of + [] -> [] + x : xs -> trimChunk FirstChunk x (go xs) + where + omitThreshold :: Int + omitThreshold = 3 + + go :: [LineDiff] -> [LineDiff] + go diffs = case diffs of + [] -> [] + [x] -> trimChunk LastChunk x [] + x : xs -> trimChunk Chunk x (go xs) + + trimChunk :: TrimMode -> LineDiff -> [LineDiff] -> [LineDiff] + trimChunk mode chunk = case chunk of + LinesBoth allLines | meetsThreshold -> keep start . (LinesOmitted omitted :) . keep end + where + meetsThreshold :: Bool + meetsThreshold = omitThreshold <= omitted + + lastLineHasNL = case (mode, reverse allLines) of + (LastChunk, "" : _) -> True + _ -> False + + omitted :: Int + omitted = n - keepStart - keepEnd + + keepStart :: Int + keepStart = case mode of + FirstChunk -> 0 + _ -> context + + keepEnd :: Int + keepEnd = case mode of + LastChunk -> 0 + _ -> context + + n :: Int + n = length allLines - case lastLineHasNL of + False -> 0 + True -> 1 + + start :: [String] + start = take keepStart allLines + + end :: [String] + end = drop (keepStart + omitted) allLines + + _ -> (chunk :) + +keep :: [String] -> [LineDiff] -> [LineDiff] +keep xs + | null xs = id + | otherwise = (LinesBoth xs :) + +diff :: String -> String -> [Diff] +diff expected actual = diffs + where + diffs :: [Diff] + diffs = map (toDiff . fmap concat) $ Diff.getGroupedDiff expectedChunks actualChunks + + expectedChunks :: [String] + expectedChunks = partition expected + + actualChunks :: [String] + actualChunks = partition actual + +toDiff :: Diff.Diff String -> Diff +toDiff d = case d of + Diff.First xs -> First xs + Diff.Second xs -> Second xs + Diff.Both xs _ -> Both xs + +partition :: String -> [String] +partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum + where + mergeBackslashes :: [String] -> [String] + mergeBackslashes xs = case xs of + ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs + z : zs -> z : mergeBackslashes zs + [] -> [] + +breakList :: (a -> Bool) -> [a] -> [[a]] +breakList _ [] = [] +breakList p xs = case break p xs of + (y, ys) -> map return y ++ case span p ys of + (z, zs) -> z `cons` breakList p zs + where + cons x + | null x = id + | otherwise = (x :) + +splitEscape :: String -> Maybe (String, String) +splitEscape xs = splitNumericEscape xs <|> msum (map split escapes) + where + split :: String -> Maybe (String, String) + split escape = (,) escape <$> stripPrefix escape xs + +splitNumericEscape :: String -> Maybe (String, String) +splitNumericEscape xs = case span isDigit xs of + ("", _) -> Nothing + r -> Just r + +escapes :: [String] +escapes = [ + "ACK" + , "CAN" + , "DC1" + , "DC2" + , "DC3" + , "DC4" + , "DEL" + , "DLE" + , "ENQ" + , "EOT" + , "ESC" + , "ETB" + , "ETX" + , "NAK" + , "NUL" + , "SOH" + , "STX" + , "SUB" + , "SYN" + , "EM" + , "FS" + , "GS" + , "RS" + , "SI" + , "SO" + , "US" + , "a" + , "b" + , "f" + , "n" + , "r" + , "t" + , "v" + , "&" + , "'" + , "\"" + , "\\" + ] diff --git a/src/Test/Hspec/Core/Formatters/Internal.hs b/src/Test/Hspec/Core/Formatters/Internal.hs --- a/src/Test/Hspec/Core/Formatters/Internal.hs +++ b/src/Test/Hspec/Core/Formatters/Internal.hs @@ -1,191 +1,313 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal ( - --- * Public API - Formatter (..) + Formatter(..) +, Item(..) +, Result(..) +, FailureReason(..) , FormatM +, formatterToFormat +, getConfig +, getConfigValue +, FormatConfig(..) + , getSuccessCount , getPendingCount , getFailCount , getTotalCount +, getExpectedTotalCount -, FailureRecord (..) +, FailureRecord(..) , getFailMessages , usedSeed +, printTimes , getCPUTime , getRealTime , write , writeLine -, newParagraph +, writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor --- * Functions for internal use +, outputUnicode + +, useDiff +, diffContext +, externalDiffAction +, prettyPrint +, prettyPrintFunction +, extraChunk +, missingChunk + +, unlessExpert + +#ifdef TEST , runFormatM -, increaseSuccessCount -, increasePendingCount -, increaseFailCount -, addFailMessage -, finally_ +, splitLines +#endif ) where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat import qualified System.IO as IO -import System.IO (Handle) -import Control.Monad -import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) -import System.Console.ANSI -import Control.Monad.Trans.State hiding (gets, modify) +import System.IO (stdout) +import System.Console.ANSI hiding (clearLine) +import Control.Monad.Trans.Reader (ReaderT(..), ask) import Control.Monad.IO.Class +import Data.Char (isSpace) +import Data.List (groupBy) import qualified System.CPUTime as CPUTime -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec (Progress, Location) +import Test.Hspec.Core.Format +import Test.Hspec.Core.Clock +data Formatter = Formatter { +-- | evaluated before a test run + formatterStarted :: FormatM () + +-- | evaluated before each spec group +, formatterGroupStarted :: Path -> FormatM () + +-- | evaluated after each spec group +, formatterGroupDone :: Path -> FormatM () + +-- | used to notify the progress of the currently evaluated example +, formatterProgress :: Path -> Progress -> FormatM () + +-- | evaluated before each spec item +, formatterItemStarted :: Path -> FormatM () + +-- | evaluated after each spec item +, formatterItemDone :: Path -> Item -> FormatM () + +-- | evaluated after a test run +, formatterDone :: FormatM () +} + +data FailureRecord = FailureRecord { + failureRecordLocation :: Maybe Location +, failureRecordPath :: Path +, failureRecordMessage :: FailureReason +} + +formatterToFormat :: Formatter -> FormatConfig -> IO Format +formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ case + Started -> formatterStarted + GroupStarted path -> formatterGroupStarted path + GroupDone path -> formatterGroupDone path + Progress path progress -> formatterProgress path progress + ItemStarted path -> formatterItemStarted path + ItemDone path item -> do + case itemResult item of + Success {} -> increaseSuccessCount + Pending {} -> increasePendingCount + Failure loc err -> addFailure $ FailureRecord (loc <|> itemLocation item) path err + formatterItemDone path item + Done _ -> formatterDone + where + addFailure r = modify $ \ s -> s { stateFailMessages = r : stateFailMessages s } + +-- | Get the number of failed examples encountered so far. +getFailCount :: FormatM Int +getFailCount = length <$> getFailMessages + +-- | Return `True` if the user requested colorized diffs, `False` otherwise. +useDiff :: FormatM Bool +useDiff = getConfigValue formatConfigUseDiff + +-- | Do nothing on `--expert`, otherwise run the given action. +-- +-- @since 2.11.2 +unlessExpert :: FormatM () -> FormatM () +unlessExpert action = getConfigValue formatConfigExpertMode >>= \ case + False -> action + True -> return () + +-- | +-- Return the value of `Test.Hspec.Core.Runner.configDiffContext`. +-- +-- @since 2.10.6 +diffContext :: FormatM (Maybe Int) +diffContext = getConfigValue formatConfigDiffContext + +-- | An action for printing diffs. +-- +-- The action takes @expected@ and @actual@ as arguments. +-- +-- When this is a `Just`-value then it should be used instead of any built-in +-- diff implementation. A `Just`-value also implies that `useDiff` returns +-- `True`. +-- +-- @since 2.10.6 +externalDiffAction :: FormatM (Maybe (String -> String -> IO ())) +externalDiffAction = getConfigValue formatConfigExternalDiff + +-- | Return `True` if the user requested pretty diffs, `False` otherwise. +prettyPrint :: FormatM Bool +prettyPrint = maybe False (const True) <$> getConfigValue formatConfigPrettyPrintFunction +{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-} + +-- | Return a function for pretty-printing if the user requested pretty diffs, +-- `Nothing` otherwise. +-- +-- @since 2.10.0 +prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String))) +prettyPrintFunction = getConfigValue formatConfigPrettyPrintFunction + +-- | Return `True` if the user requested unicode output, `False` otherwise. +-- +-- @since 2.9.0 +outputUnicode :: FormatM Bool +outputUnicode = getConfigValue formatConfigOutputUnicode + +-- | The same as `write`, but adds a newline character. +writeLine :: String -> FormatM () +writeLine s = write s >> write "\n" + +-- | Return `True` if the user requested time reporting for individual spec +-- items, `False` otherwise. +printTimes :: FormatM Bool +printTimes = gets (formatConfigPrintTimes . stateConfig) + +-- | Get the total number of examples encountered so far. +getTotalCount :: FormatM Int +getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount] + -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do - f <$> (get >>= liftIO . readIORef) + f <$> (ask >>= liftIO . readIORef) -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do - get >>= liftIO . (`modifyIORef'` f) + ask >>= liftIO . (`modifyIORef'` f) data FormatterState = FormatterState { - stateHandle :: Handle -, stateUseColor :: Bool -, produceHTML :: Bool -, successCount :: Int -, pendingCount :: Int -, failCount :: Int -, failMessages :: [FailureRecord] -, stateUsedSeed :: Integer -, cpuStartTime :: Maybe Integer -, startTime :: POSIXTime + stateSuccessCount :: !Int +, statePendingCount :: !Int +, stateFailMessages :: [FailureRecord] +, stateCpuStartTime :: Maybe Integer +, stateStartTime :: Seconds +, stateConfig :: FormatConfig +, stateColor :: Maybe SGR } +-- | @since 2.11.5 +getConfig :: FormatM FormatConfig +getConfig = gets stateConfig + +-- | @since 2.11.5 +getConfigValue :: (FormatConfig -> a) -> FormatM a +getConfigValue f = gets (f . stateConfig) + -- | 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 +usedSeed = getConfigValue formatConfigUsedSeed -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown. -newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a) +newtype FormatM a = FormatM (ReaderT (IORef FormatterState) IO a) deriving (Functor, Applicative, Monad, MonadIO) -runFormatM :: Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a -runFormatM useColor produceHTML_ printCpuTime seed handle (FormatM action) = do - time <- getPOSIXTime - cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing - st <- newIORef (FormatterState handle useColor produceHTML_ 0 0 0 [] seed cpuTime time) - evalStateT action st +runFormatM :: FormatConfig -> FormatM a -> IO a +runFormatM config (FormatM action) = withLineBuffering $ do + time <- getMonotonicTime + cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing + let + progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config) + state = FormatterState { + stateSuccessCount = 0 + , statePendingCount = 0 + , stateFailMessages = [] + , stateCpuStartTime = cpuTime + , stateStartTime = time + , stateConfig = config { formatConfigReportProgress = progress } + , stateColor = Nothing + } + newIORef state >>= runReaderT action + +withLineBuffering :: IO a -> IO a +withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do + IO.hSetBuffering stdout IO.LineBuffering >> action + -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () -increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s} +increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount 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} +increasePendingCount = modify $ \s -> s {statePendingCount = succ $ statePendingCount s} -- | Get the number of successful examples encountered so far. getSuccessCount :: FormatM Int -getSuccessCount = gets successCount +getSuccessCount = gets stateSuccessCount -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int -getPendingCount = gets pendingCount - --- | Get the number of failed examples encountered so far. -getFailCount :: FormatM Int -getFailCount = gets failCount - --- | Get the total number of examples encountered so far. -getTotalCount :: FormatM Int -getTotalCount = gets totalCount - --- | Append to the list of accumulated failure messages. -addFailMessage :: Maybe Location -> Path -> Either SomeException String -> FormatM () -addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s} +getPendingCount = gets statePendingCount -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] -getFailMessages = reverse `fmap` gets failMessages - -data FailureRecord = FailureRecord { - failureRecordLocation :: Maybe Location -, failureRecordPath :: Path -, failureRecordMessage :: Either SomeException String -} - -data Formatter = Formatter { - - headerFormatter :: FormatM () - --- | evaluated before each test group --- --- The given number indicates the position within the parent group. -, exampleGroupStarted :: [String] -> String -> FormatM () - -, exampleGroupDone :: FormatM () +getFailMessages = reverse `fmap` gets stateFailMessages --- | used to notify the progress of the currently evaluated example +-- | Get the number of spec items that will have been encountered when this run +-- completes (if it is not terminated early). -- --- /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 () +-- @since 2.9.0 +getExpectedTotalCount :: FormatM Int +getExpectedTotalCount = getConfigValue formatConfigExpectedTotalCount --- | evaluated after `failuresFormatter` -, footerFormatter :: FormatM () -} +writeTransient :: String -> FormatM () +writeTransient new = do + reportProgress <- getConfigValue formatConfigReportProgress + when reportProgress . liftIO $ do + bracket_ disableLineWrapping enableLineWrapping $ writePlain new + IO.hFlush stdout + clearLine + where + disableLineWrapping :: IO () + disableLineWrapping = writePlain "\ESC[?7l" + enableLineWrapping :: IO () + enableLineWrapping = writePlain "\ESC[?7h" --- | Append an empty line to the report. --- --- Calling this multiple times has the same effect as calling it once. -newParagraph :: FormatM () -newParagraph = writeLine "" -{-# DEPRECATED newParagraph "use @writeLine \"\"@ instead" #-} + clearLine :: IO () + clearLine = writePlain "\r\ESC[K" -- | Append some output to the report. write :: String -> FormatM () -write s = do - h <- gets stateHandle - liftIO $ IO.hPutStr h s +write = mapM_ writeChunk . splitLines --- | The same as `write`, but adds a newline character. -writeLine :: String -> FormatM () -writeLine s = write s >> write "\n" +splitLines :: String -> [String] +splitLines = groupBy (\ a b -> isNewline a == isNewline b) + where + isNewline = (== '\n') +writeChunk :: String -> FormatM () +writeChunk str = do + let + plainOutput = writePlain str + colorOutput color = bracket_ (hSetSGR stdout [color]) (hSetSGR stdout [Reset]) plainOutput + mColor <- gets stateColor + liftIO $ case mColor of + Just (SetColor Foreground _ _) | all isSpace str -> plainOutput + Just color -> colorOutput color + Nothing -> plainOutput + +writePlain :: String -> IO () +writePlain = IO.hPutStr stdout + -- | Set output color to red, run given action, and finally restore the default -- color. withFailColor :: FormatM a -> FormatM a @@ -209,55 +331,70 @@ -- | 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 + produceHTML <- getConfigValue formatConfigHtmlOutput + (if produceHTML 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 +withColor_ color action = do + oldColor <- gets stateColor + setColor (Just color) *> action <* setColor oldColor - FormatM . StateT $ \st -> do - bracket_ +setColor :: Maybe SGR -> FormatM () +setColor color = do + useColor <- getConfigValue formatConfigUseColor + when useColor $ do + modify (\ state -> state { stateColor = color }) - -- set color - (when useColor $ hSetSGR h [color]) +-- | Output given chunk in red. +extraChunk :: String -> FormatM () +extraChunk s = do + diff <- getConfigValue formatConfigUseDiff + case diff of + True -> extra s + False -> write s + where + extra :: String -> FormatM () + extra = diffColorize Red "hspec-failure" - -- reset colors - (when useColor $ hSetSGR h [Reset]) +-- | Output given chunk in green. +missingChunk :: String -> FormatM () +missingChunk s = do + diff <- getConfigValue formatConfigUseDiff + case diff of + True -> missing s + False -> write s + where + missing :: String-> FormatM () + missing = diffColorize Green "hspec-success" - -- run action - (runStateT action st) +diffColorize :: Color -> String -> String-> FormatM () +diffColorize color cls s = withColor (SetColor layer Dull color) cls $ case s of + "" -> write eraseInLine + _ -> write s + where + eraseInLine :: String + eraseInLine = "\ESC[K" --- | --- @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_ + layer :: ConsoleLayer + layer + | all isSpace s = Background + | otherwise = Foreground -- | Get the used CPU time since the test run has been started. -getCPUTime :: FormatM (Maybe Double) +getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do t1 <- liftIO CPUTime.getCPUTime - mt0 <- gets cpuStartTime - return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) + mt0 <- gets stateCpuStartTime + return $ toSeconds <$> ((t1 -) <$> mt0) where - toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer)) + toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer))) -- | Get the passed real time since the test run has been started. -getRealTime :: FormatM Double +getRealTime :: FormatM Seconds getRealTime = do - t1 <- liftIO getPOSIXTime - t0 <- gets startTime - return (realToFrac $ t1 - t0) + t1 <- liftIO getMonotonicTime + t0 <- gets stateStartTime + return (t1 - t0) diff --git a/src/Test/Hspec/Core/Formatters/Pretty.hs b/src/Test/Hspec/Core/Formatters/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Pretty.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Hspec.Core.Formatters.Pretty ( + pretty2 +#ifdef TEST +, pretty +, recoverString +, recoverMultiLineString +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (shows, intercalate) + +import Data.Char +import Data.String +import Data.List (intersperse) +import qualified Text.Show as Show + +import Test.Hspec.Core.Formatters.Pretty.Unicode +import Test.Hspec.Core.Formatters.Pretty.Parser + +pretty2 :: Bool -> String -> String -> (String, String) +pretty2 unicode expected actual = case (recoverMultiLineString unicode expected, recoverMultiLineString unicode actual) of + (Just expected_, Just actual_) -> (expected_, actual_) + _ -> case (pretty unicode expected, pretty unicode actual) of + (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_) + _ -> (expected, actual) + +recoverString :: String -> Maybe String +recoverString xs = case xs of + '"' : _ -> case reverse xs of + '"' : _ -> readMaybe xs + _ -> Nothing + _ -> Nothing + +recoverMultiLineString :: Bool -> String -> Maybe String +recoverMultiLineString unicode input = case recoverString input of + Just r | shouldParseBack r -> Just r + _ -> Nothing + where + shouldParseBack = (&&) <$> all isSafe <*> isMultiLine + isMultiLine = lines >>> length >>> (> 1) + isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n' + +pretty :: Bool -> String -> Maybe String +pretty unicode = parseValue >=> render_ + where + render_ :: Value -> Maybe String + render_ value = guard (shouldParseBack value) >> Just (renderValue unicode value) + + shouldParseBack :: Value -> Bool + shouldParseBack = go + where + go value = case value of + Char _ -> False + String _ -> True + Number _ -> False + Operator _ _ _ -> True + Record _ _ -> True + Constructor _ xs -> any go xs + Tuple xs -> any go xs + List xs -> any go xs + +newtype Builder = Builder ShowS + +instance Monoid Builder where + mempty = Builder id +#if MIN_VERSION_base(4,11,0) +instance Semigroup Builder where +#endif + Builder xs +#if MIN_VERSION_base(4,11,0) + <> +#else + `mappend` +#endif + Builder ys = Builder (xs . ys) + +runBuilder :: Builder -> String +runBuilder (Builder xs) = xs "" + +intercalate :: Builder -> [Builder] -> Builder +intercalate x xs = mconcat $ intersperse x xs + +shows :: Show a => a -> Builder +shows = Builder . Show.shows + +instance IsString Builder where + fromString = Builder . showString + +renderValue :: Bool -> Value -> String +renderValue unicode = runBuilder . render 0 + where + render :: Int -> Value -> Builder + render indentation = \ case + Char c -> shows c + String str -> if unicode then Builder $ ushows str else shows str + Number n -> fromString n + Operator a name b -> render indentation a <> " " <> fromString name <> " " <> render indentation b + Record name fields -> fromString name <> renderFields fields + Constructor name values -> intercalate " " (fromString name : map (render indentation) values) + Tuple [e@Record{}] -> render indentation e + Tuple xs -> "(" <> intercalate ", " (map (render indentation) xs) <> ")" + List xs -> "[" <> intercalate ", " (map (render indentation) xs) <> "]" + where + spaces :: Builder + spaces = indentBy (succ indentation) + + renderFields :: [(String, Value)] -> Builder + renderFields fields = mconcat [ + " {\n" <> spaces + , intercalate (",\n" <> spaces) $ map renderField fields + , "\n" <> indentBy indentation <> "}" + ] + + renderField :: (String, Value) -> Builder + renderField (name, value) = fromString name <> " = " <> render (succ indentation) value + + indentBy :: Int -> Builder + indentBy n = fromString $ replicate (2 * n) ' ' diff --git a/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs b/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hspec.Core.Formatters.Pretty.Parser ( + Value(..) +, parseValue +) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (Alternative(..), read, exp) + +import Language.Haskell.Lexer hiding (Token, Pos(..)) +import qualified Language.Haskell.Lexer as Lexer + +type Name = String + +data Value = + Char Char + | String String + | Number String + | Operator Value Name Value + | Record Name [(Name, Value)] + | Constructor Name [Value] + | Tuple [Value] + | List [Value] + deriving (Eq, Show) + +type Token = (TokenType, String) + +type TokenType = Lexer.Token + +newtype Parser a = Parser { + runParser :: [Token] -> Maybe (a, [Token]) +} deriving Functor + +instance Applicative Parser where + pure a = Parser $ \ input -> Just (a, input) + (<*>) = ap + +instance Monad Parser where + return = pure + p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2) + +parseValue :: String -> Maybe Value +parseValue input = case runParser exp (tokenize input) of + Just (v, []) -> Just v + _ -> Nothing + +tokenize :: String -> [Token] +tokenize = go . map (fmap snd) . rmSpace . lexerPass0 + where + go :: [Token] -> [Token] + go tokens = case tokens of + [] -> [] + (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs + (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs + x : xs -> x : go xs + +exp :: Parser Value +exp = infixexp + +infixexp :: Parser Value +infixexp = aexp accept reject + where + accept :: Value -> Parser Value + accept value = peek >>= \ case + (Varsym, "%") -> skip >> Operator value "%" <$> exp + (Consym, name) -> skip >> Operator value name <$> exp + _ -> return value + + reject :: Parser Value + reject = next >>= unexpected + +aexp :: forall a. (Value -> Parser a) -> Parser a -> Parser a +aexp continue done = peek >>= \ case + (CharLit, value) -> read Char value + (StringLit, value) -> read String value + (IntLit, value) -> number value + (FloatLit, value) -> number value + (Conid, name) -> accept $ constructor name + (Special, "(") -> accept tuple + (Special, "[") -> accept list + _ -> done + where + read :: Read v => (v -> Value) -> String -> Parser a + read c v = skip >> c <$> readValue v >>= continue + + number :: String -> Parser a + number value = skip >> continue (Number value) + + accept :: Parser Value -> Parser a + accept action = skip >> action >>= continue + +constructor :: String -> Parser Value +constructor name = peek >>= \ case + (Special, "{") -> skip >> Record name <$> commaSeparated field "}" + where + field :: Parser (Name, Value) + field = (,) <$> require Varid <* equals <*> exp + + _ -> Constructor name <$> parameters + where + parameters :: Parser [Value] + parameters = aexp more done + + more :: Value -> Parser [Value] + more v = (:) v <$> parameters + + done :: Parser [Value] + done = return [] + +tuple :: Parser Value +tuple = Tuple <$> commaSeparated exp ")" + +list :: Parser Value +list = List <$> commaSeparated exp "]" + +commaSeparated :: forall a. Parser a -> String -> Parser [a] +commaSeparated item close = peek >>= \ case + (Special, c) | c == close -> skip >> return [] + _ -> items + where + items :: Parser [a] + items = (:) <$> item <*> moreItems + + moreItems :: Parser [a] + moreItems = next >>= \ case + (Special, c) + | c == "," -> items + | c == close -> return [] + t -> unexpected t + +equals :: Parser () +equals = requireToken (Reservedop, "=") + +require :: TokenType -> Parser String +require expected = next >>= \ case + (token, v) | token == expected -> return v + token -> unexpected token + +requireToken :: Token -> Parser () +requireToken expected = next >>= \ case + token | token == expected -> return () + token -> unexpected token + +peek :: Parser Token +peek = Parser $ \ input -> case input of + t : _ -> Just (t, input) + [] -> Just ((GotEOF, ""), input) + +next :: Parser Token +next = Parser $ \ case + t : ts -> Just (t, ts) + ts -> Just ((GotEOF, ""), ts) + +skip :: Parser () +skip = Parser $ \ case + _ : ts -> Just ((), ts) + ts -> Just ((), ts) + +empty :: Parser a +empty = Parser $ const Nothing + +readValue :: Read a => String -> Parser a +readValue = maybe empty pure . readMaybe + +unexpected :: Token -> Parser a +unexpected _ = empty + +-- unexpected :: HasCallStack => (Token, String) -> Parser a +-- unexpected = error . show diff --git a/src/Test/Hspec/Core/Formatters/Pretty/Unicode.hs b/src/Test/Hspec/Core/Formatters/Pretty/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Pretty/Unicode.hs @@ -0,0 +1,28 @@ +module Test.Hspec.Core.Formatters.Pretty.Unicode ( + ushow +, ushows +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Char + +ushow :: String -> String +ushow xs = ushows xs "" + +ushows :: String -> ShowS +ushows = uShowString + +uShowString :: String -> ShowS +uShowString cs = showChar '"' . showLitString cs . showChar '"' + +showLitString :: String -> ShowS +showLitString [] s = s +showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s) +showLitString (c : cs) s = uShowLitChar c (showLitString cs s) + +uShowLitChar :: Char -> ShowS +uShowLitChar c + | isPrint c && not (isAscii c) = showChar c + | otherwise = showLitChar c diff --git a/src/Test/Hspec/Core/Formatters/V1.hs b/src/Test/Hspec/Core/Formatters/V1.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V1.hs @@ -0,0 +1,62 @@ +-- | +-- Stability: deprecated +-- +-- This module contains formatters that can be used with +-- `Test.Hspec.Core.Runner.hspecWith`. +module Test.Hspec.Core.Formatters.V1 +{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-} +( +-- * Formatters + silent +, checks +, 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 (..) +, FailureReason (..) +, FormatM +, formatterToFormat + +-- ** Accessing the runner state +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, Seconds(..) +, getCPUTime +, getRealTime + +-- ** Appending to the generated report +, write +, writeLine +, writeTransient + +-- ** Dealing with colors +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, useDiff +, extraChunk +, missingChunk + +-- ** Helpers +, formatException +) where + +import Prelude () +import Test.Hspec.Core.Formatters.V1.Internal diff --git a/src/Test/Hspec/Core/Formatters/V1/Free.hs b/src/Test/Hspec/Core/Formatters/V1/Free.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V1/Free.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveFunctor #-} +module Test.Hspec.Core.Formatters.V1.Free where + +import Prelude () +import Test.Hspec.Core.Compat + +data Free f a = Free (f (Free f a)) | Pure a + deriving Functor + +instance Functor f => Applicative (Free f) where + pure = Pure + Pure f <*> Pure a = Pure (f a) + Pure f <*> Free m = Free (fmap f <$> m) + Free m <*> b = Free (fmap (<*> b) m) + +instance Functor f => Monad (Free f) where + return = pure + Pure a >>= f = f a + Free m >>= f = Free (fmap (>>= f) m) + +liftF :: Functor f => f a -> Free f a +liftF command = Free (fmap Pure command) diff --git a/src/Test/Hspec/Core/Formatters/V1/Internal.hs b/src/Test/Hspec/Core/Formatters/V1/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V1/Internal.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +module Test.Hspec.Core.Formatters.V1.Internal ( +-- * Formatters + silent +, checks +, 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 (..) +, FailureReason (..) +, FormatM +, formatterToFormat + +-- ** Accessing the runner state +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, Seconds(..) +, getCPUTime +, getRealTime + +-- ** Appending to the generated report +, write +, writeLine +, writeTransient + +-- ** Dealing with colors +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, useDiff +, extraChunk +, missingChunk + +-- ** Helpers +, formatException +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Example (Location(..)) +import Text.Printf +import Control.Monad.IO.Class + +-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make +-- sure, that we only use the public API to implement formatters. +-- +-- Everything imported here has to be re-exported, so that users can implement +-- their own formatters. +import Test.Hspec.Core.Formatters.V1.Monad ( + Formatter(..) + , FailureReason(..) + , FormatM + + , getSuccessCount + , getPendingCount + , getFailCount + , getTotalCount + + , FailureRecord(..) + , getFailMessages + , usedSeed + + , getCPUTime + , getRealTime + + , write + , writeLine + , writeTransient + + , withInfoColor + , withSuccessColor + , withPendingColor + , withFailColor + + , useDiff + , extraChunk + , missingChunk + ) + +import Test.Hspec.Core.Format (FormatConfig, Format) + +import Test.Hspec.Core.Formatters.Diff +import qualified Test.Hspec.Core.Formatters.V2 as V2 +import Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith) + +formatterToFormat :: Formatter -> FormatConfig -> IO Format +formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter + +legacyFormatterToFormatter :: Formatter -> V2.Formatter +legacyFormatterToFormatter Formatter{..} = V2.Formatter { + V2.formatterStarted = interpret headerFormatter +, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted +, V2.formatterGroupDone = interpret . const exampleGroupDone +, V2.formatterProgress = \ path -> interpret . exampleProgress path +, V2.formatterItemStarted = interpret . exampleStarted +, V2.formatterItemDone = \ path item -> interpret $ do + case itemResult item of + Success -> exampleSucceeded path (itemInfo item) + Pending _ reason -> examplePending path (itemInfo item) reason + Failure _ reason -> exampleFailed path (itemInfo item) (unliftFailureReason reason) +, V2.formatterDone = interpret $ failedFormatter >> footerFormatter +} + +unliftFailureRecord :: V2.FailureRecord -> FailureRecord +unliftFailureRecord V2.FailureRecord{..} = FailureRecord { + failureRecordLocation +, failureRecordPath +, failureRecordMessage = unliftFailureReason failureRecordMessage +} + +unliftFailureReason :: V2.FailureReason -> FailureReason +unliftFailureReason = \ case + V2.NoReason -> NoReason + V2.Reason reason -> Reason reason + V2.ColorizedReason reason -> Reason (stripAnsi reason) + V2.ExpectedButGot preface expected actual -> ExpectedButGot preface expected actual + V2.Error info e -> Error info e + +interpret :: FormatM a -> V2.FormatM a +interpret = interpretWith Environment { + environmentGetSuccessCount = V2.getSuccessCount +, environmentGetPendingCount = V2.getPendingCount +, environmentGetFailMessages = map unliftFailureRecord <$> V2.getFailMessages +, environmentUsedSeed = V2.usedSeed +, environmentPrintTimes = V2.printTimes +, environmentGetCPUTime = V2.getCPUTime +, environmentGetRealTime = V2.getRealTime +, environmentWrite = V2.write +, environmentWriteTransient = V2.writeTransient +, environmentWithFailColor = V2.withFailColor +, environmentWithSuccessColor = V2.withSuccessColor +, environmentWithPendingColor = V2.withPendingColor +, environmentWithInfoColor = V2.withInfoColor +, environmentUseDiff = V2.useDiff +, environmentExtraChunk = V2.extraChunk +, environmentMissingChunk = V2.missingChunk +, environmentLiftIO = liftIO +} + +silent :: Formatter +silent = Formatter { + headerFormatter = pass +, exampleGroupStarted = \_ _ -> pass +, exampleGroupDone = pass +, exampleStarted = \_ -> pass +, exampleProgress = \_ _ -> pass +, exampleSucceeded = \ _ _ -> pass +, exampleFailed = \_ _ _ -> pass +, examplePending = \_ _ _ -> pass +, failedFormatter = pass +, footerFormatter = pass +} + +checks :: Formatter +checks = specdoc { + exampleStarted = \(nesting, requirement) -> do + writeTransient $ indentationFor nesting ++ requirement ++ " [ ]" + +, exampleProgress = \(nesting, requirement) p -> do + writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]" + +, exampleSucceeded = \(nesting, requirement) info -> do + writeResult nesting requirement info $ withSuccessColor $ write "✔" + +, exampleFailed = \(nesting, requirement) info _ -> do + writeResult nesting requirement info $ withFailColor $ write "✘" + +, examplePending = \(nesting, requirement) info reason -> do + writeResult nesting requirement info $ withPendingColor $ write "‐" + + withPendingColor $ do + writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason +} where + indentationFor nesting = replicate (length nesting * 2) ' ' + + writeResult :: [String] -> String -> String -> FormatM () -> FormatM () + writeResult nesting requirement info action = do + write $ indentationFor nesting ++ requirement ++ " [" + action + writeLine "]" + forM_ (lines info) $ \ s -> + writeLine $ indentationFor ("" : nesting) ++ s + + formatProgress (current, total) + | total == 0 = show current + | otherwise = show current ++ "/" ++ show total + +specdoc :: Formatter +specdoc = silent { + + headerFormatter = do + writeLine "" + +, exampleGroupStarted = \nesting name -> do + writeLine (indentationFor nesting ++ name) + +, exampleProgress = \_ p -> do + writeTransient (formatProgress p) + +, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do + writeLine $ indentationFor nesting ++ requirement + forM_ (lines info) $ \ s -> + writeLine $ indentationFor ("" : nesting) ++ s + +, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do + n <- getFailCount + writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]" + forM_ (lines info) $ \ s -> + writeLine $ indentationFor ("" : nesting) ++ s + +, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do + writeLine $ indentationFor nesting ++ requirement + forM_ (lines info) $ \ s -> + writeLine $ indentationFor ("" : nesting) ++ s + writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason + +, failedFormatter = defaultFailedFormatter + +, footerFormatter = defaultFooter +} where + indentationFor nesting = replicate (length nesting * 2) ' ' + formatProgress (current, total) + | total == 0 = show current + | otherwise = show current ++ "/" ++ show total + + +progress :: Formatter +progress = silent { + exampleSucceeded = \_ _ -> withSuccessColor $ write "." +, exampleFailed = \_ _ _ -> withFailColor $ write "F" +, examplePending = \_ _ _ -> withPendingColor $ write "." +, failedFormatter = defaultFailedFormatter +, footerFormatter = defaultFooter +} + + +failed_examples :: Formatter +failed_examples = silent { + failedFormatter = defaultFailedFormatter +, footerFormatter = defaultFooter +} + +defaultFailedFormatter :: FormatM () +defaultFailedFormatter = do + writeLine "" + + failures <- getFailMessages + + unless (null failures) $ do + writeLine "Failures:" + writeLine "" + + forM_ (zip [1..] failures) $ \x -> do + formatFailure x + writeLine "" + + write "Randomized with seed " >> usedSeed >>= writeLine . show + writeLine "" + where + formatFailure :: (Int, FailureRecord) -> FormatM () + formatFailure (n, FailureRecord mLoc path reason) = do + forM_ mLoc $ \loc -> do + withInfoColor $ writeLine (formatLoc loc) + write (" " ++ show n ++ ") ") + writeLine (formatRequirement path) + case reason of + NoReason -> pass + Reason err -> withFailColor $ indent err + ExpectedButGot preface expected actual -> do + mapM_ indent preface + + b <- useDiff + + let threshold = 2 :: Seconds + + mchunks <- liftIO $ if b + then timeout threshold (evaluate $ diff expected actual) + else return Nothing + + case mchunks of + Just chunks -> do + writeDiff chunks extraChunk missingChunk + Nothing -> do + writeDiff [First expected, Second actual] write write + where + indented output text = case break (== '\n') text of + (xs, "") -> output xs + (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys + + writeDiff chunks extra missing = do + withFailColor $ write (indentation ++ "expected: ") + forM_ chunks $ \ case + Both a -> indented write a + First a -> indented extra a + Second _ -> pass + writeLine "" + + withFailColor $ write (indentation ++ " but got: ") + forM_ chunks $ \ case + Both a -> indented write a + First _ -> pass + Second a -> indented missing a + writeLine "" + + Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e + + writeLine "" + writeLine (" To rerun use: --match " ++ show (joinPath path)) + where + indentation = " " + indent message = do + forM_ (lines message) $ \line -> do + writeLine (indentation ++ line) + formatLoc (Location file line column) = " " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": " + +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 + output = + pluralize total "example" + ++ ", " ++ pluralize fails "failure" + ++ if pending == 0 then "" else ", " ++ show pending ++ " pending" + c | fails /= 0 = withFailColor + | pending /= 0 = withPendingColor + | otherwise = withSuccessColor + c $ writeLine output diff --git a/src/Test/Hspec/Core/Formatters/V1/Monad.hs b/src/Test/Hspec/Core/Formatters/V1/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V1/Monad.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +module Test.Hspec.Core.Formatters.V1.Monad ( + Formatter(..) +, Item(..) +, Result(..) +, FailureReason (..) +, FormatM + +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, printTimes +, getCPUTime +, getRealTime + +, write +, writeLine +, writeTransient + +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, useDiff +, extraChunk +, missingChunk + +, Environment(..) +, interpretWith +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Monad.IO.Class + +import Test.Hspec.Core.Formatters.V1.Free +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Format hiding (FailureReason) + +data FailureReason = + NoReason + | Reason String + | ExpectedButGot (Maybe String) String String + | Error (Maybe String) SomeException + deriving Show + +data Formatter = Formatter { + + headerFormatter :: FormatM () + +-- | evaluated before each test group +, exampleGroupStarted :: [String] -> String -> FormatM () + +-- | evaluated after each test group +, exampleGroupDone :: FormatM () + +-- | evaluated before each example +, exampleStarted :: Path -> FormatM () + +-- | used to notify the progress of the currently evaluated example +, exampleProgress :: Path -> Progress -> FormatM () + +-- | evaluated after each successful example +, exampleSucceeded :: Path -> String -> FormatM () + +-- | evaluated after each failed example +, exampleFailed :: Path -> String -> FailureReason -> FormatM () + +-- | evaluated after each pending example +, examplePending :: Path -> String -> Maybe String -> FormatM () + +-- | evaluated after a test run +, failedFormatter :: FormatM () + +-- | evaluated after `failedFormatter` +, footerFormatter :: FormatM () +} + +data FailureRecord = FailureRecord { + failureRecordLocation :: Maybe Location +, failureRecordPath :: Path +, failureRecordMessage :: FailureReason +} + +data FormatF next = + GetSuccessCount (Int -> next) + | GetPendingCount (Int -> next) + | GetFailMessages ([FailureRecord] -> next) + | UsedSeed (Integer -> next) + | PrintTimes (Bool -> next) + | GetCPUTime (Maybe Seconds -> next) + | GetRealTime (Seconds -> next) + | Write String next + | WriteTransient String next + | forall a. WithFailColor (FormatM a) (a -> next) + | forall a. WithSuccessColor (FormatM a) (a -> next) + | forall a. WithPendingColor (FormatM a) (a -> next) + | forall a. WithInfoColor (FormatM a) (a -> next) + | UseDiff (Bool -> next) + | ExtraChunk String next + | MissingChunk String next + | forall a. LiftIO (IO a) (a -> next) + +instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1 + fmap f x = case x of + GetSuccessCount next -> GetSuccessCount (fmap f next) + GetPendingCount next -> GetPendingCount (fmap f next) + GetFailMessages next -> GetFailMessages (fmap f next) + UsedSeed next -> UsedSeed (fmap f next) + PrintTimes next -> PrintTimes (fmap f next) + GetCPUTime next -> GetCPUTime (fmap f next) + GetRealTime next -> GetRealTime (fmap f next) + Write s next -> Write s (f next) + WriteTransient s next -> WriteTransient s (f next) + WithFailColor action next -> WithFailColor action (fmap f next) + WithSuccessColor action next -> WithSuccessColor action (fmap f next) + WithPendingColor action next -> WithPendingColor action (fmap f next) + WithInfoColor action next -> WithInfoColor action (fmap f next) + UseDiff next -> UseDiff (fmap f next) + ExtraChunk s next -> ExtraChunk s (f next) + MissingChunk s next -> MissingChunk s (f next) + LiftIO action next -> LiftIO action (fmap f next) + +type FormatM = Free FormatF + +instance MonadIO FormatM where + liftIO s = liftF (LiftIO s id) + +data Environment m = Environment { + environmentGetSuccessCount :: m Int +, environmentGetPendingCount :: m Int +, environmentGetFailMessages :: m [FailureRecord] +, environmentUsedSeed :: m Integer +, environmentPrintTimes :: m Bool +, environmentGetCPUTime :: m (Maybe Seconds) +, environmentGetRealTime :: m Seconds +, environmentWrite :: String -> m () +, environmentWriteTransient :: String -> m () +, environmentWithFailColor :: forall a. m a -> m a +, environmentWithSuccessColor :: forall a. m a -> m a +, environmentWithPendingColor :: forall a. m a -> m a +, environmentWithInfoColor :: forall a. m a -> m a +, environmentUseDiff :: m Bool +, environmentExtraChunk :: String -> m () +, environmentMissingChunk :: String -> m () +, environmentLiftIO :: forall a. IO a -> m a +} + +interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a +interpretWith Environment{..} = go + where + go :: forall b. FormatM b -> m b + go m = case m of + Pure value -> return value + Free action -> case action of + GetSuccessCount next -> environmentGetSuccessCount >>= go . next + GetPendingCount next -> environmentGetPendingCount >>= go . next + GetFailMessages next -> environmentGetFailMessages >>= go . next + UsedSeed next -> environmentUsedSeed >>= go . next + PrintTimes next -> environmentPrintTimes >>= go . next + GetCPUTime next -> environmentGetCPUTime >>= go . next + GetRealTime next -> environmentGetRealTime >>= go . next + Write s next -> environmentWrite s >> go next + WriteTransient s next -> environmentWriteTransient s >> go next + WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next + WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next + WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next + WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next + UseDiff next -> environmentUseDiff >>= go . next + ExtraChunk s next -> environmentExtraChunk s >> go next + MissingChunk s next -> environmentMissingChunk s >> go next + LiftIO inner next -> environmentLiftIO inner >>= go . next + +-- | Get the number of successful examples encountered so far. +getSuccessCount :: FormatM Int +getSuccessCount = liftF (GetSuccessCount id) + +-- | Get the number of pending examples encountered so far. +getPendingCount :: FormatM Int +getPendingCount = liftF (GetPendingCount id) + +-- | Get the number of failed examples encountered so far. +getFailCount :: FormatM Int +getFailCount = length <$> getFailMessages + +-- | Get the total number of examples encountered so far. +getTotalCount :: FormatM Int +getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount] + +-- | Get the list of accumulated failure messages. +getFailMessages :: FormatM [FailureRecord] +getFailMessages = liftF (GetFailMessages id) + +-- | The random seed that is used for QuickCheck. +usedSeed :: FormatM Integer +usedSeed = liftF (UsedSeed id) + +-- | Return `True` if the user requested time reporting for individual spec +-- items, `False` otherwise. +printTimes :: FormatM Bool +printTimes = liftF (PrintTimes id) + +-- | Get the used CPU time since the test run has been started. +getCPUTime :: FormatM (Maybe Seconds) +getCPUTime = liftF (GetCPUTime id) + +-- | Get the passed real time since the test run has been started. +getRealTime :: FormatM Seconds +getRealTime = liftF (GetRealTime id) + +-- | Append some output to the report. +write :: String -> FormatM () +write s = liftF (Write s ()) + +-- | The same as `write`, but adds a newline character. +writeLine :: String -> FormatM () +writeLine s = write s >> write "\n" + +writeTransient :: String -> FormatM () +writeTransient s = liftF (WriteTransient s ()) + +-- | Set output color to red, run given action, and finally restore the default +-- color. +withFailColor :: FormatM a -> FormatM a +withFailColor s = liftF (WithFailColor s id) + +-- | Set output color to green, run given action, and finally restore the +-- default color. +withSuccessColor :: FormatM a -> FormatM a +withSuccessColor s = liftF (WithSuccessColor s id) + +-- | Set output color to yellow, run given action, and finally restore the +-- default color. +withPendingColor :: FormatM a -> FormatM a +withPendingColor s = liftF (WithPendingColor s id) + +-- | Set output color to cyan, run given action, and finally restore the +-- default color. +withInfoColor :: FormatM a -> FormatM a +withInfoColor s = liftF (WithInfoColor s id) + +-- | Return `True` if the user requested colorized diffs, `False` otherwise. +useDiff :: FormatM Bool +useDiff = liftF (UseDiff id) + +-- | Output given chunk in red. +extraChunk :: String -> FormatM () +extraChunk s = liftF (ExtraChunk s ()) + +-- | Output given chunk in green. +missingChunk :: String -> FormatM () +missingChunk s = liftF (MissingChunk s ()) diff --git a/src/Test/Hspec/Core/Formatters/V2.hs b/src/Test/Hspec/Core/Formatters/V2.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V2.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +-- | +-- Stability: unstable +-- +-- This is an unstable API. Use +-- [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) +-- instead. +module Test.Hspec.Core.Formatters.V2 +-- {-# WARNING "Use [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) instead." #-} +( +-- * Formatters + silent +, checks +, 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 (..) +, Path +, Progress +, Location(..) +, Item(..) +, Result(..) +, FailureReason (..) +, FormatM +, formatterToFormat + +-- ** Accessing config values +, getConfig +, getConfigValue +, FormatConfig(..) + +-- ** Accessing the runner state +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount +, getExpectedTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, printTimes + +, Seconds(..) +, getCPUTime +, getRealTime + +-- ** Appending to the generated report +, write +, writeLine +, writeTransient + +-- ** Dealing with colors +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, outputUnicode + +, useDiff +, diffContext +, externalDiffAction +, prettyPrint +, prettyPrintFunction +, extraChunk +, missingChunk + +-- ** expert mode +, unlessExpert + +-- ** Helpers +, formatLocation +, Util.formatException + +#ifdef TEST +, Chunk(..) +, ColorChunk(..) +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat +import System.IO (hFlush, stdout) + +import Test.Hspec.Core.Util hiding (formatException) +import qualified Test.Hspec.Core.Util as Util +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Example (Location(..), Progress) +import Text.Printf +import Test.Hspec.Core.Formatters.Pretty.Unicode (ushow) +import Control.Monad.IO.Class + +-- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make +-- sure, that we only use the public API to implement formatters. +-- +-- Everything imported here has to be re-exported, so that users can implement +-- their own formatters. +import Test.Hspec.Core.Formatters.Internal ( + Formatter(..) + , Item(..) + , Result(..) + , FailureReason (..) + , FormatM + , formatterToFormat + + , getConfig + , getConfigValue + , FormatConfig(..) + + , getSuccessCount + , getPendingCount + , getFailCount + , getTotalCount + , getExpectedTotalCount + + , FailureRecord (..) + , getFailMessages + , usedSeed + + , printTimes + , getCPUTime + , getRealTime + + , write + , writeLine + , writeTransient + + , withInfoColor + , withSuccessColor + , withPendingColor + , withFailColor + + , outputUnicode + + , useDiff + , diffContext + , externalDiffAction + , prettyPrint + , prettyPrintFunction + , extraChunk + , missingChunk + + , unlessExpert + ) + +import Test.Hspec.Core.Formatters.Diff + +silent :: Formatter +silent = Formatter { + formatterStarted = pass +, formatterGroupStarted = \ _ -> pass +, formatterGroupDone = \ _ -> pass +, formatterProgress = \ _ _ -> pass +, formatterItemStarted = \ _ -> pass +, formatterItemDone = \ _ _ -> pass +, formatterDone = pass +} + +checks :: Formatter +checks = specdoc { + formatterProgress = \(nesting, requirement) p -> do + writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ formatProgress p ++ "]" + +, formatterItemStarted = \(nesting, requirement) -> do + writeTransient $ indentationFor nesting ++ requirement ++ " [ ]" + +, formatterItemDone = \ (nesting, requirement) item -> do + unicode <- outputUnicode + let fallback a b = if unicode then a else b + uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of + Success {} -> (withSuccessColor, fallback "✔" "v") + Pending {} -> (withPendingColor, fallback "‐" "-") + Failure {} -> (withFailColor, fallback "✘" "x") + case itemResult item of + Success {} -> pass + Failure {} -> pass + Pending _ reason -> withPendingColor $ do + indentBy (indentationFor ("" : nesting)) $ "# PENDING: " ++ fromMaybe "No reason given" reason +} where + indentationFor nesting = replicate (length nesting * 2) ' ' + + writeResult :: [String] -> String -> Seconds -> String -> (FormatM () -> FormatM ()) -> String -> FormatM () + writeResult nesting requirement duration info withColor symbol = do + shouldPrintTimes <- printTimes + write $ indentationFor nesting ++ requirement ++ " [" + withColor $ write symbol + writeLine $ "]" ++ if shouldPrintTimes then times else "" + indentBy (indentationFor ("" : nesting)) info + where + dt :: Int + dt = toMilliseconds duration + + times + | dt == 0 = "" + | otherwise = " (" ++ show dt ++ "ms)" + + formatProgress (current, total) + | total == 0 = show current + | otherwise = show current ++ "/" ++ show total + +specdoc :: Formatter +specdoc = silent { + + formatterStarted = do + writeLine "" + +, formatterGroupStarted = \ (nesting, name) -> do + writeLine (indentationFor nesting ++ name) + +, formatterProgress = \_ p -> do + writeTransient (formatProgress p) + +, formatterItemDone = \(nesting, requirement) item -> do + let duration = itemDuration item + info = itemInfo item + + case itemResult item of + Success -> withSuccessColor $ do + writeResult nesting requirement duration info + Pending _ reason -> withPendingColor $ do + writeResult nesting requirement duration info + indentBy (indentationFor ("" : nesting)) $ "# PENDING: " ++ fromMaybe "No reason given" reason + Failure {} -> withFailColor $ do + n <- getFailCount + writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info + +, formatterDone = defaultFailedFormatter >> defaultFooter +} where + indentationFor nesting = replicate (length nesting * 2) ' ' + + writeResult nesting requirement (Seconds duration) info = do + shouldPrintTimes <- printTimes + writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else "" + indentBy (indentationFor ("" : nesting)) info + where + dt :: Int + dt = floor (duration * 1000) + + times + | dt == 0 = "" + | otherwise = " (" ++ show dt ++ "ms)" + + formatProgress (current, total) + | total == 0 = show current + | otherwise = show current ++ "/" ++ show total + +progress :: Formatter +progress = failed_examples { + formatterItemDone = \ _ item -> do + case itemResult item of + Success{} -> withSuccessColor $ write "." + Pending{} -> withPendingColor $ write "." + Failure{} -> withFailColor $ write "F" + liftIO $ hFlush stdout +} + +failed_examples :: Formatter +failed_examples = silent { + formatterDone = defaultFailedFormatter >> defaultFooter +} + +defaultFailedFormatter :: FormatM () +defaultFailedFormatter = do + writeLine "" + + failures <- getFailMessages + + unless (null failures) $ do + writeLine "Failures:" + writeLine "" + + forM_ (zip [1..] failures) $ \x -> do + formatFailure x + writeLine "" + + write "Randomized with seed " >> usedSeed >>= writeLine . show + writeLine "" + where + formatFailure :: (Int, FailureRecord) -> FormatM () + formatFailure (n, FailureRecord mLoc path reason) = do + unicode <- outputUnicode + forM_ mLoc $ \loc -> do + withInfoColor $ writeLine (" " ++ formatLocation loc) + write (" " ++ show n ++ ") ") + writeLine (formatRequirement path) + case reason of + NoReason -> pass + Reason err -> withFailColor $ indent err + ColorizedReason err -> indent err + ExpectedButGot preface expected_ actual_ -> do + pretty <- prettyPrintFunction + let + (expected, actual) = case pretty of + Just f -> f expected_ actual_ + Nothing -> (expected_, actual_) + + mapM_ indent preface + + b <- useDiff + + let threshold = 2 :: Seconds + + + mExternalDiff <- externalDiffAction + + case mExternalDiff of + Just externalDiff -> do + liftIO $ externalDiff expected actual + + Nothing -> do + context <- diffContext + mchunks <- liftIO $ if b + then timeout threshold (evaluate $ lineDiff context expected actual) + else return Nothing + + case mchunks of + Just chunks -> do + writeDiff chunks extraChunk missingChunk + Nothing -> do + writeDiff [LinesFirst (splitLines expected), LinesSecond (splitLines actual)] write write + where + writeDiff :: [LineDiff] -> (String -> FormatM ()) -> (String -> FormatM ()) -> FormatM () + writeDiff chunks extra missing = do + writeChunks "expected: " (expectedChunks chunks) extra + writeChunks " but got: " (actualChunks chunks) missing + + writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM () + writeChunks pre chunks colorize = do + withFailColor $ write (indentation ++ pre) + go pass chunks + where + indentation_ :: [Char] + indentation_ = indentation ++ replicate (length pre) ' ' + + go :: FormatM () -> [Chunk] -> FormatM () + go indent_ = \ case + [] -> pass + c : cs -> do + indent_ + case c of + Original a -> write a + Modified a -> colorize a + Info text -> withInfoColor $ write text + ModifiedChunks xs -> for_ xs $ \ case + PlainChunk a -> write a + ColorChunk a -> colorize a + write "\n" + go (write indentation_) cs + + Error info e -> do + mapM_ indent info + formatException <- getConfigValue formatConfigFormatException + withFailColor . indent $ "uncaught exception: " ++ formatException e + + + unlessExpert $ do + let path_ = (if unicode then ushow else show) (joinPath path) + writeLine "" + seed <- usedSeed + writeLine (" To rerun use: --match " ++ path_ <> " --seed " <> show seed) + where + indentation = " " + indent = indentBy indentation + +indentBy :: String -> String -> FormatM () +indentBy indentation message = do + forM_ (lines message) $ \ line -> do + writeLine (indentation ++ line) + +data Chunk = Original String | Modified String | Info String | ModifiedChunks [ColorChunk] + deriving (Eq, Show) + +expectedChunks :: [LineDiff] -> [Chunk] +expectedChunks = concatMap $ \ case + LinesBoth a -> map Original a + LinesFirst a -> map Modified a + LinesSecond _ -> [] + LinesOmitted n -> [Info $ formatOmittedLines n] + SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case + First a -> Just $ ColorChunk a + Second _ -> Nothing + Both a -> Just $ PlainChunk a + +actualChunks :: [LineDiff] -> [Chunk] +actualChunks = concatMap $ \ case + LinesBoth a -> map Original a + LinesFirst _ -> [] + LinesSecond a -> map Modified a + LinesOmitted n -> [Info $ formatOmittedLines n] + SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case + First _ -> Nothing + Second a -> Just $ ColorChunk a + Both a -> Just $ PlainChunk a + +data ColorChunk = PlainChunk String | ColorChunk String + deriving (Eq, Show) + +formatOmittedLines :: Int -> String +formatOmittedLines n = "@@ " <> show n <> " lines omitted @@" + +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 + output = + pluralize total "example" + ++ ", " ++ pluralize fails "failure" + ++ if pending == 0 then "" else ", " ++ show pending ++ " pending" + + color + | fails /= 0 = withFailColor + | pending /= 0 = withPendingColor + | otherwise = withSuccessColor + color $ writeLine output + +formatLocation :: Location -> String +formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": " diff --git a/src/Test/Hspec/Core/Hooks.hs b/src/Test/Hspec/Core/Hooks.hs --- a/src/Test/Hspec/Core/Hooks.hs +++ b/src/Test/Hspec/Core/Hooks.hs @@ -1,10 +1,21 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RecordWildCards #-} -- | Stability: provisional module Test.Hspec.Core.Hooks ( - before +-- * Types + Spec +, SpecWith +, ActionWith +-- * Hooks +, before , before_ , beforeWith , beforeAll , beforeAll_ +, beforeAllWith , after , after_ , afterAll @@ -12,13 +23,27 @@ , around , around_ , aroundWith +, aroundAll +, aroundAll_ +, aroundAllWith + +, mapSubject +, ignoreSubject + +#ifdef TEST +, decompose +#endif ) where -import Control.Exception (finally) -import Control.Concurrent.MVar +import Prelude () +import Test.Hspec.Core.Compat -import Test.Hspec.Core.Spec +import Control.Concurrent +import Test.Hspec.Core.Example +import Test.Hspec.Core.Tree +import Test.Hspec.Core.Spec.Monad + -- | Run a custom action before every spec item. before :: IO a -> SpecWith a -> Spec before action = around (action >>=) @@ -32,24 +57,38 @@ beforeWith action = aroundWith $ \e x -> action x >>= e -- | Run a custom action before the first spec item. -beforeAll :: IO a -> SpecWith a -> Spec +beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec beforeAll action spec = do - mvar <- runIO (newMVar Nothing) + mvar <- runIO (newMVar Empty) before (memoize mvar action) spec -- | Run a custom action before the first spec item. -beforeAll_ :: IO () -> SpecWith a -> SpecWith a +beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do - mvar <- runIO (newMVar Nothing) + mvar <- runIO (newMVar Empty) before_ (memoize mvar action) spec -memoize :: MVar (Maybe a) -> IO a -> IO a -memoize mvar action = modifyMVar mvar $ \ma -> case ma of - Just a -> return (ma, a) - Nothing -> do - a <- action - return (Just a, a) +-- | Run a custom action with an argument before the first spec item. +beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b +beforeAllWith action spec = do + mvar <- runIO (newMVar Empty) + beforeWith (memoize mvar . action) spec +data Memoized a = + Empty + | Memoized a + | Failed SomeException + +memoize :: HasCallStack => MVar (Memoized a) -> IO a -> IO a +memoize mvar action = do + result <- modifyMVar mvar $ \ma -> case ma of + Empty -> do + a <- try action + return (either Failed Memoized a, a) + Memoized a -> return (ma, Right a) + Failed _ -> throwIO (Pending Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-hook (see previous failure)")) + either throwIO return result + -- | Run a custom action after every spec item. after :: ActionWith a -> SpecWith a -> SpecWith a after action = aroundWith $ \e x -> e x `finally` action x @@ -58,17 +97,27 @@ after_ :: IO () -> SpecWith a -> SpecWith a after_ action = after $ \_ -> action --- | Run a custom action before and/or after every spec item. -around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +-- | Run a custom action before and/or after every spec item, supplying it with +-- an argument obtained via IO. +-- +-- This is useful for tasks like creating a file handle or similar resource +-- before a test and destroying it after the test. +around + :: (ActionWith a -> IO ()) + -- ^ Function provided with an action to run the spec item as argument. It + -- should return the action to actually execute the item. + -> SpecWith a + -- ^ Spec to modify + -> Spec around action = aroundWith $ \e () -> action e -- | Run a custom action after the last spec item. -afterAll :: ActionWith a -> SpecWith a -> SpecWith a -afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action +afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a +afterAll action = aroundAllWith (\ hook a -> hook a >> action a) -- | Run a custom action after the last spec item. -afterAll_ :: IO () -> SpecWith a -> SpecWith a -afterAll_ action = afterAll (\_ -> action) +afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a +afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite action) -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a @@ -76,10 +125,96 @@ -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b -aroundWith action = mapAround (. action) +aroundWith = mapSpecItem_ . modifyHook -mapAround :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> SpecWith a -> SpecWith b -mapAround f = mapSpecItem (untangle f) $ \i@Item{itemExample = e} -> i{itemExample = (. f) . e} +modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b +modifyHook action Item{..} = Item { + itemExample = \ params hook -> itemExample params (hook . action) + , .. + } -untangle :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> ActionWith a -> ActionWith b -untangle f g = \b -> f ($ b) g +-- | Wrap an action around the given spec. +aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec +aroundAll action = aroundAllWith $ \ e () -> action e + +-- | Wrap an action around the given spec. +aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a +aroundAll_ action spec = do + (acquire, release) <- runIO $ decompose (action .) + beforeAll_ (acquire ()) $ afterAll_ release spec + +-- | Wrap an action around the given spec. Changes the arg type inside. +aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundAllWith action spec = do + (acquire, release) <- runIO $ decompose action + beforeAllWith acquire $ afterAll_ release spec + +data Acquired a = Acquired a | ExceptionDuringAcquire SomeException +data Released = Released | ExceptionDuringRelease SomeException + +decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ()) +decompose action = do + doCleanupNow <- newEmptyMVar + acquired <- newEmptyMVar + released <- newEmptyMVar + + let + notify :: Either SomeException () -> IO () + -- `notify` is guaranteed to run without being interrupted by an async + -- exception for the following reasons: + -- + -- 1. `forkFinally` runs the final action within `mask` + -- 2. `tryPutMVar` is guaranteed not to be interruptible + -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar` + notify r = case r of + Left err -> do + exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err) + putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err + Right () -> do + putMVar released Released + + forkWorker :: b -> IO () + forkWorker b = void . flip forkFinally notify $ do + flip action b $ \ a -> do + putMVar acquired (Acquired a) + waitFor doCleanupNow + + acquire :: b -> IO a + acquire b = do + forkWorker b + r <- readMVar acquired -- This does not work reliably with base < 4.7 + case r of + Acquired a -> return a + ExceptionDuringAcquire err -> throwIO err + + release :: IO () + release = do + acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails + unless acquireHasNotBeenCalled $ do + signal doCleanupNow + r <- takeMVar released + case r of + Released -> pass + ExceptionDuringRelease err -> throwIO err + + return (acquire, release) + +type BinarySemaphore = MVar () + +signal :: BinarySemaphore -> IO () +signal = flip putMVar () + +waitFor :: BinarySemaphore -> IO () +waitFor = takeMVar + +-- | Modify the subject under test. +-- +-- Note that this resembles a contravariant functor on the first type parameter +-- of `SpecM`. This is because the subject is passed inwards, as an argument +-- to the spec item. +mapSubject :: (b -> a) -> SpecWith a -> SpecWith b +mapSubject f = aroundWith (. f) + +-- | Ignore the subject under test for a given spec. +ignoreSubject :: SpecWith () -> SpecWith a +ignoreSubject = mapSubject (const ()) diff --git a/src/Test/Hspec/Core/QuickCheck.hs b/src/Test/Hspec/Core/QuickCheck.hs --- a/src/Test/Hspec/Core/QuickCheck.hs +++ b/src/Test/Hspec/Core/QuickCheck.hs @@ -1,14 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | Stability: provisional module Test.Hspec.Core.QuickCheck ( modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize - +, modifyMaxShrinks +, modifyArgs ) where -import Test.QuickCheck -import Test.Hspec.Core.Spec +import Prelude () +import Test.Hspec.Core.Compat +import Test.QuickCheck (Args(..)) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) +import qualified Test.QuickCheck.Property as QCP + +import Test.Hspec.Core.Util +import Test.Hspec.Core.QuickCheck.Util +import Test.Hspec.Core.Example (Example(..), Params(..), Result(..), ResultStatus(..), FailureReason(..), hunitFailureToResult) +import Test.Hspec.Core.Spec.Monad (SpecWith, modifyParams) + -- | Use a modified `maxSuccess` for given spec. modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSuccess = modifyArgs . modify @@ -30,8 +46,70 @@ modify :: (Int -> Int) -> Args -> Args modify f args = args {maxSize = f (maxSize args)} +-- | Use a modified `maxShrinks` for given spec. +modifyMaxShrinks :: (Int -> Int) -> SpecWith a -> SpecWith a +modifyMaxShrinks = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxShrinks = f (maxShrinks args)} + +-- | Use modified `Args` for given spec. modifyArgs :: (Args -> Args) -> SpecWith a -> SpecWith a modifyArgs = modifyParams . modify where modify :: (Args -> Args) -> Params -> Params modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)} + +instance Example QC.Property where +#ifdef ENABLE_SPEC_HOOK_ARGS + type Arg QC.Property = () +#endif + evaluateExample e = evaluateExample (\() -> e) + +#ifdef ENABLE_SPEC_HOOK_ARGS +instance Example (a -> QC.Property) where + type Arg (a -> QC.Property) = a +#else +instance Example (() -> QC.Property) where +#endif + evaluateExample p params hook progressCallback = do + let args = paramsQuickCheckArgs params + r <- QC.quickCheckWithResult args {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p) + return $ fromQuickCheckResult args r + where + qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ + \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) + +fromQuickCheckResult :: QC.Args -> QC.Result -> Result +fromQuickCheckResult args r = case parseQuickCheckResult r of + QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) + QuickCheckResult _ info QuickCheckSuccess -> Result (if QC.chatty args then info else "") Success + QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of + Just e | Just result <- fromException e -> Result info result + Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit + Just e -> failure (uncaughtException e) + Nothing -> failure falsifiable + where + failure = Result info . Failure Nothing . Reason + + numbers = formatNumbers n quickCheckFailureNumShrinks + + hunitAssertion :: String + hunitAssertion = intercalate "\n" [ + "Falsifiable " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] + + uncaughtException e = intercalate "\n" [ + "uncaught exception: " ++ formatException e + , numbers + , indent (unlines quickCheckFailureCounterexample) + ] + + falsifiable = intercalate "\n" [ + quickCheckFailureReason ++ " " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] + +indent :: String -> String +indent = intercalate "\n" . map (" " ++) . lines diff --git a/src/Test/Hspec/Core/QuickCheck/Util.hs b/src/Test/Hspec/Core/QuickCheck/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheck/Util.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.QuickCheck.Util ( + liftHook +, aroundProperty + +, QuickCheckResult(..) +, Status(..) +, QuickCheckFailure(..) +, parseQuickCheckResult + +, formatNumbers + +, mkGen +, newSeed +#ifdef TEST +, stripSuffix +, splitBy +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Int +import System.Random + +import Test.QuickCheck +import Test.QuickCheck.Text (isOneLine) +import qualified Test.QuickCheck.Property as QCP +import Test.QuickCheck.Property hiding (Result(..)) +import Test.QuickCheck.Gen +import Test.QuickCheck.IO () +import Test.QuickCheck.Random +import qualified Test.QuickCheck.Test as QC (showTestCount) +import Test.QuickCheck.State (State(..)) + +import Test.Hspec.Core.Util + +liftHook + :: r + -- ^ Default result, taken if the hook decides to not run the test + -> ((a -> IO ()) -> IO ()) + -- ^ Hook: given an action to actually run the test, potentially does + -- some IO actions before the test, runs it while supplying an argument (or + -- skips it!), then may execute some more actions after running it. + -> (a -> IO r) + -- ^ The actual test being run, producing a result + -> IO r +liftHook def hook inner = do + ref <- newIORef def + hook $ inner >=> writeIORef ref + readIORef ref + +aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property +aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n + +aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop +aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a) + +aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result +aroundRose hook r = ioRose $ do + liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a) + +newSeed :: IO Int +newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> + newQCGen + +mkGen :: Int -> QCGen +mkGen = mkQCGen + +formatNumbers :: Int -> Int -> String +formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" + where + shrinks_ + | shrinks > 0 = " and " ++ pluralize shrinks "shrink" + | otherwise = "" + +data QuickCheckResult = QuickCheckResult { + quickCheckResultNumTests :: Int +, quickCheckResultInfo :: String +, quickCheckResultStatus :: Status +} deriving Show + +data Status = + QuickCheckSuccess + | QuickCheckFailure QuickCheckFailure + | QuickCheckOtherFailure String + deriving Show + +data QuickCheckFailure = QCFailure { + quickCheckFailureNumShrinks :: Int +, quickCheckFailureException :: Maybe SomeException +, quickCheckFailureReason :: String +, quickCheckFailureCounterexample :: [String] +} deriving Show + +parseQuickCheckResult :: Result -> QuickCheckResult +parseQuickCheckResult r = case r of + Success {..} -> result output QuickCheckSuccess + + Failure {..} -> + case stripSuffix outputWithoutVerbose output of + Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) + where + verboseOutput + | xs == "*** Failed! " = "" + | otherwise = maybeStripSuffix "*** Failed!" (strip xs) + Nothing -> couldNotParse output + where + outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase + reasonAndNumbers + | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline + | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason + numbers = formatNumbers numTests numShrinks + colonNewline = ":\n" + + GaveUp {..} -> + case stripSuffix outputWithoutVerbose output of + Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!") + Nothing -> couldNotParse output + where + numbers = showTestCount numTests numDiscarded + outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n" + + NoExpectedFailure {..} -> case splitBy "*** Failed! " output of + Just (info, err) -> otherFailure info err + Nothing -> couldNotParse output + + where + result = QuickCheckResult (numTests r) . strip + otherFailure info err = result info (QuickCheckOtherFailure $ strip err) + couldNotParse = result "" . QuickCheckOtherFailure + +showTestCount :: Int -> Int -> String +showTestCount success discarded = QC.showTestCount state + where + state = MkState { + terminal = undefined + , maxSuccessTests = undefined + , maxDiscardedRatio = undefined + , coverageConfidence = undefined +#if MIN_VERSION_QuickCheck(2,15,0) + , maxTestSize = 0 + , replayStartSize = undefined +#else + , computeSize = undefined +#endif + , numTotMaxShrinks = 0 + , numSuccessTests = success + , numDiscardedTests = discarded + , numRecentlyDiscardedTests = 0 + , labels = mempty + , classes = mempty + , tables = mempty + , requiredCoverage = mempty + , expected = True + , randomSeed = mkGen 0 + , numSuccessShrinks = 0 + , numTryShrinks = 0 + , numTotTryShrinks = 0 + } + +ensureTrailingNewline :: String -> String +ensureTrailingNewline = unlines . lines + +maybeStripPrefix :: String -> String -> String +maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) + +maybeStripSuffix :: String -> String -> String +maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse + +splitBy :: String -> String -> Maybe (String, String) +splitBy sep xs = listToMaybe [ + (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) + ] + where + stripSep = stripPrefix sep diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/QuickCheckUtil.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE CPP #-} -module Test.Hspec.Core.QuickCheckUtil where - -import Prelude () -import Test.Hspec.Compat - -import Data.Int -import Test.QuickCheck hiding (Result(..)) -import Test.QuickCheck as QC -import Test.QuickCheck.Property hiding (Result(..)) -import Test.QuickCheck.Gen -import qualified Test.QuickCheck.Property as QCP -import Test.QuickCheck.IO () - - -#if MIN_VERSION_QuickCheck(2,7,0) -import Test.QuickCheck.Random -#endif - -import System.Random - -import Test.Hspec.Core.Util - -aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property -#if MIN_VERSION_QuickCheck(2,7,0) -aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n -#else -aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n -#endif - -aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop -aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) - -aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result -aroundRose action r = ioRose $ do - ref <- newIORef (return QCP.succeeded) - action $ \a -> reduceRose (r a) >>= writeIORef ref - readIORef ref - -formatNumbers :: Result -> String -formatNumbers r = "(after " ++ pluralize (numTests r) "test" ++ shrinks ++ ")" - where - shrinks - | 0 < numShrinks r = " and " ++ pluralize (numShrinks r) "shrink" - | otherwise = "" - -newSeed :: IO Int -newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> -#if MIN_VERSION_QuickCheck(2,7,0) - newQCGen -#else - newStdGen -#endif - -#if MIN_VERSION_QuickCheck(2,7,0) -mkGen :: Int -> QCGen -mkGen = mkQCGen -#else -mkGen :: Int -> StdGen -mkGen = mkStdGen -#endif diff --git a/src/Test/Hspec/Core/Runner.hs b/src/Test/Hspec/Core/Runner.hs --- a/src/Test/Hspec/Core/Runner.hs +++ b/src/Test/Hspec/Core/Runner.hs @@ -1,112 +1,222 @@ -{-# LANGUAGE CPP #-} - -#if MIN_VERSION_base(4,6,0) --- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Stability: provisional module Test.Hspec.Core.Runner ( --- * Running a spec +-- * Simple interface hspec , hspecWith , hspecResult , hspecWithResult --- * Types +-- ** Summary , Summary (..) +, isSuccess +, evaluateSummary + +-- * Running a spec +{- | +To run a spec `hspec` performs a sequence of steps: + +1. Evaluate a `Spec` to a forest of `SpecTree`s +1. Read config values from the command-line, config files and the process environment +1. Execute each spec item of the forest and report results to `stdout` +1. Exit with `exitFailure` if at least on spec item fails + +The four primitives `evalSpec`, `readConfig`, `runSpecForest` and +`evaluateResult` each perform one of these steps respectively. + +`hspec` is defined in terms of these primitives. Loosely speaking, a definition +for @hspec@ is: + +@ +hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> + `getArgs` + >>= `readConfig` config + >>= `withArgs` [] . `runSpecForest` spec + >>= `evaluateResult` +@ + +Loosely speaking in the sense that this definition of @hspec@ ignores +@--rerun-all-on-success@. + +Using these primitives individually gives you more control over how a spec is +run. However, if you need support for @--rerun-all-on-success@ then you should +try hard to solve your use case with one of `hspec`, `hspecWith`, `hspecResult` +or `hspecWithResult`. + +-} +, evalSpec +, runSpecForest +, evaluateResult + +-- ** Result + +-- *** Spec Result +, Test.Hspec.Core.Runner.Result.SpecResult +, Test.Hspec.Core.Runner.Result.specResultItems +, Test.Hspec.Core.Runner.Result.specResultSuccess +, toSummary + +-- *** Result Item +, Test.Hspec.Core.Runner.Result.ResultItem +, Test.Hspec.Core.Runner.Result.resultItemPath +, Test.Hspec.Core.Runner.Result.resultItemStatus +, Test.Hspec.Core.Runner.Result.resultItemIsFailure + +-- *** Result Item Status +, Test.Hspec.Core.Runner.Result.ResultItemStatus(..) + +-- * Config , Config (..) , ColorMode (..) +, UnicodeMode(..) , Path , defaultConfig +, registerFormatter +, registerDefaultFormatter , configAddFilter +, readConfig + +-- * Legacy +, runSpec + +-- * Re-exports +, Spec +, SpecWith + +#ifdef TEST +, UseColor(..) +, ProgressReporting(..) +, rerunAll +, specToEvalForest +, colorOutputSupported +, unicodeOutputSupported +#endif ) where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat hiding (unicodeOutputSupported) +import qualified Test.Hspec.Core.Compat as Compat -import Control.Monad -import Data.Maybe +import Data.List.NonEmpty (nonEmpty) import System.IO -import System.Environment (getProgName, getArgs, withArgs) -import System.Exit -import qualified Control.Exception as E -import Control.Concurrent +import System.Environment (getArgs, withArgs) +import System.Exit (exitFailure) +import System.Random +import Control.Monad.ST +import Data.STRef -import System.Console.ANSI (hHideCursor, hShowCursor) +import System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC -import Control.Monad.IO.Class (liftIO) import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec -import Test.Hspec.Config -import Test.Hspec.Core.Formatters -import Test.Hspec.Core.Formatters.Internal -import Test.Hspec.FailureReport -import Test.Hspec.Core.QuickCheckUtil +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) +import Test.Hspec.Core.Tree (formatDefaultDescription) +import Test.Hspec.Core.Config +import Test.Hspec.Core.Config.Definition as Config (getSeed, getFormatter) +import Test.Hspec.Core.Extension.Config.Type as Extension (applySpecTransformation) +import Test.Hspec.Core.Format (Format, FormatConfig(..)) +import qualified Test.Hspec.Core.Formatters.V2 as V2 +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.QuickCheck.Util +import Test.Hspec.Core.Shuffle -import Test.Hspec.Core.Runner.Eval +import Test.Hspec.Core.Runner.PrintSlowSpecItems +import Test.Hspec.Core.Runner.Eval hiding (ColorMode(..), Tree(..)) +import qualified Test.Hspec.Core.Runner.Eval as Eval +import Test.Hspec.Core.Runner.Result --- | Filter specs by given predicate. +-- | +-- Make a formatter available for use with @--format@. -- --- The predicate takes a list of "describe" labels and a "requirement". -filterSpecs :: Config -> [SpecTree a] -> [SpecTree a] -filterSpecs c = go [] - where - p :: Path -> Bool - p path = (fromMaybe (const True) (configFilterPredicate c) path) && - not (fromMaybe (const False) (configSkipPredicate c) path) +-- @since 2.10.5 +registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config +{-# DEPRECATED registerFormatter "Use [@registerFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:registerFormatter) instead." #-} +registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config } - go :: [String] -> [SpecTree a] -> [SpecTree a] - go groups = mapMaybe (goSpec groups) +-- | +-- Make a formatter available for use with @--format@ and use it by default. +-- +-- @since 2.10.5 +registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config +{-# DEPRECATED registerDefaultFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:useFormatter) instead." #-} +registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format } - goSpecs :: [String] -> [SpecTree a] -> ([SpecTree a] -> b) -> Maybe b - goSpecs groups specs ctor = case go groups specs of - [] -> Nothing - xs -> Just (ctor xs) +applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] +applyFilterPredicates c = filterForestWithLabels p + where + include :: Path -> Bool + include = fromMaybe (const True) (configFilterPredicate c) - goSpec :: [String] -> SpecTree a -> Maybe (SpecTree a) - goSpec groups spec = case spec of - Leaf item -> guard (p (groups, itemRequirement item)) >> return spec - Node group specs -> goSpecs (groups ++ [group]) specs (Node group) - NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action) + skip :: Path -> Bool + skip = fromMaybe (const False) (configSkipPredicate c) -applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()] + p :: [String] -> EvalItem -> Bool + p groups item = include path && not (skip path) + where + path = (groups, evalItemDescription item) + +applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c - | configDryRun c = map (removeCleanup . fmap markSuccess) + | configDryRun c = bimapForest removeCleanup markSuccess | otherwise = id where - markSuccess :: Item () -> Item () - markSuccess item = item {itemExample = evaluateExample Success} + removeCleanup :: IO () -> IO () + removeCleanup _ = pass - removeCleanup :: SpecTree () -> SpecTree () - removeCleanup spec = case spec of - Node x xs -> Node x (map removeCleanup xs) - NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs) - leaf@(Leaf _) -> leaf + markSuccess :: EvalItem -> EvalItem + markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)} --- | Run given spec and write a report to `stdout`. +-- | Run a given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails. +-- +-- /Note/: `hspec` handles command-line options and reads config files. This +-- is not always desirable. Use `evalSpec` and `runSpecForest` if you need +-- more control over these aspects. hspec :: Spec -> IO () hspec = hspecWith defaultConfig +-- | +-- Evaluate a `Spec` to a forest of `SpecTree`s. This does not execute any +-- spec items, but it does run any IO that is used during spec construction +-- time (see `runIO`). +-- +-- A `Spec` may modify a `Config` through `modifyConfig`. These modifications +-- are applied to the given config (the first argument). +-- +-- @since 2.10.0 +evalSpec :: Config -> SpecWith a -> IO (Config, [SpecTree a]) +evalSpec config spec = do + (Endo f, forest) <- runSpecM spec + return (f config, forest) + -- Add a seed to given config if there is none. That way the same seed is used -- for all properties. This helps with --seed and --rerun. -ensureSeed :: Config -> IO Config -ensureSeed c = case configQuickCheckSeed c of - Nothing -> do - seed <- newSeed - return c {configQuickCheckSeed = Just (fromIntegral seed)} - _ -> return c +ensureSeed :: Config -> IO (Config, Integer) +ensureSeed config = do + seed <- case Config.getSeed config of + Nothing -> toInteger <$> newSeed + Just seed -> return seed + return (config { configSeed = Just seed }, seed) -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO () -hspecWith conf spec = do - r <- hspecWithResult conf spec - unless (summaryFailures r == 0) exitFailure +hspecWith defaults = hspecWithSpecResult defaults >=> evaluateResult +-- | Exit with `exitFailure` if the given `Summary` indicates that there was at +-- least one failure. +evaluateSummary :: Summary -> IO () +evaluateSummary summary = unless (isSuccess summary) exitFailure + +evaluateResult :: SpecResult -> IO () +evaluateResult result = unless (specResultSuccess result) exitFailure + -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec @@ -121,67 +231,321 @@ -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary -hspecWithResult conf spec = do - prog <- getProgName - args <- getArgs - c <- getConfig conf prog args >>= ensureSeed - withArgs [] {- do not leak command-line arguments to examples -} $ withHandle c $ \h -> do - let formatter = fromMaybe specdoc (configFormatter c) - seed = (fromJust . configQuickCheckSeed) c - qcArgs = configQuickCheckArgs c +hspecWithResult config = fmap toSummary . hspecWithSpecResult config - jobsSem <- newQSem =<< case configConcurrentJobs c of - Nothing -> getDefaultConcurrentJobs - Just maxJobs -> return maxJobs +hspecWithSpecResult :: Config -> Spec -> IO SpecResult +hspecWithSpecResult defaults spec = do + (c, forest) <- evalSpec defaults spec + config <- getArgs >>= readConfig c + oldFailureReport <- readFailureReportOnRerun config - useColor <- doesUseColor h c + let + normalMode :: IO SpecResult + normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config - filteredSpec <- filterSpecs c . applyDryRun c <$> runSpecM spec + rerunAllMode :: IO SpecResult + rerunAllMode = do + result <- normalMode + if rerunAll config oldFailureReport result then + hspecWithSpecResult defaults spec + else + return result - withHiddenCursor useColor h $ - runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do - runFormatter jobsSem useColor h c formatter filteredSpec `finally_` do - failedFormatter formatter + -- With --rerun-all we may run the spec twice. For that reason GHC can not + -- optimize away the spec tree. That means that the whole spec tree has to + -- be constructed in memory and we loose constant space behavior. + -- + -- By separating between rerunAllMode and normalMode here, we retain + -- constant space behavior in normalMode. + -- + -- see: https://github.com/hspec/hspec/issues/169 + if configRerunAllOnSuccess config then do + rerunAllMode + else do + normalMode - footerFormatter formatter +-- | +-- /Note/: `runSpec` is deprecated. It ignores any modifications applied +-- through `modifyConfig`. Use `evalSpec` and `runSpecForest` instead. +runSpec :: Spec -> Config -> IO Summary +runSpec spec config = evalSpec defaultConfig spec >>= fmap toSummary . flip runSpecForest config . snd - -- dump failure report - xs <- map failureRecordPath <$> getFailMessages - liftIO $ writeFailureReport FailureReport { - failureReportSeed = seed - , failureReportMaxSuccess = QC.maxSuccess qcArgs - , failureReportMaxSize = QC.maxSize qcArgs - , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs - , failureReportPaths = xs - } +-- | +-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is +-- defined in terms of @runSpecForest@: +-- +-- @ +-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> +-- `getArgs` +-- >>= `readConfig` config +-- >>= `withArgs` [] . runSpecForest spec +-- >>= `evaluateResult` +-- @ +-- +-- @since 2.10.0 +runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult +runSpecForest spec config = do + oldFailureReport <- readFailureReportOnRerun config + runSpecForest_ oldFailureReport spec config - Summary <$> getTotalCount <*> getFailCount +mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] +mapItem f = map (fmap f) + +mapItemIf :: (Item a -> Bool) -> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a] +mapItemIf p f = mapItem $ \ item -> if p item then f item else item + +addDefaultDescriptions :: [SpecTree a] -> [SpecTree a] +addDefaultDescriptions = mapItem addDefaultDescription where - withHiddenCursor :: Bool -> Handle -> IO a -> IO a - withHiddenCursor useColor h - | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) + addDefaultDescription :: Item a -> Item a + addDefaultDescription item + | null (itemRequirement item) = item { itemRequirement = defaultRequirement } + | otherwise = item + where + defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item) + +failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a] +failItemsWithEmptyDescription config + | configFailOnEmptyDescription config = mapItemIf condition (failWith failure) + | otherwise = id + where + condition = null . itemRequirement + failure = "item has no description; failing due to --fail-on=empty-description" + +failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a] +failFocusedItems config + | configFailOnFocused config = mapItemIf condition (failWith failure) + | otherwise = id + where + condition = itemIsFocused + failure = "item is focused; failing due to --fail-on=focused" + +failWith :: forall a. String -> Item a -> Item a +failWith reason item = item {itemExample = example} + where + failure :: ResultStatus + failure = Failure Nothing (Reason reason) + + example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result + example params hook p = do + Result info status <- itemExample item params hook p + return $ Result info $ case status of + Success -> failure + Pending _ _ -> failure + Failure{} -> status + +failPendingItems :: Config -> [SpecTree a] -> [SpecTree a] +failPendingItems config + | configFailOnPending config = mapItem failPending + | otherwise = id + +failPending :: forall a. Item a -> Item a +failPending item = item {itemExample = example} + where + example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result + example params hook p = do + Result info status <- itemExample item params hook p + return $ Result info $ case status of + Pending loc _ -> Failure loc (Reason "item is pending; failing due to --fail-on=pending") + _ -> status + +focusSpec :: Config -> [SpecTree a] -> [SpecTree a] +focusSpec config spec + | configFocusedOnly config = spec + | otherwise = focusForest spec + +runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult +runSpecForest_ oldFailureReport spec c_ = do + + (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_) + + colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) + outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout + + let + filteredSpec = specToEvalForest seed config spec + qcArgs = configQuickCheckArgs config + !numberOfItems = countEvalItems filteredSpec + + when (configFailOnEmpty config && numberOfItems == 0) $ do + when (countSpecItems spec /= 0) $ do + die "all spec items have been filtered; failing due to --fail-on=empty" + + concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config + + results <- fmap toSpecResult . withHiddenCursor (progressReporting colorMode) stdout $ do + let + formatConfig = FormatConfig { + formatConfigUseColor = shouldUseColor colorMode + , formatConfigReportProgress = progressReporting colorMode == ProgressReportingEnabled + , formatConfigOutputUnicode = outputUnicode + , formatConfigUseDiff = configDiff config + , formatConfigDiffContext = configDiffContext config + , formatConfigExternalDiff = if configDiff config then ($ configDiffContext config) <$> configExternalDiff config else Nothing + , formatConfigPrettyPrint = configPrettyPrint config + , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing + , formatConfigFormatException = configFormatException config + , formatConfigPrintTimes = configTimes config + , formatConfigHtmlOutput = configHtmlOutput config + , formatConfigPrintCpuTime = configPrintCpuTime config + , formatConfigUsedSeed = seed + , formatConfigExpectedTotalCount = numberOfItems + , formatConfigExpertMode = configExpertMode config + } + + formatter :: FormatConfig -> IO Format + formatter = fromMaybe (V2.formatterToFormat V2.checks) (Config.getFormatter config) + + format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig + + let + evalConfig = EvalConfig { + evalConfigFormat = format + , evalConfigConcurrentJobs = concurrentJobs + , evalConfigFailFast = configFailFast config + , evalConfigColorMode = bool Eval.ColorDisabled Eval.ColorEnabled (shouldUseColor colorMode) + } + runFormatter evalConfig filteredSpec + + let + failures :: [Path] + failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results + + dumpFailureReport config seed qcArgs failures + + return results + +specToEvalForest :: Integer -> Config -> [SpecTree ()] -> [EvalTree] +specToEvalForest seed config = + failItemsWithEmptyDescription config + >>> addDefaultDescriptions + >>> failFocusedItems config + >>> failPendingItems config + >>> Extension.applySpecTransformation config + >>> focusSpec config + >>> toEvalItemForest params + >>> applyDryRun config + >>> applyFilterPredicates config + >>> randomize + >>> pruneForest + where + params :: Params + params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) + + randomize :: [Tree c a] -> [Tree c a] + randomize + | configRandomize config = randomizeForest seed | 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 +pruneForest :: [Tree c a] -> [Eval.Tree c a] +pruneForest = mapMaybe pruneTree - withHandle :: Config -> (Handle -> IO a) -> IO a - withHandle c action = case configOutputFile c of - Left h -> action h - Right path -> withFile path WriteMode action +pruneTree :: Tree c a -> Maybe (Eval.Tree c a) +pruneTree node = case node of + Node group xs -> Eval.Node group <$> prune xs + NodeWithCleanup loc action xs -> Eval.NodeWithCleanup loc action <$> prune xs + Leaf item -> Just (Eval.Leaf item) + where + prune = nonEmpty . pruneForest -isDumb :: IO Bool -isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" +type EvalItemTree = Tree (IO ()) EvalItem --- | Summary of a test run. -data Summary = Summary { - summaryExamples :: Int -, summaryFailures :: Int -} deriving (Eq, Show) +toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree] +toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused + where + toEvalItem :: Item () -> EvalItem + toEvalItem (Item requirement loc isParallelizable _isFocused _annotations e) = EvalItem { + evalItemDescription = requirement + , evalItemLocation = loc + , evalItemConcurrency = if isParallelizable == Just True then Concurrent else Sequential + , evalItemAction = \ progress -> measure $ e params withUnit progress + } -instance Monoid Summary where - mempty = Summary 0 0 - (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) + withUnit :: ActionWith () -> IO () + withUnit action = action () + +dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () +dumpFailureReport config seed qcArgs xs = do + writeFailureReport config FailureReport { + failureReportSeed = seed + , failureReportMaxSuccess = QC.maxSuccess qcArgs + , failureReportMaxSize = QC.maxSize qcArgs + , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs + , failureReportPaths = xs + } + +doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a +doNotLeakCommandLineArgumentsToExamples = withArgs [] + +withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a +withHiddenCursor progress h = case progress of + ProgressReportingDisabled -> id + ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h) + +data UseColor = ColorDisabled | ColorEnabled ProgressReporting + deriving (Eq, Show) + +data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled + deriving (Eq, Show) + +shouldUseColor :: UseColor -> Bool +shouldUseColor c = case c of + ColorDisabled -> False + ColorEnabled _ -> True + +progressReporting :: UseColor -> ProgressReporting +progressReporting c = case c of + ColorDisabled -> ProgressReportingDisabled + ColorEnabled r -> r + +colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor +colorOutputSupported mode isTerminalDevice = do + github <- githubActions + buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true") + let + progress :: ProgressReporting + progress + | github || buildkite = ProgressReportingDisabled + | otherwise = ProgressReportingEnabled + + colorEnabled :: UseColor + colorEnabled = ColorEnabled progress + case mode of + ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal + ColorNever -> return ColorDisabled + ColorAlways -> return colorEnabled + where + githubActions :: IO Bool + githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true") + + colorTerminal :: IO Bool + colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice + + noColor :: IO Bool + noColor = lookupEnv "NO_COLOR" <&> (/= Nothing) + +unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool +unicodeOutputSupported mode h = case mode of + UnicodeAuto -> Compat.unicodeOutputSupported h + UnicodeNever -> return False + UnicodeAlways -> return True + +rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool +rerunAll config mOldFailureReport result = case mOldFailureReport of + Nothing -> False + Just oldFailureReport -> + configRerunAllOnSuccess config + && configRerun config + && specResultSuccess result + && (not . null) (failureReportPaths oldFailureReport) + +randomizeForest :: Integer -> [Tree c a] -> [Tree c a] +randomizeForest seed t = runST $ do + ref <- newSTRef (mkStdGen $ fromIntegral seed) + shuffleForest ref t + +countEvalItems :: [Eval.Tree c a] -> Int +countEvalItems = getSum . foldMap (foldMap . const $ Sum 1) + +countSpecItems :: [Tree c a] -> Int +countSpecItems = getSum . foldMap (foldMap . const $ Sum 1) diff --git a/src/Test/Hspec/Core/Runner/Eval.hs b/src/Test/Hspec/Core/Runner/Eval.hs --- a/src/Test/Hspec/Core/Runner/Eval.hs +++ b/src/Test/Hspec/Core/Runner/Eval.hs @@ -1,166 +1,325 @@ {-# LANGUAGE CPP #-} - -#if MIN_VERSION_base(4,6,0) --- Control.Concurrent.QSem is deprecated in base-4.6.0.* -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} +module Test.Hspec.Core.Runner.Eval ( + EvalConfig(..) +, ColorMode(..) +, EvalTree +, Tree(..) +, EvalItem(..) +, Concurrency(..) +, runFormatter +#ifdef TEST +, mergeResults #endif - -module Test.Hspec.Core.Runner.Eval (runFormatter) where +) where import Prelude () -import Test.Hspec.Compat - -import Control.Monad (unless, when) -import qualified Control.Exception as E -import Control.Concurrent -import System.IO (Handle) +import Test.Hspec.Core.Compat hiding (Monad) import Control.Monad.IO.Class (liftIO) -import Control.DeepSeq (deepseq) -import Data.Time.Clock.POSIX +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec -import Test.Hspec.Config -import Test.Hspec.Core.Formatters -import Test.Hspec.Core.Formatters.Internal -import Test.Hspec.Timer +import Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) +import Test.Hspec.Core.Timer +import Test.Hspec.Core.Format (Format) +import qualified Test.Hspec.Core.Format as Format +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Example.Location +import Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) -type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) +import Test.Hspec.Core.Runner.JobQueue + +data Tree c a = + Node String (NonEmpty (Tree c a)) + | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a)) + | Leaf a + deriving (Eq, Show, Functor, Foldable, Traversable) + +data EvalConfig = EvalConfig { + evalConfigFormat :: Format +, evalConfigConcurrentJobs :: Int +, evalConfigFailFast :: Bool +, evalConfigColorMode :: ColorMode +} + +data ColorMode = ColorDisabled | ColorEnabled + +data Env = Env { + envConfig :: EvalConfig +, envAbort :: IORef Bool +, envResults :: IORef [(Path, Format.Item)] +} + +formatEvent :: Format.Event -> EvalM () +formatEvent event = do + format <- asks $ evalConfigFormat . envConfig + liftIO $ format event + +type EvalM = ReaderT Env IO + +abort :: EvalM () +abort = do + ref <- asks envAbort + liftIO $ writeIORef ref True + +shouldAbort :: EvalM Bool +shouldAbort = do + ref <- asks envAbort + liftIO $ readIORef ref + +addResult :: Path -> Format.Item -> EvalM () +addResult path item = do + ref <- asks envResults + liftIO $ modifyIORef ref ((path, item) :) + +reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM () +reportItem path loc action = do + reportItemStarted path + action >>= reportResult path loc + +reportItemStarted :: Path -> EvalM () +reportItemStarted = formatEvent . Format.ItemStarted + +reportItemDone :: Path -> Format.Item -> EvalM () +reportItemDone path item = do + addResult path item + formatEvent $ Format.ItemDone path item + +isFailure :: Result -> Bool +isFailure r = case resultStatus r of + Success{} -> False + Pending{} -> False + Failure{} -> True + +reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () +reportResult path loc (duration, result) = do + mode <- asks (evalConfigColorMode . envConfig) + case result of + Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of + Success -> Format.Success + Pending loc_ reason -> Format.Pending loc_ reason + Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err + Failure loc_ err -> Format.Failure loc_ $ case mode of + ColorEnabled -> err + ColorDisabled -> case err of + NoReason -> err + Reason _ -> err + ExpectedButGot _ _ _ -> err + ColorizedReason r -> Reason (stripAnsi r) +#if __GLASGOW_HASKELL__ < 900 + Error _ _ -> err +#endif + +groupStarted :: Path -> EvalM () +groupStarted = formatEvent . Format.GroupStarted + +groupDone :: Path -> EvalM () +groupDone = formatEvent . Format.GroupDone + +data EvalItem = EvalItem { + evalItemDescription :: String +, evalItemLocation :: Maybe Location +, evalItemConcurrency :: Concurrency +, evalItemAction :: ProgressCallback -> IO (Seconds, Result) +} + +type EvalTree = Tree (IO ()) EvalItem + -- | Evaluate all examples of a given spec and produce a report. -runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () -runFormatter jobsSem useColor h c formatter specs = do - headerFormatter formatter - chan <- liftIO newChan - reportProgress <- liftIO mkReportProgress - run chan reportProgress c formatter (toEvalTree specs) +runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] +runFormatter config specs = do + withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do + withTimer 0.05 $ \ timer -> do + env <- mkEnv + runningSpecs_ <- enqueueItems queue specs + + let + applyReportProgress :: RunningItem_ IO -> RunningItem IO + applyReportProgress item = fmap (. reportProgress timer) item + + runningSpecs :: [RunningTree () EvalM] + runningSpecs = applyCleanup abortEarly $ map (fmap applyReportProgress) runningSpecs_ + + abortEarly :: Result -> Bool + abortEarly result = evalConfigFailFast config && isFailure result + + getResults :: IO [(Path, Format.Item)] + getResults = reverse <$> readIORef (envResults env) + + formatItems :: IO () + formatItems = runReaderT (eval runningSpecs) env + + formatDone :: IO () + formatDone = getResults >>= format . Format.Done + + format Format.Started + formatItems `finally` formatDone + getResults where - mkReportProgress :: IO (Path -> Progress -> IO ()) - mkReportProgress - | useColor = every 0.05 $ exampleProgress formatter h - | otherwise = return $ \_ _ -> return () + mkEnv :: IO Env + mkEnv = Env config <$> newIORef False <*> newIORef [] - toEvalTree :: [SpecTree ()] -> [EvalTree] - toEvalTree = map (fmap f) - where - f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) - f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize jobsSem isParallelizable $ e params ($ ())) + format :: Format + format = evalConfigFormat config - params :: Params - params = Params (configQuickCheckArgs c) (configSmallCheckDepth c) + reportProgress :: IO Bool -> Path -> Progress -> IO () + reportProgress timer path progress = do + r <- timer + when r $ do + format (Format.Progress path progress) --- | 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) +data Item a = Item { + itemDescription :: String +, itemLocation :: Maybe Location +, itemAction :: a +} deriving Functor -type FormatResult = Either E.SomeException Result -> FormatM () +type RunningItem m = Item (Path -> m (Seconds, Result)) +type RunningTree c m = Tree c (RunningItem m) -parallelize :: QSem -> Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -parallelize jobsSem isParallelizable e - | isParallelizable = runParallel jobsSem e - | otherwise = runSequentially e +type RunningItem_ m = Item (Job m Progress (Seconds, Result)) +type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -runSequentially :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -runSequentially e reportProgress formatResult = return $ do - result <- liftIO $ evalExample (e reportProgress) - formatResult result +applyFailFast :: (Result -> Bool) -> RunningTree () IO -> RunningTree () EvalM +applyFailFast = fmap . fmap . fmap . applyToItem + where + applyToItem abortEarly action = do + result@(_, r) <- lift action + when (abortEarly r) abort + return result -data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) +applyCleanup :: (Result -> Bool) -> [RunningTree (IO ()) IO] -> [RunningTree () EvalM] +applyCleanup abortEarly = map (applyFailFast abortEarly . go) + where + go :: RunningTree (IO ()) IO -> RunningTree () IO + go t = case t of + Node label xs -> Node label (go <$> xs) + NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (applyCleanupAction abortEarly loc cleanup $ go <$> xs) + Leaf a -> Leaf a -runParallel :: QSem -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -runParallel jobsSem e reportProgress formatResult = do - mvar <- newEmptyMVar - _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do - let progressCallback = replaceMVar mvar . ReportProgress - result <- evalExample (e progressCallback) - replaceMVar mvar (ReportResult result) - return $ evalReport mvar +applyCleanupAction :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO) +applyCleanupAction abortEarly loc cleanup = forLastLeaf (addCleanupOn (not . abortEarly)) . forEachLeaf (addCleanupOn abortEarly) 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 + addCleanupOn p = addCleanupToItem p loc cleanup - replaceMVar :: MVar a -> a -> IO () - replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p +forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b) +forEachLeaf f = fmap (fmap f) -evalExample :: IO Result -> IO (Either E.SomeException Result) -evalExample e = safeTry $ forceResult <$> e +forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a) +forLastLeaf p = go where - forceResult :: Result -> Result - forceResult r = case r of - Success -> r - Pending m -> m `deepseq` r - Fail _ m -> m `deepseq` r + go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse -data Message = Done | Run (FormatM ()) + goNode node = case node of + Node description xs -> Node description (go xs) + NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs) + Leaf item -> Leaf (p item) -run :: Chan Message -> (Path -> ProgressCallback) -> Config -> Formatter -> [EvalTree] -> FormatM () -run chan reportProgress_ c formatter specs = do - liftIO $ do - forM_ specs (queueSpec []) - writeChan chan Done - processMessages (readChan chan) (configFastFail c) +mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a +mapHead f xs = case xs of + y :| ys -> f y :| ys + +addCleanupToItem :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> RunningItem IO -> RunningItem IO +addCleanupToItem shouldRunCleanup loc cleanup item = item { + itemAction = \ path -> do + result@(t1, r1) <- itemAction item path + if shouldRunCleanup r1 then do + (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success) + let t = t1 + t2 + return (t, mergeResults loc r1 r2) + else do + return result +} + +mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result +mergeResults mCallSite (Result info r1) r2 = Result info $ case (r1, r2) of + (_, Success) -> r1 + (Failure{}, _) -> r1 + (Pending{}, Pending{}) -> r1 + (Success, Pending{}) -> r2 + (_, Failure mLoc err) -> Failure (mLoc <|> hookLoc) $ case err of + Error message e -> Error (message <|> hookFailed) e + _ -> err where - defer :: FormatM () -> IO () - defer = writeChan chan . Run + hookLoc = snd <$> mCallSite + hookFailed = case mCallSite of + Just (name, _) -> Just $ "in " ++ name ++ "-hook:" + Nothing -> Nothing - runCleanup :: IO () -> Path -> FormatM () - runCleanup action path = do - r <- liftIO $ safeTry action - either (failed Nothing path . Left) return r +enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m] +enqueueItems queue = mapM (traverse $ enqueueItem queue) - queueSpec :: [String] -> EvalTree -> IO () - queueSpec rGroups (Node group xs) = do - defer (exampleGroupStarted formatter (reverse rGroups) group) - forM_ xs (queueSpec (group : rGroups)) - defer (exampleGroupDone formatter) - queueSpec rGroups (NodeWithCleanup action xs) = do - forM_ xs (queueSpec rGroups) - defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook")) - queueSpec rGroups (Leaf e) = - queueExample (reverse rGroups) e +enqueueItem :: MonadIO m => JobQueue -> EvalItem -> IO (RunningItem_ m) +enqueueItem queue EvalItem{..} = do + job <- enqueueJob queue evalItemConcurrency evalItemAction + return Item { + itemDescription = evalItemDescription + , itemLocation = evalItemLocation + , itemAction = job >=> liftIO . either exceptionToResult return + } + where + exceptionToResult :: SomeException -> IO (Seconds, Result) + exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err - queueExample :: [String] -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO () - queueExample groups (requirement, loc, e) = e reportProgress formatResult >>= defer +eval :: [RunningTree () EvalM] -> EvalM () +eval specs = do + sequenceActions (concatMap foldSpec specs) + where + foldSpec :: RunningTree () EvalM -> [EvalM ()] + foldSpec = foldTree FoldTree { + onGroupStarted = groupStarted + , onGroupDone = groupDone + , onCleanup = runCleanup + , onLeafe = evalItem + } + + runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM () + runCleanup _loc _groups = return + + evalItem :: [String] -> RunningItem EvalM -> EvalM () + evalItem groups (Item requirement loc action) = do + reportItem path loc $ action path where path :: Path path = (groups, requirement) - reportProgress = reportProgress_ path - - formatResult :: Either E.SomeException Result -> FormatM () - formatResult result = do - case result of - Right Success -> do - increaseSuccessCount - exampleSucceeded formatter path - Right (Pending reason) -> do - increasePendingCount - examplePending formatter path reason - Right (Fail loc_ err) -> failed (loc_ <|> loc) path (Right err) - Left err -> failed loc path (Left err) +data FoldTree c a r = FoldTree { + onGroupStarted :: Path -> r +, onGroupDone :: Path -> r +, onCleanup :: Maybe (String, Location) -> [String] -> c -> r +, onLeafe :: [String] -> a -> r +} - failed loc path err = do - increaseFailCount - addFailMessage loc path err - exampleFailed formatter path err +foldTree :: FoldTree c a r -> Tree c a -> [r] +foldTree FoldTree{..} = go [] + where + go rGroups (Node group xs) = start : children ++ [done] + where + path = (reverse rGroups, group) + start = onGroupStarted path + children = concatMap (go (group : rGroups)) xs + done = onGroupDone path + go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup] + where + children = concatMap (go rGroups) xs + cleanup = onCleanup loc (reverse rGroups) action + go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -processMessages :: IO Message -> Bool -> FormatM () -processMessages getMessage fastFail = go +sequenceActions :: [EvalM ()] -> EvalM () +sequenceActions = go where - go = liftIO getMessage >>= \m -> case m of - Run action -> do - action - fails <- getFailCount - unless (fastFail && fails /= 0) go - Done -> return () + go :: [EvalM ()] -> EvalM () + go [] = pass + go (action : actions) = do + action + shouldAbort >>= \ case + False -> go actions + True -> pass diff --git a/src/Test/Hspec/Core/Runner/JobQueue.hs b/src/Test/Hspec/Core/Runner/JobQueue.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Runner/JobQueue.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} + +module Test.Hspec.Core.Runner.JobQueue ( + MonadIO +, Job +, Concurrency(..) +, JobQueue +, withJobQueue +, enqueueJob +) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (Monad) +import qualified Test.Hspec.Core.Compat as M + +import Control.Concurrent +import Control.Concurrent.Async (Async, async, waitCatch, cancelMany) + +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.IO.Class as M + +-- for compatibility with GHC < 7.10.1 +type Monad m = (Functor m, Applicative m, M.Monad m) +type MonadIO m = (Monad m, M.MonadIO m) + +type Job m progress a = (progress -> m ()) -> m a + +data Concurrency = Sequential | Concurrent + +data JobQueue = JobQueue { + _semaphore :: Semaphore +, _cancelQueue :: CancelQueue +} + +data Semaphore = Semaphore { + _wait :: IO () +, _signal :: IO () +} + +type CancelQueue = IORef [Async ()] + +withJobQueue :: Int -> (JobQueue -> IO a) -> IO a +withJobQueue concurrency = bracket new cancelAll + where + new :: IO JobQueue + new = JobQueue <$> newSemaphore concurrency <*> newIORef [] + + cancelAll :: JobQueue -> IO () + cancelAll (JobQueue _ cancelQueue) = readIORef cancelQueue >>= cancelMany + +newSemaphore :: Int -> IO Semaphore +newSemaphore capacity = do + sem <- newQSem capacity + return $ Semaphore (waitQSem sem) (signalQSem sem) + +enqueueJob :: MonadIO m => JobQueue -> Concurrency -> Job IO progress a -> IO (Job m progress (Either SomeException a)) +enqueueJob (JobQueue sem cancelQueue) concurrency = case concurrency of + Sequential -> runSequentially cancelQueue + Concurrent -> runConcurrently sem cancelQueue + +runSequentially :: forall m progress a. MonadIO m => CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a)) +runSequentially cancelQueue action = do + barrier <- newEmptyMVar + let + wait :: IO () + wait = takeMVar barrier + + signal :: m () + signal = liftIO $ putMVar barrier () + + job <- runConcurrently (Semaphore wait pass) cancelQueue action + return $ \ notifyPartial -> signal >> job notifyPartial + +data Partial progress a = Partial progress | Done + +runConcurrently :: forall m progress a. MonadIO m => Semaphore -> CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a)) +runConcurrently (Semaphore wait signal) cancelQueue action = do + result :: MVar (Partial progress a) <- newEmptyMVar + let + worker :: IO a + worker = bracket_ wait signal $ do + interruptible (action partialResult) `finally` done + where + partialResult :: progress -> IO () + partialResult = replaceMVar result . Partial + + done :: IO () + done = replaceMVar result Done + + pushOnCancelQueue :: Async a -> IO () + pushOnCancelQueue = (modifyIORef cancelQueue . (:) . void) + + job <- bracket (async worker) pushOnCancelQueue return + + let + waitForResult :: (progress -> m ()) -> m (Either SomeException a) + waitForResult notifyPartial = do + r <- liftIO (takeMVar result) + case r of + Partial progress -> notifyPartial progress >> waitForResult notifyPartial + Done -> liftIO $ waitCatch job + + return waitForResult + +replaceMVar :: MVar a -> a -> IO () +replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p diff --git a/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs b/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Test.Hspec.Core.Runner.PrintSlowSpecItems ( + printSlowSpecItems +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.IO (stderr, hPutStrLn) + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Format + +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Formatters.V2 (formatLocation) + +data SlowItem = SlowItem { + location :: Maybe Location +, path :: Path +, duration :: Int +} + +printSlowSpecItems :: Int -> Format -> Format +printSlowSpecItems n format event = do + format event + case event of + Done items -> do + let xs = slowItems n $ map toSlowItem items + unless (null xs) $ do + hPutStrLn stderr "\nSlow spec items:" + mapM_ printSlowSpecItem xs + _ -> pass + +toSlowItem :: (Path, Item) -> SlowItem +toSlowItem (path, item) = SlowItem (itemLocation item) path (toMilliseconds $ itemDuration item) + +slowItems :: Int -> [SlowItem] -> [SlowItem] +slowItems n = take n . reverse . sortOn duration . filter ((/= 0) . duration) + +printSlowSpecItem :: SlowItem -> IO () +printSlowSpecItem SlowItem{..} = do + hPutStrLn stderr $ " " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)" diff --git a/src/Test/Hspec/Core/Runner/Result.hs b/src/Test/Hspec/Core/Runner/Result.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Runner/Result.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Runner.Result ( +-- RE-EXPORTED from Test.Hspec.Core.Runner + SpecResult(SpecResult) +, specResultItems +, specResultSuccess + +, ResultItem(ResultItem) +, resultItemPath +, resultItemStatus +, resultItemIsFailure + +, ResultItemStatus(..) + +, Summary(..) +, toSummary +, isSuccess +-- END RE-EXPORTED from Test.Hspec.Core.Runner + +, toSpecResult +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Util +import qualified Test.Hspec.Core.Format as Format + +-- | +-- @since 2.10.0 +data SpecResult = SpecResult { + -- | + -- @since 2.10.0 + specResultItems :: [ResultItem] + + -- | + -- @since 2.10.0 +, specResultSuccess :: !Bool +} deriving (Eq, Show) + +-- | +-- @since 2.10.0 +data ResultItem = ResultItem { + -- | + -- @since 2.10.0 + resultItemPath :: Path + + -- | + -- @since 2.10.0 +, resultItemStatus :: ResultItemStatus +} deriving (Eq, Show) + +-- | +-- @since 2.10.0 +resultItemIsFailure :: ResultItem -> Bool +resultItemIsFailure item = case resultItemStatus item of + ResultItemSuccess -> False + ResultItemPending -> False + ResultItemFailure -> True + +data ResultItemStatus = + ResultItemSuccess + | ResultItemPending + | ResultItemFailure + deriving (Eq, Show) + +toSpecResult :: [(Path, Format.Item)] -> SpecResult +toSpecResult results = SpecResult items success + where + items = map toResultItem results + success = all (not . resultItemIsFailure) items + +toResultItem :: (Path, Format.Item) -> ResultItem +toResultItem (path, item) = ResultItem path status + where + status = case Format.itemResult item of + Format.Success{} -> ResultItemSuccess + Format.Pending{} -> ResultItemPending + Format.Failure{} -> ResultItemFailure + +-- | Summary of a test run. +data Summary = Summary { + summaryExamples :: !Int +, summaryFailures :: !Int +} deriving (Eq, Show) + +instance Monoid Summary where + mempty = Summary 0 0 +#if MIN_VERSION_base(4,11,0) +instance Semigroup Summary where +#endif + (Summary x1 x2) +#if MIN_VERSION_base(4,11,0) + <> +#else + `mappend` +#endif + (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) + +toSummary :: SpecResult -> Summary +toSummary result = Summary { + summaryExamples = length items +, summaryFailures = length failures +} where + items = specResultItems result + failures = filter resultItemIsFailure items + +-- | `True` if the given `Summary` indicates that there were no +-- failures, `False` otherwise. +isSuccess :: Summary -> Bool +isSuccess summary = summaryFailures summary == 0 diff --git a/src/Test/Hspec/Core/Shuffle.hs b/src/Test/Hspec/Core/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Shuffle.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Shuffle ( + shuffleForest +#ifdef TEST +, shuffle +, mkArray +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat +import Test.Hspec.Core.Tree + +import System.Random +import Control.Monad.ST +import Data.STRef +import Data.Array.ST + +shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a] +shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) + +shuffleTree :: STRef st StdGen -> Tree c a -> ST st (Tree c a) +shuffleTree ref t = case t of + Node d xs -> Node d <$> shuffleForest ref xs + NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs + Leaf {} -> return t + +shuffle :: STRef st StdGen -> [a] -> ST st [a] +shuffle ref xs = do + arr <- mkArray xs + bounds@(_, n) <- getBounds arr + forM (range bounds) $ \ i -> do + j <- randomIndex (i, n) + vi <- readArray arr i + vj <- readArray arr j + writeArray arr j vi + return vj + where + randomIndex bounds = do + (a, gen) <- randomR bounds <$> readSTRef ref + writeSTRef ref gen + return a + +mkArray :: [a] -> ST st (STArray st Int a) +mkArray xs = newListArray (1, length xs) xs diff --git a/src/Test/Hspec/Core/Spec.hs b/src/Test/Hspec/Core/Spec.hs --- a/src/Test/Hspec/Core/Spec.hs +++ b/src/Test/Hspec/Core/Spec.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,8,1) -#define HAS_SOURCE_LOCATIONS -{-# LANGUAGE ImplicitParams #-} -#endif +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} -- | -- Stability: unstable -- @@ -11,38 +9,119 @@ module Test.Hspec.Core.Spec ( -- * Defining a spec - describe -, it + it +, specify +, describe +, context , pending , pendingWith +, xit +, xspecify +, xdescribe +, xcontext + +-- * Focused spec items #focus# +-- | +-- During a test run, when a spec contains /focused/ spec items, all other spec +-- items are ignored. +, focus +, fit +, fspecify +, fdescribe +, fcontext + , parallel +, sequential -- * The @SpecM@ monad -, module Test.Hspec.Core.Spec.Monad +, Test.Hspec.Core.Spec.Monad.Spec +, Test.Hspec.Core.Spec.Monad.SpecWith +, Test.Hspec.Core.Spec.Monad.SpecM(..) +, Test.Hspec.Core.Spec.Monad.runSpecM +, Test.Hspec.Core.Spec.Monad.fromSpecList +, Test.Hspec.Core.Spec.Monad.runIO +, Test.Hspec.Core.Spec.Monad.mapSpecForest +, Test.Hspec.Core.Spec.Monad.mapSpecItem +, Test.Hspec.Core.Spec.Monad.mapSpecItem_ +, Test.Hspec.Core.Spec.Monad.modifyParams +, Test.Hspec.Core.Spec.Monad.modifyConfig +, getSpecDescriptionPath -- * A type class for examples -, module Test.Hspec.Core.Example +, Test.Hspec.Core.Example.Example (..) +#ifndef ENABLE_SPEC_HOOK_ARGS +, Test.Hspec.Core.Example.Arg +#endif +, Test.Hspec.Core.Example.Params (..) +, Test.Hspec.Core.Example.defaultParams +, Test.Hspec.Core.Example.ActionWith +, Test.Hspec.Core.Example.Progress +, Test.Hspec.Core.Example.ProgressCallback +, Test.Hspec.Core.Example.Result(..) +, Test.Hspec.Core.Example.ResultStatus (..) +, Test.Hspec.Core.Example.Location (..) +, Test.Hspec.Core.Example.FailureReason (..) +, Test.Hspec.Core.Example.safeEvaluate +, Test.Hspec.Core.Example.safeEvaluateExample -- * Internal representation of a spec tree -, module Test.Hspec.Core.Tree +, Test.Hspec.Core.Tree.SpecTree +, Test.Hspec.Core.Tree.Tree (..) +, Test.Hspec.Core.Tree.Item (..) +, Test.Hspec.Core.Tree.specGroup +, Test.Hspec.Core.Tree.specItem +, Test.Hspec.Core.Tree.bimapTree +, Test.Hspec.Core.Tree.bimapForest +, Test.Hspec.Core.Tree.filterTree +, Test.Hspec.Core.Tree.filterForest +, Test.Hspec.Core.Tree.filterTreeWithLabels +, Test.Hspec.Core.Tree.filterForestWithLabels +, Test.Hspec.Core.Tree.pruneTree -- unused +, Test.Hspec.Core.Tree.pruneForest -- unused +, Test.Hspec.Core.Tree.location + +, focusForest + +-- * Re-exports +, HasCallStack +, Expectation ) where -#ifdef HAS_SOURCE_LOCATIONS -import GHC.Stack -#endif +import Prelude () +import Test.Hspec.Core.Compat -import qualified Control.Exception as E +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (asks) import Test.Hspec.Expectations (Expectation) import Test.Hspec.Core.Example +import Test.Hspec.Core.Hooks import Test.Hspec.Core.Tree import Test.Hspec.Core.Spec.Monad +import Test.Hspec.Core.QuickCheck () -- | The @describe@ function combines a list of specs into a larger spec. -describe :: String -> SpecWith a -> SpecWith a -describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label +describe :: HasCallStack => String -> SpecWith a -> SpecWith a +describe label = withEnv pushLabel . mapSpecForest (return . specGroup label) + where + pushLabel (Env labels) = Env $ label : labels +-- | @context@ is an alias for `describe`. +context :: HasCallStack => String -> SpecWith a -> SpecWith a +context = describe + +-- | +-- Changing `describe` to `xdescribe` marks all spec items of the corresponding subtree as pending. +-- +-- This can be used to temporarily disable spec items. +xdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a +xdescribe label spec = before_ pending_ $ describe label spec + +-- | @xcontext@ is an alias for `xdescribe`. +xcontext :: HasCallStack => String -> SpecWith a -> SpecWith a +xcontext = xdescribe + -- | The @it@ function creates a spec item. -- -- A spec item consists of: @@ -54,19 +133,75 @@ -- > describe "absolute" $ do -- > it "returns a positive number when given a negative number" $ -- > absolute (-1) == 1 -#ifdef HAS_SOURCE_LOCATIONS -it :: (?loc :: CallStack, Example a) => String -> a -> SpecWith (Arg a) -#else -it :: Example a => String -> a -> SpecWith (Arg a) -#endif +-- +-- @`Example` a@ optionally accepts an argument @`Arg` a@, which is then given +-- to the test body. This is useful for provisioning resources for a test which +-- are created and cleaned up outside the test itself. See `Arg` for details. +-- +-- Note that this function is often on the scene of nasty type errors due to GHC failing +-- to infer the type of @do@ notation in the test body. +-- It can be helpful to use +-- [TypeApplications](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html) +-- to explicitly specify the intended `Example` type. +it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it label action = fromSpecList [specItem label action] +-- | @specify@ is an alias for `it`. +specify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +specify = it + +-- | +-- Changing `it` to `xit` marks the corresponding spec item as pending. +-- +-- This can be used to temporarily disable a spec item. +xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +xit label action = before_ pending_ $ it label action + +-- | @xspecify@ is an alias for `xit`. +xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +xspecify = xit + +-- | `focus` focuses all spec items of the given spec. +-- +-- Applying `focus` to a spec with focused spec items has no effect. +focus :: SpecWith a -> SpecWith a +focus = mapSpecForest focusForest + +-- | Marks an entire spec forest as focused if nothing in it is already focused. +focusForest :: [SpecTree a] -> [SpecTree a] +focusForest xs + | any (any itemIsFocused) xs = xs + | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs + +-- | @fit@ is an alias for @fmap focus . it@ +fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +fit = fmap focus . it + +-- | @fspecify@ is an alias for `fit`. +fspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +fspecify = fit + +-- | @fdescribe@ is an alias for @fmap focus . describe@ +fdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a +fdescribe = fmap focus . describe + +-- | @fcontext@ is an alias for `fdescribe`. +fcontext :: HasCallStack => String -> SpecWith a -> SpecWith a +fcontext = fdescribe + -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a -parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True} +parallel = mapSpecItem_ (setParallelizable True) --- | `pending` can be used to indicate that an example is /pending/. +-- | `sequential` marks all spec items of the given spec to be evaluated sequentially. +sequential :: SpecWith a -> SpecWith a +sequential = mapSpecItem_ (setParallelizable False) + +setParallelizable :: Bool -> Item a -> Item a +setParallelizable value item = item {itemIsParallelizable = itemIsParallelizable item <|> Just value} + +-- | `pending` can be used to mark a spec item as pending. -- -- If you want to textually specify a behavior but do not have an example yet, -- use this: @@ -74,11 +209,30 @@ -- > describe "fancyFormatter" $ do -- > it "can format text in a way that everyone likes" $ -- > pending -pending :: Expectation -pending = E.throwIO (Pending Nothing) +pending :: HasCallStack => Expectation +pending = throwIO (Pending location Nothing) +pending_ :: Expectation +pending_ = (throwIO (Pending Nothing Nothing)) + -- | -- `pendingWith` is similar to `pending`, but it takes an additional string --- argument that can be used to specify the reason for why it's pending. -pendingWith :: String -> Expectation -pendingWith = E.throwIO . Pending . Just +-- argument that can be used to specify the reason for why the spec item is pending. +pendingWith :: HasCallStack => String -> Expectation +pendingWith = throwIO . Pending location . Just + +-- | Get the path of `describe` labels, from the root all the way in to the +-- call-site of this function. +-- +-- ==== __Example__ +-- >>> :{ +-- runSpecM $ do +-- describe "foo" $ do +-- describe "bar" $ do +-- getSpecDescriptionPath >>= runIO . print +-- :} +-- ["foo","bar"] +-- +-- @since 2.10.0 +getSpecDescriptionPath :: SpecM a [String] +getSpecDescriptionPath = SpecM $ lift $ reverse <$> asks envSpecDescriptionPath diff --git a/src/Test/Hspec/Core/Spec/Monad.hs b/src/Test/Hspec/Core/Spec/Monad.hs --- a/src/Test/Hspec/Core/Spec/Monad.hs +++ b/src/Test/Hspec/Core/Spec/Monad.hs @@ -1,47 +1,88 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Spec , SpecWith -, SpecM (..) +, SpecM (SpecM) , runSpecM , fromSpecList , runIO -, mapSpecTree +, mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams + +, modifyConfig +-- END RE-EXPORTED from Test.Hspec.Core.Spec + +, Env(..) +, withEnv ) where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat -import Control.Monad.Trans.Writer import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer import Test.Hspec.Core.Example import Test.Hspec.Core.Tree +import Test.Hspec.Core.Config.Definition (Config) + +-- | A `SpecWith` that can be evaluated directly by the +-- `Test.Hspec.Core.Runner.hspec` function as it does not require any +-- parameters. type Spec = SpecWith () +-- | A @'SpecWith' a@ represents a test or group of tests that require an @a@ +-- value to run. +-- +-- In the common case, a 'Spec' is a @'SpecWith' ()@ which requires @()@ and +-- can thus be executed with `Test.Hspec.Core.Runner.hspec'. +-- +-- To supply an argument to `SpecWith` tests to turn them into `Spec`, use +-- functions from "Test.Hspec.Core.Hooks" such as +-- `Test.Hspec.Core.Hooks.around`, `Test.Hspec.Core.Hooks.before', +-- `Test.Hspec.Core.Hooks.mapSubject' and similar. +-- +-- Values of this type are created by `Test.Hspec.Core.Spec.it`, +-- `Test.Hspec.Core.Spec.describe` and similar. type SpecWith a = SpecM a () --- | A writer monad for `SpecTree` forests -newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r) +-- | +-- @since 2.10.0 +modifyConfig :: (Config -> Config) -> SpecWith a +modifyConfig f = SpecM $ tell (Endo f, mempty) + +-- | A writer monad for `SpecTree` forests. +-- +-- This is used by `Test.Hspec.Core.Spec.describe` and is used +-- to construct the forest of spec items. +-- +-- It allows for dynamically generated spec trees, for example, by using data +-- obtained by performing IO actions with 'runIO'. +newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r } deriving (Functor, Applicative, Monad) -- | Convert a `Spec` to a forest of `SpecTree`s. -runSpecM :: SpecWith a -> IO [SpecTree a] -runSpecM (SpecM specs) = execWriterT specs +runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a]) +runSpecM = flip runReaderT (Env []) . execWriterT . unSpecM -- | Create a `Spec` from a forest of `SpecTree`s. +fromSpecForest :: (Endo Config, [SpecTree a]) -> SpecWith a +fromSpecForest = SpecM . tell + +-- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a -fromSpecList = SpecM . tell +fromSpecList = fromSpecForest . (,) mempty -- | Run an IO action while constructing the spec tree. -- -- `SpecM` is a monad to construct a spec tree, without executing any spec --- items. @runIO@ allows you to run IO actions during this construction phase. +-- items itself. @runIO@ allows you to run IO actions during this construction phase. -- The IO action is always run when the spec tree is constructed (e.g. even -- when @--dry-run@ is specified). -- If you do not need the result of the IO action to construct the spec tree, @@ -49,19 +90,30 @@ runIO :: IO r -> SpecM a r runIO = SpecM . liftIO -mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecWith a -> SpecWith b -mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f +mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r +mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs) +-- {-# DEPRECATED mapSpecItem "Use `mapSpecItem_` instead." #-} +-- | Deprecated: Use `mapSpecItem_` instead. mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b -mapSpecItem g f = mapSpecTree go - where - go spec = case spec of - Node d xs -> Node d (map go xs) - NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs) - Leaf item -> Leaf (f item) +mapSpecItem _ = mapSpecItem_ -mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a -mapSpecItem_ = mapSpecItem id +mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b +mapSpecItem_ = mapSpecForest . bimapForest id +-- | Modifies the `Params` on the spec items to be generated by `SpecWith`. modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} + +newtype Env = Env { + -- | The path of _parent_ `Hspec.Core.Spec.describe` labels from innermost to + -- outermost. + envSpecDescriptionPath :: [String] +} + +-- | Applies a function to modify the `Env` of items being written by a child +-- spec writer. +-- +-- This is used to implement `Hspec.Core.Spec.describe`. +withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r +withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM diff --git a/src/Test/Hspec/Core/Timer.hs b/src/Test/Hspec/Core/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Timer.hs @@ -0,0 +1,20 @@ +module Test.Hspec.Core.Timer (withTimer) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Concurrent.Async + +import Test.Hspec.Core.Clock + +withTimer :: Seconds -> (IO Bool -> IO a) -> IO a +withTimer delay action = do + ref <- newIORef False + bracket (async $ worker delay ref) cancel $ \_ -> do + action $ atomicModifyIORef ref (\a -> (False, a)) + +worker :: Seconds -> IORef Bool -> IO () +worker delay ref = do + forever $ do + sleep delay + atomicWriteIORef ref True diff --git a/src/Test/Hspec/Core/Tree.hs b/src/Test/Hspec/Core/Tree.hs --- a/src/Test/Hspec/Core/Tree.hs +++ b/src/Test/Hspec/Core/Tree.hs @@ -1,62 +1,99 @@ {-# LANGUAGE DeriveFunctor #-} - -{-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,8,1) -#define HAS_SOURCE_LOCATIONS -{-# LANGUAGE ImplicitParams #-} -#endif +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} --- | --- Stability: unstable module Test.Hspec.Core.Tree ( +-- RE-EXPORTED from Test.Hspec.Core.Spec SpecTree , Tree (..) , Item (..) , specGroup , specItem -) where +, bimapTree +, bimapForest +, filterTree +, filterForest +, filterTreeWithLabels +, filterForestWithLabels +, pruneTree -- unused +, pruneForest -- unused +, location +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, callSite +, formatDefaultDescription +, toModuleName -#ifdef HAS_SOURCE_LOCATIONS -#if !MIN_VERSION_base(4,9,0) -import GHC.SrcLoc -#endif -import GHC.Stack -#endif +, setItemAnnotation +, getItemAnnotation +) where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat +import Data.Char +import System.FilePath +import qualified Data.CallStack as CallStack + import Test.Hspec.Core.Example +import Test.Hspec.Core.Annotations (Annotations) +import qualified Test.Hspec.Core.Annotations as Annotations -- | Internal tree data structure data Tree c a = Node String [Tree c a] - | NodeWithCleanup c [Tree c a] + | NodeWithCleanup (Maybe (String, Location)) c [Tree c a] | Leaf a - deriving Functor + deriving (Eq, Show, Functor, Foldable, Traversable) -instance Foldable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance - foldMap = go - where - go :: Monoid m => (a -> m) -> Tree c a -> m - go f t = case t of - Node _ xs -> foldMap (foldMap f) xs - NodeWithCleanup _ xs -> foldMap (foldMap f) xs - Leaf x -> f x +-- | A tree is used to represent a spec internally. The tree is parameterized +-- over the type of cleanup actions and the type of the actual spec items. +type SpecTree a = Tree (IO ()) (Item a) -instance Traversable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance - sequenceA = go - where - go :: Applicative f => Tree c (f a) -> f (Tree c a) - go t = case t of - Node label xs -> Node label <$> sequenceA (map go xs) - NodeWithCleanup action xs -> NodeWithCleanup action <$> sequenceA (map go xs) - Leaf a -> Leaf <$> a +bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] +bimapForest g f = map (bimapTree g f) --- | A tree is used to represent a spec internally. The tree is parametrize --- over the type of cleanup actions and the type of the actual spec items. -type SpecTree a = Tree (ActionWith a) (Item a) +bimapTree :: (a -> b) -> (c -> d) -> Tree a c -> Tree b d +bimapTree g f = go + where + go spec = case spec of + Node d xs -> Node d (map go xs) + NodeWithCleanup loc action xs -> NodeWithCleanup loc (g action) (map go xs) + Leaf item -> Leaf (f item) +filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTree = filterTreeWithLabels . const + +filterForest :: (a -> Bool) -> [Tree c a] -> [Tree c a] +filterForest = filterForestWithLabels . const + +filterTreeWithLabels :: ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTreeWithLabels = filterTree_ [] + +filterForestWithLabels :: ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] +filterForestWithLabels = filterForest_ [] + +filterForest_ :: [String] -> ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] +filterForest_ groups = mapMaybe . filterTree_ groups + +filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTree_ groups p tree = case tree of + Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs + NodeWithCleanup loc action xs -> Just $ NodeWithCleanup loc action $ filterForest_ groups p xs + Leaf item -> Leaf <$> guarded (p groups) item + +pruneForest :: [Tree c a] -> [Tree c a] +pruneForest = mapMaybe pruneTree + +pruneTree :: Tree c a -> Maybe (Tree c a) +pruneTree node = case node of + Node group xs -> Node group <$> prune xs + NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs + Leaf{} -> Just node + where + prune = guarded (not . null) . pruneForest + -- | -- @Item@ is used to represent spec items internally. A spec item consists of: -- @@ -68,42 +105,71 @@ -- example, including QuickCheck properties, Hspec expectations and HUnit -- assertions. data Item a = Item { + -- | Textual description of behavior itemRequirement :: String + -- | Source location of the spec item , itemLocation :: Maybe Location + -- | A flag that indicates whether it is safe to evaluate this spec item in -- parallel with other spec items -, itemIsParallelizable :: Bool +, itemIsParallelizable :: Maybe Bool + + -- | A flag that indicates whether this spec item is focused +, itemIsFocused :: Bool + + -- | Arbitrary additional data that can be used by third-party extensions. + -- + -- @since 2.12.0 +, itemAnnotations :: Annotations + -- | Example for behavior , itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } +setItemAnnotation :: Typeable value => value -> Item a -> Item a +setItemAnnotation value config = config { itemAnnotations = Annotations.setValue value $ itemAnnotations config } + +getItemAnnotation :: Typeable value => Item a -> Maybe value +getItemAnnotation = Annotations.getValue . itemAnnotations + -- | The @specGroup@ function combines a list of specs into a larger spec. -specGroup :: String -> [SpecTree a] -> SpecTree a +specGroup :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg where + msg :: HasCallStack => String msg - | null s = "(no description given)" + | null s = maybe "(no description given)" formatDefaultDescription location | otherwise = s -- | The @specItem@ function creates a spec item. -#ifdef HAS_SOURCE_LOCATIONS -specItem :: (?loc :: CallStack, Example a) => String -> a -> SpecTree (Arg a) -#else -specItem :: Example a => String -> a -> SpecTree (Arg a) -#endif -specItem s e = Leaf $ Item requirement location False (evaluateExample e) - where - requirement - | null s = "(unspecified behavior)" - | otherwise = s +specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e) +specItem s e = Leaf Item { + itemRequirement = s + , itemLocation = location + , itemIsParallelizable = Nothing + , itemIsFocused = False + , itemAnnotations = mempty + , itemExample = safeEvaluateExample e + } - location :: Maybe Location -#ifdef HAS_SOURCE_LOCATIONS - location = case reverse (getCallStack ?loc) of - (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation) - _ -> Nothing -#else - location = Nothing -#endif +location :: HasCallStack => Maybe Location +location = snd <$> callSite + +callSite :: HasCallStack => Maybe (String, Location) +callSite = fmap toLocation <$> CallStack.callSite + +formatDefaultDescription :: Location -> String +formatDefaultDescription loc = toModuleName (locationFile loc) ++ "[" ++ show (locationLine loc) ++ ":" ++ show (locationColumn loc) ++ "]" + +toModuleName :: FilePath -> String +toModuleName = intercalate "." . reverse . takeWhile isModuleNameComponent . reverse . splitDirectories . dropExtension + +isModuleNameComponent :: String -> Bool +isModuleNameComponent name = case name of + x : xs -> isUpper x && all isIdChar xs + _ -> False + +isIdChar :: Char -> Bool +isIdChar c = isAlphaNum c || c == '_' || c == '\'' diff --git a/src/Test/Hspec/Core/Util.hs b/src/Test/Hspec/Core/Util.hs --- a/src/Test/Hspec/Core/Util.hs +++ b/src/Test/Hspec/Core/Util.hs @@ -1,27 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions pluralize , strip , lineBreaksAt +, stripAnsi -- * Working with paths , Path +, joinPath , formatRequirement , filterPredicate --- * Working with exception +-- * Working with exceptions , safeTry , formatException +, formatExceptionWith ) where -import Data.List +import Prelude () +import Test.Hspec.Core.Compat hiding (join) + import Data.Char (isSpace) + +#ifndef __MHS__ import GHC.IO.Exception -import Control.Exception -import Control.Concurrent.Async +#else +import System.IO.Error +#endif -import Test.Hspec.Compat (showType) +import Control.Concurrent.Async -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given @@ -37,22 +47,30 @@ -- -- >>> pluralize 2 "example" -- "2 examples" +-- +-- @since 2.0.0 pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s" -- | Strip leading and trailing whitespace +-- +-- @since 2.0.0 strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse -- | --- ensure that lines are not longer then given `n`, insert line breaks at word +-- Ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries +-- +-- @since 2.0.0 lineBreaksAt :: Int -> String -> [String] -lineBreaksAt n input = case words input of - [] -> [] - x:xs -> go (x, xs) +lineBreaksAt n = concatMap f . lines where + f input = case words input of + [] -> [] + x:xs -> go (x, xs) + go :: (String, [String]) -> [String] go c = case c of (s, []) -> [s] @@ -62,14 +80,45 @@ else s : go (y, ys) -- | --- A `Path` represents the location of an example within the spec tree. +-- Remove ANSI color escape sequences. -- +-- @since 2.11.0 +stripAnsi :: String -> String +stripAnsi = go + where + go :: String -> String + go input = case input of + '\ESC' : '[' : (parameters -> 'm' : xs) -> go xs + x : xs -> x : go xs + [] -> [] + + parameters :: String -> String + parameters = dropWhile p + where + p :: Char -> Bool + p c = c >= '0' && c <= '9' || c == ';' + +-- | +-- A `Path` describes the location of a spec item within a spec tree. +-- -- It consists of a list of group descriptions and a requirement description. +-- +-- @since 2.0.0 type Path = ([String], String) -- | +-- Join a `Path` with slashes. The result will have a leading and a trailing +-- slash. +-- +-- @since 2.5.4 +joinPath :: Path -> String +joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/" + +-- | -- Try to create a proper English sentence from a path by applying some -- heuristics. +-- +-- @since 2.0.0 formatRequirement :: Path -> String formatRequirement (groups, requirement) = groups_ ++ requirement where @@ -82,12 +131,14 @@ ys -> concatMap (++ ", ") ys -- | A predicate that can be used to filter a spec tree. +-- +-- @since 2.0.0 filterPredicate :: String -> Path -> Bool -filterPredicate pattern path@(groups, requirement) = - pattern `isInfixOf` plain - || pattern `isInfixOf` formatted +filterPredicate pattern_ path = + pattern_ `isInfixOf` plain + || pattern_ `isInfixOf` formatted where - plain = intercalate "/" (groups ++ [requirement]) + plain = joinPath path formatted = formatRequirement path -- | The function `formatException` converts an exception to a string. @@ -95,13 +146,19 @@ -- This is different from `show`. The type of the exception is included, e.g.: -- -- >>> formatException (toException DivideByZero) --- "ArithException (divide by zero)" +-- "ArithException\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well. +-- +-- @since 2.0.0 formatException :: SomeException -> String -formatException err@(SomeException e) = case fromException err of - Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")" - Nothing -> showType e ++ " (" ++ show e ++ ")" +formatException = formatExceptionWith show + +-- | @since 2.11.5 +formatExceptionWith :: (SomeException -> String) -> SomeException -> String +formatExceptionWith showException err = case fromException err of + Nothing -> showExceptionType err ++ "\n" ++ showException err + Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ showException (toException ioe) where showIOErrorType :: IOException -> String showIOErrorType ioe = case ioe_type ioe of @@ -125,8 +182,13 @@ ResourceVanished -> "ResourceVanished" Interrupted -> "Interrupted" +showExceptionType :: SomeException -> String +showExceptionType (SomeException e) = showType e + -- | @safeTry@ evaluates given action and returns its result. If an exception -- occurs, the exception is returned instead. Unlike `try` it is agnostic to -- asynchronous exceptions. +-- +-- @since 2.0.0 safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch diff --git a/src/Test/Hspec/FailureReport.hs b/src/Test/Hspec/FailureReport.hs deleted file mode 100644 --- a/src/Test/Hspec/FailureReport.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE CPP #-} -module Test.Hspec.FailureReport ( - FailureReport (..) -, writeFailureReport -, readFailureReport -) where - -#ifndef __GHCJS__ -import System.SetEnv -import Test.Hspec.Core.Util (safeTry) -#endif -import System.IO -import Test.Hspec.Compat -import Test.Hspec.Core.Util (Path) - -data FailureReport = FailureReport { - failureReportSeed :: Integer -, failureReportMaxSuccess :: Int -, failureReportMaxSize :: Int -, failureReportMaxDiscardRatio :: Int -, failureReportPaths :: [Path] -} deriving (Eq, Show, Read) - -writeFailureReport :: FailureReport -> IO () -#ifdef __GHCJS__ -writeFailureReport _ = return () - -- ghcjs currently does not support setting environment variables - -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report - -- into the environment is a non-essential feature we just disable this to be - -- able to run hspec test-suites with ghcjs at all. Should be reverted once - -- the issue is fixed. -#else -writeFailureReport x = do - -- on Windows this can throw an exception when the input is too large, hence - -- we use `safeTry` here - safeTry (setEnv "HSPEC_FAILURES" $ show x) >>= either onError return - where - onError err = do - hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") -#endif - -readFailureReport :: IO (Maybe FailureReport) -readFailureReport = do - mx <- lookupEnv "HSPEC_FAILURES" - case mx >>= readMaybe of - Nothing -> do - hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!" - return Nothing - x -> return x diff --git a/src/Test/Hspec/Options.hs b/src/Test/Hspec/Options.hs deleted file mode 100644 --- a/src/Test/Hspec/Options.hs +++ /dev/null @@ -1,198 +0,0 @@ -module Test.Hspec.Options ( - Config(..) -, ColorMode (..) -, defaultConfig -, filterOr -, parseOptions -) where - -import Prelude () -import Control.Monad -import Test.Hspec.Compat - -import System.IO -import System.Exit -import System.Console.GetOpt - -import Test.Hspec.Core.Formatters -import Test.Hspec.Core.Util -import Test.Hspec.Core.Example (Params(..), defaultParams) - -data Config = Config { - configDryRun :: Bool -, configPrintCpuTime :: Bool -, configFastFail :: Bool - --- | --- A predicate that is used to filter the spec before it is run. Only examples --- that satisfy the predicate are run. -, configRerun :: Bool -, configFilterPredicate :: Maybe (Path -> Bool) -, configSkipPredicate :: Maybe (Path -> Bool) -, configQuickCheckSeed :: Maybe Integer -, configQuickCheckMaxSuccess :: Maybe Int -, configQuickCheckMaxDiscardRatio :: Maybe Int -, configQuickCheckMaxSize :: Maybe Int -, configSmallCheckDepth :: Int -, configColorMode :: ColorMode -, configFormatter :: Maybe Formatter -, configHtmlOutput :: Bool -, configOutputFile :: Either Handle FilePath -, configConcurrentJobs :: Maybe Int -} - -defaultConfig :: Config -defaultConfig = Config { - configDryRun = False -, configPrintCpuTime = False -, configFastFail = False -, configRerun = False -, configFilterPredicate = Nothing -, configSkipPredicate = Nothing -, configQuickCheckSeed = Nothing -, configQuickCheckMaxSuccess = Nothing -, configQuickCheckMaxDiscardRatio = Nothing -, configQuickCheckMaxSize = Nothing -, configSmallCheckDepth = paramsSmallCheckDepth defaultParams -, configColorMode = ColorAuto -, configFormatter = Nothing -, configHtmlOutput = False -, configOutputFile = Left stdout -, configConcurrentJobs = Nothing -} - -filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool) -filterOr p1_ p2_ = case (p1_, p2_) of - (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path - _ -> p1_ <|> p2_ - -addMatch :: String -> Config -> Config -addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} - -addSkip :: String -> Config -> Config -addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} - -setDepth :: Int -> Config -> Config -setDepth n c = c {configSmallCheckDepth = n} - -setMaxSuccess :: Int -> Config -> Config -setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} - -setMaxSize :: Int -> Config -> Config -setMaxSize n c = c {configQuickCheckMaxSize = Just n} - -setMaxDiscardRatio :: Int -> Config -> Config -setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} - -setSeed :: Integer -> Config -> Config -setSeed n c = c {configQuickCheckSeed = Just n} - -data ColorMode = ColorAuto | ColorNever | ColorAlways - deriving (Eq, Show) - -formatters :: [(String, Formatter)] -formatters = [ - ("specdoc", specdoc) - , ("progress", progress) - , ("failed-examples", failed_examples) - , ("silent", silent) - ] - -formatHelp :: String -formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters) - -type Result = Either NoConfig Config - -data NoConfig = Help | InvalidArgument String String - -data Arg a = Arg { - _argumentName :: String -, _argumentParser :: String -> Maybe a -, _argumentSetter :: a -> Config -> Config -} - -mkOption :: [Char] -> String -> Arg a -> String -> OptDescr (Result -> Result) -mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help - where - arg :: String -> Result -> Result - arg input x = x >>= \c -> case parser input of - Just n -> Right (setter n c) - Nothing -> Left (InvalidArgument name input) - -addLineBreaks :: String -> [String] -addLineBreaks = lineBreaksAt 44 - -options :: [OptDescr (Result -> Result)] -options = [ - Option [] ["help"] (NoArg (const $ Left Help)) (h "display this help and exit") - , mkOption "m" "match" (Arg "PATTERN" return addMatch) (h "only run examples that match given PATTERN") - , mkOption [] "skip" (Arg "PATTERN" return addSkip) (h "skip examples that match given PATTERN") - , Option [] ["color"] (NoArg setColor) (h "colorize the output") - , Option [] ["no-color"] (NoArg setNoColor) (h "do not colorize the output") - , mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) formatHelp - , mkOption "o" "out" (Arg "FILE" return setOutputFile) (h "write output to a file instead of STDOUT") - , mkOption [] "depth" (Arg "N" readMaybe setDepth) (h "maximum depth of generated test values for SmallCheck properties") - , mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) (h "maximum number of successful tests before a QuickCheck property succeeds") - , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) (h "size to use for the biggest test cases") - , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up") - , mkOption [] "seed" (Arg "N" readMaybe setSeed) (h "used seed for QuickCheck properties") - , Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) (h "include used CPU time in summary") - , Option [] ["dry-run"] (NoArg setDryRun) (h "pretend that everything passed; don't verify anything") - , Option [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") - , Option "r" ["rerun"] (NoArg setRerun) (h "rerun all examples that failed in the previously test run (only works in GHCi)") - , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) (h "run at most N parallelizable tests simultaneously (default: number of available processors)") - ] - where - h = unlines . addLineBreaks - - readFormatter :: String -> Maybe Formatter - readFormatter = (`lookup` formatters) - - readMaxJobs :: String -> Maybe Int - readMaxJobs s = do - n <- readMaybe s - guard $ n > 0 - return n - - setFormatter :: Formatter -> Config -> Config - setFormatter f c = c {configFormatter = Just f} - - setOutputFile :: String -> Config -> Config - setOutputFile file c = c {configOutputFile = Right file} - - setMaxJobs :: Int -> Config -> Config - setMaxJobs n c = c {configConcurrentJobs = Just n} - - setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True} - setDryRun x = x >>= \c -> return c {configDryRun = True} - setFastFail x = x >>= \c -> return c {configFastFail = True} - setRerun x = x >>= \c -> return c {configRerun = True} - setNoColor x = x >>= \c -> return c {configColorMode = ColorNever} - setColor x = x >>= \c -> return c {configColorMode = ColorAlways} - -undocumentedOptions :: [OptDescr (Result -> Result)] -undocumentedOptions = [ - -- for compatibility with test-framework - mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" - - -- undocumented for now, as we probably want to change this to produce a - -- standalone HTML report in the future - , Option [] ["html"] (NoArg setHtml) "produce HTML output" - - -- now a noop - , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" - ] - where - setHtml :: Result -> Result - setHtml x = x >>= \c -> return c {configHtmlOutput = True} - -parseOptions :: Config -> String -> [String] -> Either (ExitCode, String) Config -parseOptions c prog args = case getOpt Permute (options ++ undocumentedOptions) args of - (opts, [], []) -> case foldl' (flip id) (Right c) opts of - Left Help -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") options) - Left (InvalidArgument flag value) -> tryHelp ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n") - Right x -> Right x - (_, _, err:_) -> tryHelp err - (_, arg:_, _) -> tryHelp ("unexpected argument `" ++ arg ++ "'\n") - where - tryHelp msg = Left (ExitFailure 1, prog ++ ": " ++ msg ++ "Try `" ++ prog ++ " --help' for more information.\n") diff --git a/src/Test/Hspec/Timer.hs b/src/Test/Hspec/Timer.hs deleted file mode 100644 --- a/src/Test/Hspec/Timer.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Test.Hspec.Timer where - -import Data.IORef -import Data.Time.Clock.POSIX - -newTimer :: POSIXTime -> IO (IO Bool) -newTimer delay = do - ref <- getPOSIXTime >>= newIORef - return $ do - t0 <- readIORef ref - t1 <- getPOSIXTime - if delay < t1 - t0 - then writeIORef ref t1 >> return True - else return False diff --git a/test/GetOpt/Declarative/EnvironmentSpec.hs b/test/GetOpt/Declarative/EnvironmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/GetOpt/Declarative/EnvironmentSpec.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +module GetOpt.Declarative.EnvironmentSpec (spec) where + +import Prelude () +import Helper + +import GetOpt.Declarative.Types +import GetOpt.Declarative.Environment + +spec :: Spec +spec = do + describe "parseEnvironmentOption" $ do + context "with NoArg" $ do + let + option :: Option Bool + option = Option { + optionName = "some-flag" + , optionSetter = NoArg $ const True + } + it "accepts 'yes'" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True + + it "rejects other values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] False option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" + + context "with Flag" $ do + let + option :: Option Bool + option = Option { + optionName = "some-flag" + , optionSetter = Flag $ \ value _ -> value + } + it "accepts 'yes'" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True + + it "accepts 'no'" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] True option `shouldBe` Right False + + it "rejects other values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "nay")] True option `shouldBe` invalidValue "FOO_SOME_FLAG" "nay" + + context "with OptArg" $ do + let + option :: Option String + option = Option { + optionName = "some-flag" + , optionSetter = OptArg undefined $ \ (Just arg) _ -> guard (arg == "yes") >> Just arg + } + + it "accepts valid values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes" + + it "rejects invalid values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" + + context "with Arg" $ do + let + option :: Option String + option = Option { + optionName = "some-flag" + , optionSetter = Arg undefined $ \ arg _ -> guard (arg == "yes") >> Just arg + } + + it "accepts valid values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes" + + it "rejects invalid values" $ do + parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" + where + invalidValue name = Left . InvalidValue name diff --git a/test/GetOpt/Declarative/UtilSpec.hs b/test/GetOpt/Declarative/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/GetOpt/Declarative/UtilSpec.hs @@ -0,0 +1,31 @@ +module GetOpt.Declarative.UtilSpec (spec) where + +import Prelude () +import Helper + +import System.Console.GetOpt + +import GetOpt.Declarative.Util + +spec :: Spec +spec = do + describe "mkUsageInfo" $ do + it "restricts output size to 80 characters" $ do + let options = [ + Option "" ["color"] (NoArg ()) (unwords $ replicate 3 "some very long and verbose help text") + ] + mkUsageInfo "" options `shouldBe` unlines [ + "" + , " --color some very long and verbose help text some very long and verbose" + , " help text some very long and verbose help text" + ] + + it "condenses help for --no-options" $ do + let options = [ + Option "" ["color"] (NoArg ()) "some help" + , Option "" ["no-color"] (NoArg ()) "some other help" + ] + mkUsageInfo "" options `shouldBe` unlines [ + "" + , " --[no-]color some help" + ] diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -1,53 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Helper ( module Test.Hspec.Meta -, module Test.Hspec.Compat +, module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently +, Seconds(..) , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary +, normalizeTimes , ignoreExitCode , ignoreUserInterrupt , throwException +, throwException_ +, withEnvironment +, withTempDirectory +, inTempDirectory + +, hspecSilent +, hspecResultSilent +, hspecCapture , shouldUseArgs , removeLocations + +, () +, mkLocation +, workaroundForIssue19236 + +, replace + +, red +, green +, colorize ) where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat -import Data.List import Data.Char -import Control.Monad -import System.Environment (withArgs) +import System.Environment (withArgs, getEnvironment, setEnv, unsetEnv) 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 System.FilePath +import System.Directory +import System.IO.Temp (withSystemTempDirectory) +import System.Console.ANSI -import Test.Hspec.Meta +import Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import Test.QuickCheck hiding (Result(..)) +import qualified Test.HUnit.Lang as HUnit import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H -import Test.Hspec.Core.QuickCheckUtil (mkGen) +import Test.Hspec.Core.QuickCheck.Util (mkGen) +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..), Location(..)) +import Test.Hspec.Core.Example.Location (workaroundForIssue19236) +import Test.Hspec.Core.Util +import qualified Test.Hspec.Core.Format as Format +import Test.Hspec.Core.Formatters.V2 (formatterToFormat, silent) -throwException :: IO () -throwException = E.throwIO (E.ErrorCall "foobar") +import Data.Orphans () +exceptionEq :: SomeException -> SomeException -> Bool +exceptionEq a b + | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ErrorCall) + | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ArithException) + | otherwise = throw (HUnit.HUnitFailure Nothing $ HUnit.ExpectedButGot Nothing (formatException b) (formatException a)) + +deriving instance Eq FailureReason +deriving instance Eq ResultStatus +deriving instance Eq Result + +deriving instance Eq Format.Result +deriving instance Eq Format.Item + +instance Eq SomeException where + (==) = exceptionEq + +throwException :: IO a +throwException = throwIO DivideByZero + +throwException_ :: IO () +throwException_ = throwException + ignoreExitCode :: IO () -> IO () -ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () +ignoreExitCode action = action `catch` \e -> let _ = e :: ExitCode in pass ignoreUserInterrupt :: IO () -> IO () -ignoreUserInterrupt action = E.catchJust (guard . (== E.UserInterrupt)) action return +ignoreUserInterrupt action = catchJust (guard . (== UserInterrupt)) action return captureLines :: IO a -> IO [String] captureLines = fmap lines . capture_ @@ -61,26 +112,99 @@ g x | isNumber x = '0' | otherwise = x +normalizeTimes :: [String] -> [String] +normalizeTimes = map go + where + go xs = case xs of + [] -> [] + '(' : y : ys | isNumber y, Just zs <- stripPrefix "ms)" $ dropWhile isNumber ys -> "(2ms)" ++ go zs + y : ys -> y : go ys + defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}} noOpProgressCallback :: H.ProgressCallback -noOpProgressCallback _ = return () +noOpProgressCallback _ = pass -sleep :: POSIXTime -> IO () -sleep = threadDelay . floor . (* 1000000) +silentConfig :: H.Config +silentConfig = H.defaultConfig {H.configFormat = Just $ formatterToFormat silent} -timeout :: POSIXTime -> IO a -> IO (Maybe a) -timeout = System.timeout . floor . (* 1000000) +hspecSilent :: H.Spec -> IO () +hspecSilent = H.hspecWith silentConfig -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) +hspecResultSilent :: H.Spec -> IO H.Summary +hspecResultSilent = H.hspecWithResult silentConfig +hspecCapture :: [String] -> H.Spec -> IO String +hspecCapture args = fmap (unlines . normalizeSummary) . captureLines . ignoreExitCode . withArgs args . H.hspec . removeLocations + +shouldUseArgs :: HasCallStack => (Eq n, Show n) => [String] -> (Args -> n, n) -> Expectation +shouldUseArgs args (accessor, expected) = do + spy <- newIORef stdArgs + let + interceptArgs :: H.Item a -> H.Item a + interceptArgs item = item { + H.itemExample = \ params action progressCallback -> do + writeIORef spy (H.paramsQuickCheckArgs params) + H.itemExample item params action progressCallback + } + spec :: H.Spec + spec = H.mapSpecItem_ interceptArgs $ H.it "" True + withArgs args $ hspecSilent spec + accessor <$> readIORef spy `shouldReturn` expected + removeLocations :: H.SpecWith a -> H.SpecWith a -removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing}) +removeLocations = H.mapSpecItem_ $ \ item -> item { + H.itemLocation = Nothing +, H.itemExample = \ params action progressCallback -> removeResultLocation <$> H.itemExample item params action progressCallback +} + +removeResultLocation :: Result -> Result +removeResultLocation (Result info status) = case status of + Success -> Result info status + Pending _loc reason -> Result info (Pending Nothing reason) + Failure _loc reason -> Result info (Failure Nothing reason) + +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment environment action = bracket saveEnv restoreEnv $ const action + where + saveEnv :: IO [(String, String)] + saveEnv = do + env <- clearEnv + forM_ environment $ uncurry setEnv + return env + restoreEnv :: [(String, String)] -> IO () + restoreEnv env = do + _ <- clearEnv + forM_ env $ uncurry setEnv + clearEnv :: IO [(String, String)] + clearEnv = do + env <- getEnvironment + forM_ env (unsetEnv . fst) + return env + +withTempDirectory :: (FilePath -> IO a) -> IO a +withTempDirectory = withSystemTempDirectory "hspec" + +inTempDirectory :: IO a -> IO a +inTempDirectory action = withTempDirectory $ \path -> do + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory path + action + +mkLocation :: FilePath -> Int -> Int -> Maybe Location +mkLocation file line column = Just (Location (workaroundForIssue19236 file) line column) + +replace :: Eq a => a -> a -> [a] -> [a] +replace x y xs = case break (== x) xs of + (ys, _: zs) -> ys ++ y : zs + _ -> xs + +green :: String -> String +green = colorize Foreground Green + +red :: String -> String +red = colorize Foreground Red + +colorize :: ConsoleLayer -> Color -> String -> String +colorize layer color text = setSGRCode [SetColor layer Dull color] <> text <> setSGRCode [Reset] diff --git a/test/Mock.hs b/test/Mock.hs --- a/test/Mock.hs +++ b/test/Mock.hs @@ -1,7 +1,7 @@ module Mock where import Prelude () -import Test.Hspec.Compat +import Test.Hspec.Core.Compat newtype Mock = Mock (IORef Int) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} +{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover #-} diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/test/SpecHook.hs @@ -0,0 +1,17 @@ +module SpecHook (hook) where + +import Prelude () +import Helper + +import System.Environment (getEnvironment) + +ignoreHspecConfig :: IO a -> IO a +ignoreHspecConfig action = do + env <- getEnvironment + let filteredEnv = ("IGNORE_DOT_HSPEC", "yes") : filter p env + withEnvironment filteredEnv action + where + p (name, _value) = name == "COMSPEC" || name == "PATH" + +hook :: Spec -> Spec +hook = aroundAll_ ignoreHspecConfig diff --git a/test/Test/Hspec/CompatSpec.hs b/test/Test/Hspec/CompatSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/CompatSpec.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Test.Hspec.CompatSpec (main, spec) where - -import Helper -import System.SetEnv -import Data.Typeable - -data SomeType = SomeType - deriving Typeable - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "showType" $ do - it "shows unqualified name of type" $ do - showType SomeType `shouldBe` "SomeType" - - describe "showFullType (currently unused)" $ do - it "shows fully qualified name of type" $ do - showFullType SomeType `shouldBe` "Test.Hspec.CompatSpec.SomeType" - - describe "lookupEnv" $ do - it "returns value of specified environment variable" $ do - setEnv "FOO" "bar" - lookupEnv "FOO" `shouldReturn` Just "bar" - - it "returns Nothing if specified environment variable is not set" $ do - unsetEnv "FOO" - lookupEnv "FOO" `shouldReturn` Nothing diff --git a/test/Test/Hspec/Core/AnnotationsSpec.hs b/test/Test/Hspec/Core/AnnotationsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/AnnotationsSpec.hs @@ -0,0 +1,29 @@ +module Test.Hspec.Core.AnnotationsSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Annotations + +newtype A = A Int + deriving (Eq, Show) + +newtype B = B Int + deriving (Eq, Show) + +spec :: Spec +spec = do + describe "Annotations" $ do + it "can store a value" $ do + let annotations = setValue (A 23) mempty + getValue annotations `shouldBe` Just (A 23) + + it "can store multiple values of different types" $ do + let annotations = setValue (B 42) $ setValue (A 23) mempty + getValue annotations `shouldBe` Just (A 23) + getValue annotations `shouldBe` Just (B 42) + + context "when a value of the same type is added multiple times" $ do + it "gives precedence to the value that was added last" $ do + let annotations = setValue (A 42) $ setValue (A 23) mempty + getValue annotations `shouldBe` Just (A 42) diff --git a/test/Test/Hspec/Core/ClockSpec.hs b/test/Test/Hspec/Core/ClockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/ClockSpec.hs @@ -0,0 +1,16 @@ +module Test.Hspec.Core.ClockSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Clock + +spec :: Spec +spec = do + describe "toMilliseconds" $ do + it "converts Seconds to milliseconds" $ do + toMilliseconds 0.1 `shouldBe` 100 + + describe "toMicroseconds" $ do + it "converts Seconds to microseconds" $ do + toMicroseconds 2.5 `shouldBe` 2500000 diff --git a/test/Test/Hspec/Core/CompatSpec.hs b/test/Test/Hspec/Core/CompatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/CompatSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Test.Hspec.Core.CompatSpec (spec) where + +import Prelude () +import Helper + +import System.Environment + +data SomeType = SomeType + +spec :: Spec +spec = do + describe "showType" $ do + it "shows unqualified name of type" $ do + showType SomeType `shouldBe` "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/Config/DefinitionSpec.hs b/test/Test/Hspec/Core/Config/DefinitionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Config/DefinitionSpec.hs @@ -0,0 +1,22 @@ +module Test.Hspec.Core.Config.DefinitionSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Config.Definition + +spec :: Spec +spec = do + describe "splitOn" $ do + it "splits a string" $ do + splitOn ',' "foo,bar,baz" `shouldBe` ["foo", "bar", "baz"] + + it "splits *arbitrary* strings" $ property $ do + let + string :: Gen String + string = arbitrary `suchThat` p + + p :: String -> Bool + p = (&&) <$> not . null <*> all (/= ',') + + forAll (listOf string) $ \ xs -> splitOn ',' (intercalate "," xs) `shouldBe` xs diff --git a/test/Test/Hspec/Core/Config/OptionsSpec.hs b/test/Test/Hspec/Core/Config/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Config/OptionsSpec.hs @@ -0,0 +1,230 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +module Test.Hspec.Core.Config.OptionsSpec (spec) where + +import Prelude () +import Helper + +import System.Exit + +import Test.Hspec.Core.Config +import Test.Hspec.Core.Config.Options hiding (parseOptions) +import qualified Test.Hspec.Core.Config.Options as Options + +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "fromLeft: No left value!" + +spec :: Spec +spec = do + describe "parseOptions" $ do + + let parseOptions configFiles envVar env args = snd <$> Options.parseOptions defaultConfig "my-spec" configFiles envVar env args + + it "rejects unexpected arguments" $ do + fromLeft (parseOptions [] Nothing [] ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] Nothing [] ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n") + + it "sets configColorMode to ColorAuto" $ do + configColorMode <$> parseOptions [] Nothing [] [] `shouldBe` Right ColorAuto + + context "when the same option is specified multiple times" $ do + it "gives later occurrences precedence" $ do + configColorMode <$> parseOptions [] Nothing [] ["--color", "--no-color"] `shouldBe` Right ColorNever + + context "with --help" $ do + let Left (code, help) = Options.parseOptions defaultConfig "spec" [] Nothing [] ["--help"] + + it "returns ExitSuccess" $ do + code `shouldBe` ExitSuccess + + it "prints help" $ do + expected <- readFile "help.txt" + help `shouldBe` expected + + describe "RUNNER OPTIONS" $ do + let parseOptions_ args = snd <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [] args + + it "gives HSPEC_FAIL_ON precedence over HSPEC_STRICT" $ do + (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "no"), ("HSPEC_FAIL_ON", "focused")] [] + `shouldBe` Right (True, False) + + it "gives HSPEC_NO_FAIL_ON precedence over HSPEC_STRICT" $ do + (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "yes"), ("HSPEC_NO_FAIL_ON", "focused")] [] + `shouldBe` Right (False, True) + + context "with --fail-on-focused" $ do + it "sets configFailOnFocused to True" $ do + configFailOnFocused <$> parseOptions_ ["--fail-on-focused"] `shouldBe` Right True + + context "with --fail-on-pending" $ do + it "sets configFailOnPending to True" $ do + configFailOnPending <$> parseOptions_ ["--fail-on-pending"] `shouldBe` Right True + + context "with --fail-on" $ do + it "accepts a list of values" $ do + let config = parseOptions_ ["--fail-on=focused,pending"] + configFailOnFocused <$> config `shouldBe` Right True + configFailOnPending <$> config `shouldBe` Right True + + context "with focused" $ do + it "sets configFailOnFocused to True" $ do + configFailOnFocused <$> parseOptions_ ["--fail-on=focused"] `shouldBe` Right True + + context "with pending" $ do + it "sets configFailOnPending to True" $ do + configFailOnPending <$> parseOptions_ ["--fail-on=pending"] `shouldBe` Right True + + context "with --no-fail-on" $ do + it "inverts --fail-on" $ do + let config = parseOptions_ ["--fail-on=focused,pending", "--no-fail-on=focused,pending"] + configFailOnFocused <$> config `shouldBe` Right False + configFailOnPending <$> config `shouldBe` Right False + + context "with --color" $ do + it "sets configColorMode to ColorAlways" $ do + configColorMode <$> parseOptions [] Nothing [] ["--color"] `shouldBe` Right ColorAlways + + context "with --no-color" $ do + it "sets configColorMode to ColorNever" $ do + configColorMode <$> parseOptions [] Nothing [] ["--no-color"] `shouldBe` Right ColorNever + + context "with --diff" $ do + it "sets configDiff to True" $ do + configDiff <$> parseOptions [] Nothing [] ["--diff"] `shouldBe` Right True + + context "with --no-diff" $ do + it "sets configDiff to False" $ do + configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False + + context "with --diff-context" $ do + it "accepts 0" $ do + configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=0"] `shouldBe` Right (Just 0) + + it "accepts positive values" $ do + configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=5"] `shouldBe` Right (Just 5) + + it "rejects invalid values" $ do + let msg = "my-spec: invalid argument `foo' for `--diff-context'\nTry `my-spec --help' for more information.\n" + void (parseOptions [] Nothing [] ["--diff-context=foo"]) `shouldBe` Left (ExitFailure 1, msg) + + context "with negative values" $ do + it "disables the option" $ do + configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=-1"] `shouldBe` Right Nothing + + context "with 'full'" $ do + it "disables the option" $ do + configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=full"] `shouldBe` Right Nothing + + context "with --diff-command=" $ do + it "sets configExternalDiff to Nothing" $ do + fmap (const ()) . configExternalDiff <$> parseOptions [] Nothing [] ["--diff-command="] `shouldBe` Right Nothing + + context "with --print-slow-items" $ do + it "sets configPrintSlowItems to N" $ do + configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=5"] `shouldBe` Right (Just 5) + + it "defaults N to 10" $ do + configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items"] `shouldBe` Right (Just 10) + + it "rejects invalid values" $ do + let msg = "my-spec: invalid argument `foo' for `--print-slow-items'\nTry `my-spec --help' for more information.\n" + void (parseOptions [] Nothing [] ["--print-slow-items=foo"]) `shouldBe` Left (ExitFailure 1, msg) + + context "when N is 0" $ do + it "disables the option" $ do + configPrintSlowItems <$> parseOptions [] Nothing [] ["-p0"] `shouldBe` Right Nothing + + context "when N is negative" $ do + it "disables the option" $ do + configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=-23"] `shouldBe` Right Nothing + + context "with --qc-max-success" $ do + it "sets QuickCheck maxSuccess" $ do + maxSuccess . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-success", "23"]) `shouldBe` Right 23 + + context "when given an invalid argument" $ do + it "returns an error message" $ do + fromLeft (parseOptions [] Nothing [] ["--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 --qc-max-shrinks" $ do + it "sets QuickCheck maxShrinks" $ do + maxShrinks . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-shrinks", "23"]) `shouldBe` Right 23 + + context "with --depth" $ do + it "sets depth parameter for SmallCheck" $ do + configSmallCheckDepth <$> parseOptions [] Nothing [] ["--depth", "23"] `shouldBe` Right (Just 23) + + context "with --jobs" $ do + it "sets number of concurrent jobs" $ do + configConcurrentJobs <$> parseOptions [] Nothing [] ["--jobs=23"] `shouldBe` Right (Just 23) + + it "rejects values < 1" $ do + let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" + void (parseOptions [] Nothing [] ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) + + context "when given a config file" $ do + it "uses options from config file" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] ["--color"] `shouldBe` Right ColorAlways + + it "rejects --help" $ do + fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n") + + it "rejects ambiguous options" $ do + fromLeft (parseOptions [("~/.hspec", ["--print"])] Nothing [] []) `shouldBe` (ExitFailure 1, + unlines [ + "my-spec: option `--print' is ambiguous; could be one of:" + , " --print-cpu-time include used CPU time in summary" + , " -p[N] --print-slow-items[=N] print the N slowest spec items (default: 10)" + , "in config file ~/.hspec" + ] + ) + + context "when the same option is specified multiple times" $ do + it "gives later occurrences precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--color", "--no-color"])] Nothing [] [] `shouldBe` Right ColorNever + + context "when given multiple config files" $ do + it "gives later config files precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] [] `shouldBe` Right ColorAlways + + context "when given HSPEC_OPTIONS (deprecated)" $ do + it "uses options from HSPEC_OPTIONS" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) [] [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) [] ["--color"] `shouldBe` Right ColorAlways + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] (Just ["--invalid"]) [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n") + + context "when given an option as an environment variable" $ do + it "sets config value from environment variable" $ do + configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] ["--color"] `shouldBe` Right ColorAlways + + it "warns on unrecognized option values" $ do + fmap configColorMode <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [("HSPEC_COLOR", "foo")] [] `shouldBe` Right (["invalid value `foo' for environment variable HSPEC_COLOR"], ColorAuto) + + describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do + context "by default" $ do + it "returns False" $ do + ignoreConfigFile defaultConfig [] `shouldReturn` False + + context "with --ignore-dot-hspec" $ do + it "returns True" $ do + ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True + + context "with IGNORE_DOT_HSPEC" $ do + it "returns True" $ do + withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do + ignoreConfigFile defaultConfig [] `shouldReturn` True diff --git a/test/Test/Hspec/Core/ConfigSpec.hs b/test/Test/Hspec/Core/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/ConfigSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.ConfigSpec (spec) where + +import Prelude () +import Helper + +import System.Directory + +import Test.Hspec.Core.Config + +spec :: Spec +spec = around_ inTempDirectory $ around_ (withEnvironment [("HOME", "foo")]) $ do + describe "readConfig" $ do + it "recognizes options from HSPEC_OPTIONS" $ do + withEnvironment [("HSPEC_OPTIONS", "--color")] $ do + configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways + + it "recognizes options from HSPEC_*" $ do + withEnvironment [("HSPEC_COLOR", "yes")] $ do + configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways + + describe "readConfigFiles" $ do + it "reads .hspec" $ do + dir <- getCurrentDirectory + let name = dir ".hspec" + writeFile name "--diff --foo 'bar baz'" + readConfigFiles `shouldReturn` [(name, ["--diff", "--foo", "bar baz"])] + +#ifndef mingw32_HOST_OS + it "reads ~/.hspec" $ do + let name = "my-home/.hspec" + createDirectory "my-home" + writeFile name "--diff" + withEnvironment [("HOME", "my-home")] $ do + readConfigFiles `shouldReturn` [(name, ["--diff"])] + + context "without $HOME" $ do + it "returns empty list" $ do + readConfigFiles `shouldReturn` [] + + context "without current directory" $ do + it "returns empty list" $ do + dir <- getCurrentDirectory + removeDirectory dir + readConfigFiles `shouldReturn` [] +#endif diff --git a/test/Test/Hspec/Core/Example/LocationSpec.hs b/test/Test/Hspec/Core/Example/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Example/LocationSpec.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -O0 #-} +module Test.Hspec.Core.Example.LocationSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Example +import Test.Hspec.Core.Example.Location + +class SomeClass a where + someMethod :: a -> IO () + +instance SomeClass () where + +data Person = Person { + name :: String +, age :: Int +} deriving (Eq, Show) + +spec :: Spec +spec = do + describe "parseAssertionFailed" $ do + context "with pre-GHC-8.* error message" $ do + it "extracts source location" $ do + parseAssertionFailed "Foo.hs:4:7-12: Assertion failed\n" `shouldBe` Just (Location "Foo.hs" 4 7) + + describe "extractLocation" $ do + context "with pattern match failure in do expression" $ do + context "in IO" $ do + it "extracts Location" $ do + let location = Just $ Location file (__LINE__ + 2) 13 + Left e <- try $ do + Just n <- return Nothing + return (n :: Int) + extractLocation e `shouldBe` location + +#if !MIN_VERSION_base(4,12,0) + context "in Either" $ do + it "extracts Location" $ do + let location = Just $ Location file (__LINE__ + 4) 15 + let + foo :: Either () () + foo = do + 23 <- Right (42 :: Int) + pass + Left e <- try (evaluate foo) + extractLocation e `shouldBe` location +#endif + + context "with ErrorCall" $ do + it "extracts Location" $ do + let + location = + Just $ Location file (succ __LINE__) 34 + Left e <- try (evaluate (undefined :: ())) + extractLocation e `shouldBe` location + + context "with PatternMatchFail" $ do + context "with single-line source span" $ do + it "extracts Location" $ do + let + location = Just $ Location file (__LINE__ + 1) 40 + Left e <- try (evaluate (let Just n = Nothing in (n :: Int))) + extractLocation e `shouldBe` location + + context "with multi-line source span" $ do + it "extracts Location" $ do + let location = Just $ Location file (__LINE__ + 1) 36 + Left e <- try (evaluate (case Nothing of + Just n -> n :: Int + )) + extractLocation e `shouldBe` location + + context "with RecConError" $ do + it "extracts Location" $ do + let + location = Just $ Location file (__LINE__ + 1) 39 + Left e <- try $ evaluate (age Person {name = "foo"}) + extractLocation e `shouldBe` location + + context "with NoMethodError" $ do + it "extracts Location" $ do + Left e <- try $ someMethod () + extractLocation e `shouldBe` Just (Location file 19 10) + + context "with AssertionFailed" $ do + it "extracts Location" $ do + let + location = Just $ Location file (__LINE__ + 1) 36 + Left e <- try . evaluate $ assert False () + extractLocation e `shouldBe` location + + describe "parseBacktraces" $ do + it "parses Location from Backtraces" $ do + let + input :: String + input = unlines [ + "Cost-centre stack backtrace:" + , " ..." + , "IPE backtrace:" + , " ..." + , "HasCallStack backtrace:" + , " foo, called at Foo.hs:23:7 in main:Foo" + , " bar, called at Foo.hs:42:7 in main:Foo" + , " baz, called at Foo.hs:65:9 in main:Foo" + , "..." + , " ..." + ] + parseBacktraces input `shouldBe` Just Location { + locationFile = "Foo.hs" + , locationLine = 65 + , locationColumn = 9 + } + + describe "parseCallStack" $ do + it "parses Location from call stack" $ do + let input = [ + "CallStack (from HasCallStack):" + , " error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err" + , " undefined, called at test/Test/Hspec.hs:13:32 in main:Test.Hspec" + ] + parseCallStack input `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 13 32) + + describe "parseLocation" $ do + it "parses Location" $ do + parseLocation "test/Test/Hspec.hs:13:32" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 13 32) + + describe "parseSourceSpan" $ do + it "parses single-line source span" $ do + parseSourceSpan "test/Test/Hspec.hs:25:36-51:" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 25 36) + + it "parses multi-line source span" $ do + parseSourceSpan "test/Test/Hspec.hs:(15,7)-(17,26):" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 15 7) + +file :: FilePath +file = workaroundForIssue19236 __FILE__ diff --git a/test/Test/Hspec/Core/ExampleSpec.hs b/test/Test/Hspec/Core/ExampleSpec.hs --- a/test/Test/Hspec/Core/ExampleSpec.hs +++ b/test/Test/Hspec/Core/ExampleSpec.hs @@ -1,49 +1,161 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} -module Test.Hspec.Core.ExampleSpec (main, spec) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Test.Hspec.Core.ExampleSpec (spec) where + +import Prelude () import Helper + import Mock -import Data.List -import qualified Control.Exception as E +import Test.HUnit (assertFailure, assertEqual) +import Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..)) +import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Example as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H -main :: IO () -main = hspec spec +safeEvaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result +safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result +evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result +evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO Result evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback +evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO Result +evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback + +bottom :: a +bottom = throw DivideByZero + spec :: Spec spec = do + describe "safeEvaluate" $ do + let + status :: ResultStatus + status = Failure Nothing (Error Nothing $ toException DivideByZero) + + err :: Result + err = Result "" status + + it "forces Result" $ do + H.safeEvaluate (return $ Result "" bottom) `shouldReturn` err + + it "handles ResultStatus exceptions" $ do + H.safeEvaluate (throwIO status) `shouldReturn` err + + it "forces ResultStatus exceptions" $ do + H.safeEvaluate (throwIO $ Failure Nothing bottom) `shouldReturn` err + + it "handles other exceptions" $ do + H.safeEvaluate (throwIO DivideByZero) `shouldReturn` err + + it "forces other exceptions" $ do + H.safeEvaluate (throwIO $ ErrorCall bottom) `shouldReturn` err + + describe "safeEvaluateResultStatus" $ do + let + err :: ResultStatus + err = Failure Nothing (Error Nothing $ toException DivideByZero) + + it "forces ResultStatus" $ do + H.safeEvaluateResultStatus (return $ Failure Nothing bottom) `shouldReturn` err + + it "handles ResultStatus exceptions" $ do + H.safeEvaluateResultStatus (throwIO err) `shouldReturn` err + + it "forces ResultStatus exceptions" $ do + H.safeEvaluateResultStatus (throwIO $ Failure Nothing bottom) `shouldReturn` err + + it "handles other exceptions" $ do + H.safeEvaluateResultStatus (throwIO DivideByZero) `shouldReturn` err + + it "forces other exceptions" $ do + H.safeEvaluateResultStatus (throwIO $ ErrorCall bottom) `shouldReturn` err + + describe "safeEvaluateExample" $ do + context "for Expectation" $ do + it "returns Failure if an expectation does not hold" $ do + Result "" (Failure _ msg) <- safeEvaluateExample (23 `H.shouldBe` (42 :: Int)) + msg `shouldBe` ExpectedButGot Nothing "42" "23" + + context "when used with `pending`" $ do + it "returns Pending" $ do + result <- safeEvaluateExample (H.pending) + let location = mkLocation __FILE__ (pred __LINE__) 42 + result `shouldBe` Result "" (Pending location Nothing) + + context "when used with `pendingWith`" $ do + it "includes the optional reason" $ do + result <- safeEvaluateExample (H.pendingWith "foo") + let location = mkLocation __FILE__ (pred __LINE__) 42 + result `shouldBe` Result "" (Pending location $ Just "foo") + describe "evaluateExample" $ do + context "for Result" $ do + it "propagates exceptions" $ do + evaluateExample (error "foobar" :: Result) `shouldThrow` errorCall "foobar" + + it "runs around-action" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + e + modifyIORef ref succ + + result = Result "" (Failure Nothing NoReason) + evaluateExampleWith action result `shouldReturn` result + readIORef ref `shouldReturn` 1 + + it "accepts arguments" $ do + ref <- newIORef (0 :: Int) + let action :: (Integer -> IO ()) -> IO () + action e = do + e 42 + modifyIORef ref succ + evaluateExampleWithArgument action (Result "" . Failure Nothing . Reason . show) `shouldReturn` Result "" (Failure Nothing $ Reason "42") + readIORef ref `shouldReturn` 1 + context "for Bool" $ do it "returns Success on True" $ do - evaluateExample True `shouldReturn` H.Success + evaluateExample True `shouldReturn` Result "" Success - it "returns Fail on False" $ do - evaluateExample False `shouldReturn` H.Fail Nothing "" + it "returns Failure on False" $ do + evaluateExample False `shouldReturn` Result "" (Failure Nothing NoReason) it "propagates exceptions" $ do evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" + it "runs around-action" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + e + modifyIORef ref succ + evaluateExampleWith action False `shouldReturn` Result "" (Failure Nothing NoReason) + readIORef ref `shouldReturn` 1 + + it "accepts arguments" $ do + ref <- newIORef (0 :: Int) + let action :: (Integer -> IO ()) -> IO () + action e = do + e 42 + modifyIORef ref succ + evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` Result "" (Failure Nothing NoReason) + readIORef ref `shouldReturn` 1 + context "for Expectation" $ do it "returns Success if all expectations hold" $ do - evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success - - it "returns Fail if an expectation does not hold" $ do - H.Fail _ msg <- evaluateExample (23 `shouldBe` (42 :: Int)) - msg `shouldEndWith` "expected: 42\n but got: 23" + evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` Result "" Success it "propagates exceptions" $ do evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" - it "runs provided action around expectation" $ do + it "runs around-action" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do @@ -51,34 +163,30 @@ e readIORef ref `shouldReturn` succ n modifyIORef ref succ - evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` H.Success + evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` Result "" 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 + evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` Result "+++ OK, passed 1000 tests." Success - it "returns Fail if property does not hold" $ do - H.Fail _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int) - return () + it "shows the collected labels" $ do + Result info Success <- evaluateExample $ property $ \ () -> label "unit" True + info `shouldBe` "+++ OK, passed 1000 tests (100.0% unit)." + it "returns Failure if property does not hold" $ do + Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int) + pass + it "shows what falsified it" $ do - H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False - r `shouldBe` intercalate "\n" [ - "Falsifiable (after 1 test): " - , "0" - , "1" + Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False + r `shouldBe` (Reason . intercalate "\n") [ + "Falsified (after 1 test):" + , " 0" + , " 1" ] - it "runs provided action around each single check of the property" $ do + it "runs around-action for each single check of the property" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do @@ -86,51 +194,63 @@ e readIORef ref `shouldReturn` succ n modifyIORef ref succ - H.Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) + Result _ Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) readIORef ref `shouldReturn` 2000 it "pretty-prints exceptions" $ do - H.Fail _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool)) - r `shouldBe` intercalate "\n" [ -#if MIN_VERSION_QuickCheck(2,7,0) - "uncaught exception: ErrorCall (foobar) (after 1 test)" -#else - "Exception: 'foobar' (after 1 test): " -#endif - , "0" + Result "" (Failure _ r) <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (throw (ErrorCall "foobar") :: Bool)) + r `shouldBe` (Reason . intercalate "\n") [ + "uncaught exception: ErrorCall" + , "foobar" + , "(after 1 test)" + , " 0" ] - context "when used with shouldBe" $ do - it "shows what falsified it" $ do - H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int) - r `shouldStartWith` "Falsifiable (after 1 test): \n" - r `shouldEndWith` intercalate "\n" [ - "expected: 42" - , " but got: 23" - , "0" - , "1" - ] + context "when used with Expectation" $ do + let prop p = property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> p + context "when used with shouldBe" $ do + it "shows what falsified it" $ do + Result "" (Failure _ err) <- evaluateExample $ prop $ 23 `H.shouldBe` (42 :: Int) + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1") "42" "23" + context "when used with assertEqual" $ do + it "includes prefix" $ do + Result "" (Failure _ err) <- evaluateExample $ prop $ assertEqual "foobar" (42 :: Int) 23 + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1\nfoobar") "42" "23" + + context "when used with assertFailure" $ do + it "includes reason" $ do + Result "" (Failure _ err) <- evaluateExample $ prop (assertFailure "foobar" :: IO ()) + err `shouldBe` Reason "Falsifiable (after 1 test):\n 0\n 1\nfoobar" + + context "when used with verbose" $ do + it "includes verbose output" $ do + Result info (Failure _ err) <- evaluateExample $ verbose $ (`H.shouldBe` (23 :: Int)) + info `shouldBe` "Failed:\n0" + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0") "23" "0" + context "when used with `pending`" $ do it "returns Pending" $ do - evaluateExample (property H.pending) `shouldReturn` H.Pending Nothing + let location = mkLocation __FILE__ (succ __LINE__) 37 + evaluateExample (property H.pending) `shouldReturn` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do - evaluateExample (property $ H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") + let location = mkLocation __FILE__ (succ __LINE__) 39 + evaluateExample (property $ H.pendingWith "foo") `shouldReturn` Result "" (Pending location $ Just "foo") describe "Expectation" $ do context "as a QuickCheck property" $ do it "can be quantified" $ do e <- newMock - silence . H.hspec $ do + hspecSilent $ 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 + hspecResultSilent $ do H.describe "readIO" $ do H.it "is inverse to show" $ property $ \x -> do (readIO . show) x `shouldReturn` (x :: Int) diff --git a/test/Test/Hspec/Core/FailureReportSpec.hs b/test/Test/Hspec/Core/FailureReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/FailureReportSpec.hs @@ -0,0 +1,48 @@ +module Test.Hspec.Core.FailureReportSpec (spec) where + +import Prelude () +import Helper + +import System.IO +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.Config + +spec :: Spec +spec = do + describe "writeFailureReport" $ do + it "prints a warning on unexpected exceptions" $ do + r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (throw (ErrorCall "some error")) + r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" + + describe "readFailureReport" $ do + context "when configFailureReport is specified" $ do + let + file = "report" + config = defaultConfig {configFailureReport = Just file} + report = FailureReport { + failureReportSeed = 23 + , failureReportMaxSuccess = 42 + , failureReportMaxSize = 65 + , failureReportMaxDiscardRatio = 123 + , failureReportPaths = [(["foo", "bar"], "baz")] + } + it "reads a failure report from a file" $ do + inTempDirectory $ do + writeFailureReport config report + readFailureReport config `shouldReturn` Just report + + context "when file does not exist" $ do + it "returns Nothing" $ do + inTempDirectory $ do + readFailureReport config `shouldReturn` Nothing + + context "when file is malformed" $ do + it "returns Nothing" $ do + hSilence [stderr] $ inTempDirectory $ do + writeFile file "foo" + readFailureReport config `shouldReturn` Nothing + + it "prints a warning" $ do + inTempDirectory $ do + writeFile file "foo" + hCapture_ [stderr] (readFailureReport config) `shouldReturn` "WARNING: Could not read failure report from file \"report\"!\n" diff --git a/test/Test/Hspec/Core/FormatSpec.hs b/test/Test/Hspec/Core/FormatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/FormatSpec.hs @@ -0,0 +1,19 @@ +module Test.Hspec.Core.FormatSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Format + +spec :: Spec +spec = do + describe "monadic" $ do + context "on exception" $ do + it "propagates" $ do + format <- monadic id (\ _ -> throwIO DivideByZero) + format (Done []) `shouldThrow` (== DivideByZero) + + it "does not hang" $ do + format <- monadic id (\ _ -> throwIO DivideByZero) + format (Done []) `shouldThrow` (== DivideByZero) + format (Done []) diff --git a/test/Test/Hspec/Core/Formatters/DiffSpec.hs b/test/Test/Hspec/Core/Formatters/DiffSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/DiffSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hspec.Core.Formatters.DiffSpec (spec) where + +import Prelude () +import Helper +import Data.Char + +import Test.Hspec.Core.Formatters.Diff as Diff + +dropQuotes :: String -> String +dropQuotes = init . drop 1 + +spec :: Spec +spec = do + describe "lineDiff" $ do + let + enumerate name n = map ((name ++) . show) [1 .. n :: Int] + diff_ expected actual = lineDiff (Just 2) (unlines expected) (unlines actual) + + it "suppresses excessive diff output" $ do + let + expected = enumerate "foo" 99 + actual = replace "foo50" "bar50" expected + + diff_ expected actual `shouldBe` [ + LinesOmitted 47 + , LinesBoth [ + "foo48" + , "foo49" + ] + , SingleLineDiff [First "foo50", Second "bar50"] + , LinesBoth [ + "foo51" + , "foo52" + ] + , LinesOmitted 47 + , LinesBoth [""] + ] + + it "ensures that omitted sections are at least three lines in size" $ do + forAll (elements [1..20]) $ \ size -> do + let expected = enumerate "" size + forAll (elements expected) $ \ i -> do + let actual = replace i "bar" expected + [n | LinesOmitted n <- diff_ expected actual] `shouldSatisfy` all (>= 3) + + context "with modifications within a line" $ do + it "suppresses excessive diff output" $ do + let + expected = enumerate "foo " 99 + actual = replace "foo 42" "foo 23" expected + + diff_ expected actual `shouldBe` [ + LinesOmitted 39 + , LinesBoth [ + "foo 40" + , "foo 41" + ] + , SingleLineDiff [Both "foo ", First "42", Second "23"] + , LinesBoth [ + "foo 43" + , "foo 44" + ] + , LinesOmitted 55 + , LinesBoth [""] + ] + + context "with modifications at start / end" $ do + it "suppresses excessive diff output" $ do + let + expected = enumerate "foo" 9 + actual = replace "foo9" "bar9" $ replace "foo1" "bar1" expected + + diff_ expected actual `shouldBe` [ + SingleLineDiff [First "foo1", Second "bar1"] + , LinesBoth [ + "foo2" + , "foo3" + ] + , LinesOmitted 3 + , LinesBoth [ + "foo7" + , "foo8" + ] + , SingleLineDiff [First "foo9", Second "bar9"] + , LinesBoth [""] + ] + + describe "splitLines" $ do + it "splits on newline characters" $ do + splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "bar", "baz"] + + describe "with a newline characters at the start" $ do + it "splits on newline characters" $ do + splitLines "\nfoo\nbar\nbaz" `shouldBe` ["", "foo", "bar", "baz"] + + describe "with a newline characters at the end" $ do + it "splits on newline characters" $ do + splitLines "foo\nbar\nbaz\n" `shouldBe` ["foo", "bar", "baz", ""] + + describe "partition" $ do + context "with a single shown Char" $ do + it "never partitions a character escape" $ do + property $ \ (c :: Char) -> partition (show c) `shouldBe` ["'", dropQuotes (show c), "'"] + + context "with a shown String" $ do + it "puts backslash-escaped characters into separate chunks" $ do + partition (show "foo\nbar") `shouldBe` ["\"", "foo", "\\n", "bar", "\""] + + it "puts *arbitrary* backslash-escaped characters into separate chunks" $ do + property $ \ xs c ys -> + let + char = dropQuotes (show [c]) + isEscaped = length char > 1 + escape = drop 1 char + sep = case ys of + x : _ | all isDigit escape && isDigit x || escape == "SO" && x == 'H' -> ["\\&"] + _ -> [] + actual = partition (show (xs ++ c : ys)) + expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys) + in isEscaped ==> actual `shouldBe` expected + + describe "breakList" $ do + context "with a list where the predicate matches at the beginning and the end" $ do + it "breaks the list into pieces" $ do + breakList isAlphaNum "foo bar baz" `shouldBe` ["foo", " ", "bar", " ", " ", "baz"] + + context "with a list where the predicate does not match at the beginning and the end" $ do + it "breaks the list into pieces" $ do + breakList isAlphaNum " foo bar baz " `shouldBe` [" ", " ", "foo", " ", "bar", " ", " ", "baz", " ", " "] diff --git a/test/Test/Hspec/Core/Formatters/InternalSpec.hs b/test/Test/Hspec/Core/Formatters/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/InternalSpec.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Formatters.InternalSpec (spec) where + +import Prelude () +import Helper + +import System.Console.ANSI + +import Test.Hspec.Core.Format +import Test.Hspec.Core.Formatters.Internal + +formatConfig :: FormatConfig +formatConfig = defaultFormatConfig { + formatConfigUseColor = True +, formatConfigUseDiff = True +, formatConfigDiffContext = Just 3 +} + +spec :: Spec +spec = do + forM_ [ + ("extraChunk", extraChunk, Red) + , ("missingChunk", missingChunk, Green) + ] $ \ (name, chunk, color) -> do + + describe name $ do + it "colorizes chunks" $ do + capture_ $ runFormatM formatConfig $ do + chunk "foo" + `shouldReturn` colorize Foreground color "foo" + + context "with an all-spaces chunk" $ do + it "colorizes background" $ do + capture_ $ runFormatM formatConfig $ do + chunk " " + `shouldReturn` colorize Background color " " + + context "with an all-newlines chunk" $ do + it "colorizes background" $ do + capture_ $ runFormatM formatConfig $ do + chunk "\n\n\n" + `shouldReturn` colorize Background color "\n\n\n" + + describe "write" $ do + it "does not span colored output over multiple lines" $ do + + -- This helps with output on Jenkins and Buildkite: + -- https://github.com/hspec/hspec/issues/346 + + capture_ $ runFormatM formatConfig $ do + withSuccessColor $ write "foo\nbar\nbaz\n" + `shouldReturn` unlines [green "foo", green "bar", green "baz"] + + describe "splitLines" $ do + it "splits a string into chunks" $ do + splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "\n", "bar", "\n", "baz"] + + it "splits *arbitrary* strings into chunks" $ do + property $ \ xs -> do + mconcat (splitLines xs) `shouldBe` xs + + it "puts newlines into separate chunks" $ do + property $ \ xs -> do + filter (notElem '\n') (splitLines xs) `shouldBe` filter (not . null) (lines xs) diff --git a/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs b/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +module Test.Hspec.Core.Formatters.Pretty.ParserSpec ( + spec +, Person(..) +, Address(..) +, person +) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Formatters.Pretty.Parser + +data OperatorType = String :*: Int + deriving (Eq, Show) + +data Person = Person { + personName :: String +, personAge :: Int +, personAddress :: Maybe Address +} deriving (Eq, Show) + +data Address = Address { + addressStreet :: String +, addressPostalCode :: Int +} deriving (Eq, Show) + +person :: Person +person = Person "Joe" 23 (Just $ Address "Main Street" 50000) + +infix 1 `shouldParseAs` + +shouldParseAs :: HasCallStack => String -> Value -> Expectation +shouldParseAs input expected = parseValue input `shouldBe` Just expected + +unit :: Value +unit = Tuple [] + +parentheses :: Value -> Value +parentheses value = Tuple [value] + +spec :: Spec +spec = do + describe "parseValue" $ do + it "parses unit" $ do + show () `shouldParseAs` unit + + it "parses characters" $ do + show 'c' `shouldParseAs` Char 'c' + + it "parses strings" $ do + show "foo" `shouldParseAs` String "foo" + + it "accepts rationals" $ do + show (0.5 :: Rational) `shouldParseAs` Operator (Number "1") "%" (Number "2") + + it "accepts negative rationals" $ do + show (-0.5 :: Rational) `shouldParseAs` Operator (parentheses $ Number "-1") "%" (Number "2") + + it "accepts constructor symbols" $ do + show ("foo" :*: 23) `shouldParseAs` Operator (String "foo") ":*:" (Number "23") + + it "accepts integers" $ do + "23" `shouldParseAs` Number "23" + + it "accepts negative integers" $ do + "-23" `shouldParseAs` Number "-23" + + it "accepts floats" $ do + show (23.0 :: Float) `shouldParseAs` Number "23.0" + + it "accepts negative floats" $ do + show (-23.0 :: Float) `shouldParseAs` Number "-23.0" + + it "parses lists" $ do + show ["foo", "bar", "baz"] `shouldParseAs` List [String "foo", String "bar", String "baz"] + + it "parses tuples" $ do + show ("foo", "bar", "baz") `shouldParseAs` Tuple [String "foo", String "bar", String "baz"] + + it "parses Nothing" $ do + show (Nothing :: Maybe Int) `shouldParseAs` Constructor "Nothing" [] + + it "parses Just" $ do + show (Just "foo") `shouldParseAs` Constructor "Just" [String "foo"] + + it "parses nested Just" $ do + show (Just $ Just "foo") `shouldParseAs` Constructor "Just" [parentheses (Constructor "Just" [String "foo"])] + + it "parses records" $ do + show person `shouldParseAs` Record "Person" [ + ("personName", String "Joe") + , ("personAge", Number "23") + , ("personAddress", Constructor "Just" [Tuple [Record "Address" [ + ("addressStreet", String "Main Street") + , ("addressPostalCode", Number "50000") + ]]]) + ] + + context "with deeply nested data structures" $ do + it "completes in O(n) time" $ do + let + input = show ( + "0", ( + "1", ( + "2", ( + "3", ( + "4", ( + "5", ( + "6", ( + "7", ( + "8", ( + "9", ( + "10", ( + "11", ( + "12", ( + "13", ( + "14", ( + "15", ( + "16", ( + "17", ( + "18", ( + "19", ( + "20", ( + "21", ( + "22", ( + "23", ( + "24", ( + "25", ( + "26", ( + "27", ( + "28", ( + "29", ( + ))))))))))))))))))))))))))))))) + r <- timeout 1 $ evaluate (parseValue input) + (join r :: Maybe Value) `shouldSatisfy` isJust diff --git a/test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs b/test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs @@ -0,0 +1,16 @@ +module Test.Hspec.Core.Formatters.Pretty.UnicodeSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Formatters.Pretty.Unicode + +spec :: Spec +spec = do + describe "ushow" $ do + it "retains unicode characters" $ do + ushow "foo-\955-bar" `shouldBe` "\"foo-\955-bar\"" + + it "is inverted by read" $ do + property $ \ xs -> + read (ushow xs) `shouldBe` xs diff --git a/test/Test/Hspec/Core/Formatters/PrettySpec.hs b/test/Test/Hspec/Core/Formatters/PrettySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/PrettySpec.hs @@ -0,0 +1,158 @@ +module Test.Hspec.Core.Formatters.PrettySpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Formatters.Pretty.ParserSpec hiding (spec) + +import Test.Hspec.Core.Formatters.Pretty + +spec :: Spec +spec = do + describe "pretty2" $ do + context "with single-line string literals" $ do + context "with --unicode" $ do + it "recovers unicode" $ do + pretty2 True (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\955bar\"", "\"foo-bar\"") + + context "with --no-unicode" $ do + it "does not recover unicode" $ do + pretty2 False (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\\955bar\"", "\"foo-bar\"") + + context "when expected and actual would be equal after pretty-printing" $ do + it "returns the original values unmodified" $ do + pretty2 True (show "foo") (show "foo" <> " ") `shouldBe` (show "foo", show "foo" <> " ") + + describe "recoverString" $ do + it "recovers a string" $ do + recoverString (show "foo") `shouldBe` Just "foo" + + it "recovers the empty string" $ do + recoverString (show "") `shouldBe` Just "" + + it "does not recover a string with leading space" $ do + recoverString (" " <> show "foo") `shouldBe` Nothing + + it "does not recover a string with trailing space" $ do + recoverString (show "foo" <> " ") `shouldBe` Nothing + + it "does not recover an empty list" $ do + recoverString "[]" `shouldBe` Nothing + + describe "recoverMultiLineString" $ do + let + multiLineString :: String + multiLineString = "foo\nbar\nbaz\n" + + it "recovers multi-line string literals" $ do + recoverMultiLineString True (show multiLineString) `shouldBe` Just multiLineString + + it "does not recover string literals that contain control characters" $ do + recoverMultiLineString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing + + it "does not recover string literals that span a single line" $ do + recoverMultiLineString True (show "foo\n") `shouldBe` Nothing + + it "does not recover a string with trailing space" $ do + recoverMultiLineString True (" " <> show multiLineString) `shouldBe` Nothing + + it "does not recover a string with trailing space" $ do + recoverMultiLineString True (show multiLineString <> " ") `shouldBe` Nothing + + context "when unicode is True" $ do + it "recovers string literals that contain unicode" $ do + recoverMultiLineString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n" + + context "when unicode is False" $ do + it "does not recover string literals that contain unicode" $ do + recoverMultiLineString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing + + describe "pretty" $ do + it "pretty-prints records" $ do + pretty True (show person) `shouldBe` just [ + "Person {" + , " personName = \"Joe\"," + , " personAge = 23," + , " personAddress = Just Address {" + , " addressStreet = \"Main Street\"," + , " addressPostalCode = 50000" + , " }" + , "}" + ] + + it "pretty-prints Just-values" $ do + pretty True (show $ Just person) `shouldBe` just [ + "Just Person {" + , " personName = \"Joe\"," + , " personAge = 23," + , " personAddress = Just Address {" + , " addressStreet = \"Main Street\"," + , " addressPostalCode = 50000" + , " }" + , "}" + ] + + it "pretty-prints tuples" $ do + pretty True (show (person, -0.5 :: Rational)) `shouldBe` just [ + "(Person {" + , " personName = \"Joe\"," + , " personAge = 23," + , " personAddress = Just Address {" + , " addressStreet = \"Main Street\"," + , " addressPostalCode = 50000" + , " }" + , "}, (-1) % 2)" + ] + + it "pretty-prints lists" $ do + pretty True (show [Just person, Nothing]) `shouldBe` just [ + "[Just Person {" + , " personName = \"Joe\"," + , " personAge = 23," + , " personAddress = Just Address {" + , " addressStreet = \"Main Street\"," + , " addressPostalCode = 50000" + , " }" + , "}, Nothing]" + ] + + context "with --unicode" $ do + it "retains unicode characters in record fields" $ do + pretty True (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [ + "Person {" + , " personName = \"λ-Joe\"," + , " personAge = 23," + , " personAddress = Nothing" + , "}" + ] + + it "retains unicode characters in list elements" $ do + pretty True (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"λ\", \"bar\"]"] + + context "with --no-unicode" $ do + it "does not retain unicode characters in record fields" $ do + pretty False (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [ + "Person {" + , " personName = \"\\955-Joe\"," + , " personAge = 23," + , " personAddress = Nothing" + , "}" + ] + + it "does not retain unicode characters in list elements" $ do + pretty False (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"\\955\", \"bar\"]"] + + context "with input that looks like a list" $ do + it "it returns Nothing" $ do + pretty True "[23,42]" `shouldBe` Nothing + + context "with input that looks like a tuple" $ do + it "it returns Nothing" $ do + pretty True "(23,42)" `shouldBe` Nothing + + context "with input that looks like function applications" $ do + it "it returns Nothing" $ do + let input = unlines ["foo", "bar", "baz"] + pretty True input `shouldBe` Nothing + where + just = Just . intercalate "\n" diff --git a/test/Test/Hspec/Core/Formatters/V1Spec.hs b/test/Test/Hspec/Core/Formatters/V1Spec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/V1Spec.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Formatters.V1Spec (spec) where + +import Prelude () +import Helper hiding (colorize) +import Data.String +import Control.Monad.IO.Class +import Control.Monad.Trans.Writer hiding (pass) + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Formatters.V1 as H hiding (FailureReason(..)) +import qualified Test.Hspec.Core.Formatters.V1.Monad as H (interpretWith) +import Test.Hspec.Core.Formatters.V1.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..)) + +data ColorizedText = + Plain String + | Transient String + | Info String + | Succeeded String + | Failed String + | Pending String + | Extra String + | Missing String + deriving (Eq, Show) + +instance IsString ColorizedText where + fromString = Plain + +removeColors :: [ColorizedText] -> String +removeColors input = case input of + Plain x : xs -> x ++ removeColors xs + Transient _ : xs -> removeColors xs + Info x : xs -> x ++ removeColors xs + Succeeded x : xs -> x ++ removeColors xs + Failed x : xs -> x ++ removeColors xs + Pending x : xs -> x ++ removeColors xs + Extra x : xs -> x ++ removeColors xs + Missing x : xs -> x ++ removeColors xs + [] -> "" + +simplify :: [ColorizedText] -> [ColorizedText] +simplify input = case input of + Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs) + Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs) + Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs) + x : xs -> x : simplify xs + [] -> [] + +colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText] +colorize color input = case simplify input of + Plain x : xs -> color x : xs + xs -> xs + +interpret :: FormatM a -> IO [ColorizedText] +interpret = interpretWith environment + +interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText] +interpretWith env = fmap simplify . execWriterT . H.interpretWith env + +environment :: Environment (WriterT [ColorizedText] IO) +environment = Environment { + environmentGetSuccessCount = return 0 +, environmentGetPendingCount = return 0 +, environmentGetFailMessages = return [] +, environmentUsedSeed = return 0 +, environmentGetCPUTime = return Nothing +, environmentGetRealTime = return 0 +, environmentWrite = tell . return . Plain +, environmentWriteTransient = tell . return . Transient +, environmentWithFailColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Failed r) >> return a +, environmentWithSuccessColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Succeeded r) >> return a +, environmentWithPendingColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Pending r) >> return a +, environmentWithInfoColor = \ action -> do + (a, r) <- liftIO $ runWriterT action + tell (colorize Info r) >> return a +, environmentUseDiff = return True +, environmentPrintTimes = return False +, environmentExtraChunk = tell . return . Extra +, environmentMissingChunk = tell . return . Missing +, environmentLiftIO = liftIO +} + +testSpec :: H.Spec +testSpec = do + H.describe "Example" $ do + H.it "success" (H.Result "" H.Success) + H.it "fail 1" (H.Result "" $ H.Failure Nothing $ H.Reason "fail message") + H.it "pending" (H.pendingWith "pending message") + H.it "fail 2" (H.Result "" $ H.Failure Nothing H.NoReason) + H.it "exceptions" (undefined :: H.Result) + H.it "fail 3" (H.Result "" $ H.Failure Nothing H.NoReason) + +spec :: Spec +spec = do + describe "progress" $ do + let formatter = H.progress + + describe "exampleSucceeded" $ do + it "marks succeeding examples with ." $ do + interpret (H.exampleSucceeded formatter undefined undefined) `shouldReturn` [ + Succeeded "." + ] + + describe "exampleFailed" $ do + it "marks failing examples with F" $ do + interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [ + Failed "F" + ] + + describe "examplePending" $ do + it "marks pending examples with ." $ do + interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [ + Pending "." + ] + + describe "specdoc" $ do + let + formatter = H.specdoc + runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} + + it "displays a header for each thing being described" $ do + _:x:_ <- runSpec testSpec + x `shouldBe` "Example" + + it "displays one row for each behavior" $ do + r <- runSpec $ do + H.describe "List as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + H.describe "Maybe as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + normalizeSummary r `shouldBe` [ + "" + , "List as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "Maybe as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "" + , "Finished in 0.0000 seconds" + , "6 examples, 0 failures" + ] + + it "outputs an empty line at the beginning (even for non-nested specs)" $ do + r <- runSpec $ do + H.it "example 1" True + H.it "example 2" True + normalizeSummary r `shouldBe` [ + "" + , "example 1" + , "example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + it "displays a row for each successful, failed, or pending example" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " fail 1 FAILED [1]") + r `shouldSatisfy` any (== " success") + + it "displays a '#' with an additional message for pending examples" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " # PENDING: pending message") + + context "with an empty group" $ do + it "omits that group from the report" $ do + r <- runSpec $ do + H.describe "foo" $ do + H.it "example 1" True + H.describe "bar" $ do + pass + H.describe "baz" $ do + H.it "example 2" True + + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " example 1" + , "baz" + , " example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + describe "failedFormatter" $ do + let action = H.failedFormatter formatter + + context "when actual/expected contain newlines" $ do + let + env = environment { + environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] + } + it "adds indentation" $ do + (removeColors <$> interpretWith env action) `shouldReturn` unlines [ + "" + , "Failures:" + , "" + , " 1) " + , " expected: first" + , " second" + , " third" + , " but got: first" + , " two" + , " third" + , "" + , " To rerun use: --match \"//\"" + , "" + , "Randomized with seed 0" + , "" + ] + + describe "footerFormatter" $ do + let action = H.footerFormatter formatter + + context "without failures" $ do + let env = environment {environmentGetSuccessCount = return 1} + it "shows summary in green if there are no failures" $ do + interpretWith env action `shouldReturn` [ + "Finished in 0.0000 seconds\n" + , Succeeded "1 example, 0 failures\n" + ] + + context "with pending examples" $ do + let env = environment {environmentGetPendingCount = return 1} + it "shows summary in yellow if there are pending examples" $ do + interpretWith env action `shouldReturn` [ + "Finished in 0.0000 seconds\n" + , Pending "1 example, 0 failures, 1 pending\n" + ] + + context "with failures" $ do + let env = environment {environmentGetFailMessages = return [undefined]} + it "shows summary in red" $ do + interpretWith env action `shouldReturn` [ + "Finished in 0.0000 seconds\n" + , Failed "1 example, 1 failure\n" + ] + + context "with both failures and pending examples" $ do + let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1} + it "shows summary in red" $ do + interpretWith env action `shouldReturn` [ + "Finished in 0.0000 seconds\n" + , Failed "2 examples, 1 failure, 1 pending\n" + ] + + context "same as failed_examples" $ do + failed_examplesSpec formatter + +failed_examplesSpec :: H.Formatter -> Spec +failed_examplesSpec formatter = do + let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} + + 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" (throw (ErrorCall "baz") :: Bool) + r `shouldContain` [ + " 1) foobar" + , " uncaught exception: ErrorCall" + , " baz" + ] + + it "prints all descriptions when a nested requirement fails" $ do + r <- runSpec $ + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" False + r `shouldSatisfy` any (== " 1) foo.bar baz") + + + context "when a failed example has a source location" $ do + it "includes that source location above the error message" $ do + let loc = H.Location "test/FooSpec.hs" 23 4 + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"] diff --git a/test/Test/Hspec/Core/Formatters/V2Spec.hs b/test/Test/Hspec/Core/Formatters/V2Spec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/V2Spec.hs @@ -0,0 +1,294 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Test.Hspec.Core.Formatters.V2Spec (spec) where + +import Prelude () +import Helper + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Spec as Spec +import qualified Test.Hspec.Core.Runner as H +import Test.Hspec.Core.Format +import Test.Hspec.Core.Formatters.V2 + +testSpec :: H.Spec +testSpec = do + H.describe "Example" $ do + H.it "success" (H.Result "" Spec.Success) + H.it "fail 1" (H.Result "" $ Spec.Failure Nothing $ H.Reason "fail message") + H.it "pending" (H.pendingWith "pending message") + H.it "fail 2" (H.Result "" $ Spec.Failure Nothing H.NoReason) + H.it "exceptions" (undefined :: Spec.Result) + H.it "fail 3" (H.Result "" $ Spec.Failure Nothing H.NoReason) + +formatConfig :: FormatConfig +formatConfig = defaultFormatConfig { + formatConfigOutputUnicode = unicode +, formatConfigUseDiff = True +, formatConfigDiffContext = Just 3 +, formatConfigExternalDiff = Nothing +, formatConfigPrettyPrint = True +, formatConfigPrettyPrintFunction = Just (H.configPrettyPrintFunction H.defaultConfig unicode) +} where + unicode = True + +runSpecWith :: Formatter -> H.Spec -> IO [String] +runSpecWith formatter = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ formatterToFormat formatter} + +spec :: Spec +spec = do + describe "progress" $ do + let item = ItemDone ([], "") . Item Nothing 0 "" + describe "formatterItemDone" $ do + it "marks succeeding examples with ." $ do + formatter <- formatterToFormat progress formatConfig + captureLines (formatter $ item Success) + `shouldReturn` ["."] + + it "marks failing examples with F" $ do + formatter <- formatterToFormat progress formatConfig + captureLines (formatter . item $ Failure Nothing NoReason) + `shouldReturn` ["F"] + + it "marks pending examples with ." $ do + formatter <- formatterToFormat progress formatConfig + captureLines (formatter . item $ Pending Nothing Nothing) + `shouldReturn` ["."] + + describe "checks" $ do + let + formatter = checks + config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter } + + it "prints unicode check marks" $ do + r <- captureLines . H.hspecWithResult config $ do + H.it "foo" True + normalizeSummary r `shouldBe` [ + "" + , "foo [✔]" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + ] + + it "uses ASCII as a fallback" $ do + r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do + H.it "foo" True + normalizeSummary r `shouldBe` [ + "" + , "foo [v]" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + ] + + describe "specdoc" $ do + + let runSpec = runSpecWith specdoc + + it "displays a header for each thing being described" $ do + _:x:_ <- runSpec testSpec + x `shouldBe` "Example" + + it "displays one row for each behavior" $ do + r <- runSpec $ do + H.describe "List as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + H.describe "Maybe as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + normalizeSummary r `shouldBe` [ + "" + , "List as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "Maybe as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "" + , "Finished in 0.0000 seconds" + , "6 examples, 0 failures" + ] + + it "outputs an empty line at the beginning (even for non-nested specs)" $ do + r <- runSpec $ do + H.it "example 1" True + H.it "example 2" True + normalizeSummary r `shouldBe` [ + "" + , "example 1" + , "example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + it "displays a row for each successful, failed, or pending example" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " fail 1 FAILED [1]") + r `shouldSatisfy` any (== " success") + + it "displays a '#' with an additional message for pending examples" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " # PENDING: pending message") + + context "with an empty group" $ do + it "omits that group from the report" $ do + r <- runSpec $ do + H.describe "foo" $ do + H.it "example 1" True + H.describe "bar" $ do + pass + H.describe "baz" $ do + H.it "example 2" True + + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " example 1" + , "baz" + , " example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + describe "formatterDone" $ do + let expectedButGot expected actual = ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing expected actual + + it "recovers unicode from ExpectedButGot" $ do + formatter <- formatterToFormat failed_examples formatConfig { formatConfigOutputUnicode = True } + formatter $ expectedButGot (show "\955") (show "\956") + (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ + "" + , "Failures:" + , "" + , " 1) " + , " expected: \"λ\"" + , " but got: \"μ\"" + , "" + , " To rerun use: --match \"//\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "on --expert" $ do + it "does not print rerun message" $ do + formatter <- formatterToFormat failed_examples formatConfig { formatConfigExpertMode = True } + formatter $ expectedButGot "foo" "bar" + (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ + "" + , "Failures:" + , "" + , " 1) " + , " expected: foo" + , " but got: bar" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "when actual/expected contain newlines" $ do + it "adds indentation" $ do + formatter <- formatterToFormat failed_examples formatConfig + formatter $ expectedButGot "first\nsecond\nthird" "first\ntwo\nthird" + (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ + "" + , "Failures:" + , "" + , " 1) " + , " expected: first" + , " second" + , " third" + , " but got: first" + , " two" + , " third" + , "" + , " To rerun use: --match \"//\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "without failures" $ do + it "shows summary in green if there are no failures" $ do + formatter <- formatterToFormat failed_examples formatConfig + formatter . ItemDone ([], "") . Item Nothing 0 "" $ Success + (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ + "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + ] + + context "with pending examples" $ do + it "shows summary in yellow if there are pending examples" $ do + formatter <- formatterToFormat failed_examples formatConfig + formatter . ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing + (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ + "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures, 1 pending" + ] + + context "same as failed_examples" $ do + failed_examplesSpec specdoc + + describe "getExpectedTotalCount" $ do + let formatter = silent { formatterStarted = fmap show getExpectedTotalCount >>= writeLine } + runSpec = runSpecWith formatter + it "returns the total number of spec items" $ do + result:_ <- runSpec testSpec + result `shouldBe` "6" + +failed_examplesSpec :: Formatter -> Spec +failed_examplesSpec formatter = do + let runSpec = runSpecWith formatter + + 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" (throw (ErrorCall "baz") :: Bool) + r `shouldContain` [ + " 1) foobar" + , " uncaught exception: ErrorCall" + , " baz" + ] + + it "prints all descriptions when a nested requirement fails" $ do + r <- runSpec $ + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" False + r `shouldSatisfy` any (== " 1) foo.bar baz") + + + context "when a failed example has a source location" $ do + it "includes that source location above the error message" $ do + let loc = H.Location "test/FooSpec.hs" 23 4 + addLoc e = e {Spec.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"] diff --git a/test/Test/Hspec/Core/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/FormattersSpec.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE CPP #-} -module Test.Hspec.Core.FormattersSpec (main, spec) where - -import Prelude () -import Helper -import qualified Control.Exception as E - -import qualified Test.Hspec.Core.Spec as H -import qualified Test.Hspec.Core.Runner as H -import qualified Test.Hspec.Core.Formatters as H - -#ifndef mingw32_HOST_OS -import System.Console.ANSI -#endif - -main :: IO () -main = hspec spec - -testSpec :: H.Spec -testSpec = do - H.describe "Example" $ do - H.it "success" (H.Success) - H.it "fail 1" (H.Fail Nothing "fail message") - H.it "pending" (H.pendingWith "pending message") - H.it "fail 2" (H.Fail Nothing "") - H.it "exceptions" (undefined :: H.Result) - H.it "fail 3" (H.Fail Nothing "") - -spec :: Spec -spec = do - describe "silent" $ do - let runSpec = fmap fst . capture . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} - it "produces no output" $ do - runSpec testSpec `shouldReturn` "" - - describe "failed_examples" $ do - failed_examplesSpec H.failed_examples - - describe "progress" $ do - let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.progress} - - it "produces '..F...FF.F' style output" $ do - r <- runSpec testSpec - head r `shouldBe` ".F.FFF" - - context "same as failed_examples" $ do - failed_examplesSpec H.progress - - describe "specdoc" $ do - let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.specdoc} - - it "displays a header for each thing being described" $ do - _:x:_ <- runSpec testSpec - x `shouldBe` "Example" - - it "displays one row for each behavior" $ do - r <- runSpec $ do - H.describe "List as a Monoid" $ do - H.describe "mappend" $ do - H.it "is associative" True - H.describe "mempty" $ do - H.it "is a left identity" True - H.it "is a right identity" True - H.describe "Maybe as a Monoid" $ do - H.describe "mappend" $ do - H.it "is associative" True - H.describe "mempty" $ do - H.it "is a left identity" True - H.it "is a right identity" True - normalizeSummary r `shouldBe` [ - "" - , "List as a Monoid" - , " mappend" - , " is associative" - , " mempty" - , " is a left identity" - , " is a right identity" - , "Maybe as a Monoid" - , " mappend" - , " is associative" - , " mempty" - , " is a left identity" - , " is a right identity" - , "" - , "Finished in 0.0000 seconds" - , "6 examples, 0 failures" - ] - - it "outputs an empty line at the beginning (even for non-nested specs)" $ do - r <- runSpec $ do - H.it "example 1" True - H.it "example 2" True - normalizeSummary r `shouldBe` [ - "" - , "example 1" - , "example 2" - , "" - , "Finished in 0.0000 seconds" - , "2 examples, 0 failures" - ] - - it "displays a row for each successfull, failed, or pending example" $ do - r <- runSpec testSpec - r `shouldSatisfy` any (== " fail 1 FAILED [1]") - r `shouldSatisfy` any (== " success") - - it "displays a '#' with an additional message for pending examples" $ do - r <- runSpec testSpec - r `shouldSatisfy` any (== " # PENDING: pending message") - - context "with an empty group" $ do - it "omits that group from the report" $ do - r <- runSpec $ do - H.describe "foo" $ do - H.it "example 1" True - H.describe "bar" $ do - return () - H.describe "baz" $ do - H.it "example 2" True - - normalizeSummary r `shouldBe` [ - "" - , "foo" - , " example 1" - , "baz" - , " example 2" - , "" - , "Finished in 0.0000 seconds" - , "2 examples, 0 failures" - ] - - context "same as failed_examples" $ do - failed_examplesSpec H.progress - -failed_examplesSpec :: H.Formatter -> Spec -failed_examplesSpec formatter = do - let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} - - it "summarizes the time it takes to finish" $ do - r <- runSpec (return ()) - normalizeSummary r `shouldSatisfy` any (== "Finished in 0.0000 seconds") - - context "displays a detailed list of failures" $ do - it "prints all requirements that are not met" $ do - r <- runSpec testSpec - r `shouldSatisfy` any (== " 1) Example fail 1") - - it "prints the exception type for requirements that fail due to an uncaught exception" $ do - r <- runSpec $ do - H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool) - r `shouldContain` [ - " 1) foobar" - , " uncaught exception: ErrorCall (baz)" - ] - - it "prints all descriptions when a nested requirement fails" $ do - r <- runSpec $ - H.describe "foo" $ do - H.describe "bar" $ do - H.it "baz" False - r `shouldSatisfy` any (== " 1) foo.bar baz") - - - context "when a failed example has a source location" $ do - let bestEffortExplanation = "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." - - it "includes the source locations above the error messages" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldContain` [" test/FooSpec.hs:23: ", " 1) foo"] - - context "when source location is exact" $ do - it "includes that source locations" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== " test/FooSpec.hs:23: ") - - it "does not include 'best-effort' explanation" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` all (/= bestEffortExplanation) - - context "when source location is best-effort" $ do - it "marks that source location as 'best-effort'" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== " test/FooSpec.hs:23: (best-effort)") - - it "includes 'best-effort' explanation" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== bestEffortExplanation) - - it "summarizes the number of examples and failures" $ do - r <- runSpec testSpec - r `shouldSatisfy` any (== "6 examples, 4 failures, 1 pending") - - -- Windows has no support for ANSI escape codes. The Console API is used for - -- colorized output, hence the following tests do not work on Windows. -#ifndef mingw32_HOST_OS - it "shows summary in green if there are no failures" $ do - r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do - H.it "foobar" True - r `shouldSatisfy` any (== (green ++ "1 example, 0 failures" ++ reset)) - - it "shows summary in yellow if there are pending examples" $ do - r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do - H.it "foobar" H.pending - r `shouldSatisfy` any (== (yellow ++ "1 example, 0 failures, 1 pending" ++ reset)) - - it "shows summary in red if there are failures" $ do - r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do - H.it "foobar" False - r `shouldSatisfy` any (== (red ++ "1 example, 1 failure" ++ reset)) - - it "shows summary in red if there are both failures and pending examples" $ do - r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do - H.it "foo" False - H.it "bar" H.pending - r `shouldSatisfy` any (== (red ++ "2 examples, 1 failure, 1 pending" ++ reset)) - where - green = setSGRCode [SetColor Foreground Dull Green] - yellow = setSGRCode [SetColor Foreground Dull Yellow] - red = setSGRCode [SetColor Foreground Dull Red] - reset = setSGRCode [Reset] -#endif diff --git a/test/Test/Hspec/Core/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs --- a/test/Test/Hspec/Core/HooksSpec.hs +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -1,20 +1,45 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Hspec.Core.HooksSpec (main, spec) where +module Test.Hspec.Core.HooksSpec (spec) where import Prelude () import Helper +import Mock -import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Spec as H +import Test.Hspec.Core.Format +import Test.Hspec.Core.Runner.Eval import qualified Test.Hspec.Core.Hooks as H -main :: IO () -main = hspec spec +evalSpec_ :: H.Spec -> IO () +evalSpec_ = void . evalSpec -runSilent :: H.Spec -> IO () -runSilent = silence . H.hspec +evalSpec :: H.Spec -> IO [([String], Item)] +evalSpec = fmap normalize . (toEvalForest >=> runFormatter config) + where + config = EvalConfig { + evalConfigFormat = \ _ -> pass + , evalConfigConcurrentJobs = 1 + , evalConfigFailFast = False + , evalConfigColorMode = ColorEnabled + } + normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item) + normalizeItem item = item { + itemLocation = Nothing + , itemDuration = 0 + , itemResult = case itemResult item of + Success -> Success + Pending _ reason -> Pending Nothing reason + Failure _ reason -> Failure Nothing reason + } + pathToList (xs, x) = xs ++ [x] + +toEvalForest :: H.SpecWith () -> IO [EvalTree] +toEvalForest = fmap (uncurry (H.specToEvalForest 0) . first (($ H.defaultConfig) . appEndo)) . H.runSpecM + mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do ref <- newIORef ([] :: [String]) @@ -26,32 +51,24 @@ describe "before" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before (rec "before" >> return "value") $ do + evalSpec_ $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> do rec (value ++ " foo") H.it "bar" $ \value -> do rec (value ++ " bar") retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before (rec "before" >> return "value") $ do + evalSpec_ $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - describe "before_" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before_ (rec "before") $ do + evalSpec_ $ H.before_ (rec "before") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -61,7 +78,7 @@ context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do + evalSpec_ $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` ["outer", "inner", "foo"] @@ -69,14 +86,14 @@ context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before_ (rec "before") $ do + evalSpec_ $ H.before_ (rec "before") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 200 . cycle) ["before", "foo"] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do + evalSpec_ $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 300 . cycle) ["outer", "inner", "foo"] @@ -85,7 +102,7 @@ (rec, retrieve) <- mkAppend let action :: Int -> IO String action = return . show - runSilent $ H.before (return 23) $ H.beforeWith action $ do + evalSpec_ $ H.before (return 23) $ H.beforeWith action $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["23"] @@ -101,7 +118,7 @@ (rec, retrieve) <- mkAppend - runSilent $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do + evalSpec_ $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["foo 24"] @@ -109,7 +126,7 @@ describe "beforeAll" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do + evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do H.it "foo" $ \value -> do rec $ "foo " ++ value H.it "bar" $ \value -> do @@ -120,21 +137,29 @@ , "bar value" ] + context "when specified action throws an exception" $ do + it "sets subsequent spec items to pending" $ do + evalSpec $ H.beforeAll throwException $ do + H.it "foo" $ \n -> do + n `shouldBe` (23 :: Int) + H.it "bar" $ \n -> do + n `shouldBe` 23 + `shouldReturn` [ + item ["foo"] divideByZero + , item ["bar"] (Pending Nothing $ exceptionIn "beforeAll") + ] + context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend - runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do - return () + evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do + pass retrieve `shouldReturn` [] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - describe "beforeAll_" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.beforeAll_ (rec "beforeAll_") $ do + evalSpec_ $ H.beforeAll_ (rec "beforeAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -148,7 +173,7 @@ context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend - runSilent $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do + evalSpec_ $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -160,10 +185,73 @@ , "bar" ] + describe "beforeAllWith" $ do + it "transforms the spec argument" $ do + (rec, retrieve) <- mkAppend + let action :: Int -> IO String + action = return . show + evalSpec_ $ H.beforeAll (return 23) $ H.beforeAllWith action $ do + H.it "foo" $ \value -> rec value + retrieve `shouldReturn` ["23"] + + it "can be used multiple times" $ do + let action1 :: Int -> IO Int + action1 = return . succ + + action2 :: Int -> IO String + action2 = return . show + + action3 :: String -> IO String + action3 = return . ("foo " ++) + + (rec, retrieve) <- mkAppend + + evalSpec_ $ H.beforeAll (return 23) $ + H.beforeAllWith action1 $ H.beforeAllWith action2 $ H.beforeAllWith action3 $ do + H.it "foo" $ \value -> rec value + + retrieve `shouldReturn` ["foo 24"] + + it "runs an action before the first spec item" $ do + (rec, retrieve) <- mkAppend + evalSpec_ $ H.beforeAll (return (23 :: Int)) $ + H.beforeAllWith (\value -> rec "beforeAllWith" >> return (show value)) $ do + H.it "foo" $ \value -> do + rec $ "foo " ++ value + H.it "bar" $ \value -> do + rec $ "bar " ++ value + retrieve `shouldReturn` [ + "beforeAllWith" + , "foo 23" + , "bar 23" + ] + + context "when specified action throws an exception" $ do + it "sets subsequent spec items to pending" $ do + evalSpec $ do + H.beforeAll (return (23 :: Int)) $ do + H.beforeAllWith (\ _ -> throwException) $ do + H.it "foo" $ \n -> do + n `shouldBe` (23 :: Int) + H.it "bar" $ \n -> do + n `shouldBe` 23 + `shouldReturn` [ + item ["foo"] divideByZero + , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith") + ] + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + (rec, retrieve) <- mkAppend + evalSpec_ $ H.beforeAll (return (23 :: Int)) $ + H.beforeAllWith (\_ -> rec "beforeAllWith" >> return "value") $ do + pass + retrieve `shouldReturn` [] + describe "after" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before (rec "before" >> return "from before") $ H.after rec $ do + evalSpec_ $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do @@ -179,20 +267,16 @@ it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend - silence . ignoreExitCode . H.hspec $ H.before (rec "before" >> return "from before") $ H.after rec $ do + evalSpec_ $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do - ioError $ userError "foo" :: IO () + throwException_ rec "foo" retrieve `shouldReturn` ["before", "from before"] - context "when used multiple times" $ do - it "is evaluated inside out" $ do - pending - describe "after_" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.after_ (rec "after") $ do + evalSpec_ $ H.after_ (rec "after") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -206,16 +290,16 @@ it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend - silence . ignoreExitCode $ H.hspec $ H.after_ (rec "after") $ do + evalSpec_ $ H.after_ (rec "after") $ do H.it "foo" $ do - ioError $ userError "foo" :: IO () + throwException_ rec "foo" retrieve `shouldReturn` ["after"] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend - runSilent $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do + evalSpec_ $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ @@ -227,7 +311,7 @@ describe "afterAll" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do + evalSpec_ $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do @@ -237,27 +321,29 @@ , "foo" , "before" , "bar" - , "before" , "from before" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do - (rec, retrieve) <- mkAppend - runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do - return () - retrieve `shouldReturn` [] + evalSpec $ H.before undefined $ H.afterAll undefined $ do + pass + `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do - r <- runSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do + evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do H.it "foo" $ \a -> a `shouldBe` "from before" - r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") + H.it "bar" $ \a -> a `shouldBe` "from before" + `shouldReturn` [ + item ["foo"] Success + , item ["bar"] $ divideByZeroIn "afterAll" + ] describe "afterAll_" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend - runSilent $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do + evalSpec_ $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -267,14 +353,13 @@ , "foo" , "before" , "bar" - , "before" , "afterAll_" ] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend - runSilent $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do + evalSpec_ $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ @@ -286,22 +371,46 @@ context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend - runSilent $ H.afterAll_ (rec "afterAll_") $ do - return () + evalSpec_ $ H.afterAll_ (rec "afterAll_") $ do + pass retrieve `shouldReturn` [] + context "when action is pending" $ do + it "reports pending" $ do + evalSpec $ do + H.afterAll_ H.pending $ do + H.it "foo" True + H.it "bar" True + `shouldReturn` [ + item ["foo"] Success + , item ["bar"] (Pending Nothing Nothing) + ] + context "when action throws an exception" $ do it "reports a failure" $ do - r <- runSpec $ do + evalSpec $ do H.afterAll_ throwException $ do H.it "foo" True - r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") + H.it "bar" True + `shouldReturn` [ + item ["foo"] Success + , item ["bar"] $ divideByZeroIn "afterAll_" + ] + context "when action is successful" $ do + it "does not report anything" $ do + evalSpec $ do + H.afterAll_ pass $ do + H.it "foo" True + `shouldReturn` [ + item ["foo"] Success + ] + describe "around" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e "from around" >> rec "after" - runSilent $ H.around action $ do + evalSpec_ $ H.around action $ do H.it "foo" $ rec . ("foo " ++) H.it "bar" $ rec . ("bar " ++) retrieve `shouldReturn` [ @@ -313,15 +422,11 @@ , "after" ] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - describe "around_" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e >> rec "after" - runSilent $ H.around_ action $ do + evalSpec_ $ H.around_ action $ do H.it "foo" $ do rec "foo" H.it "bar" $ do @@ -340,7 +445,7 @@ (rec, retrieve) <- mkAppend let actionOuter e = rec "before outer" >> e >> rec "after outer" actionInner e = rec "before inner" >> e >> rec "after inner" - runSilent $ H.around_ actionOuter $ H.around_ actionInner $ do + evalSpec_ $ H.around_ actionOuter $ H.around_ actionInner $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ @@ -353,12 +458,218 @@ describe "aroundWith" $ do it "wraps every spec item with an action" $ do + mock <- newMock (rec, retrieve) <- mkAppend - let action :: H.ActionWith String -> H.ActionWith Int - action e = e . show - runSilent $ H.before (return 23) $ H.aroundWith action $ do + let action = (. show) + evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundWith action $ do H.it "foo" rec - retrieve `shouldReturn` ["23"] + H.it "bar" rec + H.it "baz" rec + retrieve `shouldReturn` [ + "1" + , "2" + , "3" + ] + mockCounter mock `shouldReturn` 3 + + describe "aroundAll" $ do + it "wraps an action around a spec" $ do + (rec, retrieve) <- mkAppend + let action e = rec "before" *> e "from around" <* rec "after" + evalSpec_ $ H.aroundAll action $ do + H.it "foo" $ rec . ("foo " ++) + H.it "bar" $ rec . ("bar " ++) + H.it "baz" $ rec . ("baz " ++) + retrieve `shouldReturn` [ + "before" + , "foo from around" + , "bar from around" + , "baz from around" + , "after" + ] + + describe "aroundAll_" $ do + it "wraps an action around a spec" $ do + (rec, retrieve) <- mkAppend + let action inner = rec "before" *> inner <* rec "after" + evalSpec_ $ H.aroundAll_ action $ do + H.it "foo" $ rec "foo" + H.it "bar" $ rec "bar" + retrieve `shouldReturn` [ + "before" + , "foo" + , "bar" + , "after" + ] + + it "wrap actions around a spec in order" $ do + (rec, retrieve) <- mkAppend + let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i) + evalSpec_ $ H.aroundAll_ (action "1") $ H.aroundAll_ (action "2") $ do + H.it "foo" $ rec "foo" + H.it "bar" $ rec "bar" + retrieve `shouldReturn` [ + "before 1" + , "before 2" + , "foo" + , "bar" + , "after 2" + , "after 1" + ] + + it "does not call actions wrapped around a failing action" $ do + (rec, retrieve) <- mkAppend + let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i) + evalSpec_ $ + H.aroundAll_ (action "1") $ + H.aroundAll_ (action "2 failing" . const throwException) $ + H.aroundAll_ (action "3") $ do + H.it "foo" $ rec "foo" + H.it "bar" $ rec "bar" + retrieve `shouldReturn` [ + "before 1" + , "before 2 failing" + , "after 1" + ] + + it "does not memoize subject" $ do + mock <- newMock + let action :: IO Int + action = mockAction mock >> mockCounter mock + + (rec, retrieve) <- mkAppend + evalSpec_ $ H.before action $ H.aroundAll_ id $ do + H.it "foo" $ rec . show + H.it "bar" $ rec . show + H.it "baz" $ rec . show + retrieve `shouldReturn` [ + "1" + , "2" + , "3" + ] + mockCounter mock `shouldReturn` 3 + + it "reports exceptions on acquire" $ do + evalSpec $ do + H.aroundAll_ (throwException <*) $ do + H.it "foo" True + H.it "bar" True + `shouldReturn` [ + item ["foo"] divideByZero + , item ["bar"] (Pending Nothing $ exceptionIn "aroundAll_") + ] + + it "reports exceptions on release" $ do + evalSpec $ do + H.aroundAll_ (<* throwException) $ do + H.it "foo" True + H.it "bar" True + `shouldReturn` [ + item ["foo"] Success + , item ["bar"] $ divideByZeroIn "aroundAll_" + ] + + describe "aroundAllWith" $ do + it "wraps an action around a spec" $ do + mock <- newMock + (rec, retrieve) <- mkAppend + let action = (. show) + evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundAllWith action $ do + H.it "foo" rec + H.it "bar" rec + H.it "baz" rec + retrieve `shouldReturn` [ + "1" + , "1" + , "1" + ] + mockCounter mock `shouldReturn` 3 + + it "wrap actions around a spec in order" $ do + (rec, retrieve) <- mkAppend + let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i) + evalSpec_ $ H.aroundAllWith (action "1") $ H.aroundAllWith (action "2") $ do + H.it "foo" $ rec "foo" + H.it "bar" $ rec "bar" + retrieve `shouldReturn` [ + "before 1" + , "before 2" + , "foo" + , "bar" + , "after 2" + , "after 1" + ] + + it "does not call actions wrapped around a failing action" $ do + (rec, retrieve) <- mkAppend + let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i) + evalSpec_ $ + H.aroundAllWith (action "1") $ + H.aroundAllWith (action "2 failing" . const . const throwException) $ + H.aroundAllWith (action "3") $ do + H.it "foo" $ rec "foo" + H.it "bar" $ rec "bar" + retrieve `shouldReturn` [ + "before 1" + , "before 2 failing" + , "after 1" + ] + + it "reports exceptions on acquire" $ do + evalSpec $ do + H.aroundAllWith (\ action () -> throwException >>= action) $ do + H.it "foo" H.pending + `shouldReturn` [ + item ["foo"] divideByZero + ] + + it "reports exceptions on release" $ do + evalSpec $ do + H.aroundAllWith (\ action () -> action () <* throwException) $ do + H.it "foo" True + H.it "bar" True + `shouldReturn` [ + item ["foo"] Success + , item ["bar"] $ divideByZeroIn "aroundAllWith" + ] + + describe "decompose" $ do + it "decomposes a with-style action into acquire / release" $ do + (acquire, release) <- H.decompose $ \ action x -> do + action (x + 42 :: Int) + acquire 23 `shouldReturn` 65 + release + + context "when release is called before acquire" $ do + it "does nothing" $ do + (_, release) <- H.decompose $ \ action x -> do + action (x + 42 :: Int) + release + + context "with an exception during resource acquisition" $ do + it "propagates that exception" $ do + (acquire, release) <- H.decompose $ \ action () -> do + throwException_ + action () + acquire () `shouldThrow` (== DivideByZero) + release + + context "with an exception during resource deallocation" $ do + it "propagates that exception" $ do + (acquire, release) <- H.decompose $ \ action () -> do + action () + throwException_ + acquire () + release `shouldThrow` (== DivideByZero) + where - runSpec :: H.Spec -> IO [String] - runSpec = captureLines . H.hspecResult + divideByZero :: Result + divideByZero = Failure Nothing (Error Nothing $ toException DivideByZero) + + divideByZeroIn :: String -> Result + divideByZeroIn hook = Failure Nothing (Error (Just $ "in " <> hook <> "-hook:") $ toException DivideByZero) + + item :: [String] -> Result -> ([String], Item) + item path result = (path, Item Nothing 0 "" result) + + exceptionIn name = Just ("exception in " <> name <> "-hook (see previous failure)") diff --git a/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs b/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +module Test.Hspec.Core.QuickCheck.UtilSpec (spec) where + +import Prelude () +import Helper + +import qualified Test.QuickCheck.Property as QCP + +import Test.Hspec.Core.QuickCheck.Util + +deriving instance Eq QuickCheckResult +deriving instance Eq Status +deriving instance Eq QuickCheckFailure + +spec :: Spec +spec = do + describe "formatNumbers" $ do + it "includes number of tests" $ do + formatNumbers 1 0 `shouldBe` "(after 1 test)" + + it "pluralizes number of tests" $ do + formatNumbers 3 0 `shouldBe` "(after 3 tests)" + + it "includes number of shrinks" $ do + formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)" + + it "pluralizes number of shrinks" $ do + formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)" + + describe "stripSuffix" $ do + it "drops the given suffix from a list" $ do + stripSuffix "bar" "foobar" `shouldBe` Just "foo" + + describe "splitBy" $ do + it "splits a string by a given infix" $ do + splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz") + + describe "parseQuickCheckResult" $ do + let + args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)} + qc = quickCheckWithResult args + + context "with Success" $ do + let p :: Int -> Bool + p n = n == n + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess + + it "includes labels" $ do + parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess + + context "with GaveUp" $ do + let p :: Int -> Property + p n = (n == 1234) ==> True + + qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1} + result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests; 2 discarded!") + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Skipped (precondition false):" + , "0" + , "" + , "Skipped (precondition false):" + , "0" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with NoExpectedFailure" $ do + let + p :: Int -> Property + p _ = expectFailure True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).") + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "23" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") + + context "with cover" $ do + context "without checkCoverage" $ do + let + p :: Int -> Property + p n = cover 10 (n == 5) "is 5" True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "23" + , "" +#if MIN_VERSION_QuickCheck(2,15,0) + , "+++ OK, passed 2 tests (0% is 5)." +#else + , "+++ OK, passed 2 tests." +#endif + , "" + , "Only 0% is 5, but expected 10%" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info QuickCheckSuccess + + context "with checkCoverage" $ do + let + p :: Int -> Property + p n = checkCoverage $ cover 10 (n == 23) "is 23" True + + failure :: QuickCheckFailure + failure = QCFailure { + quickCheckFailureNumShrinks = 0 + , quickCheckFailureException = Nothing + , quickCheckFailureReason = "Insufficient coverage" + , quickCheckFailureCounterexample = [ + " 0.9% is 23" + , "" + , "Only 0.9% is 23, but expected 10.0%" + ] + } + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 800 "" (QuickCheckFailure failure) + + it "includes verbose output" $ do +-- This off-by-one error was fixed in QuickCheck 2.15 +#if MIN_VERSION_QuickCheck(2,15,0) + let info = intercalate "\n\n" (replicate 800 "Passed:") +#else + let info = intercalate "\n\n" (replicate 799 "Passed:") +#endif + parseQuickCheckResult <$> qc (verbose . p) `shouldReturn` + QuickCheckResult 800 info (QuickCheckFailure failure) + + context "with Failure" $ do + context "with single-line failure reason" $ do + let + p :: Int -> Bool + p = (< 1) + + err = "Falsified" + result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "-2" + , "" + , "Failed:" + , "3" + , "" + , "Passed:" + , "0" + , "" + , "Failed:" + , "2" + , "" + , "Passed:" + , "0" + , "" + , "Failed:" + , "1" + , "" + , "Passed:" + , "0" + ] + + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with multi-line failure reason" $ do + let + p :: Int -> QCP.Result + p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err} + + err = "foo\nbar" + result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "-2" + , "" + , "Passed:" + , "3" + , "" + , "Failed:" + , "2" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "1" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with HUnit assertion" $ do + let p :: Int -> Int -> Expectation + p m n = do + m `shouldBe` n + + it "includes counterexample" $ do + result <- qc p + let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result + quickCheckFailureCounterexample r `shouldBe` ["0", "1"] diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -module Test.Hspec.Core.QuickCheckUtilSpec (main, spec) where - -import Helper - -import Test.QuickCheck -import Test.Hspec.Core.QuickCheckUtil - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "formatNumbers" $ do - it "includes number of tests" $ do - formatNumbers (failure 1 0) `shouldBe` "(after 1 test)" - - it "pluralizes number of tests" $ do - formatNumbers (failure 3 0) `shouldBe` "(after 3 tests)" - - it "includes number of shrinks" $ do - formatNumbers (failure 3 1) `shouldBe` "(after 3 tests and 1 shrink)" - - it "pluralizes number of shrinks" $ do - formatNumbers (failure 3 3) `shouldBe` "(after 3 tests and 3 shrinks)" - where - failure tests shrinks = Failure { - numTests = tests - , numShrinks = shrinks - } diff --git a/test/Test/Hspec/Core/Runner/EvalSpec.hs b/test/Test/Hspec/Core/Runner/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/EvalSpec.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Test.Hspec.Core.Runner.EvalSpec (spec) where + +import Prelude () +import Helper + +import Data.List.NonEmpty (fromList) + +import Test.Hspec.Core.Spec (FailureReason(..), Result(..), ResultStatus(..), Location(..)) + +import Test.Hspec.Core.Runner.Eval + +instance Arbitrary ResultStatus where + arbitrary = oneof [ + pure Success + , Pending <$> arbitrary <*> arbitrary + , failure + ] + +instance Arbitrary FailureReason where + arbitrary = oneof [ + pure NoReason + , ExpectedButGot <$> arbitrary <*> (show <$> positive) <*> (show <$> positive) + , Error <$> arbitrary <*> pure (toException DivideByZero) + ] + +instance Arbitrary Location where + arbitrary = Location <$> elements ["src/Foo.hs", "src/Bar.hs", "src/Baz.hs"] <*> positive <*> positive + +positive :: Gen Int +positive = getPositive <$> arbitrary + +failureResult :: Gen Result +failureResult = Result <$> arbitrary <*> failure + +pendingResult :: Gen Result +pendingResult = Result <$> arbitrary <*> pending + +successResult :: Gen Result +successResult = Result <$> arbitrary <*> pure Success + +pending :: Gen ResultStatus +pending = Pending <$> arbitrary <*> arbitrary + +failure :: Gen ResultStatus +failure = Failure <$> arbitrary <*> arbitrary + +spec :: Spec +spec = do + describe "mergeResults" $ do + it "gives failures from items precedence" $ do + forAll failureResult $ \ item hook -> do + mergeResults Nothing item hook `shouldBe` item + + it "gives failures from hooks precedence over succeeding items" $ do + forAll successResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do + mergeResults Nothing item hook `shouldBe` Result info hook + + it "gives failures from hooks precedence over pending items" $ do + forAll pendingResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do + mergeResults Nothing item hook `shouldBe` Result info hook + + it "gives pending items precedence over pending hooks" $ do + forAll pendingResult $ \ item -> forAll pending $ \ hook -> do + mergeResults Nothing item hook `shouldBe` item + + describe "traverse" $ do + context "when used with Tree" $ do + let + tree :: Tree () Int + tree = Node "" $ fromList [Node "" $ fromList [Leaf 1, Node "" $ fromList [Leaf 2, Leaf 3]], Leaf 4] + it "walks the tree left-to-right, depth-first" $ do + ref <- newIORef [] + traverse_ (modifyIORef ref . (:) ) tree + reverse <$> readIORef ref `shouldReturn` [1 .. 4] diff --git a/test/Test/Hspec/Core/Runner/JobQueueSpec.hs b/test/Test/Hspec/Core/Runner/JobQueueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/JobQueueSpec.hs @@ -0,0 +1,44 @@ +module Test.Hspec.Core.Runner.JobQueueSpec (spec) where + +import Prelude () +import Helper + +import Control.Concurrent + +import Test.Hspec.Core.Runner.JobQueue + +spec :: Spec +spec = do + describe "enqueueJob" $ do + let + waitFor job = job (\ _ -> pass) >>= either throwIO return + + context "with Sequential" $ do + it "runs actions sequentially" $ do + withJobQueue 10 $ \ queue -> do + ref <- newIORef [] + jobA <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (23 :) + jobB <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (42 :) + waitFor jobB + readIORef ref `shouldReturn` [42 :: Int] + waitFor jobA + readIORef ref `shouldReturn` [23, 42] + + context "with Concurrent" $ do + it "runs actions concurrently" $ do + withJobQueue 10 $ \ queue -> do + barrierA <- newEmptyMVar + barrierB <- newEmptyMVar + + jobA <- enqueueJob queue Concurrent $ \ _ -> do + putMVar barrierB () + takeMVar barrierA + + jobB <- enqueueJob queue Concurrent $ \ _ -> do + putMVar barrierA () + takeMVar barrierB + + timeout (0.1 :: Seconds) $ do + waitFor jobA + waitFor jobB + `shouldReturn` Just () diff --git a/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs b/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs @@ -0,0 +1,49 @@ +module Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec (spec) where + +import Prelude () +import Helper + +import System.IO (stderr) + +import Test.Hspec.Core.Format +import Test.Hspec.Core.Runner.PrintSlowSpecItems + +location :: Location +location = Location { + locationFile = "Foo.hs" +, locationLine = 23 +, locationColumn = 42 +} + +item :: Item +item = Item { + itemLocation = Just location +, itemDuration = 0 +, itemInfo = undefined +, itemResult = undefined +} + +spec :: Spec +spec = do + describe "printSlowSpecItems" $ do + let + format = printSlowSpecItems 2 $ \ _ -> pass + run = hCapture_ [stderr] . format . Done + + it "prints slow spec items" $ do + run [ + ((["foo", "bar"], "one"), item {itemDuration = 0.100}) + , ((["foo", "bar"], "two"), item {itemDuration = 0.500}) + , ((["foo", "bar"], "thr"), item {itemDuration = 0.050}) + ] + `shouldReturn` unlines [ + "" + , "Slow spec items:" + , " Foo.hs:23:42: /foo/bar/two/ (500ms)" + , " Foo.hs:23:42: /foo/bar/one/ (100ms)" + ] + + context "when there are no slow items" $ do + it "prints nothing" $ do + run [((["foo", "bar"], "one"), item {itemDuration = 0})] + `shouldReturn` "" diff --git a/test/Test/Hspec/Core/Runner/ResultSpec.hs b/test/Test/Hspec/Core/Runner/ResultSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/ResultSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RecordWildCards #-} +module Test.Hspec.Core.Runner.ResultSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Format + +import Test.Hspec.Core.Runner.Result + +spec :: Spec +spec = do + describe "Summary" $ do + let + summary :: Summary + summary = toSummary $ toSpecResult [item Success, item failure] + + it "can be deconstructed via accessor functions" $ do + (summaryExamples &&& summaryFailures) summary `shouldBe` (2, 1) + + it "can be deconstructed via pattern matching" $ do + let Summary examples failures = summary + (examples, failures) `shouldBe` (2, 1) + + it "can be deconstructed via RecordWildCards" $ do + let Summary{..} = summary + (summaryExamples, summaryFailures) `shouldBe` (2, 1) + + describe "specResultSuccess" $ do + context "when all spec items passed" $ do + it "returns True" $ do + specResultSuccess (toSpecResult [item Success]) `shouldBe` True + + context "with a failed spec item" $ do + it "returns False" $ do + specResultSuccess (toSpecResult [item Success, item failure]) `shouldBe` False + + context "with an empty result list" $ do + it "returns True" $ do + specResultSuccess (toSpecResult []) `shouldBe` True + where + failure = Failure Nothing NoReason + item result = (([], ""), Item Nothing 0 "" result) diff --git a/test/Test/Hspec/Core/RunnerSpec.hs b/test/Test/Hspec/Core/RunnerSpec.hs --- a/test/Test/Hspec/Core/RunnerSpec.hs +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -1,32 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Hspec.Core.RunnerSpec (main, spec) where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +module Test.Hspec.Core.RunnerSpec (spec) where import Prelude () import Helper -import System.IO (stderr) -import Control.Monad (replicateM_) -import System.Environment (withArgs, withProgName, getArgs) +import System.IO +import System.Environment (withArgs, withProgName, getArgs, setEnv, unsetEnv) import System.Exit import Control.Concurrent -import qualified Control.Exception as E +import Control.Concurrent.Async import Mock -import System.SetEnv -import Test.Hspec.FailureReport (FailureReport(..)) +import Test.Hspec.Core.FailureReport (FailureReport(..)) +import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H +import Test.Hspec.Core.Runner (UseColor(..), ProgressReporting(..)) import qualified Test.Hspec.Core.Runner as H -import qualified Test.Hspec.Core.Formatters as H (silent) +import Test.Hspec.Core.Runner.Result import qualified Test.Hspec.Core.QuickCheck as H import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H -main :: IO () -main = hspec spec - -quickCheckOptions :: [([Char], Args -> Int)] -quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] +import Test.Hspec.Core.Formatters.Pretty.ParserSpec (Person(..)) +import Test.Hspec.Core.Extension () runPropFoo :: [String] -> IO String runPropFoo args = unlines . normalizeSummary . lines <$> do @@ -34,16 +36,54 @@ H.it "foo" $ do property (/= (23 :: Int)) +person :: Int -> Person +person age = Person "Joe" age Nothing + +data MyException = MyException + deriving (Eq, Show) + +instance Exception MyException where + displayException MyException = "my exception" + +resultWithColorizedReason :: H.Result +resultWithColorizedReason = H.Result { + H.resultInfo = "info" +, H.resultStatus = H.Failure Nothing . H.ColorizedReason $ "some " <> green "colorized" <> " error message" +} + spec :: Spec spec = do describe "hspec" $ do + + let + hspec args = withArgs args . hspecSilent + hspec_ = hspecSilent + + it "evaluates examples Unmasked" $ do + mvar <- newEmptyMVar + hspec_ $ do + H.it "foo" $ do + getMaskingState >>= putMVar mvar + takeMVar mvar `shouldReturn` Unmasked + + it "runs finalizers" $ do + mvar <- newEmptyMVar + ref <- newIORef "did not run finalizer" + a <- async $ hspec_ $ do + H.it "foo" $ do + (putMVar mvar () >> threadDelay 10000000) `finally` + writeIORef ref "ran finalizer" + takeMVar mvar + cancel a + readIORef ref `shouldReturn` "ran finalizer" + it "runs a spec" $ do - silence . H.hspec $ do + hspec_ $ do H.it "foobar" True `shouldReturn` () it "exits with exitFailure if not all examples pass" $ do - silence . H.hspec $ do + hspec_ $ do H.it "foobar" False `shouldThrow` (== ExitFailure 1) @@ -62,7 +102,7 @@ ] it "stores a failure report in the environment" $ do - silence . ignoreExitCode . withArgs ["--seed", "23"] . H.hspec $ do + ignoreExitCode . hspec ["--seed", "23"] $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" True @@ -80,73 +120,105 @@ ] } - 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 + context "with --rerun" $ do + let + failingSpec = 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" + succeedingSpec = do + H.it "example 1" True + H.it "example 2" True + H.it "example 3" True + H.it "example 4" True + H.it "example 5" True - r1 <- withArgs ["--rerun"] runSpec - r1 `shouldSatisfy` elem "3 examples, 3 failures" + run = captureLines . H.hspecResult + rerun = withArgs ["--rerun"] . run - it "reuses the same seed" $ do + it "reuses same --seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun"] `shouldReturn` r - forM_ quickCheckOptions $ \(flag, accessor) -> do - it ("reuses same " ++ flag) $ do - [flag, "23"] `shouldUseArgs` ((== 23) . accessor) - ["--rerun"] `shouldUseArgs` ((== 23) . accessor) + it "reuses same --qc-max-success" $ do + n <- generate arbitrary + ["--qc-max-success", show n] `shouldUseArgs` (QC.maxSuccess, n) + ["--rerun"] `shouldUseArgs` (QC.maxSuccess, n) - context "when no examples failed previously" $ do - it "runs all examples" $ do - let run = capture_ . H.hspec $ do - H.it "example 1" True - H.it "example 2" True - H.it "example 3" True + it "reuses same --qc-max-discard" $ do + n <- generate arbitrary + ["--qc-max-discard", show n] `shouldUseArgs` (QC.maxDiscardRatio, n) + ["--rerun"] `shouldUseArgs` (QC.maxDiscardRatio, n) - r0 <- run - r0 `shouldContain` "3 examples, 0 failures" + it "reuses same --qc-max-size" $ do + n <- generate arbitrary + ["--qc-max-size", show n] `shouldUseArgs` (QC.maxSize, n) + ["--rerun"] `shouldUseArgs` (QC.maxSize, n) - r1 <- withArgs ["--rerun"] run - r1 `shouldContain` "3 examples, 0 failures" + context "with failing examples" $ do + it "only reruns failing examples" $ do + r0 <- run failingSpec + last r0 `shouldBe` "5 examples, 3 failures" + r1 <- rerun failingSpec + last r1 `shouldBe` "3 examples, 3 failures" + + context "without failing examples" $ do + it "runs all examples" $ do + r0 <- run succeedingSpec + last r0 `shouldBe` "5 examples, 0 failures" + + r1 <- rerun succeedingSpec + last r1 `shouldBe` "5 examples, 0 failures" + context "when there is no failure report in the environment" $ do - it "runs everything" $ do + it "runs all examples" $ do unsetEnv "HSPEC_FAILURES" - r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec + r <- hSilence [stderr] $ rerun failingSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do unsetEnv "HSPEC_FAILURES" - r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec + r <- hCapture_ [stderr] $ rerun failingSpec 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 + it "runs all examples" $ do setEnv "HSPEC_FAILURES" "some invalid report" - r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec + r <- hSilence [stderr] $ rerun failingSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do setEnv "HSPEC_FAILURES" "some invalid report" - r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec + r <- hCapture_ [stderr] $ rerun failingSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" + context "with --rerun-all-on-success" $ do + let rerunAllOnSuccess = withArgs ["--rerun", "--rerun-all-on-success"] . run + context "after a previously failing rerun succeeds for the first time" $ do + it "runs the whole test suite" $ do + _ <- run failingSpec + output <- rerunAllOnSuccess succeedingSpec + output `shouldSatisfy` elem "3 examples, 0 failures" + last output `shouldBe` "5 examples, 0 failures" - it "does not leak command-line flags to examples" $ do - silence . withArgs ["--verbose"] $ do - H.hspec $ do - H.it "foobar" $ do - getArgs `shouldReturn` [] - `shouldReturn` () + it "reruns runIO-actions" $ do + ref <- newIORef (0 :: Int) + let succeedingSpecWithRunIO = H.runIO (modifyIORef ref succ) >> succeedingSpec + _ <- run failingSpec + _ <- rerunAllOnSuccess succeedingSpecWithRunIO + readIORef ref `shouldReturn` 2 + + it "does not leak command-line options to examples" $ do + hspec ["--diff"] $ do + H.it "foobar" $ do + getArgs `shouldReturn` [] + `shouldReturn` () + context "when interrupted with ctrl-c" $ do it "prints summary immediately" $ do mvar <- newEmptyMVar @@ -160,55 +232,47 @@ H.it "baz" True putMVar mvar r takeMVar sync - throwTo threadId E.UserInterrupt + throwTo threadId UserInterrupt r <- takeMVar mvar normalizeSummary r `shouldBe` [ "" - , "foo FAILED [1]" + , "foo [✘]" , "" , "Failures:" , "" , " 1) foo" , "" + , " To rerun use: --match \"/foo/\" --seed 23" + , "" , "Randomized with seed 23" , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" ] it "throws UserInterrupt" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do - silence . H.hspec $ do + hspec_ $ do H.it "foo" $ do putMVar sync () threadDelay 1000000 - `E.catch` putMVar mvar + `catch` putMVar mvar takeMVar sync - throwTo threadId E.UserInterrupt - takeMVar mvar `shouldReturn` E.UserInterrupt - - context "with --help" $ do - let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure () - it "prints help" $ do - r <- (captureLines . ignoreExitCode) printHelp - r `shouldStartWith` ["Usage: spec [OPTION]..."] - silence printHelp `shouldThrow` (== ExitSuccess) - - it "constrains lines to 80 characters" $ do - r <- (captureLines . ignoreExitCode) printHelp - r `shouldSatisfy` all ((<= 80) . length) - r `shouldSatisfy` any ((78 <=) . length) + throwTo threadId UserInterrupt + takeMVar mvar `shouldReturn` UserInterrupt context "with --dry-run" $ do - let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec + let withDryRun = hspecCapture ["--dry-run"] it "produces a report" $ do - r <- withDryRun $ do + withDryRun $ do H.it "foo" True H.it "bar" True - normalizeSummary r `shouldBe` [ + `shouldReturn` unlines [ "" - , "foo" - , "bar" + , "foo [✔]" + , "bar [✔]" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" @@ -228,53 +292,192 @@ H.it "bar" True readIORef ref `shouldReturn` False + context "with --focused-only" $ do + let run = hspecCapture ["--focused-only"] + context "when there aren't any focused spec items" $ do + it "does not run anything" $ do + run $ do + H.it "foo" True + H.it "bar" True + `shouldReturn` unlines [ + "" + , "" + , "Finished in 0.0000 seconds" + , "0 examples, 0 failures" + ] + + context "with --fail-on=empty" $ do + it "fails if no spec items have been run" $ do + (out, r) <- hCapture [stdout, stderr] . try . withProgName "spec" . withArgs ["--skip=", "--fail-on=empty"] . H.hspec $ do + H.it "foo" True + H.it "bar" True + H.it "baz" True + unlines (normalizeSummary (lines out)) `shouldBe` unlines [ + "spec: all spec items have been filtered; failing due to --fail-on=empty" + ] + r `shouldBe` Left (ExitFailure 1) + + context "with --fail-on=focused" $ do + let run = hspecCapture ["--fail-on=focused", "--seed", "23"] + it "fails on focused spec items" $ do + run $ do + H.it "foo" True + H.fit "bar" True + `shouldReturn` unlines [ + "" + , "bar [✘]" + , "" + , "Failures:" + , "" + , " 1) bar" + , " item is focused; failing due to --fail-on=focused" + , "" + , " To rerun use: --match \"/bar/\" --seed 23" + , "" + , "Randomized with seed 23" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --fail-on=empty-description" $ do + let run = hspecCapture ["--fail-on=empty-description", "--seed", "23"] + it "fails on items with empty requirement" $ do + run $ do + H.it "foo" True + H.it "" True + `shouldReturn` unlines [ + "" + , "foo [✔]" + , "(unspecified behavior) [✘]" + , "" + , "Failures:" + , "" + , " 1) (unspecified behavior)" + , " item has no description; failing due to --fail-on=empty-description" + , "" + , " To rerun use: --match \"/(unspecified behavior)/\" --seed 23" + , "" + , "Randomized with seed 23" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 1 failure" + ] + + context "with --fail-on=pending" $ do + let run = hspecCapture ["--fail-on=pending", "--seed", "23"] + it "fails on pending spec items" $ do + run $ do + H.it "foo" True + H.it "bar" $ do + void $ throwIO (H.Pending Nothing Nothing) + `shouldReturn` unlines [ + "" + , "foo [✔]" + , "bar [✘]" + , "" + , "Failures:" + , "" + , " 1) bar" + , " item is pending; failing due to --fail-on=pending" + , "" + , " To rerun use: --match \"/bar/\" --seed 23" + , "" + , "Randomized with seed 23" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 1 failure" + ] + context "with --fail-fast" $ do it "stops after first failure" $ do - r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do + hspecCapture ["--fail-fast", "--seed", "23"] $ do H.it "foo" True H.it "bar" False H.it "baz" False - normalizeSummary r `shouldBe` [ + `shouldReturn` unlines [ "" - , "foo" - , "bar FAILED [1]" + , "foo [✔]" + , "bar [✘]" , "" , "Failures:" , "" , " 1) bar" , "" + , " To rerun use: --match \"/bar/\" --seed 23" + , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "2 examples, 1 failure" ] + it "cancels running parallel spec items on failure" $ do + child1 <- newQSem 0 + child2 <- newQSem 0 + parent <- newQSem 0 + ref <- newIORef "" + ignoreExitCode . hspec ["--fail-fast", "-j", "2"] $ do + H.parallel $ do + H.it "foo" $ do + waitQSem child1 + "foo" `shouldBe` "bar" + H.it "bar" $ do + -- NOTE: waitQSem should never return here, as we want to + -- guarantee that the thread is killed before hspec returns + (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `finally` signalQSem parent + signalQSem child2 + waitQSem parent + readIORef ref `shouldReturn` "" + it "works for nested specs" $ do - r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do + hspecCapture ["--fail-fast", "--seed", "23"] $ do H.describe "foo" $ do H.it "bar" False H.it "baz" True - normalizeSummary r `shouldBe` [ + `shouldReturn` unlines [ "" , "foo" - , " bar FAILED [1]" + , " bar [✘]" , "" , "Failures:" , "" , " 1) foo bar" , "" + , " To rerun use: --match \"/foo/bar/\" --seed 23" + , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] + context "with a cleanup action" $ do + it "runs cleanup action" $ do + ref <- newIORef 0 + ignoreExitCode $ hspec ["--fail-fast"] $ do + H.afterAll_ (modifyIORef ref succ) $ do + H.it "foo" True + H.it "bar" False + H.it "baz" True + readIORef ref `shouldReturn` (1 :: Int) + + context "when last leaf fails" $ do + it "runs cleanup action exactly once" $ do + ref <- newIORef 0 + ignoreExitCode $ hspec ["--fail-fast"] $ do + H.afterAll_ (modifyIORef ref succ) $ do + H.it "foo" True + H.it "bar" True + H.it "baz" False + readIORef ref `shouldReturn` (1 :: Int) + 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 + hspec ["-m", "/bar/example"] $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" $ mockAction e1 @@ -288,7 +491,7 @@ e2 <- newMock e3 <- newMock e4 <- newMock - silence . withArgs ["-m", "/bar/example", "--skip", "example 3"] . H.hspec $ do + hspec ["-m", "/bar/example", "--skip", "example 3"] $ do H.describe "foo" $ do H.describe "bar" $ do H.it "example 1" $ mockAction e1 @@ -303,7 +506,7 @@ e1 <- newMock e2 <- newMock e3 <- newMock - silence . withArgs ["-m", "foo", "-m", "baz"] . H.hspec $ do + hspec ["-m", "foo", "-m", "baz"] $ do H.describe "foo" $ do H.it "example 1" $ mockAction e1 H.describe "bar" $ do @@ -312,6 +515,247 @@ H.it "example 3" $ mockAction e3 (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) +#if __GLASGOW_HASKELL__ >= 802 + context "with --pretty" $ do + it "pretty-prints Haskell values" $ do + let args = ["--pretty", "--seed=0", "--format=failed-examples"] + r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do + H.it "foo" $ do + person 23 `H.shouldBe` person 42 + r `shouldBe` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , " expected: Person {" + , " personName = \"Joe\"," + , " personAge = 42," + , " personAddress = Nothing" + , " }" + , " but got: Person {" + , " personName = \"Joe\"," + , " personAge = 23," + , " personAddress = Nothing" + , " }" + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] +#endif + + it "uses custom pretty-print functions" $ do + let pretty _ _ _ = ("foo", "bar") + + r <- capture_ . ignoreExitCode . withArgs ["--pretty"] . H.hspec $ do + H.modifyConfig $ \ c -> c { H.configPrettyPrintFunction = pretty } + H.it "foo" $ do + 23 `H.shouldBe` (42 :: Int) + r `shouldContain` unlines [ + " expected: foo" + , " but got: bar" + ] + + context "with --no-pretty" $ do + it "does not pretty-prints Haskell values" $ do + r <- capture_ . ignoreExitCode . withArgs ["--no-pretty"] . H.hspec $ do + H.it "foo" $ do + person 23 `H.shouldBe` person 42 + r `shouldContain` unlines [ + " expected: Person {personName = \"Joe\", personAge = 42, personAddress = Nothing}" + , " but got: Person {personName = \"Joe\", personAge = 23, personAddress = Nothing}" + ] + + context "when formatting exceptions" $ do + let spec_ = H.it "foo" $ void (withFrozenCallStack throwIO MyException) + context "with --show-exceptions" $ do + it "uses `show`" $ do + hspecCapture ["--seed=0", "--format=failed-examples", "--display-exceptions", "--show-exceptions"] spec_ + `shouldReturn` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , " uncaught exception: MyException" + , " MyException" + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --display-exceptions" $ do + it "uses `displayException`" $ do + hspecCapture ["--seed=0", "--format=failed-examples", "--show-exceptions", "--display-exceptions"] spec_ + `shouldReturn` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , " uncaught exception: MyException" + , " my exception" +#if MIN_VERSION_base(4,20,0) && !MIN_VERSION_base(4,21,0) + , " HasCallStack backtrace:" + , " " +#endif + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --color" $ do + it "outputs ColorizedReason" $ do + hspecCapture ["--seed=0", "--format=failed-examples", "--color"] $ do + H.it "foo" resultWithColorizedReason + `shouldReturn` unlines [ + "\ESC[?25l" + , "Failures:" + , "" + , " 1) foo" + , " some " ++ green "colorized" ++ " error message" + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , red "1 example, 1 failure" + , "\ESC[?25h" + ] + + context "with --no-color" $ do + it "strips ANSI sequences from ColorizedReason" $ do + hspecCapture ["--seed=0", "--format=failed-examples", "--no-color"] $ do + H.it "foo" resultWithColorizedReason + `shouldReturn` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , " some colorized error message" + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --diff" $ do + it "shows colorized diffs" $ do + r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do + H.it "foo" $ do + 23 `H.shouldBe` (42 :: Int) + r `shouldContain` unlines [ + red " expected: " ++ red "42" + , red " but got: " ++ green "23" + ] + + context "with --no-diff" $ do + it "it does not show colorized diffs" $ do + r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do + H.it "foo" $ do + 23 `H.shouldBe` (42 :: Int) + r `shouldContain` unlines [ + red " expected: " ++ "42" + , red " but got: " ++ "23" + ] + + context "with --diff-context" $ do + it "suppresses excessive diff output" $ do + let + args = ["--seed=0", "--format=failed-examples", "--diff-context=1"] + expected = map show [1 .. 99 :: Int] + actual = replace "50" "foo" expected + r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do + H.it "foo" $ do + unlines actual `H.shouldBe` unlines expected + r `shouldBe` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , " expected: @@ 48 lines omitted @@" + , " 49" + , " 50" + , " 51" + , " @@ 48 lines omitted @@" + , " " + , " but got: @@ 48 lines omitted @@" + , " 49" + , " foo" + , " 51" + , " @@ 48 lines omitted @@" + , " " + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --diff-command" $ do + it "uses an external diff command" $ do + let + args = ["--seed=0", "--format=failed-examples", "--diff-command", "diff -u -L expected -L actual"] + expected = map show [1 .. 99 :: Int] + actual = replace "50" "foo" expected + r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do + H.it "foo" $ do + unlines actual `H.shouldBe` unlines expected + r `shouldBe` unlines [ + "" + , "Failures:" + , "" + , " 1) foo" + , "--- expected" + , "+++ actual" + , "@@ -47,7 +47,7 @@" + , " 47" + , " 48" + , " 49" + , "-50" + , "+foo" + , " 51" + , " 52" + , " 53" + , "" + , " To rerun use: --match \"/foo/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --print-slow-items" $ do + it "prints slow items" $ do + r <- fmap lines . hCapture_ [stdout, stderr] . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do + H.it "foo" $ threadDelay 2000 + normalizeTimes (normalizeSummary r) `shouldBe` [ + "" + , "foo [✔]" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + , "" + , "Slow spec items:" + , " test" "Test" "Hspec" "Core" "RunnerSpec.hs:" <> show (__LINE__ - 9 :: Int) <> ":11: /foo/ (2ms)" + ] + context "with --format" $ do it "uses specified formatter" $ do r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do @@ -328,26 +772,65 @@ r `shouldContain` "invalid argument `foo' for `--format'" context "with --qc-max-success" $ do + let + run :: HasCallStack => String -> IO () + run option = do + m <- newMock + hspec [option, "23"] $ do + H.it "foo" $ property $ \(_ :: Int) -> do + mockAction m + mockCounter m `shouldReturn` 23 + it "tries QuickCheck properties specified number of times" $ do - m <- newMock - silence . withArgs ["--qc-max-success", "23"] . H.hspec $ do - H.it "foo" $ property $ \(_ :: Int) -> do - mockAction m - mockCounter m `shouldReturn` 23 + run "--qc-max-success" + it "accepts --maximum-generated-tests as an alias" $ do + run "--maximum-generated-tests" + 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) + ["--qc-max-success", "23"] `shouldUseArgs` (QC.maxSuccess, 23) + ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` (QC.maxSuccess, 42) + context "with --qc-max-discard" $ do + it "passes specified maxDiscardRatio to QuickCheck properties" $ do + ["--qc-max-discard", "23"] `shouldUseArgs` (QC.maxDiscardRatio, 23) + context "with --qc-max-size" $ do - it "passes specified size to QuickCheck properties" $ do - ["--qc-max-size", "23"] `shouldUseArgs` ((== 23) . QC.maxSize) + it "passes specified maxSize to QuickCheck properties" $ do + ["--qc-max-size", "23"] `shouldUseArgs` (QC.maxSize, 23) - 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 --qc-max-shrinks" $ do + it "passes specified maxShrinks to QuickCheck properties" $ do + ["--qc-max-shrinks", "23"] `shouldUseArgs` (QC.maxShrinks, 23) + describe "Test.QuickCheck.Args.chatty" $ do + let + setChatty value args = args { chatty = value } + withChatty value = hspecCapture [] . H.modifyArgs (setChatty value) $ do + H.it "foo" $ once $ property True + + context "when True" $ do + it "includes informational output" $ do + withChatty True `shouldReturn` unlines [ + "" + , "foo [✔]" + , " +++ OK, passed 1 test." + , "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + ] + + context "when False" $ do + it "suppresses informational output" $ do + withChatty False `shouldReturn` unlines [ + "" + , "foo [✔]" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 0 failures" + ] + context "with --seed" $ do it "uses specified seed" $ do r <- runPropFoo ["--seed", "42"] @@ -383,21 +866,25 @@ 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" + 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" + r `shouldContain` "foo [‐]\n" 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" + r `shouldContain` "foo [✘]\n" describe "hspecResult" $ do + let + hspecResult args = withArgs args . hspecResultSilent + hspecResult_ = hspecResultSilent + it "returns a summary of the test run" $ do - silence . H.hspecResult $ do + hspecResult_ $ do H.it "foo" True H.it "foo" False H.it "foo" False @@ -406,32 +893,36 @@ `shouldReturn` H.Summary 5 2 it "treats uncaught exceptions as failure" $ do - silence . H.hspecResult $ do - H.it "foobar" throwException + hspecResult_ $ do + H.it "foobar" throwException_ `shouldReturn` H.Summary 1 1 + it "handles unguarded exceptions in runner" $ do + let + throwExceptionThatIsNotGuardedBy_safeTry :: H.Item () -> H.Item () + throwExceptionThatIsNotGuardedBy_safeTry item = item { + H.itemExample = \ _params _hook _progress -> throwIO DivideByZero + } + hspecResult_ $ H.mapSpecItem_ throwExceptionThatIsNotGuardedBy_safeTry $ do + H.it "foo" True + `shouldReturn` H.Summary 1 1 + it "uses the specdoc formatter by default" $ do _:r:_ <- captureLines . H.hspecResult $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` "Foo.Bar" - it "can use a custom formatter" $ do - r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do - H.describe "Foo.Bar" $ do - H.it "some example" True - r `shouldBe` "" - it "does not let escape error thunks from failure messages" $ do - r <- silence . H.hspecResult $ do - H.it "some example" (H.Fail Nothing $ "foobar" ++ undefined) + r <- hspecResult_ $ do + H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined) r `shouldBe` H.Summary 1 1 it "runs specs in parallel" $ do - let n = 10 + let n = 100 t = 0.01 dt = t * (fromIntegral n / 2) - r <- timeout dt . silence . withArgs ["-j", show n] . H.hspecResult . H.parallel $ do + r <- timeout dt . hspecResult ["-j", show n] . H.parallel $ do replicateM_ n (H.it "foo" $ sleep t) r `shouldBe` Just (H.Summary n 0) @@ -446,8 +937,91 @@ current <- atomicModifyIORef currentRef $ \x -> let y = succ x in (y, y) atomicModifyIORef highRef $ \x -> (max x current, ()) stop = atomicModifyIORef currentRef $ \x -> (pred x, ()) - r <- withArgs ["-j", show j] . H.hspecResult . H.parallel $ do - replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t + r <- hspecResult ["-j", show j] . H.parallel $ do + replicateM_ n $ H.it "foo" $ bracket_ start stop $ sleep t r `shouldBe` H.Summary n 0 high <- readIORef highRef high `shouldBe` j + + describe "colorOutputSupported" $ do + context "without a terminal device" $ do + + let isTerminalDevice = return False + + it "disables color output" $ do + H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled + + context "with GITHUB_ACTIONS=true" $ do + it "enable color output" $ do + withEnvironment [("GITHUB_ACTIONS", "true")] $ do + H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled + + context "with a terminal device" $ do + + let isTerminalDevice = return True + + it "enable color output" $ do + H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingEnabled + + context "with BUILDKITE=true" $ do + it "disables progress reporting" $ do + withEnvironment [("BUILDKITE", "true")] $ do + H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled + + context "when NO_COLOR is set" $ do + it "disables color output" $ do + withEnvironment [("NO_COLOR", "yes")] $ do + H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled + + describe "unicodeOutputSupported" $ do + context "with UnicodeAlways" $ do + it "returns True" $ do + H.unicodeOutputSupported H.UnicodeAlways undefined `shouldReturn` True + + context "with UnicodeNever" $ do + it "returns False" $ do + H.unicodeOutputSupported H.UnicodeNever undefined `shouldReturn` False + + context "with UnicodeAuto" $ do + context "when file encoding is UTF-8" $ do + it "returns True" $ do + inTempDirectory $ do + withFile "foo" WriteMode $ \ h -> do + hSetEncoding h utf8 + H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` True + + context "when file encoding is not UTF-8" $ do + it "returns False" $ do + inTempDirectory $ do + withFile "foo" WriteMode $ \ h -> do + hSetEncoding h latin1 + H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` False + + describe "rerunAll" $ do + let + report = FailureReport 0 0 0 0 [([], "foo")] + config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True} + result = SpecResult [] True + context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do + it "returns True" $ do + H.rerunAll config (Just report) result `shouldBe` True + + context "without --rerun" $ do + it "returns False" $ do + H.rerunAll config {H.configRerun = False} (Just report) result `shouldBe` False + + context "without --rerun-all-on-success" $ do + it "returns False" $ do + H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) result `shouldBe` False + + context "without previous failures" $ do + it "returns False" $ do + H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False + + context "without failure report" $ do + it "returns False" $ do + H.rerunAll config Nothing result `shouldBe` False + + context "on failure" $ do + it "returns False" $ do + H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False diff --git a/test/Test/Hspec/Core/ShuffleSpec.hs b/test/Test/Hspec/Core/ShuffleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/ShuffleSpec.hs @@ -0,0 +1,47 @@ +module Test.Hspec.Core.ShuffleSpec (spec) where + +import Prelude () +import Helper + +import qualified Test.Hspec.Core.Shuffle as H +import Test.Hspec.Core.Tree + +import Data.Array.ST +import Control.Monad.ST +import Data.STRef +import System.Random + +spec :: Spec +spec = do + describe "shuffleForest" $ do + let + shuffleForest :: Int -> [Tree () Int] -> [Tree () Int] + shuffleForest seed xs = runST $ do + gen <- newSTRef (mkStdGen seed) + H.shuffleForest gen xs + + it "shuffles a forest" $ do + shuffleForest 2 + [Leaf 1, Leaf 2, Leaf 3] `shouldBe` + [Leaf 3, Leaf 1, Leaf 2] + + it "recurses into Node" $ do + shuffleForest 1 + [Node "foo" [Node "bar" [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe` + [Node "foo" [Node "bar" [Leaf 2, Leaf 3, Leaf 1]]] + + it "recurses into NodeWithCleanup" $ do + shuffleForest 1 + [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe` + [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 2, Leaf 3, Leaf 1]]] + + describe "shuffle" $ do + it "shuffles a list" $ do + runST $ do + gen <- newSTRef (mkStdGen 2) + H.shuffle gen [1, 2, 3 :: Int] + `shouldBe` [3, 1, 2] + + describe "mkArray" $ do + it "creates an STArray from a list" $ do + runST (H.mkArray [1, 2, 3 :: Int] >>= getElems) `shouldBe` [1, 2, 3] diff --git a/test/Test/Hspec/Core/SpecSpec.hs b/test/Test/Hspec/Core/SpecSpec.hs --- a/test/Test/Hspec/Core/SpecSpec.hs +++ b/test/Test/Hspec/Core/SpecSpec.hs @@ -1,24 +1,41 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} -module Test.Hspec.Core.SpecSpec (main, spec) where +module Test.Hspec.Core.SpecSpec (spec) where import Prelude () import Helper -import Test.Hspec.Core.Spec (Item(..), Result(..)) +import Test.Hspec.Core.Spec (Item(..), Result(..), ResultStatus(..)) import qualified Test.Hspec.Core.Runner as H -import Test.Hspec.Core.Spec (Tree(..), runSpecM) +import Test.Hspec.Core.Spec (Tree(..)) import qualified Test.Hspec.Core.Spec as H -main :: IO () -main = hspec spec +extract :: (Item () -> a) -> H.Spec -> IO [Tree () a] +extract f = fmap (H.bimapForest (const ()) f) . fmap snd . H.runSpecM runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult spec :: Spec spec = do + let + runSpecM :: H.SpecWith a -> IO [H.SpecTree a] + runSpecM = fmap snd . H.runSpecM + + runItem :: Item () -> IO Result + runItem item = itemExample item defaultParams ($ ()) noOpProgressCallback + + describe "getSpecDescriptionPath" $ do + it "returns the spec path" $ do + let descriptionPathShouldBe xs = + H.getSpecDescriptionPath >>= H.runIO . (`shouldBe` xs) + void . runSpecM $ do + descriptionPathShouldBe [] + H.describe "foo" $ do + H.describe "bar" $ do + descriptionPathShouldBe ["foo", "bar"] + H.it "baz" True + describe "describe" $ do it "can be nested" $ do [Node foo [Node bar [Leaf _]]] <- runSpecM $ do @@ -30,8 +47,13 @@ context "when no description is given" $ do it "uses a default description" $ do [Node d _] <- runSpecM (H.describe "" (pure ())) - d `shouldBe` "(no description given)" + d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (pred __LINE__ :: Int) ++ ":33]" + describe "xdescribe" $ do + it "creates a tree of pending spec items" $ do + [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True) + runItem item `shouldReturn` Result "" (Pending Nothing Nothing) + describe "it" $ do it "takes a description of a desired behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) @@ -39,41 +61,62 @@ it "takes an example of that behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) - itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success + runItem item `shouldReturn` Result "" Success -#ifdef HAS_SOURCE_LOCATIONS it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) - let location = H.Location __FILE__ (pred $ __LINE__) 32 H.ExactLocation - itemLocation item `shouldBe` Just location -#endif + let location = mkLocation __FILE__ (pred __LINE__) 32 + itemLocation item `shouldBe` location - context "when no description is given" $ do - it "uses a default description" $ do - [Leaf item] <- runSpecM (H.it "" True) - itemRequirement item `shouldBe` "(unspecified behavior)" + describe "xit" $ do + it "creates a pending spec item" $ do + [Leaf item] <- runSpecM (H.xit "whatever" True) + runItem item `shouldReturn` Result "" (Pending Nothing Nothing) describe "pending" $ do it "specifies a pending example" $ do r <- runSpec $ do H.it "foo" H.pending - r `shouldSatisfy` any (== " # PENDING: No reason given") + 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") + r `shouldSatisfy` any (== " # PENDING: for some reason") + describe "focus" $ do + it "focuses spec items" $ do + items <- extract itemIsFocused $ H.focus $ do + H.it "is focused and will run" True + H.it "is also focused and will also run" True + items `shouldBe` [Leaf True, Leaf True] + + context "when applied to a spec with focused spec items" $ do + it "has no effect" $ do + items <- extract itemIsFocused $ H.focus $ do + H.focus $ H.it "is focused and will run" True + H.it "is not focused and will not run" True + items `shouldBe` [Leaf True, Leaf False] + describe "parallel" $ do it "marks examples for parallel execution" $ do - [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" True - itemIsParallelizable item `shouldBe` True + items <- extract itemIsParallelizable . H.parallel $ H.it "whatever" H.pending + items `shouldBe` [Leaf $ Just True] it "is applied recursively" $ do - [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do + items <- extract itemIsParallelizable . H.parallel $ do H.describe "foo" $ do H.describe "bar" $ do - H.it "baz" True - itemIsParallelizable item `shouldBe` True + H.it "baz" H.pending + items `shouldBe` [Node "foo" [Node "bar" [Leaf $ Just True]]] + + describe "sequential" $ do + it "marks examples for sequential execution" $ do + items <- extract itemIsParallelizable . H.sequential $ H.it "whatever" H.pending + items `shouldBe` [Leaf $ Just False] + + it "takes precedence over a later `parallel`" $ do + items <- extract itemIsParallelizable . H.parallel . H.sequential $ H.it "whatever" H.pending + items `shouldBe` [Leaf $ Just False] diff --git a/test/Test/Hspec/Core/TimerSpec.hs b/test/Test/Hspec/Core/TimerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/TimerSpec.hs @@ -0,0 +1,32 @@ +module Test.Hspec.Core.TimerSpec (spec) where + +import Prelude () +import Helper + +-- import Test.Hspec.Core.Timer + +spec :: Spec +spec = do + describe "timer action provided by withTimer" $ do + pass -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352 + +{- + let + dt = 0.01 + wait = sleep (dt * 1.1) + + it "returns False" $ do + withTimer dt $ \timer -> do + timer `shouldReturn` False + + context "after specified time" $ do + it "returns True" $ do + withTimer dt $ \timer -> do + wait + timer `shouldReturn` True + timer `shouldReturn` False + wait + wait + timer `shouldReturn` True + timer `shouldReturn` False + -} diff --git a/test/Test/Hspec/Core/TreeSpec.hs b/test/Test/Hspec/Core/TreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/TreeSpec.hs @@ -0,0 +1,12 @@ +module Test.Hspec.Core.TreeSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Tree + +spec :: Spec +spec = do + describe "toModuleName" $ do + it "derives a module name from a FilePath" $ do + toModuleName "src/Foo/Bar.hs" `shouldBe` "Foo.Bar" diff --git a/test/Test/Hspec/Core/UtilSpec.hs b/test/Test/Hspec/Core/UtilSpec.hs --- a/test/Test/Hspec/Core/UtilSpec.hs +++ b/test/Test/Hspec/Core/UtilSpec.hs @@ -1,14 +1,12 @@ -module Test.Hspec.Core.UtilSpec (main, spec) where +module Test.Hspec.Core.UtilSpec (spec) where +import Prelude () import Helper + import Control.Concurrent -import qualified Control.Exception as E import Test.Hspec.Core.Util -main :: IO () -main = hspec spec - spec :: Spec spec = do describe "pluralize" $ do @@ -23,12 +21,16 @@ describe "formatException" $ do it "converts exception to string" $ do - formatException (E.toException E.DivideByZero) `shouldBe` "ArithException (divide by zero)" + formatException (toException DivideByZero) `shouldBe` "ArithException\ndivide by zero" context "when used with an IOException" $ do it "includes the IOErrorType" $ do - Left e <- E.try (readFile "foo") - formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))" + inTempDirectory $ do + Left e <- try (readFile "foo") + formatException e `shouldBe` intercalate "\n" [ + "IOException of type NoSuchThing" + , "foo: openFile: does not exist (No such file or directory)" + ] describe "lineBreaksAt" $ do it "inserts line breaks at word boundaries" $ do @@ -41,6 +43,18 @@ , "sed do eiusmod" ] + it "preserves existing line breaks" $ do + lineBreaksAt 10 "foo bar baz\none two three" `shouldBe` [ + "foo bar" + , "baz" + , "one two" + , "three" + ] + + describe "stripAnsi" $ do + it "removes ANSI color sequences" $ do + stripAnsi ("some " <> green "colorized" <> " text") `shouldBe` "some colorized text" + describe "safeTry" $ do it "returns Right on success" $ do Right e <- safeTry (return 23 :: IO Int) @@ -48,21 +62,21 @@ it "returns Left on exception" $ do Left e <- safeTry throwException - show e `shouldBe` "foobar" + fromException e `shouldBe` Just DivideByZero it "evaluates result to weak head normal form" $ do - Left e <- safeTry (return $ E.throw $ E.ErrorCall "foo") + Left e <- safeTry (return $ throw $ ErrorCall "foo") show e `shouldBe` "foo" it "does not catch asynchronous exceptions" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do - safeTry (putMVar sync () >> threadDelay 1000000) >> return () - `E.catch` putMVar mvar + safeTry (putMVar sync () >> threadDelay 1000000) >> pass + `catch` putMVar mvar takeMVar sync - throwTo threadId E.UserInterrupt - readMVar mvar `shouldReturn` E.UserInterrupt + throwTo threadId UserInterrupt + readMVar mvar `shouldReturn` UserInterrupt describe "filterPredicate" $ do it "tries to match a pattern against a path" $ do @@ -79,15 +93,20 @@ 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 + it "succeeds with a pattern that matches the message given in the failure list" $ do let p = filterPredicate "ModuleA.ModuleB.foo does something" p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True + context "with an absolute path that begins or ends with a slash" $ do + it "succeeds" $ do + let p = filterPredicate "/foo/bar/baz/example 1/" + p (["foo", "bar", "baz"], "example 1") `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 + it "creates a sentence from a subject and a requirement when the subject consists 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 diff --git a/test/Test/Hspec/FailureReportSpec.hs b/test/Test/Hspec/FailureReportSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/FailureReportSpec.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Test.Hspec.FailureReportSpec (main, spec) where - -import Helper - -import System.IO -import qualified Control.Exception as E -import Test.Hspec.FailureReport - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "writeFailureReport" $ do - it "prints a warning on unexpected exceptions" $ do - r <- hCapture_ [stderr] $ writeFailureReport (E.throw (E.ErrorCall "some error")) - r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" diff --git a/test/Test/Hspec/OptionsSpec.hs b/test/Test/Hspec/OptionsSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/OptionsSpec.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Test.Hspec.OptionsSpec (main, spec) where - -import Control.Monad -import Helper -import System.Exit - -import qualified Test.Hspec.Options as Options -import Test.Hspec.Options hiding (parseOptions) - -main :: IO () -main = hspec spec - -fromLeft :: Either a b -> a -fromLeft (Left a) = a -fromLeft _ = error "fromLeft: No left value!" - -spec :: Spec -spec = do - describe "parseOptions" $ do - - let parseOptions = Options.parseOptions defaultConfig "my-spec" - - it "sets configColorMode to ColorAuto" $ do - configColorMode <$> parseOptions [] `shouldBe` Right ColorAuto - - context "with --no-color" $ do - it "sets configColorMode to ColorNever" $ do - configColorMode <$> parseOptions ["--no-color"] `shouldBe` Right ColorNever - - context "with --color" $ do - it "sets configColorMode to ColorAlways" $ do - configColorMode <$> parseOptions ["--color"] `shouldBe` Right ColorAlways - - context "with --out" $ do - it "sets configOutputFile" $ do - either (const Nothing) Just . configOutputFile <$> parseOptions ["--out", "foo"] `shouldBe` Right (Just "foo") - - context "with --qc-max-success" $ do - context "when given an invalid argument" $ do - it "returns an error message" $ do - fromLeft (parseOptions ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n") - - context "with --depth" $ do - it "sets depth parameter for SmallCheck" $ do - configSmallCheckDepth <$> parseOptions ["--depth", "23"] `shouldBe` Right 23 - - context "with --jobs" $ do - it "sets number of concurrent jobs" $ do - configConcurrentJobs <$> parseOptions ["--jobs=23"] `shouldBe` Right (Just 23) - - it "rejects values < 1" $ do - let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" - void (parseOptions ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) diff --git a/test/Test/Hspec/TimerSpec.hs b/test/Test/Hspec/TimerSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/TimerSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Test.Hspec.TimerSpec (main, spec) where - -import Helper - -import Test.Hspec.Timer - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "timer action returned by newTimer" $ do - - let dt = 0.01 - - it "returns False" $ do - timer <- newTimer dt - timer `shouldReturn` False - - context "after specified time" $ do - it "returns True" $ do - timer <- newTimer dt - sleep dt - timer `shouldReturn` True - timer `shouldReturn` False - sleep dt - sleep dt - timer `shouldReturn` True - timer `shouldReturn` False diff --git a/vendor/Data/Algorithm/Diff.hs b/vendor/Data/Algorithm/Diff.hs new file mode 100644 --- /dev/null +++ b/vendor/Data/Algorithm/Diff.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -fno-warn-x-partial #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithm.Diff +-- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This is an implementation of the O(ND) diff algorithm as described in +-- \"An O(ND) Difference Algorithm and Its Variations (1986)\" +-- . It is O(mn) in space. +-- The algorithm is the same one used by standared Unix diff. +----------------------------------------------------------------------------- + +module Data.Algorithm.Diff + ( Diff(..) + -- * Comparing lists for differences + , getDiff + , getDiffBy + + -- * Finding chunks of differences + , getGroupedDiff + , getGroupedDiffBy + ) where + +import Prelude hiding (pi) + +import Data.Array + +data DI = F | S | B deriving (Show, Eq) + +-- | A value is either from the 'First' list, the 'Second' or from 'Both'. +-- 'Both' contains both the left and right values, in case you are using a form +-- of equality that doesn't check all data (for example, if you are using a +-- newtype to only perform equality on side of a tuple). +data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor) + +data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq) + +instance Ord DL + where x <= y = if poi x == poi y + then poj x > poj y + else poi x <= poi y + +canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool +canDiag eq as bs lena lenb = \ i j -> + if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False + where arAs = listArray (0,lena - 1) as + arBs = listArray (0,lenb - 1) bs + +dstep :: (Int -> Int -> Bool) -> [DL] -> [DL] +dstep cd dls = hd:pairMaxes rst + where (hd:rst) = nextDLs dls + nextDLs [] = [] + nextDLs (dl:rest) = dl':dl'':nextDLs rest + where dl' = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)} + dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)} + pdl = path dl + pairMaxes [] = [] + pairMaxes [x] = [x] + pairMaxes (x:y:rest) = max x y:pairMaxes rest + +addsnake :: (Int -> Int -> Bool) -> DL -> DL +addsnake cd dl + | cd pi pj = addsnake cd $ + dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)} + | otherwise = dl + where pi = poi dl; pj = poj dl + +lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI] +lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) . + concat . iterate (dstep cd) . (:[]) . addsnake cd $ + DL {poi=0,poj=0,path=[]} + where cd = canDiag eq as bs lena lenb + lena = length as; lenb = length bs + +-- | Takes two lists and returns a list of differences between them. This is +-- 'getDiffBy' with '==' used as predicate. +getDiff :: (Eq t) => [t] -> [t] -> [Diff t] +getDiff = getDiffBy (==) + +-- | Takes two lists and returns a list of differences between them, grouped +-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate. +getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]] +getGroupedDiff = getGroupedDiffBy (==) + +-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate +-- is taken as the first argument. +getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t] +getDiffBy eq a b = markup a b . reverse $ lcs eq a b + where markup (x:xs) ys (F:ds) = First x : markup xs ys ds + markup xs (y:ys) (S:ds) = Second y : markup xs ys ds + markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds + markup _ _ _ = [] + +getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]] +getGroupedDiffBy eq a b = go $ getDiffBy eq a b + where go (First x : xs) = let (fs, rest) = goFirsts xs in First (x:fs) : go rest + go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs) : go rest + go (Both x y : xs) = let (fs, rest) = goBoth xs + (fxs, fys) = unzip fs + in Both (x:fxs) (y:fys) : go rest + go [] = [] + + goFirsts (First x : xs) = let (fs, rest) = goFirsts xs in (x:fs, rest) + goFirsts xs = ([],xs) + + goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest) + goSeconds xs = ([],xs) + + goBoth (Both x y : xs) = let (fs, rest) = goBoth xs in ((x,y):fs, rest) + goBoth xs = ([],xs) diff --git a/vendor/async-2.2.5/Control/Concurrent/Async.hs b/vendor/async-2.2.5/Control/Concurrent/Async.hs new file mode 100644 --- /dev/null +++ b/vendor/async-2.2.5/Control/Concurrent/Async.hs @@ -0,0 +1,870 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes, + ExistentialQuantification #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE DeriveDataTypeable #-} +#endif +{-# OPTIONS -Wall -fno-warn-implicit-prelude -fno-warn-unused-imports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Async.Internal +-- Copyright : (c) Simon Marlow 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Simon Marlow +-- Stability : provisional +-- Portability : non-portable (requires concurrency) +-- +-- This module is an internal module. The public API is provided in +-- "Control.Concurrent.Async". Breaking changes to this module will not be +-- reflected in a major bump, and using this module may break your code +-- unless you are extremely careful. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.Async where + +import Control.Concurrent.STM.TMVar +import Control.Exception +import Control.Concurrent +import qualified Data.Foldable as F +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif +import Control.Monad +import Control.Applicative +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid(mempty,mappend)) +import Data.Traversable +#endif +#if __GLASGOW_HASKELL__ < 710 +import Data.Typeable +#endif +#if MIN_VERSION_base(4,8,0) +import Data.Bifunctor +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup((<>))) +#endif + +import Data.IORef + +import GHC.Exts +import GHC.IO hiding (finally, onException) +import GHC.Conc + +-- ----------------------------------------------------------------------------- +-- STM Async API + + +-- | An asynchronous action spawned by 'async' or 'withAsync'. +-- Asynchronous actions are executed in a separate thread, and +-- operations are provided for waiting for asynchronous actions to +-- complete and obtaining their results (see e.g. 'wait'). +-- +data Async a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncWait :: STM (Either SomeException a) + } + +instance Eq (Async a) where + Async a _ == Async b _ = a == b + +instance Ord (Async a) where + Async a _ `compare` Async b _ = a `compare` b + +instance Functor Async where + fmap f (Async a w) = Async a (fmap (fmap f) w) + +-- | Compare two Asyncs that may have different types by their 'ThreadId'. +compareAsyncs :: Async a -> Async b -> Ordering +compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2 + +-- | Spawn an asynchronous action in a separate thread. +-- +-- Like for 'forkIO', the action may be left running unintentionally +-- (see module-level documentation for details). +-- +-- __Use 'withAsync' style functions wherever you can instead!__ +async :: IO a -> IO (Async a) +async = inline asyncUsing rawForkIO + +-- | Like 'async' but using 'forkOS' internally. +asyncBound :: IO a -> IO (Async a) +asyncBound = asyncUsing forkOS + +-- | Like 'async' but using 'forkOn' internally. +asyncOn :: Int -> IO a -> IO (Async a) +asyncOn = asyncUsing . rawForkOn + +-- | Like 'async' but using 'forkIOWithUnmask' internally. The child +-- thread is passed a function that can be used to unmask asynchronous +-- exceptions. +asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) +asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask) + +-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally. The +-- child thread is passed a function that can be used to unmask +-- asynchronous exceptions. +asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) +asyncOnWithUnmask cpu actionWith = + asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) + +asyncUsing :: (IO () -> IO ThreadId) + -> IO a -> IO (Async a) +asyncUsing doFork = \action -> do + var <- newEmptyTMVarIO + -- t <- forkFinally action (\r -> atomically $ putTMVar var r) + -- slightly faster: + t <- mask $ \restore -> + doFork $ try (restore action) >>= atomically . putTMVar var + return (Async t (readTMVar var)) + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +-- +withAsync :: IO a -> (Async a -> IO b) -> IO b +withAsync = inline withAsyncUsing rawForkIO + +-- | Like 'withAsync' but uses 'forkOS' internally. +withAsyncBound :: IO a -> (Async a -> IO b) -> IO b +withAsyncBound = withAsyncUsing forkOS + +-- | Like 'withAsync' but uses 'forkOn' internally. +withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b +withAsyncOn = withAsyncUsing . rawForkOn + +-- | Like 'withAsync' but uses 'forkIOWithUnmask' internally. The +-- child thread is passed a function that can be used to unmask +-- asynchronous exceptions. +withAsyncWithUnmask + :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b +withAsyncWithUnmask actionWith = + withAsyncUsing rawForkIO (actionWith unsafeUnmask) + +-- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally. The +-- child thread is passed a function that can be used to unmask +-- asynchronous exceptions +withAsyncOnWithUnmask + :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b +withAsyncOnWithUnmask cpu actionWith = + withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) + +withAsyncUsing :: (IO () -> IO ThreadId) + -> IO a -> (Async a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyTMVarIO + mask $ \restore -> do + t <- doFork $ try (restore action) >>= atomically . putTMVar var + let a = Async t (readTMVar var) + r <- restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +-- +{-# INLINE wait #-} +wait :: Async a -> IO a +wait = tryAgain . atomically . waitSTM + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +-- +{-# INLINE waitCatch #-} +waitCatch :: Async a -> IO (Either SomeException a) +waitCatch = tryAgain . atomically . waitCatchSTM + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f + +-- | Check whether an 'Async' has completed yet. If it has not +-- completed yet, then the result is @Nothing@, otherwise the result +-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an +-- exception @x@, or @Right a@ if it returned a value @a@. +-- +-- > poll = atomically . pollSTM +-- +{-# INLINE poll #-} +poll :: Async a -> IO (Maybe (Either SomeException a)) +poll = atomically . pollSTM + +-- | A version of 'wait' that can be used inside an STM transaction. +-- +waitSTM :: Async a -> STM a +waitSTM a = do + r <- waitCatchSTM a + either throwSTM return r + +-- | A version of 'waitCatch' that can be used inside an STM transaction. +-- +{-# INLINE waitCatchSTM #-} +waitCatchSTM :: Async a -> STM (Either SomeException a) +waitCatchSTM (Async _ w) = w + +-- | A version of 'poll' that can be used inside an STM transaction. +-- +{-# INLINE pollSTM #-} +pollSTM :: Async a -> STM (Maybe (Either SomeException a)) +pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: Async a -> IO () +cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a + +-- | Cancel multiple asynchronous actions by throwing the @AsyncCancelled@ +-- exception to each of them in turn, then waiting for all the `Async` threads +-- to complete. +cancelMany :: [Async a] -> IO () +cancelMany as = do + mapM_ (\(Async t _) -> throwTo t AsyncCancelled) as + mapM_ waitCatch as + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving (Show, Eq +#if __GLASGOW_HASKELL__ < 710 + ,Typeable +#endif + ) + +instance Exception AsyncCancelled where +#if __GLASGOW_HASKELL__ >= 708 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: Async a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel + +-- | Cancel an asynchronous action by throwing the supplied exception +-- to it. +-- +-- > cancelWith a x = throwTo (asyncThreadId a) x +-- +-- The notes about the synchronous nature of 'cancel' also apply to +-- 'cancelWith'. +cancelWith :: Exception e => Async a -> e -> IO () +cancelWith a@(Async t _) e = throwTo t e <* waitCatch a + +-- | Wait for any of the supplied asynchronous operations to complete. +-- The value returned is a pair of the 'Async' that completed, and the +-- result that would be returned by 'wait' on that 'Async'. +-- The input list must be non-empty. +-- +-- If multiple 'Async's complete or have completed, then the value +-- returned corresponds to the first completed 'Async' in the list. +-- +{-# INLINE waitAnyCatch #-} +waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a) +waitAnyCatch = atomically . waitAnyCatchSTM + +-- | A version of 'waitAnyCatch' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a) +waitAnyCatchSTM [] = + throwSTM $ ErrorCall + "waitAnyCatchSTM: invalid argument: input list must be non-empty" +waitAnyCatchSTM asyncs = + foldr orElse retry $ + map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs + +-- | Like 'waitAnyCatch', but also cancels the other asynchronous +-- operations as soon as one has completed. +-- +waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a) +waitAnyCatchCancel asyncs = + waitAnyCatch asyncs `finally` cancelMany asyncs + +-- | Wait for any of the supplied @Async@s to complete. If the first +-- to complete throws an exception, then that exception is re-thrown +-- by 'waitAny'. +-- The input list must be non-empty. +-- +-- If multiple 'Async's complete or have completed, then the value +-- returned corresponds to the first completed 'Async' in the list. +-- +{-# INLINE waitAny #-} +waitAny :: [Async a] -> IO (Async a, a) +waitAny = atomically . waitAnySTM + +-- | A version of 'waitAny' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitAnySTM :: [Async a] -> STM (Async a, a) +waitAnySTM [] = + throwSTM $ ErrorCall + "waitAnySTM: invalid argument: input list must be non-empty" +waitAnySTM asyncs = + foldr orElse retry $ + map (\a -> do r <- waitSTM a; return (a, r)) asyncs + +-- | Like 'waitAny', but also cancels the other asynchronous +-- operations as soon as one has completed. +-- +waitAnyCancel :: [Async a] -> IO (Async a, a) +waitAnyCancel asyncs = + waitAny asyncs `finally` cancelMany asyncs + +-- | Wait for the first of two @Async@s to finish. +{-# INLINE waitEitherCatch #-} +waitEitherCatch :: Async a -> Async b + -> IO (Either (Either SomeException a) + (Either SomeException b)) +waitEitherCatch left right = + tryAgain $ atomically (waitEitherCatchSTM left right) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f + +-- | A version of 'waitEitherCatch' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitEitherCatchSTM :: Async a -> Async b + -> STM (Either (Either SomeException a) + (Either SomeException b)) +waitEitherCatchSTM left right = + (Left <$> waitCatchSTM left) + `orElse` + (Right <$> waitCatchSTM right) + +-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before +-- returning. +-- +waitEitherCatchCancel :: Async a -> Async b + -> IO (Either (Either SomeException a) + (Either SomeException b)) +waitEitherCatchCancel left right = + waitEitherCatch left right `finally` cancelMany [() <$ left, () <$ right] + +-- | Wait for the first of two @Async@s to finish. If the @Async@ +-- that finished first raised an exception, then the exception is +-- re-thrown by 'waitEither'. +-- +{-# INLINE waitEither #-} +waitEither :: Async a -> Async b -> IO (Either a b) +waitEither left right = atomically (waitEitherSTM left right) + +-- | A version of 'waitEither' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitEitherSTM :: Async a -> Async b -> STM (Either a b) +waitEitherSTM left right = + (Left <$> waitSTM left) + `orElse` + (Right <$> waitSTM right) + +-- | Like 'waitEither', but the result is ignored. +-- +{-# INLINE waitEither_ #-} +waitEither_ :: Async a -> Async b -> IO () +waitEither_ left right = atomically (waitEitherSTM_ left right) + +-- | A version of 'waitEither_' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitEitherSTM_:: Async a -> Async b -> STM () +waitEitherSTM_ left right = + (void $ waitSTM left) + `orElse` + (void $ waitSTM right) + +-- | Like 'waitEither', but also 'cancel's both @Async@s before +-- returning. +-- +waitEitherCancel :: Async a -> Async b -> IO (Either a b) +waitEitherCancel left right = + waitEither left right `finally` cancelMany [() <$ left, () <$ right] + +-- | Waits for both @Async@s to finish, but if either of them throws +-- an exception before they have both finished, then the exception is +-- re-thrown by 'waitBoth'. +-- +{-# INLINE waitBoth #-} +waitBoth :: Async a -> Async b -> IO (a,b) +waitBoth left right = tryAgain $ atomically (waitBothSTM left right) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f + +-- | A version of 'waitBoth' that can be used inside an STM transaction. +-- +-- @since 2.1.0 +waitBothSTM :: Async a -> Async b -> STM (a,b) +waitBothSTM left right = do + a <- waitSTM left + `orElse` + (waitSTM right >> retry) + b <- waitSTM right + return (a,b) + + +-- ----------------------------------------------------------------------------- +-- Linking threads + +data ExceptionInLinkedThread = + forall a . ExceptionInLinkedThread (Async a) SomeException +#if __GLASGOW_HASKELL__ < 710 + deriving Typeable +#endif + +instance Show ExceptionInLinkedThread where + showsPrec p (ExceptionInLinkedThread (Async t _) e) = + showParen (p >= 11) $ + showString "ExceptionInLinkedThread " . + showsPrec 11 t . + showString " " . + showsPrec 11 e + +instance Exception ExceptionInLinkedThread where +#if __GLASGOW_HASKELL__ >= 708 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Link the given @Async@ to the current thread, such that if the +-- @Async@ raises an exception, that exception will be re-thrown in +-- the current thread, wrapped in 'ExceptionInLinkedThread'. +-- +-- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread, +-- so that it's safe to 'cancel' a thread you're linked to. If you want +-- different behaviour, use 'linkOnly'. +-- +link :: Async a -> IO () +link = linkOnly (not . isCancel) + +-- | Link the given @Async@ to the current thread, such that if the +-- @Async@ raises an exception, that exception will be re-thrown in +-- the current thread, wrapped in 'ExceptionInLinkedThread'. +-- +-- The supplied predicate determines which exceptions in the target +-- thread should be propagated to the source thread. +-- +linkOnly + :: (SomeException -> Bool) -- ^ return 'True' if the exception + -- should be propagated, 'False' + -- otherwise. + -> Async a + -> IO () +linkOnly shouldThrow a = do + me <- myThreadId + void $ forkRepeat $ do + r <- waitCatch a + case r of + Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e) + _otherwise -> return () + +-- | Link two @Async@s together, such that if either raises an +-- exception, the same exception is re-thrown in the other @Async@, +-- wrapped in 'ExceptionInLinkedThread'. +-- +-- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible +-- to 'cancel' either thread without cancelling the other. If you +-- want different behaviour, use 'link2Only'. +-- +link2 :: Async a -> Async b -> IO () +link2 = link2Only (not . isCancel) + +-- | Link two @Async@s together, such that if either raises an +-- exception, the same exception is re-thrown in the other @Async@, +-- wrapped in 'ExceptionInLinkedThread'. +-- +-- The supplied predicate determines which exceptions in the target +-- thread should be propagated to the source thread. +-- +link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO () +link2Only shouldThrow left@(Async tl _) right@(Async tr _) = + void $ forkRepeat $ do + r <- waitEitherCatch left right + case r of + Left (Left e) | shouldThrow e -> + throwTo tr (ExceptionInLinkedThread left e) + Right (Left e) | shouldThrow e -> + throwTo tl (ExceptionInLinkedThread right e) + _ -> return () + +isCancel :: SomeException -> Bool +isCancel e + | Just AsyncCancelled <- fromException e = True + | otherwise = False + + +-- ----------------------------------------------------------------------------- + +-- | Run two @IO@ actions concurrently, and return the first to +-- finish. The loser of the race is 'cancel'led. +-- +-- > race left right = +-- > withAsync left $ \a -> +-- > withAsync right $ \b -> +-- > waitEither a b +-- +race :: IO a -> IO b -> IO (Either a b) + +-- | Like 'race', but the result is ignored. +-- +race_ :: IO a -> IO b -> IO () + + +-- | Run two @IO@ actions concurrently, and return both results. If +-- either action throws an exception at any time, then the other +-- action is 'cancel'led, and the exception is re-thrown by +-- 'concurrently'. +-- +-- > concurrently left right = +-- > withAsync left $ \a -> +-- > withAsync right $ \b -> +-- > waitBoth a b +concurrently :: IO a -> IO b -> IO (a,b) + + +-- | Run two @IO@ actions concurrently. If both of them end with @Right@, +-- return both results. If one of then ends with @Left@, interrupt the other +-- action and return the @Left@. +-- +concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b)) + +-- | 'concurrently', but ignore the result values +-- +-- @since 2.1.1 +concurrently_ :: IO a -> IO b -> IO () + +#define USE_ASYNC_VERSIONS 0 + +#if USE_ASYNC_VERSIONS + +race left right = + withAsync left $ \a -> + withAsync right $ \b -> + waitEither a b + +race_ left right = void $ race left right + +concurrently left right = + withAsync left $ \a -> + withAsync right $ \b -> + waitBoth a b + +concurrently_ left right = void $ concurrently left right + +#else + +-- MVar versions of race/concurrently +-- More ugly than the Async versions, but quite a bit faster. + +-- race :: IO a -> IO b -> IO (Either a b) +race left right = concurrently' left right collect + where + collect m = do + e <- m + case e of + Left ex -> throwIO ex + Right r -> return r + +-- race_ :: IO a -> IO b -> IO () +race_ left right = void $ race left right + +-- concurrently :: IO a -> IO b -> IO (a,b) +concurrently left right = concurrently' left right (collect []) + where + collect [Left a, Right b] _ = return (a,b) + collect [Right b, Left a] _ = return (a,b) + collect xs m = do + e <- m + case e of + Left ex -> throwIO ex + Right r -> collect (r:xs) m + +-- concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b)) +concurrentlyE left right = concurrently' left right (collect []) + where + collect [Left (Right a), Right (Right b)] _ = return $ Right (a,b) + collect [Right (Right b), Left (Right a)] _ = return $ Right (a,b) + collect (Left (Left ea):_) _ = return $ Left ea + collect (Right (Left eb):_) _ = return $ Left eb + collect xs m = do + e <- m + case e of + Left ex -> throwIO ex + Right r -> collect (r:xs) m + +concurrently' :: IO a -> IO b + -> (IO (Either SomeException (Either a b)) -> IO r) + -> IO r +concurrently' left right collect = do + done <- newEmptyMVar + mask $ \restore -> do + -- Note: uninterruptibleMask here is because we must not allow + -- the putMVar in the exception handler to be interrupted, + -- otherwise the parent thread will deadlock when it waits for + -- the thread to terminate. + lid <- forkIO $ uninterruptibleMask_ $ + restore (left >>= putMVar done . Right . Left) + `catchAll` (putMVar done . Left) + rid <- forkIO $ uninterruptibleMask_ $ + restore (right >>= putMVar done . Right . Right) + `catchAll` (putMVar done . Left) + + count <- newIORef (2 :: Int) + let takeDone = do + r <- takeMVar done -- interruptible + -- Decrement the counter so we know how many takes are left. + -- Since only the parent thread is calling this, we can + -- use non-atomic modifications. + -- NB. do this *after* takeMVar, because takeMVar might be + -- interrupted. + modifyIORef count (subtract 1) + return r + + let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f + + stop = do + -- kill right before left, to match the semantics of + -- the version using withAsync. (#27) + uninterruptibleMask_ $ do + count' <- readIORef count + -- we only need to use killThread if there are still + -- children alive. Note: forkIO here is because the + -- child thread could be in an uninterruptible + -- putMVar. + when (count' > 0) $ + void $ forkIO $ do + throwTo rid AsyncCancelled + throwTo lid AsyncCancelled + -- ensure the children are really dead + replicateM_ count' (tryAgain $ takeMVar done) + + r <- collect (tryAgain $ takeDone) `onException` stop + stop + return r + +concurrently_ left right = concurrently' left right (collect 0) + where + collect 2 _ = return () + collect i m = do + e <- m + case e of + Left ex -> throwIO ex + Right _ -> collect (i + 1 :: Int) m + + +#endif + +-- | Maps an 'IO'-performing function over any 'Traversable' data +-- type, performing all the @IO@ actions concurrently, and returning +-- the original data structure with the arguments replaced by the +-- results. +-- +-- If any of the actions throw an exception, then all other actions are +-- cancelled and the exception is re-thrown. +-- +-- For example, @mapConcurrently@ works with lists: +-- +-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"] +-- +-- Take into account that @async@ will try to immediately spawn a thread +-- for each element of the @Traversable@, so running this on large +-- inputs without care may lead to resource exhaustion (of memory, +-- file descriptors, or other limited resources). +mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b) +mapConcurrently f = runConcurrently . traverse (Concurrently . f) + +-- | `forConcurrently` is `mapConcurrently` with its arguments flipped +-- +-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url +-- +-- @since 2.1.0 +forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b) +forConcurrently = flip mapConcurrently + +-- | `mapConcurrently_` is `mapConcurrently` with the return value discarded; +-- a concurrent equivalent of 'mapM_'. +mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO () +mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f) + +-- | `forConcurrently_` is `forConcurrently` with the return value discarded; +-- a concurrent equivalent of 'forM_'. +forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO () +forConcurrently_ = flip mapConcurrently_ + +-- | Perform the action in the given number of threads. +-- +-- @since 2.1.1 +replicateConcurrently :: Int -> IO a -> IO [a] +replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently + +-- | Same as 'replicateConcurrently', but ignore the results. +-- +-- @since 2.1.1 +replicateConcurrently_ :: Int -> IO a -> IO () +replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void + +-- ----------------------------------------------------------------------------- + +-- | A value of type @Concurrently a@ is an @IO@ operation that can be +-- composed with other @Concurrently@ values, using the @Applicative@ +-- and @Alternative@ instances. +-- +-- Calling @runConcurrently@ on a value of type @Concurrently a@ will +-- execute the @IO@ operations it contains concurrently, before +-- delivering the result of type @a@. +-- +-- For example +-- +-- > (page1, page2, page3) +-- > <- runConcurrently $ (,,) +-- > <$> Concurrently (getURL "url1") +-- > <*> Concurrently (getURL "url2") +-- > <*> Concurrently (getURL "url3") +-- +newtype Concurrently a = Concurrently { runConcurrently :: IO a } + +instance Functor Concurrently where + fmap f (Concurrently a) = Concurrently $ f <$> a + +instance Applicative Concurrently where + pure = Concurrently . return + Concurrently fs <*> Concurrently as = + Concurrently $ (\(f, a) -> f a) <$> concurrently fs as + +-- | 'Control.Alternative.empty' waits forever. 'Control.Alternative.<|>' returns the first to finish and 'cancel's the other. +instance Alternative Concurrently where + empty = Concurrently $ forever (threadDelay maxBound) + Concurrently as <|> Concurrently bs = + Concurrently $ either id id <$> race as bs + +#if MIN_VERSION_base(4,9,0) +-- | Only defined by @async@ for @base >= 4.9@ +-- +-- @since 2.1.0 +instance Semigroup a => Semigroup (Concurrently a) where + (<>) = liftA2 (<>) + +-- | @since 2.1.0 +instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where + mempty = pure mempty + mappend = (<>) +#else +-- | @since 2.1.0 +instance Monoid a => Monoid (Concurrently a) where + mempty = pure mempty + mappend = liftA2 mappend +#endif + +-- | A value of type @ConcurrentlyE e a@ is an @IO@ operation that can be +-- composed with other @ConcurrentlyE@ values, using the @Applicative@ instance. +-- +-- Calling @runConcurrentlyE@ on a value of type @ConcurrentlyE e a@ will +-- execute the @IO@ operations it contains concurrently, before delivering +-- either the result of type @a@, or an error of type @e@ if one of the actions +-- returns @Left@. +-- +-- | @since 2.2.5 +newtype ConcurrentlyE e a = ConcurrentlyE { runConcurrentlyE :: IO (Either e a) } + +instance Functor (ConcurrentlyE e) where + fmap f (ConcurrentlyE ea) = ConcurrentlyE $ fmap (fmap f) ea + +#if MIN_VERSION_base(4,8,0) +instance Bifunctor ConcurrentlyE where + bimap f g (ConcurrentlyE ea) = ConcurrentlyE $ fmap (bimap f g) ea +#endif + +instance Applicative (ConcurrentlyE e) where + pure = ConcurrentlyE . return . return + ConcurrentlyE fs <*> ConcurrentlyE eas = + ConcurrentlyE $ fmap (\(f, a) -> f a) <$> concurrentlyE fs eas + +#if MIN_VERSION_base(4,9,0) +-- | Either the combination of the successful results, or the first failure. +instance Semigroup a => Semigroup (ConcurrentlyE e a) where + (<>) = liftA2 (<>) + +instance (Semigroup a, Monoid a) => Monoid (ConcurrentlyE e a) where + mempty = pure mempty + mappend = (<>) +#endif + +-- ---------------------------------------------------------------------------- + +-- | Fork a thread that runs the supplied action, and if it raises an +-- exception, re-runs the action. The thread terminates only when the +-- action runs to completion without raising an exception. +forkRepeat :: IO a -> IO ThreadId +forkRepeat action = + mask $ \restore -> + let go = do r <- tryAll (restore action) + case r of + Left _ -> go + _ -> return () + in forkIO go + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = catch + +tryAll :: IO a -> IO (Either SomeException a) +tryAll = try + +-- A version of forkIO that does not include the outer exception +-- handler: saves a bit of time when we will be installing our own +-- exception handler. +{-# INLINE rawForkIO #-} +rawForkIO :: IO () -> IO ThreadId +rawForkIO (IO action) = IO $ \ s -> + case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) + +{-# INLINE rawForkOn #-} +rawForkOn :: Int -> IO () -> IO ThreadId +rawForkOn (I# cpu) (IO action) = IO $ \ s -> + case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) diff --git a/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs b/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs new file mode 100644 --- /dev/null +++ b/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +{-# OPTIONS -fno-warn-implicit-prelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TMVar +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- TMVar: Transactional MVars, for use in the STM monad +-- (GHC only) +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TMVar ( +#ifdef __GLASGOW_HASKELL__ + -- * TMVars + TMVar, + newTMVar, + newEmptyTMVar, + newTMVarIO, + newEmptyTMVarIO, + takeTMVar, + putTMVar, + readTMVar, + tryReadTMVar, + swapTMVar, + tryTakeTMVar, + tryPutTMVar, + isEmptyTMVar, + mkWeakTMVar +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Conc +import GHC.Weak + +import Data.Typeable (Typeable) + +newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable) +{- ^ +A 'TMVar' is a synchronising variable, used +for communication between concurrent threads. It can be thought of +as a box, which may be empty or full. +-} + +-- |Create a 'TMVar' which contains the supplied value. +newTMVar :: a -> STM (TMVar a) +newTMVar a = do + t <- newTVar (Just a) + return (TMVar t) + +-- |@IO@ version of 'newTMVar'. This is useful for creating top-level +-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTMVarIO :: a -> IO (TMVar a) +newTMVarIO a = do + t <- newTVarIO (Just a) + return (TMVar t) + +-- |Create a 'TMVar' which is initially empty. +newEmptyTMVar :: STM (TMVar a) +newEmptyTMVar = do + t <- newTVar Nothing + return (TMVar t) + +-- |@IO@ version of 'newEmptyTMVar'. This is useful for creating top-level +-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newEmptyTMVarIO :: IO (TMVar a) +newEmptyTMVarIO = do + t <- newTVarIO Nothing + return (TMVar t) + +-- |Return the contents of the 'TMVar'. If the 'TMVar' is currently +-- empty, the transaction will 'retry'. After a 'takeTMVar', +-- the 'TMVar' is left empty. +takeTMVar :: TMVar a -> STM a +takeTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> do writeTVar t Nothing; return a + +-- | A version of 'takeTMVar' that does not 'retry'. The 'tryTakeTMVar' +-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if +-- the 'TMVar' was full with contents @a@. After 'tryTakeTMVar', the +-- 'TMVar' is left empty. +tryTakeTMVar :: TMVar a -> STM (Maybe a) +tryTakeTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return Nothing + Just a -> do writeTVar t Nothing; return (Just a) + +-- |Put a value into a 'TMVar'. If the 'TMVar' is currently full, +-- 'putTMVar' will 'retry'. +putTMVar :: TMVar a -> a -> STM () +putTMVar (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return () + Just _ -> retry + +-- | A version of 'putTMVar' that does not 'retry'. The 'tryPutTMVar' +-- function attempts to put the value @a@ into the 'TMVar', returning +-- 'True' if it was successful, or 'False' otherwise. +tryPutTMVar :: TMVar a -> a -> STM Bool +tryPutTMVar (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return True + Just _ -> return False + +-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it +-- takes the value from the 'TMVar', puts it back, and also returns +-- it. +readTMVar :: TMVar a -> STM a +readTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> return a + +-- | A version of 'readTMVar' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +-- +-- @since 2.3 +tryReadTMVar :: TMVar a -> STM (Maybe a) +tryReadTMVar (TMVar t) = readTVar t + +-- |Swap the contents of a 'TMVar' for a new value. +swapTMVar :: TMVar a -> a -> STM a +swapTMVar (TMVar t) new = do + m <- readTVar t + case m of + Nothing -> retry + Just old -> do writeTVar t (Just new); return old + +-- |Check whether a given 'TMVar' is empty. +isEmptyTMVar :: TMVar a -> STM Bool +isEmptyTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return True + Just _ -> return False + +-- | Make a 'Weak' pointer to a 'TMVar', using the second argument as +-- a finalizer to run when the 'TMVar' is garbage-collected. +-- +-- @since 2.4.4 +mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a)) +mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s -> + case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #) +#endif diff --git a/version.yaml b/version.yaml new file mode 100644 --- /dev/null +++ b/version.yaml @@ -0,0 +1,7 @@ +version: &version 2.11.17 +synopsis: A Testing Framework for Haskell +author: Simon Hengel +maintainer: Simon Hengel +category: Testing +stability: experimental +homepage: https://hspec.github.io/