diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2021 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,24 +1,26 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- 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.7.10 +version: 2.11.17 license: MIT license-file: LICENSE -copyright: (c) 2011-2021 Simon Hengel, +copyright: (c) 2011-2026 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple 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. @@ -31,56 +33,91 @@ hs-source-dirs: src vendor - ghc-options: -Wall + ghc-options: -Wall -fno-warn-incomplete-uni-patterns build-depends: HUnit ==1.6.* - , QuickCheck >=2.13.1 - , ansi-terminal >=0.5 + , QuickCheck >=2.13.1 && <2.19 + , ansi-terminal >=0.6.2 , array - , base >=4.5.0.0 && <5 - , call-stack - , clock >=0.7.1 + , base >=4.9.0.0 && <5 + , call-stack >=0.2.0 + , containers , deepseq , directory , filepath - , hspec-expectations ==0.8.2.* + , haskell-lexer + , hspec-expectations ==0.8.4.* + , process , quickcheck-io >=0.2.0 , random - , setenv - , stm >=2.2 - , tf-random + , time , 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: + 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.Config.Util Test.Hspec.Core.Example Test.Hspec.Core.Example.Location + Test.Hspec.Core.Extension.Config.Type Test.Hspec.Core.FailureReport - Test.Hspec.Core.Format Test.Hspec.Core.Formatters.Diff - Test.Hspec.Core.Formatters.Free Test.Hspec.Core.Formatters.Internal - Test.Hspec.Core.Formatters.Monad - 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 - Control.Concurrent.Async 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 @@ -89,81 +126,128 @@ src vendor test - ghc-options: -Wall + ghc-options: -Wall -fno-warn-incomplete-uni-patterns cpp-options: -DTEST build-depends: HUnit ==1.6.* , QuickCheck >=2.14 - , ansi-terminal >=0.5 + , ansi-terminal >=0.6.2 , array - , base >=4.5.0.0 && <5 - , call-stack - , clock >=0.7.1 + , base >=4.9.0.0 && <5 + , base-orphans + , call-stack >=0.2.0 + , containers , deepseq , directory , filepath - , hspec-expectations ==0.8.2.* - , hspec-meta ==2.7.8 + , haskell-lexer + , hspec-expectations ==0.8.4.* + , hspec-meta ==2.11.17 , process , quickcheck-io >=0.2.0 , random - , setenv , silently >=1.2.4 - , stm >=2.2 , temporary - , tf-random + , time , transformers >=0.2.2.0 build-tool-depends: hspec-meta:hspec-meta-discover other-modules: + 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.Config.Util 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.Free Test.Hspec.Core.Formatters.Internal - Test.Hspec.Core.Formatters.Monad + 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 - Control.Concurrent.Async Data.Algorithm.Diff - All + 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.Config.UtilSpec 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.FormattersSpec + 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.QuickCheckUtilSpec + 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/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 --- a/src/Test/Hspec/Core/Clock.hs +++ b/src/Test/Hspec/Core/Clock.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock ( Seconds(..) +, toMilliseconds , toMicroseconds , getMonotonicTime , measure @@ -8,21 +10,40 @@ , 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 System.Clock 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, Num, Fractional, PrintfArg) + 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 <- getTime Monotonic - return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000) + t <- getPOSIXTime + return $ Seconds (realToFrac t) +#endif measure :: IO a -> IO (Seconds, a) measure action = do diff --git a/src/Test/Hspec/Core/Compat.hs b/src/Test/Hspec/Core/Compat.hs --- a/src/Test/Hspec/Core/Compat.hs +++ b/src/Test/Hspec/Core/Compat.hs @@ -1,31 +1,14 @@ {-# LANGUAGE CPP #-} module Test.Hspec.Core.Compat ( - getDefaultConcurrentJobs -, showType -, showFullType -, readMaybe -, lookupEnv -, module Data.IORef - -, module Prelude -, module Control.Applicative -, module Control.Monad -, module Data.Foldable -, module Data.Traversable -, module Data.Monoid -, module Data.List - -#if !MIN_VERSION_base(4,6,0) -, modifyIORef' -, atomicWriteIORef -#endif -, interruptible - -, guarded + module Imports +, module Test.Hspec.Core.Compat +, Typeable ) where -import Control.Applicative -import Control.Monad hiding ( +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 @@ -34,12 +17,37 @@ , sequence , sequence_ ) -import Data.Foldable -import Data.Traversable -import Data.Monoid -import Data.List (intercalate) +import Data.Maybe as Imports +import Data.Foldable as Imports +import GHC.Stack as Imports (HasCallStack, withFrozenCallStack) -import Prelude hiding ( +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 @@ -60,90 +68,104 @@ , sequence , sequence_ , sum -#if !MIN_VERSION_base(4,6,0) - , catch -#endif + , length + , null ) -import Data.Typeable (Typeable, typeOf, typeRepTyCon) -import Text.Read -import Data.IORef -import System.Environment - -import Data.Typeable (tyConModule, tyConName) -import Control.Concurrent +import Data.Typeable +import Data.IORef as Imports -#if MIN_VERSION_base(4,9,0) -import Control.Exception (interruptible) +#if MIN_VERSION_base(4,12,0) +import GHC.ResponseFile as Imports (unescapeArgs) #else -import GHC.IO +import Data.Char #endif -#if !MIN_VERSION_base(4,6,0) -import qualified Text.ParserCombinators.ReadP as P +import Text.Read as Imports (readMaybe) +import System.Environment as Imports (lookupEnv) --- |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' -atomicWriteIORef :: IORef a -> a -> IO () -atomicWriteIORef ref a = do - x <- atomicModifyIORef ref (\_ -> (a, ())) - x `seq` return () - --- | 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 +import Data.Bool as Imports (bool) --- | 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 +import Control.Concurrent --- | 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 +#ifndef __MHS__ +import GHC.IO.Exception +#else +import System.IO.Error #endif + ( ioe_type, IOErrorType(..) ) -showType :: Typeable a => a -> String -showType a = let t = typeRepTyCon (typeOf a) in - show t +isUnsupportedOperation :: IOError -> Bool +isUnsupportedOperation e = ioe_type e == UnsupportedOperation -showFullType :: Typeable a => a -> String -showFullType a = let t = typeRepTyCon (typeOf a) in - tyConModule t ++ "." ++ tyConName t +showType :: Typeable a => a -> String +showType = show . typeRepTyCon . typeOf getDefaultConcurrentJobs :: IO Int getDefaultConcurrentJobs = getNumCapabilities -#if !MIN_VERSION_base(4,9,0) -interruptible :: IO a -> IO a -interruptible act = do - st <- getMaskingState - case st of - Unmasked -> act - MaskedInterruptible -> unsafeUnmask act - MaskedUninterruptible -> act -#endif - 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 --- a/src/Test/Hspec/Core/Config.hs +++ b/src/Test/Hspec/Core/Config.hs @@ -2,6 +2,7 @@ module Test.Hspec.Core.Config ( Config (..) , ColorMode(..) +, UnicodeMode(..) , defaultConfig , readConfig , configAddFilter @@ -17,22 +18,31 @@ import Prelude () import Test.Hspec.Core.Compat -import Control.Exception -import Data.Maybe import System.IO import System.IO.Error import System.Exit import System.FilePath import System.Directory -import System.Environment (getProgName) +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.QuickCheckUtil (mkGen) +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 @@ -41,21 +51,21 @@ } applyFailureReport :: Maybe FailureReport -> Config -> Config -applyFailureReport mFailureReport opts = opts { +applyFailureReport mFailureReport config = config { configFilterPredicate = matchFilter `filterOr` rerunFilter - , configQuickCheckSeed = mSeed + , configSeed = 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) + mSeed = getSeed config <|> (failureReportSeed <$> mFailureReport) + mMaxSuccess = configQuickCheckMaxSuccess config <|> (failureReportMaxSuccess <$> mFailureReport) + mMaxSize = configQuickCheckMaxSize config <|> (failureReportMaxSize <$> mFailureReport) + mMaxDiscardRatio = configQuickCheckMaxDiscardRatio config <|> (failureReportMaxDiscardRatio <$> mFailureReport) - matchFilter = configFilterPredicate opts + matchFilter = configFilterPredicate config rerunFilter = case failureReportPaths <$> mFailureReport of Just [] -> Nothing @@ -66,19 +76,23 @@ configQuickCheckArgs c = qcArgs where qcArgs = ( - maybe id setSeed (configQuickCheckSeed c) - . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) + 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} - setMaxDiscardRatio :: Int -> QC.Args -> QC.Args - setMaxDiscardRatio n args = args {QC.maxDiscardRatio = 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)} @@ -89,7 +103,7 @@ -- -- 1. @~/.hspec@ (a config file in the user's home directory) -- 1. @.hspec@ (a config file in the current working directory) --- 1. the environment variable @HSPEC_OPTIONS@ +-- 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) @@ -113,10 +127,13 @@ case ignore of True -> return [] False -> readConfigFiles - envVar <- fmap words <$> lookupEnv envVarName - case parseOptions opts_ prog configFiles envVar args of + env <- getEnvironment + let envVar = words <$> lookup envVarName env + case parseOptions opts_ prog configFiles envVar env args of Left (err, msg) -> exitWithMessage err msg - Right opts -> return opts + Right (warnings, opts) -> do + mapM_ (hPutStrLn stderr) warnings + return opts readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) readFailureReportOnRerun config @@ -131,10 +148,13 @@ readGlobalConfigFile :: IO (Maybe ConfigFile) readGlobalConfigFile = do - mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory + 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 @@ -146,7 +166,7 @@ readConfigFile :: FilePath -> IO (Maybe ConfigFile) readConfigFile name = do exists <- doesFileExist name - if exists then Just . (,) name . words <$> readFile name else return Nothing + if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing exitWithMessage :: ExitCode -> String -> IO a exitWithMessage err msg = do 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 --- a/src/Test/Hspec/Core/Config/Options.hs +++ b/src/Test/Hspec/Core/Config/Options.hs @@ -1,337 +1,88 @@ +{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config.Options ( - Config(..) -, ColorMode (..) -, defaultConfig -, filterOr -, parseOptions -, ConfigFile -, ignoreConfigFile + ConfigFile , envVarName +, ignoreConfigFile +, parseOptions ) where import Prelude () import Test.Hspec.Core.Compat -import System.IO import System.Exit -import System.Console.GetOpt -import Test.Hspec.Core.Formatters -import Test.Hspec.Core.Config.Util -import Test.Hspec.Core.Util -import Test.Hspec.Core.Example (Params(..), defaultParams) -import Data.Functor.Identity -import Data.Maybe +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" -data Config = Config { - configIgnoreConfigFile :: Bool -, configDryRun :: Bool -, configFocusedOnly :: Bool -, configFailOnFocused :: Bool -, configPrintCpuTime :: Bool -, configFastFail :: Bool -, configRandomize :: Bool -, 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) -, configQuickCheckSeed :: Maybe Integer -, configQuickCheckMaxSuccess :: Maybe Int -, configQuickCheckMaxDiscardRatio :: Maybe Int -, configQuickCheckMaxSize :: Maybe Int -, configSmallCheckDepth :: Int -, configColorMode :: ColorMode -, configDiff :: Bool -, configFormatter :: Maybe Formatter -, configHtmlOutput :: Bool -, configOutputFile :: Either Handle FilePath -, configConcurrentJobs :: Maybe Int -} - -defaultConfig :: Config -defaultConfig = Config { - configIgnoreConfigFile = False -, configDryRun = False -, configFocusedOnly = False -, configFailOnFocused = False -, configPrintCpuTime = False -, configFastFail = False -, configRandomize = False -, configFailureReport = Nothing -, configRerun = False -, configRerunAllOnSuccess = False -, configFilterPredicate = Nothing -, configSkipPredicate = Nothing -, configQuickCheckSeed = Nothing -, configQuickCheckMaxSuccess = Nothing -, configQuickCheckMaxDiscardRatio = Nothing -, configQuickCheckMaxSize = Nothing -, configSmallCheckDepth = paramsSmallCheckDepth defaultParams -, configColorMode = ColorAuto -, configDiff = True -, 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) - -type Result m = Either InvalidArgument (m Config) - -data InvalidArgument = InvalidArgument String String - -data Arg a = Arg { - _argumentName :: String -, _argumentParser :: String -> Maybe a -, _argumentSetter :: a -> Config -> Config -} - -mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m) -mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help - where - arg input x = x >>= \c -> case parser input of - Just n -> Right (setter n `liftM` c) - Nothing -> Left (InvalidArgument name input) - -mkFlag :: Monad m => String -> (Bool -> Config -> Config) -> String -> [OptDescr (Result m -> Result m)] -mkFlag name setter help = [ - Option [] [name] (NoArg $ set $ setter True) help - , Option [] ["no-" ++ name] (NoArg $ set $ setter False) ("do not " ++ help) - ] - -commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)] -commandLineOptions = [ - Option [] ["help"] (NoArg (const $ Right Nothing)) "display this help and exit" - , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) "do not read options from ~/.hspec and .hspec" - , mkOption "m" "match" (Arg "PATTERN" return addMatch) "only run examples that match given PATTERN" - , mkOption [] "skip" (Arg "PATTERN" return addSkip) "skip examples that match given PATTERN" - ] - where - setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True} - -formatterOptions :: Monad m => [OptDescr (Result m -> Result m)] -formatterOptions = concat [ - [mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) helpForFormat] - , mkFlag "color" setColor "colorize the output" - , mkFlag "diff" setDiff "show colorized diffs" - , [Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary"] - ] - where - formatters :: [(String, Formatter)] - formatters = [ - ("checks", checks) - , ("specdoc", specdoc) - , ("progress", progress) - , ("failed-examples", failed_examples) - , ("silent", silent) - ] - - helpForFormat :: String - helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) - - readFormatter :: String -> Maybe Formatter - readFormatter = (`lookup` formatters) - - setFormatter :: Formatter -> Config -> Config - setFormatter f c = c {configFormatter = Just f} - - setColor :: Bool -> Config -> Config - setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} - - setDiff :: Bool -> Config -> Config - setDiff v config = config {configDiff = v} - - setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} - -smallCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] -smallCheckOptions = [ - mkOption [] "depth" (Arg "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties" - ] - -quickCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] -quickCheckOptions = [ - mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" - , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) "size to use for the biggest test cases" - , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up" - , mkOption [] "seed" (Arg "N" readMaybe setSeed) "used seed for QuickCheck properties" - ] - -runnerOptions :: Monad m => [OptDescr (Result m -> Result m)] -runnerOptions = concat [ - mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything" - , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" - , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" - , mkFlag "fail-fast" setFastFail "abort on first failure" - , mkFlag "randomize" setRandomize "randomize execution order" - ] ++ [ - Option "r" ["rerun"] (NoArg setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" - , mkOption [] "failure-report" (Arg "FILE" return setFailureReport) "read/write a failure report for use with --rerun" - , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" - - - , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" - ] - where - 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} - - setFailOnFocused :: Bool -> Config -> Config - setFailOnFocused value config = config {configFailOnFocused = value} - - setFastFail :: Bool -> Config -> Config - setFastFail value config = config {configFastFail = value} - - setRandomize :: Bool -> Config -> Config - setRandomize value config = config {configRandomize = value} - - setRerun = set $ \config -> config {configRerun = True} - setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} +commandLineOptions :: Config -> [(String, [Declarative.Option Config])] +commandLineOptions config = + ("OPTIONS", commandLineOnlyOptions) + : otherOptions config -documentedConfigFileOptions :: Monad m => [(String, [OptDescr (Result m -> Result m)])] -documentedConfigFileOptions = [ +otherOptions :: Config -> [(String, [Declarative.Option Config])] +otherOptions config = [ ("RUNNER OPTIONS", runnerOptions) - , ("FORMATTER OPTIONS", formatterOptions) + , ("FORMATTER OPTIONS", formatterOptions formatters) , ("OPTIONS FOR QUICKCHECK", quickCheckOptions) , ("OPTIONS FOR SMALLCHECK", smallCheckOptions) - ] - -documentedOptions :: [(String, [OptDescr (Result Maybe -> Result Maybe)])] -documentedOptions = ("OPTIONS", commandLineOptions) : documentedConfigFileOptions - -configFileOptions :: Monad m => [OptDescr (Result m -> Result m)] -configFileOptions = (concat . map snd) documentedConfigFileOptions - -set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config) -set = liftM . liftM - -undocumentedOptions :: Monad m => [OptDescr (Result m -> Result m)] -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" - - , mkOption "o" "out" (Arg "FILE" return setOutputFile) "write output to a file instead of STDOUT" - - -- now a noop - , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" - ] + ] ++ extensionOptions where - setHtml = set $ \config -> config {configHtmlOutput = True} - - setOutputFile :: String -> Config -> Config - setOutputFile file c = c {configOutputFile = Right file} + formatters = configAvailableFormatters config + extensionOptions = getExtensionOptions config -recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)] -recognizedOptions = commandLineOptions ++ configFileOptions ++ undocumentedOptions +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] -> Either (ExitCode, String) Config -parseOptions config prog configFiles envVar args = do +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 - >>= parseEnvVarOptions prog envVar - >>= parseCommandLineOptions prog args + >>= maybe return (parseEnvVarOptions prog) envVar + >>= parseEnvironmentOptions env + >>= traverse (parseCommandLineOptions prog args) parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config -parseCommandLineOptions prog args config = case parse recognizedOptions config args of - Right Nothing -> Left (ExitSuccess, usage) - Right (Just c) -> Right c - Left err -> failure err - where - failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n") +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) - usage :: String - usage = "Usage: " ++ prog ++ " [OPTION]...\n\n" - ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions) +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 -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config -parseEnvVarOptions prog args = - parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args) +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 configFileOptions config args of - Right (Identity c) -> Right c +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] - -parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config) -parse options config args = case getOpt Permute options args of - (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of - Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'") - Right x -> Right x - (_, _, err:_) -> Left (init err) - (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") - -ignoreConfigFile :: Config -> [String] -> IO Bool -ignoreConfigFile config args = do - ignore <- lookupEnv "IGNORE_DOT_HSPEC" - case ignore of - Just _ -> return True - Nothing -> case parse recognizedOptions config args of - Right (Just c) -> return (configIgnoreConfigFile c) - _ -> return False diff --git a/src/Test/Hspec/Core/Config/Util.hs b/src/Test/Hspec/Core/Config/Util.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Config/Util.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Test.Hspec.Core.Config.Util where - -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 "" [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) -> - Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys - x : xs -> x : condenseNoOptions xs - [] -> [] - -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/Example.hs b/src/Test/Hspec/Core/Example.hs --- a/src/Test/Hspec/Core/Example.hs +++ b/src/Test/Hspec/Core/Example.hs @@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Example ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Example (..) +#ifndef ENABLE_SPEC_HOOK_ARGS +, Arg +#endif , Params (..) , defaultParams , ActionWith @@ -19,126 +21,223 @@ , FailureReason (..) , safeEvaluate , safeEvaluateExample +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, safeEvaluateResultStatus +, exceptionToResultStatus +, toLocation +, hunitFailureToResult ) where +import Prelude () +import Test.Hspec.Core.Compat + import qualified Test.HUnit.Lang as HUnit -import Data.CallStack +import Data.CallStack (SrcLoc(..)) -import Control.Exception import Control.DeepSeq -import Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) -import qualified Test.QuickCheck.Property as QCP - -import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util -import Test.Hspec.Core.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 type Arg e = () - evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result +#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 + + -- | 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 = Result { resultInfo :: String , resultStatus :: ResultStatus -} deriving (Show, Typeable) +} deriving Show data ResultStatus = Success | Pending (Maybe Location) (Maybe String) | Failure (Maybe Location) FailureReason - deriving (Show, Typeable) + deriving Show data FailureReason = NoReason | Reason String + | ColorizedReason String | ExpectedButGot (Maybe String) String String | Error (Maybe String) SomeException - deriving (Show, Typeable) + deriving Show 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` e `seq` () + Error m e -> m `deepseq` show e `deepseq` () instance Exception ResultStatus -safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result -safeEvaluateExample example params around progress = safeEvaluate $ forceResult <$> evaluateExample example params around progress - where - forceResult :: Result -> Result - forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r +forceResult :: Result -> Result +forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r - forceResultStatus :: ResultStatus -> ResultStatus - forceResultStatus r = case r of - Success -> r - Pending _ m -> m `deepseq` r - Failure _ m -> m `deepseq` r +forceResultStatus :: ResultStatus -> ResultStatus +forceResultStatus r = case r of + Success -> r + Pending _ m -> m `deepseq` r + Failure _ m -> m `deepseq` r +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 $ action - return $ case r of - Left e | Just result <- fromException e -> Result "" result - Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit - Left e -> Result "" $ Failure Nothing $ Error Nothing e - Right result -> result + 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 = () +#endif evaluateExample e = evaluateExample (\() -> e) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Result) where type Arg (a -> Result) = a - evaluateExample example _params action _callback = do - ref <- newIORef (Result "" Success) - action (evaluate . example >=> writeIORef ref) - readIORef ref +#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) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Bool) where type Arg (a -> Bool) = a - evaluateExample p _params action _callback = do - ref <- newIORef (Result "" Success) - action (evaluate . example >=> writeIORef ref) - readIORef ref +#else +instance Example (() -> Bool) where +#endif + evaluateExample p _params hook _callback = do + liftHook (Result "" Success) hook (evaluate . example) where example a | p a = Result "" Success | otherwise = Result "" $ Failure Nothing NoReason instance Example Expectation where +#ifdef ENABLE_SPEC_HOOK_ARGS type Arg Expectation = () +#endif evaluateExample e = evaluateExample (\() -> e) hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus @@ -155,60 +254,20 @@ where location = case mLoc of Nothing -> Nothing - Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) + Just loc -> Just $ toLocation loc where addPre :: String -> String addPre xs = case pre of Just x -> x ++ "\n" ++ xs Nothing -> xs +toLocation :: SrcLoc -> Location +toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) + +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Expectation) where type Arg (a -> Expectation) = a - evaluateExample e _ action _ = action e >> return (Result "" Success) - -instance Example QC.Property where - type Arg QC.Property = () - evaluateExample e = evaluateExample (\() -> e) - -instance Example (a -> QC.Property) where - type Arg (a -> QC.Property) = a - evaluateExample p c action progressCallback = do - r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) - return $ fromQuickCheckResult r - where - qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ - \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) - -fromQuickCheckResult :: QC.Result -> Result -fromQuickCheckResult r = case parseQuickCheckResult r of - QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) - QuickCheckResult _ info QuickCheckSuccess -> Result info 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 +#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 --- a/src/Test/Hspec/Core/Example/Location.hs +++ b/src/Test/Hspec/Core/Example/Location.hs @@ -1,24 +1,34 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} module Test.Hspec.Core.Example.Location ( Location(..) , extractLocation --- for testing +#ifdef TEST +, parseBacktraces , parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan + +, workaroundForIssue19236 +#endif ) where import Prelude () import Test.Hspec.Core.Compat -import Control.Exception -import Data.List import Data.Char -import Data.Maybe 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 @@ -27,14 +37,36 @@ } 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 @@ -46,17 +78,17 @@ Nothing -> Nothing parseAssertionFailed :: String -> Maybe Location -parseAssertionFailed loc = parseCallStack loc <|> parseSourceSpan loc +parseAssertionFailed loc = parseCallStack (lines loc) <|> parseSourceSpan loc locationFromErrorCall :: SomeException -> Maybe Location locationFromErrorCall e = case fromException e of -#if MIN_VERSION_base(4,9,0) - Just (ErrorCallWithLocation err loc) -> - parseCallStack loc <|> +#if MIN_VERSION_base(4,21,0) + Just (ErrorCall _) -> Nothing #else - Just (ErrorCall err) -> -#endif + Just (ErrorCallWithLocation err loc) -> + parseCallStack (lines loc) <|> fromPatternMatchFailureInDoExpression err +#endif Nothing -> Nothing locationFromPatternMatchFail :: SomeException -> Maybe Location @@ -77,10 +109,14 @@ 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 (lines input) of +parseCallStack :: [String] -> Maybe Location +parseCallStack input = case reverse input of [] -> Nothing line : _ -> findLocation line where @@ -93,11 +129,11 @@ parseLocation :: String -> Maybe Location parseLocation input = case fmap breakColon (breakColon input) of - (file, (line, column)) -> Location file <$> readMaybe line <*> readMaybe column + (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of - (file, xs) -> (uncurry $ Location file) <$> (tuple <|> colonSeparated) + (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated) where lineAndColumn :: String lineAndColumn = takeWhile (/= '-') xs @@ -111,3 +147,15 @@ 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 --- a/src/Test/Hspec/Core/FailureReport.hs +++ b/src/Test/Hspec/Core/FailureReport.hs @@ -5,17 +5,28 @@ , 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 -#ifndef __GHCJS__ -import System.SetEnv +#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.Options (Config(..)) +import Test.Hspec.Core.Config.Definition (Config(..)) data FailureReport = FailureReport { failureReportSeed :: Integer @@ -29,20 +40,15 @@ writeFailureReport config report = case configFailureReport config of Just file -> writeFile file (show report) Nothing -> do -#ifdef __GHCJS__ - -- 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. - return () -#else +#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) diff --git a/src/Test/Hspec/Core/Format.hs b/src/Test/Hspec/Core/Format.hs --- a/src/Test/Hspec/Core/Format.hs +++ b/src/Test/Hspec/Core/Format.hs @@ -1,6 +1,18 @@ {-# LANGUAGE RankNTypes #-} -module Test.Hspec.Core.Format ( - Format(..) +{-# 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(..) @@ -8,13 +20,23 @@ , Item(..) , Result(..) , FailureReason(..) +, monadic ) where -import Test.Hspec.Core.Spec (Progress, Location(..)) -import Test.Hspec.Core.Example (FailureReason(..)) -import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Clock +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 @@ -24,15 +46,102 @@ data Result = Success - | Pending (Maybe String) - | Failure FailureReason + | Pending (Maybe Location) (Maybe String) + | Failure (Maybe Location) FailureReason deriving Show -data Format m = Format { - formatRun :: forall a. m a -> IO a -, formatGroupStarted :: Path -> m () -, formatGroupDone :: Path -> m () -, formatProgress :: Path -> Progress -> m () -, formatItemStarted :: Path -> m () -, formatItemDone :: Path -> Item -> m () +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,314 +1,5 @@ -{-# LANGUAGE CPP #-} --- | --- Stability: experimental --- --- This module contains formatters that can be used with --- `Test.Hspec.Core.Runner.hspecWith`. -module Test.Hspec.Core.Formatters ( - --- * 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 - --- ** 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 hiding (First) - -import Data.Maybe -import Test.Hspec.Core.Util -import Test.Hspec.Core.Clock -import Test.Hspec.Core.Spec (Location(..)) -import Text.Printf -import Control.Monad.IO.Class -import Control.Exception - --- 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.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.Formatters.Diff - -silent :: Formatter -silent = Formatter { - headerFormatter = return () -, exampleGroupStarted = \_ _ -> return () -, exampleGroupDone = return () -, exampleStarted = \_ -> return () -, exampleProgress = \_ _ -> return () -, exampleSucceeded = \ _ _ -> return () -, exampleFailed = \_ _ _ -> return () -, examplePending = \_ _ _ -> return () -, failedFormatter = return () -, footerFormatter = return () -} - -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 "" - -#if __GLASGOW_HASKELL__ == 800 - withFailColor $ do - writeLine "WARNING:" - writeLine " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - writeLine " Source locations may not work as expected." - writeLine "" - writeLine " Please consider upgrading GHC!" - writeLine "" -#endif - - 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 -> return () - 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 $ \ chunk -> case chunk of - Both a _ -> indented write a - First a -> indented extra a - Second _ -> return () - writeLine "" - - withFailColor $ write (indentation ++ " but got: ") - forM_ chunks $ \ chunk -> case chunk of - Both a _ -> indented write a - First _ -> return () - 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 +{-# 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 --- a/src/Test/Hspec/Core/Formatters/Diff.hs +++ b/src/Test/Hspec/Core/Formatters/Diff.hs @@ -1,8 +1,15 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff ( Diff (..) , diff + +, LineDiff(..) +, lineDiff + +, splitLines + #ifdef TEST , partition , breakList @@ -13,15 +20,130 @@ import Test.Hspec.Core.Compat import Data.Char -import Data.List (stripPrefix) -import Data.Algorithm.Diff +import qualified Data.Algorithm.Diff as Diff -diff :: String -> String -> [Diff String] -diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual) +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 @@ -38,7 +160,7 @@ | otherwise = (x :) splitEscape :: String -> Maybe (String, String) -splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes) +splitEscape xs = splitNumericEscape xs <|> msum (map split escapes) where split :: String -> Maybe (String, String) split escape = (,) escape <$> stripPrefix escape xs diff --git a/src/Test/Hspec/Core/Formatters/Free.hs b/src/Test/Hspec/Core/Formatters/Free.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Formatters/Free.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Test.Hspec.Core.Formatters.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/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,16 +1,57 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal ( - FormatM -, FormatConfig(..) -, runFormatM -, interpret -, increaseSuccessCount -, increasePendingCount -, addFailMessage -, finally_ + 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 + #ifdef TEST -, overwriteWith +, runFormatM +, splitLines #endif ) where @@ -18,87 +59,138 @@ import Test.Hspec.Core.Compat import qualified System.IO as IO -import System.IO (Handle) -import Control.Exception (AsyncException(..), bracket_, try, throwIO) -import System.Console.ANSI -import Control.Monad.Trans.State hiding (state, 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 qualified Test.Hspec.Core.Formatters.Monad as M -import Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) import Test.Hspec.Core.Format import Test.Hspec.Core.Clock -formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM -formatterToFormat formatter config = Format { - formatRun = \action -> runFormatM config $ do - interpret (M.headerFormatter formatter) - a <- action `finally_` interpret (M.failedFormatter formatter) - interpret (M.footerFormatter formatter) - return a -, formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name -, formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter) +data Formatter = Formatter { +-- | evaluated before a test run + formatterStarted :: FormatM () -, formatProgress = \ path progress -> do - interpret $ M.exampleProgress formatter path progress +-- | evaluated before each spec group +, formatterGroupStarted :: Path -> FormatM () -, formatItemStarted = \ path -> do - interpret $ M.exampleStarted formatter path +-- | evaluated after each spec group +, formatterGroupDone :: Path -> FormatM () -, formatItemDone = \ path (Item loc _duration info result) -> do - clearTransientOutput - case result of - Success -> do - increaseSuccessCount - interpret $ M.exampleSucceeded formatter path info - Pending reason -> do - increasePendingCount - interpret $ M.examplePending formatter path info reason - Failure err -> do - addFailMessage loc path err - interpret $ M.exampleFailed formatter path info err +-- | 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 () } -interpret :: M.FormatM a -> FormatM a -interpret = interpretWith Environment { - environmentGetSuccessCount = getSuccessCount -, environmentGetPendingCount = getPendingCount -, environmentGetFailMessages = getFailMessages -, environmentUsedSeed = usedSeed -, environmentGetCPUTime = getCPUTime -, environmentGetRealTime = getRealTime -, environmentWrite = write -, environmentWriteTransient = writeTransient -, environmentWithFailColor = withFailColor -, environmentWithSuccessColor = withSuccessColor -, environmentWithPendingColor = withPendingColor -, environmentWithInfoColor = withInfoColor -, environmentUseDiff = gets (formatConfigUseDiff . stateConfig) -, environmentExtraChunk = extraChunk -, environmentMissingChunk = missingChunk -, environmentLiftIO = liftIO +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) - -data FormatConfig = FormatConfig { - formatConfigHandle :: Handle -, formatConfigUseColor :: Bool -, formatConfigUseDiff :: Bool -, formatConfigHtmlOutput :: Bool -, formatConfigPrintCpuTime :: Bool -, formatConfigUsedSeed :: Integer -} deriving (Eq, Show) + ask >>= liftIO . (`modifyIORef'` f) data FormatterState = FormatterState { stateSuccessCount :: !Int @@ -106,32 +198,49 @@ , stateFailMessages :: [FailureRecord] , stateCpuStartTime :: Maybe Integer , stateStartTime :: Seconds -, stateTransientOutput :: String -, stateConfig :: FormatConfig +, stateConfig :: FormatConfig +, stateColor :: Maybe SGR } -getConfig :: (FormatConfig -> a) -> FormatM a -getConfig f = gets (f . stateConfig) +-- | @since 2.11.5 +getConfig :: FormatM FormatConfig +getConfig = gets stateConfig -getHandle :: FormatM Handle -getHandle = getConfig formatConfigHandle +-- | @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 = getConfig formatConfigUsedSeed +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 :: FormatConfig -> FormatM a -> IO a -runFormatM config (FormatM action) = do +runFormatM config (FormatM action) = withLineBuffering $ do time <- getMonotonicTime - cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing - st <- newIORef (FormatterState 0 0 [] cpuTime time "" config) - evalStateT action st + 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 {stateSuccessCount = succ $ stateSuccessCount s} @@ -148,44 +257,57 @@ getPendingCount :: FormatM Int getPendingCount = gets statePendingCount --- | Append to the list of accumulated failure messages. -addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM () -addFailMessage loc p m = modify $ \s -> s {stateFailMessages = FailureRecord loc p m : stateFailMessages s} - -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages -overwriteWith :: String -> String -> String -overwriteWith old new - | n == 0 = new - | otherwise = '\r' : new ++ replicate (n - length new) ' ' - where - n = length old +-- | Get the number of spec items that will have been encountered when this run +-- completes (if it is not terminated early). +-- +-- @since 2.9.0 +getExpectedTotalCount :: FormatM Int +getExpectedTotalCount = getConfigValue formatConfigExpectedTotalCount writeTransient :: String -> FormatM () writeTransient new = do - useColor <- getConfig formatConfigUseColor - when (useColor) $ do - old <- gets stateTransientOutput - write $ old `overwriteWith` new - modify $ \ state -> state {stateTransientOutput = new} - h <- getHandle - liftIO $ IO.hFlush h + reportProgress <- getConfigValue formatConfigReportProgress + when reportProgress . liftIO $ do + bracket_ disableLineWrapping enableLineWrapping $ writePlain new + IO.hFlush stdout + clearLine + where + disableLineWrapping :: IO () + disableLineWrapping = writePlain "\ESC[?7l" -clearTransientOutput :: FormatM () -clearTransientOutput = do - n <- length <$> gets stateTransientOutput - unless (n == 0) $ do - write ("\r" ++ replicate n ' ' ++ "\r") - modify $ \ state -> state {stateTransientOutput = ""} + enableLineWrapping :: IO () + enableLineWrapping = writePlain "\ESC[?7h" + clearLine :: IO () + clearLine = writePlain "\r\ESC[K" + -- | Append some output to the report. write :: String -> FormatM () -write s = do - h <- getHandle - liftIO $ IO.hPutStr h s +write = mapM_ writeChunk . splitLines +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,34 +331,28 @@ -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do - produceHTML <- getConfig formatConfigHtmlOutput + 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 <- getConfig formatConfigUseColor - h <- getHandle - - FormatM . StateT $ \st -> do - bracket_ - - -- set color - (when useColor $ hSetSGR h [color]) - - -- reset colors - (when useColor $ hSetSGR h [Reset]) +withColor_ color action = do + oldColor <- gets stateColor + setColor (Just color) *> action <* setColor oldColor - -- run action - (runStateT action st) +setColor :: Maybe SGR -> FormatM () +setColor color = do + useColor <- getConfigValue formatConfigUseColor + when useColor $ do + modify (\ state -> state { stateColor = color }) -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do - useDiff <- getConfig formatConfigUseDiff - case useDiff of + diff <- getConfigValue formatConfigUseDiff + case diff of True -> extra s False -> write s where @@ -246,8 +362,8 @@ -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do - useDiff <- getConfig formatConfigUseDiff - case useDiff of + diff <- getConfigValue formatConfigUseDiff + case diff of True -> missing s False -> write s where @@ -255,35 +371,24 @@ missing = diffColorize Green "hspec-success" diffColorize :: Color -> String -> String-> FormatM () -diffColorize color cls s = withColor (SetColor layer Dull color) cls $ do - write s +diffColorize color cls s = withColor (SetColor layer Dull color) cls $ case s of + "" -> write eraseInLine + _ -> write s where + eraseInLine :: String + eraseInLine = "\ESC[K" + + layer :: ConsoleLayer layer | all isSpace s = Background | otherwise = Foreground --- | --- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is --- run even when a `UserInterrupt` occurs during @actionA@. -finally_ :: FormatM a -> FormatM () -> FormatM a -finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do - r <- try (runStateT actionA st) - case r of - Left e -> do - when (e == UserInterrupt) $ - runStateT actionB st >> return () - throwIO e - Right (a, st_) -> do - runStateT actionB st_ >>= return . replaceValue a - where - replaceValue a (_, st) = (a, st) - -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do t1 <- liftIO CPUTime.getCPUTime mt0 <- gets stateCpuStartTime - return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) + return $ toSeconds <$> ((t1 -) <$> mt0) where toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer))) diff --git a/src/Test/Hspec/Core/Formatters/Monad.hs b/src/Test/Hspec/Core/Formatters/Monad.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Formatters/Monad.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ExistentialQuantification #-} -module Test.Hspec.Core.Formatters.Monad ( - Formatter (..) -, FailureReason (..) -, FormatM - -, getSuccessCount -, getPendingCount -, getFailCount -, getTotalCount - -, FailureRecord (..) -, getFailMessages -, usedSeed - -, 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.Free -import Test.Hspec.Core.Example (FailureReason(..)) -import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec (Progress, Location) -import Test.Hspec.Core.Clock - -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 `failuresFormatter` -, 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) - | 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) - 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 -, 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 - 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) - --- | 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/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,7 +1,16 @@ +{-# 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 @@ -17,14 +26,19 @@ , aroundAll , aroundAll_ , aroundAllWith + +, mapSubject +, ignoreSubject + +#ifdef TEST +, decompose +#endif ) where import Prelude () import Test.Hspec.Core.Compat -import Control.Exception (SomeException, finally, throwIO, try, catch) -import Control.Concurrent.MVar -import Control.Concurrent.Async +import Control.Concurrent import Test.Hspec.Core.Example import Test.Hspec.Core.Tree @@ -43,19 +57,19 @@ 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 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 Empty) before_ (memoize mvar action) spec -- | Run a custom action with an argument before the first spec item. -beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b +beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do mvar <- runIO (newMVar Empty) beforeWith (memoize mvar . action) spec @@ -65,14 +79,14 @@ | Memoized a | Failed SomeException -memoize :: MVar (Memoized a) -> IO a -> IO a +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 beforeAll-hook (see previous failure)")) + 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. @@ -83,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 @@ -101,60 +125,79 @@ -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b -aroundWith action = mapSpecItem action (modifyAroundAction action) +aroundWith = mapSpecItem_ . modifyHook -modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b -modifyAroundAction action item@Item{itemExample = e} = - item{ itemExample = \params aroundAction -> e params (aroundAction . action) } +modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b +modifyHook action Item{..} = Item { + itemExample = \ params hook -> itemExample params (hook . action) + , .. + } -- | Wrap an action around the given spec. -aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll action = aroundAllWith $ \ e () -> action e -- | Wrap an action around the given spec. -aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a +aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a aroundAll_ action spec = do - allSpecItemsDone <- runIO newEmptyMVar - workerRef <- runIO newEmptyMVar - let - acquire :: IO () - acquire = do - resource <- newEmptyMVar - worker <- async $ do - action $ do - signal resource - waitFor allSpecItemsDone - putMVar workerRef worker - unwrapExceptionsFromLinkedThread $ do - link worker - waitFor resource - release :: IO () - release = signal allSpecItemsDone >> takeMVar workerRef >>= wait - beforeAll_ acquire $ afterAll_ release spec + (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. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundAllWith action spec = do - allSpecItemsDone <- runIO newEmptyMVar - workerRef <- runIO newEmptyMVar + (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 - resource <- newEmptyMVar - worker <- async $ do - flip action b $ \ a -> do - putMVar resource a - waitFor allSpecItemsDone - putMVar workerRef worker - unwrapExceptionsFromLinkedThread $ do - link worker - takeMVar resource + 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 = signal allSpecItemsDone >> takeMVar workerRef >>= wait - beforeAllWith acquire $ afterAll_ release spec + 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 -unwrapExceptionsFromLinkedThread :: IO a -> IO a -unwrapExceptionsFromLinkedThread = (`catch` \ (ExceptionInLinkedThread _ e) -> throwIO e) + return (acquire, release) type BinarySemaphore = MVar () @@ -163,3 +206,15 @@ 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,15 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | Stability: provisional module Test.Hspec.Core.QuickCheck ( - modifyArgs -, modifyMaxSuccess + 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 @@ -44,3 +59,57 @@ 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,148 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Test.Hspec.Core.QuickCheckUtil where - -import Prelude () -import Test.Hspec.Core.Compat - -import Control.Exception -import Data.List -import Data.Maybe -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 - -aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property -aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n - -aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop -aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) - -aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result -aroundRose action r = ioRose $ do - ref <- newIORef (return QCP.succeeded) - action $ \a -> reduceRose (r a) >>= writeIORef ref - readIORef ref - -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 - , computeSize = undefined - , 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/Runner.hs b/src/Test/Hspec/Core/Runner.hs --- a/src/Test/Hspec/Core/Runner.hs +++ b/src/Test/Hspec/Core/Runner.hs @@ -1,64 +1,153 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Stability: provisional module Test.Hspec.Core.Runner ( --- * Running a spec +-- * Simple interface hspec -, runSpec +, hspecWith +, hspecResult +, hspecWithResult +-- ** 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 --- * Summary -, Summary (..) -, isSuccess -, evaluateSummary - -- * Legacy --- | The following primitives are deprecated. Use `runSpec` instead. -, hspecWith -, hspecResult -, hspecWithResult +, runSpec +-- * Re-exports +, Spec +, SpecWith + #ifdef TEST +, UseColor(..) +, ProgressReporting(..) , rerunAll , specToEvalForest +, colorOutputSupported +, unicodeOutputSupported #endif ) where import Prelude () -import Test.Hspec.Core.Compat +import Test.Hspec.Core.Compat hiding (unicodeOutputSupported) +import qualified Test.Hspec.Core.Compat as Compat -import Data.Maybe +import Data.List.NonEmpty (nonEmpty) import System.IO import System.Environment (getArgs, withArgs) -import System.Exit -import qualified Control.Exception as E +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 Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec +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.Formatters -import Test.Hspec.Core.Formatters.Internal +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.QuickCheckUtil +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 -applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree] +-- | +-- Make a formatter available for use with @--format@. +-- +-- @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 } + +-- | +-- 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 } + +applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p where include :: Path -> Bool @@ -72,61 +161,69 @@ where path = (groups, evalItemDescription item) -applyDryRun :: Config -> [EvalTree] -> [EvalTree] +applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c | configDryRun c = bimapForest removeCleanup markSuccess | otherwise = id where removeCleanup :: IO () -> IO () - removeCleanup _ = return () + removeCleanup _ = pass markSuccess :: EvalItem -> EvalItem - markSuccess item = item {evalItemAction = \ _ -> return $ Result "" Success} + markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)} -- | 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 desired. Use `runSpec` if you need more control over these --- aspects. +-- is not always desirable. Use `evalSpec` and `runSpecForest` if you need +-- more control over these aspects. hspec :: Spec -> IO () -hspec spec = - getArgs - >>= readConfig defaultConfig - >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec - >>= evaluateSummary +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 config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary - --- | `True` if the given `Summary` indicates that there were no --- failures, `False` otherwise. -isSuccess :: Summary -> Bool -isSuccess summary = summaryFailures summary == 0 +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 -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary -hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec +hspecResult = hspecWithResult defaultConfig -- | Run given spec with custom options and returns a summary of the test run. -- @@ -134,123 +231,235 @@ -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary -hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec +hspecWithResult config = fmap toSummary . hspecWithSpecResult config +hspecWithSpecResult :: Config -> Spec -> IO SpecResult +hspecWithSpecResult defaults spec = do + (c, forest) <- evalSpec defaults spec + config <- getArgs >>= readConfig c + oldFailureReport <- readFailureReportOnRerun config + + let + normalMode :: IO SpecResult + normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config + + rerunAllMode :: IO SpecResult + rerunAllMode = do + result <- normalMode + if rerunAll config oldFailureReport result then + hspecWithSpecResult defaults spec + else + return result + + -- 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 + -- | --- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in --- terms of @runSpec@: +-- /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 + +-- | +-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is +-- defined in terms of @runSpecForest@: -- -- @ --- hspec spec = +-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> -- `getArgs` --- >>= `readConfig` `defaultConfig` --- >>= `withArgs` [] . runSpec spec --- >>= `evaluateSummary` +-- >>= `readConfig` config +-- >>= `withArgs` [] . runSpecForest spec +-- >>= `evaluateResult` -- @ -runSpec :: Spec -> Config -> IO Summary -runSpec spec c_ = do - oldFailureReport <- readFailureReportOnRerun c_ +-- +-- @since 2.10.0 +runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult +runSpecForest spec config = do + oldFailureReport <- readFailureReportOnRerun config + runSpecForest_ oldFailureReport spec config - c <- ensureSeed (applyFailureReport oldFailureReport c_) +mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] +mapItem f = map (fmap f) - if configRerunAllOnSuccess c - -- 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 - then rerunAllMode c oldFailureReport - else normalMode c +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 - normalMode c = runSpec_ c spec - rerunAllMode c oldFailureReport = do - summary <- runSpec_ c spec - if rerunAll c oldFailureReport summary - then runSpec spec c_ - else return summary + addDefaultDescription :: Item a -> Item a + addDefaultDescription item + | null (itemRequirement item) = item { itemRequirement = defaultRequirement } + | otherwise = item + where + defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item) -failFocused :: Item a -> Item a -failFocused item = item {itemExample = example} +failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a] +failItemsWithEmptyDescription config + | configFailOnEmptyDescription config = mapItemIf condition (failWith failure) + | otherwise = id where - failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused") - example - | itemIsFocused item = \ params hook p -> do - Result info status <- itemExample item params hook p - return $ Result info $ case status of - Success -> failure - Pending _ _ -> failure - Failure{} -> status - | otherwise = itemExample item + condition = null . itemRequirement + failure = "item has no description; failing due to --fail-on=empty-description" -failFocusedItems :: Config -> Spec -> Spec -failFocusedItems config spec - | configFailOnFocused config = mapSpecItem_ failFocused spec - | otherwise = spec +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" -focusSpec :: Config -> Spec -> Spec +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 = focus spec + | otherwise = focusForest spec -runSpec_ :: Config -> Spec -> IO Summary -runSpec_ config spec = do - filteredSpec <- specToEvalForest config spec - withHandle config $ \h -> do - let formatter = fromMaybe specdoc (configFormatter config) - seed = (fromJust . configQuickCheckSeed) config - qcArgs = configQuickCheckArgs config +runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult +runSpecForest_ oldFailureReport spec c_ = do - concurrentJobs <- case configConcurrentJobs config of - Nothing -> getDefaultConcurrentJobs - Just n -> return n + (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_) - useColor <- doesUseColor h config + colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) + outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout - results <- withHiddenCursor useColor h $ do - let - formatConfig = FormatConfig { - formatConfigHandle = h - , formatConfigUseColor = useColor - , formatConfigUseDiff = configDiff config - , formatConfigHtmlOutput = configHtmlOutput config - , formatConfigPrintCpuTime = configPrintCpuTime config - , formatConfigUsedSeed = seed - } - evalConfig = EvalConfig { - evalConfigFormat = formatterToFormat formatter formatConfig - , evalConfigConcurrentJobs = concurrentJobs - , evalConfigFastFail = configFastFail config - } - runFormatter evalConfig filteredSpec + let + filteredSpec = specToEvalForest seed config spec + qcArgs = configQuickCheckArgs config + !numberOfItems = countEvalItems filteredSpec - let failures = filter resultItemIsFailure results + when (configFailOnEmpty config && numberOfItems == 0) $ do + when (countSpecItems spec /= 0) $ do + die "all spec items have been filtered; failing due to --fail-on=empty" - dumpFailureReport config seed qcArgs (map fst failures) + concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config - return Summary { - summaryExamples = length results - , summaryFailures = length failures - } + 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 + } -specToEvalForest :: Config -> Spec -> IO [EvalTree] -specToEvalForest config spec = do + 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 - seed = (fromJust . configQuickCheckSeed) config - focusedSpec = focusSpec config (failFocusedItems config spec) + 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 - randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec -toEvalForest :: Params -> [SpecTree ()] -> [EvalTree] -toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused +pruneForest :: [Tree c a] -> [Eval.Tree c a] +pruneForest = mapMaybe pruneTree + +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 + +type EvalItemTree = Tree (IO ()) EvalItem + +toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree] +toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused + where toEvalItem :: Item () -> EvalItem - toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit) + 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 + } withUnit :: ActionWith () -> IO () withUnit action = action () @@ -268,49 +477,75 @@ doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a doNotLeakCommandLineArgumentsToExamples = withArgs [] -withHiddenCursor :: Bool -> Handle -> IO a -> IO a -withHiddenCursor useColor h - | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) - | otherwise = id +withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a +withHiddenCursor progress h = case progress of + ProgressReportingDisabled -> id + ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h) -doesUseColor :: Handle -> Config -> IO Bool -doesUseColor h c = case configColorMode c of - ColorAuto -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb) - ColorNever -> return False - ColorAlways -> return True +data UseColor = ColorDisabled | ColorEnabled ProgressReporting + deriving (Eq, Show) -withHandle :: Config -> (Handle -> IO a) -> IO a -withHandle c action = case configOutputFile c of - Left h -> action h - Right path -> withFile path WriteMode action +data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled + deriving (Eq, Show) -rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool -rerunAll _ Nothing _ = False -rerunAll config (Just oldFailureReport) summary = - configRerunAllOnSuccess config - && configRerun config - && isSuccess summary - && (not . null) (failureReportPaths oldFailureReport) +shouldUseColor :: UseColor -> Bool +shouldUseColor c = case c of + ColorDisabled -> False + ColorEnabled _ -> True -isDumb :: IO Bool -isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" +progressReporting :: UseColor -> ProgressReporting +progressReporting c = case c of + ColorDisabled -> ProgressReportingDisabled + ColorEnabled r -> r --- | Summary of a test run. -data Summary = Summary { - summaryExamples :: Int -, summaryFailures :: Int -} deriving (Eq, Show) +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 -instance Monoid Summary where - mempty = Summary 0 0 -#if !MIN_VERSION_base(4,11,0) - (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) -#else -instance Semigroup Summary where - (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) -#endif + 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,217 +1,279 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} - -#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) --- Control.Concurrent.QSem is deprecated in base-4.6.0.* -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif - +{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Runner.Eval ( EvalConfig(..) +, ColorMode(..) , EvalTree +, Tree(..) , EvalItem(..) +, Concurrency(..) , runFormatter -, resultItemIsFailure #ifdef TEST -, runSequentially +, mergeResults #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (Monad) -import qualified Test.Hspec.Core.Compat as M -import qualified Control.Exception as E -import Control.Concurrent -import Control.Concurrent.Async hiding (cancel) - import Control.Monad.IO.Class (liftIO) -import qualified Control.Monad.IO.Class as M - -import Control.Monad.Trans.State hiding (State, state) +import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) +import Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import Test.Hspec.Core.Timer -import Test.Hspec.Core.Format (Format(..)) +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 (safeEvaluate) +import Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) --- 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) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) -data EvalConfig m = EvalConfig { - evalConfigFormat :: Format m +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 -, evalConfigFastFail :: Bool +, evalConfigFailFast :: Bool +, evalConfigColorMode :: ColorMode } -data State m = State { - stateConfig :: EvalConfig m -, stateResults :: [(Path, Format.Item)] +data ColorMode = ColorDisabled | ColorEnabled + +data Env = Env { + envConfig :: EvalConfig +, envAbort :: IORef Bool +, envResults :: IORef [(Path, Format.Item)] } -type EvalM m = StateT (State m) m +formatEvent :: Format.Event -> EvalM () +formatEvent event = do + format <- asks $ evalConfigFormat . envConfig + liftIO $ format event -addResult :: Monad m => Path -> Format.Item -> EvalM m () -addResult path item = modify $ \ state -> state {stateResults = (path, item) : stateResults state} +type EvalM = ReaderT Env IO -getFormat :: Monad m => (Format m -> a) -> EvalM m a -getFormat format = gets (format . evalConfigFormat . stateConfig) +abort :: EvalM () +abort = do + ref <- asks envAbort + liftIO $ writeIORef ref True -reportItem :: Monad m => Path -> Maybe Location -> EvalM m (Seconds, Result) -> EvalM m () +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 :: Monad m => Path -> EvalM m () -reportItemStarted path = do - format <- getFormat formatItemStarted - lift (format path) +reportItemStarted :: Path -> EvalM () +reportItemStarted = formatEvent . Format.ItemStarted -reportItemDone :: Monad m => Path -> Format.Item -> EvalM m () +reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do addResult path item - format <- getFormat formatItemDone - lift (format path item) + formatEvent $ Format.ItemDone path item -failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item -failureItem loc duration info err = Format.Item loc duration info (Format.Failure err) +isFailure :: Result -> Bool +isFailure r = case resultStatus r of + Success{} -> False + Pending{} -> False + Failure{} -> True -reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m () +reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do + mode <- asks (evalConfigColorMode . envConfig) case result of - Result info status -> case status of - Success -> reportItemDone path (Format.Item loc duration info Format.Success) - Pending loc_ reason -> reportItemDone path (Format.Item (loc_ <|> loc) duration info $ Format.Pending reason) - Failure loc_ err@(Error _ e) -> reportItemDone path (failureItem (loc_ <|> extractLocation e <|> loc) duration info err) - Failure loc_ err -> reportItemDone path (failureItem (loc_ <|> loc) duration info err) + 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 :: Monad m => Path -> EvalM m () -groupStarted path = do - format <- getFormat formatGroupStarted - lift $ format path +groupStarted :: Path -> EvalM () +groupStarted = formatEvent . Format.GroupStarted -groupDone :: Monad m => Path -> EvalM m () -groupDone path = do - format <- getFormat formatGroupDone - lift $ format path +groupDone :: Path -> EvalM () +groupDone = formatEvent . Format.GroupDone data EvalItem = EvalItem { evalItemDescription :: String , evalItemLocation :: Maybe Location -, evalItemParallelize :: Bool -, evalItemAction :: ProgressCallback -> IO Result +, evalItemConcurrency :: Concurrency +, evalItemAction :: ProgressCallback -> IO (Seconds, Result) } type EvalTree = Tree (IO ()) EvalItem -runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m) -runEvalM config action = execStateT action (State config []) - -- | Evaluate all examples of a given spec and produce a report. -runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)]) +runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] runFormatter config specs = do - let - start = parallelizeTree (evalConfigConcurrentJobs config) specs - cancel = cancelMany . concatMap toList . map (fmap fst) - E.bracket start cancel $ \ runningSpecs -> do + withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do withTimer 0.05 $ \ timer -> do - state <- formatRun format $ do - runEvalM config $ - run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs - return (reverse $ stateResults state) + 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 + mkEnv :: IO Env + mkEnv = Env config <$> newIORef False <*> newIORef [] + + format :: Format format = evalConfigFormat config - reportProgress :: IO Bool -> Path -> Progress -> m () + reportProgress :: IO Bool -> Path -> Progress -> IO () reportProgress timer path progress = do - r <- liftIO timer - when r (formatProgress format path progress) - -cancelMany :: [Async a] -> IO () -cancelMany asyncs = do - mapM_ (killThread . asyncThreadId) asyncs - mapM_ waitCatch asyncs + r <- timer + when r $ do + format (Format.Progress path progress) data Item a = Item { - _itemDescription :: String -, _itemLocation :: Maybe Location -, _itemAction :: a + itemDescription :: String +, itemLocation :: Maybe Location +, itemAction :: a } deriving Functor -type Job m p a = (p -> m ()) -> m a - type RunningItem m = Item (Path -> m (Seconds, Result)) -type RunningTree m = Tree (IO ()) (RunningItem m) +type RunningTree c m = Tree c (RunningItem m) -type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result))) +type RunningItem_ m = Item (Job m Progress (Seconds, Result)) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -data Semaphore = Semaphore { - semaphoreWait :: IO () -, semaphoreSignal :: IO () -} +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 -parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m] -parallelizeTree n specs = do - sem <- newQSem n - mapM (traverse $ parallelizeItem sem) specs +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 -parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m) -parallelizeItem sem EvalItem{..} = do - (asyncAction, evalAction) <- parallelize (Semaphore (waitQSem sem) (signalQSem sem)) evalItemParallelize (interruptible . evalItemAction) - return (asyncAction, Item evalItemDescription evalItemLocation evalAction) +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 + addCleanupOn p = addCleanupToItem p loc cleanup -parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) -parallelize sem isParallelizable - | isParallelizable = runParallel sem - | otherwise = runSequentially +forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b) +forEachLeaf f = fmap (fmap f) -runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a)) -runSequentially action = do - mvar <- newEmptyMVar - (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) (return ())) action - return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial) +forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a) +forLastLeaf p = go + where + go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse -data Parallel p a = Partial p | Return a + goNode node = case node of + Node description xs -> Node description (go xs) + NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs) + Leaf item -> Leaf (p item) -runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) -runParallel Semaphore{..} action = do - mvar <- newEmptyMVar - asyncAction <- async $ E.bracket_ semaphoreWait semaphoreSignal (worker mvar) - return (asyncAction, eval mvar) +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 - worker mvar = do - let partialCallback = replaceMVar mvar . Partial - result <- measure $ action partialCallback - replaceMVar mvar (Return result) + hookLoc = snd <$> mCallSite + hookFailed = case mCallSite of + Just (name, _) -> Just $ "in " ++ name ++ "-hook:" + Nothing -> Nothing - eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a) - eval mvar notifyPartial = do - r <- liftIO (takeMVar mvar) - case r of - Partial p -> do - notifyPartial p - eval mvar notifyPartial - Return result -> return result +enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m] +enqueueItems queue = mapM (traverse $ enqueueItem queue) -replaceMVar :: MVar a -> a -> IO () -replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p +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 -run :: forall m. MonadIO m => [RunningTree m] -> EvalM m () -run specs = do - fastFail <- gets (evalConfigFastFail . stateConfig) - sequenceActions fastFail (concatMap foldSpec specs) +eval :: [RunningTree () EvalM] -> EvalM () +eval specs = do + sequenceActions (concatMap foldSpec specs) where - foldSpec :: RunningTree m -> [EvalM m ()] + foldSpec :: RunningTree () EvalM -> [EvalM ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone @@ -219,18 +281,12 @@ , onLeafe = evalItem } - runCleanup :: [String] -> IO () -> EvalM m () - runCleanup groups action = do - r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success)) - case r of - (_, Result "" Success) -> return () - _ -> reportItem path Nothing (return r) - where - path = (groups, "afterAll-hook") + runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM () + runCleanup _loc _groups = return - evalItem :: [String] -> RunningItem m -> EvalM m () + evalItem :: [String] -> RunningItem EvalM -> EvalM () evalItem groups (Item requirement loc action) = do - reportItem path loc $ lift (action path) + reportItem path loc $ action path where path :: Path path = (groups, requirement) @@ -238,7 +294,7 @@ data FoldTree c a r = FoldTree { onGroupStarted :: Path -> r , onGroupDone :: Path -> r -, onCleanup :: [String] -> c -> r +, onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -251,27 +307,19 @@ start = onGroupStarted path children = concatMap (go (group : rGroups)) xs done = onGroupDone path - go rGroups (NodeWithCleanup action xs) = children ++ [cleanup] + go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup] where children = concatMap (go rGroups) xs - cleanup = onCleanup (reverse rGroups) action + cleanup = onCleanup loc (reverse rGroups) action go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m () -sequenceActions fastFail = go +sequenceActions :: [EvalM ()] -> EvalM () +sequenceActions = go where - go :: Monad m => [EvalM m ()] -> EvalM m () - go [] = return () + go :: [EvalM ()] -> EvalM () + go [] = pass go (action : actions) = do action - hasFailures <- any resultItemIsFailure <$> gets stateResults - let stopNow = fastFail && hasFailures - unless stopNow (go actions) - -resultItemIsFailure :: (Path, Format.Item) -> Bool -resultItemIsFailure = isFailure . Format.itemResult . snd - where - isFailure r = case r of - Format.Success{} -> False - Format.Pending{} -> False - Format.Failure{} -> True + 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 --- a/src/Test/Hspec/Core/Shuffle.hs +++ b/src/Test/Hspec/Core/Shuffle.hs @@ -16,16 +16,16 @@ import Data.STRef import Data.Array.ST -shuffleForest :: STRef s StdGen -> [Tree c a] -> ST s [Tree c a] +shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a] shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) -shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a) +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 c xs -> NodeWithCleanup c <$> shuffleForest ref xs + NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs Leaf {} -> return t -shuffle :: STRef s StdGen -> [a] -> ST s [a] +shuffle :: STRef st StdGen -> [a] -> ST st [a] shuffle ref xs = do arr <- mkArray xs bounds@(_, n) <- getBounds arr @@ -41,5 +41,5 @@ writeSTRef ref gen return a -mkArray :: [a] -> ST s (STArray s Int 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} -- | @@ -19,6 +20,10 @@ , 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 @@ -29,20 +34,64 @@ , 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 import Prelude () import Test.Hspec.Core.Compat -import qualified Control.Exception as E -import Data.CallStack +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (asks) import Test.Hspec.Expectations (Expectation) @@ -50,10 +99,13 @@ 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 :: HasCallStack => String -> SpecWith a -> SpecWith a -describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label +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 @@ -81,6 +133,16 @@ -- > describe "absolute" $ do -- > it "returns a positive number when given a negative number" $ -- > absolute (-1) == 1 +-- +-- @`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] @@ -103,14 +165,14 @@ -- -- Applying `focus` to a spec with focused spec items has no effect. focus :: SpecWith a -> SpecWith a -focus spec = do - xs <- runIO (runSpecM spec) - let - ys - | any (any itemIsFocused) xs = xs - | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs - fromSpecList ys +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 @@ -148,13 +210,29 @@ -- > it "can format text in a way that everyone likes" $ -- > pending pending :: HasCallStack => Expectation -pending = E.throwIO (Pending location Nothing) +pending = throwIO (Pending location Nothing) pending_ :: Expectation -pending_ = (E.throwIO (Pending Nothing Nothing)) +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 the spec item is pending. pendingWith :: HasCallStack => String -> Expectation -pendingWith = E.throwIO . Pending location . Just +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,49 +1,88 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Spec.Monad ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Spec , SpecWith -, SpecM (..) +, SpecM (SpecM) , runSpecM , fromSpecList , runIO +, mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams + +, modifyConfig +-- END RE-EXPORTED from Test.Hspec.Core.Spec + +, Env(..) +, withEnv ) where import Prelude () import Test.Hspec.Core.Compat -import Control.Arrow -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, @@ -52,13 +91,29 @@ runIO = SpecM . liftIO mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r -mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (second f)) specs) +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 = mapSpecForest (bimapForest g f) +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 --- a/src/Test/Hspec/Core/Timer.hs +++ b/src/Test/Hspec/Core/Timer.hs @@ -3,7 +3,6 @@ import Prelude () import Test.Hspec.Core.Compat -import Control.Exception import Control.Concurrent.Async import Test.Hspec.Core.Clock 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 @@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Tree ( +-- RE-EXPORTED from Test.Hspec.Core.Spec SpecTree , Tree (..) , Item (..) @@ -17,29 +17,39 @@ , filterForest , filterTreeWithLabels , filterForestWithLabels -, pruneTree -, pruneForest +, pruneTree -- unused +, pruneForest -- unused , location +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, callSite +, formatDefaultDescription +, toModuleName + +, setItemAnnotation +, getItemAnnotation ) where import Prelude () import Test.Hspec.Core.Compat -import Data.CallStack -import Data.Maybe +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 (Show, Eq, Functor, Foldable, Traversable) + deriving (Eq, Show, Functor, Foldable, Traversable) --- | A tree is used to represent a spec internally. The tree is parametrize +-- | 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 (ActionWith a) (Item a) +type SpecTree a = Tree (IO ()) (Item a) bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] bimapForest g f = map (bimapTree g f) @@ -49,7 +59,7 @@ where go spec = case spec of Node d xs -> Node d (map go xs) - NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (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) @@ -70,7 +80,7 @@ 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 action xs -> Just $ NodeWithCleanup action $ filterForest_ groups 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] @@ -79,7 +89,7 @@ pruneTree :: Tree c a -> Maybe (Tree c a) pruneTree node = case node of Node group xs -> Node group <$> prune xs - NodeWithCleanup action xs -> NodeWithCleanup action <$> prune xs + NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs Leaf{} -> Just node where prune = guarded (not . null) . pruneForest @@ -106,37 +116,60 @@ -- parallel with other spec items , itemIsParallelizable :: Maybe Bool - -- | A flag that indicates whether this spec item is focused. + -- | 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 :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg where msg :: HasCallStack => String msg - | null s = fromMaybe "(no description given)" defaultDescription + | null s = maybe "(no description given)" formatDefaultDescription location | otherwise = s -- | The @specItem@ function creates a spec item. -specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a) -specItem s e = Leaf $ Item requirement location Nothing False (safeEvaluateExample e) - where - requirement :: HasCallStack => String - requirement - | null s = fromMaybe "(unspecified behavior)" defaultDescription - | 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 :: HasCallStack => Maybe Location -location = case reverse callStack of - (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)) - _ -> Nothing +location = snd <$> callSite -defaultDescription :: HasCallStack => Maybe String -defaultDescription = case reverse callStack of - (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]") - _ -> Nothing +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,9 +1,12 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions pluralize , strip , lineBreaksAt +, stripAnsi -- * Working with paths , Path @@ -11,18 +14,24 @@ , 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.Core.Compat (showType) +import Control.Concurrent.Async -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given @@ -38,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 than 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] @@ -63,20 +80,45 @@ else s : go (y, ys) -- | +-- 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 @@ -89,10 +131,12 @@ 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 = - pattern `isInfixOf` plain - || pattern `isInfixOf` formatted +filterPredicate pattern_ path = + pattern_ `isInfixOf` plain + || pattern_ `isInfixOf` formatted where plain = joinPath path formatted = formatRequirement path @@ -102,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 ++ "\n" ++ show ioe - Nothing -> showType e ++ "\n" ++ 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 @@ -132,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/test/All.hs b/test/All.hs deleted file mode 100644 --- a/test/All.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-} 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 @@ -8,12 +8,14 @@ , module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently +, Seconds(..) , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary +, normalizeTimes , ignoreExitCode , ignoreUserInterrupt @@ -21,26 +23,38 @@ , throwException_ , withEnvironment +, withTempDirectory , inTempDirectory +, hspecSilent +, hspecResultSilent +, hspecCapture , shouldUseArgs , removeLocations + +, () +, mkLocation +, workaroundForIssue19236 + +, replace + +, red +, green +, colorize ) where import Prelude () import Test.Hspec.Core.Compat -import Data.List import Data.Char -import System.Environment (withArgs, getEnvironment) +import System.Environment (withArgs, getEnvironment, setEnv, unsetEnv) import System.Exit -import qualified Control.Exception as E -import Control.Exception import System.IO.Silently -import System.SetEnv +import System.FilePath import System.Directory -import System.IO.Temp +import System.IO.Temp (withSystemTempDirectory) +import System.Console.ANSI import Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import Test.QuickCheck hiding (Result(..)) @@ -48,20 +62,20 @@ 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(..)) +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) -#if !MIN_VERSION_base(4,7,0) -deriving instance Eq ErrorCall -#endif +import Data.Orphans () -exceptionEq :: E.SomeException -> E.SomeException -> Bool +exceptionEq :: SomeException -> SomeException -> Bool exceptionEq a b - | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ErrorCall) - | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ArithException) + | 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 @@ -75,16 +89,16 @@ (==) = exceptionEq throwException :: IO a -throwException = E.throwIO DivideByZero +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_ @@ -98,24 +112,59 @@ 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 -shouldUseArgs :: HasCallStack => [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) +silentConfig :: H.Config +silentConfig = H.defaultConfig {H.configFormat = Just $ formatterToFormat silent} +hspecSilent :: H.Spec -> IO () +hspecSilent = H.hspecWith silentConfig + +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 @@ -134,8 +183,28 @@ forM_ env (unsetEnv . fst) return env +withTempDirectory :: (FilePath -> IO a) -> IO a +withTempDirectory = withSystemTempDirectory "hspec" + inTempDirectory :: IO a -> IO a -inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do +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/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,1 @@ -module Main where - -import Test.Hspec.Meta -import System.SetEnv -import qualified All - -spec :: Spec -spec = beforeAll_ (setEnv "IGNORE_DOT_HSPEC" "yes" >> unsetEnv "HSPEC_OPTIONS") $ afterAll_ (unsetEnv "IGNORE_DOT_HSPEC") All.spec - -main :: IO () -main = hspec spec +{-# 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/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 --- a/test/Test/Hspec/Core/ClockSpec.hs +++ b/test/Test/Hspec/Core/ClockSpec.hs @@ -1,11 +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 --- a/test/Test/Hspec/Core/CompatSpec.hs +++ b/test/Test/Hspec/Core/CompatSpec.hs @@ -1,22 +1,18 @@ {-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where +import Prelude () import Helper -import System.SetEnv -import Data.Typeable +import System.Environment + data SomeType = SomeType - deriving Typeable 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.Core.CompatSpec.SomeType" describe "lookupEnv" $ do it "returns value of specified environment variable" $ do 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 --- a/test/Test/Hspec/Core/Config/OptionsSpec.hs +++ b/test/Test/Hspec/Core/Config/OptionsSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Test.Hspec.Core.Config.OptionsSpec (spec) where import Prelude () @@ -5,8 +6,9 @@ import System.Exit -import qualified Test.Hspec.Core.Config.Options as Options +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 @@ -16,101 +18,202 @@ spec = do describe "parseOptions" $ do - let parseOptions = Options.parseOptions defaultConfig "my-spec" + 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") + 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") + 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 + 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, output) = parseOptions [] Nothing ["--help"] - help = lines output + let Left (code, help) = Options.parseOptions defaultConfig "spec" [] Nothing [] ["--help"] it "returns ExitSuccess" $ do code `shouldBe` ExitSuccess it "prints help" $ do - help `shouldStartWith` ["Usage: my-spec [OPTION]..."] + expected <- readFile "help.txt" + help `shouldBe` expected - context "with --no-color" $ do - it "sets configColorMode to ColorNever" $ do - configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever + 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 + 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 + 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 + configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False - context "with --out" $ do - it "sets configOutputFile" $ do - either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo") + 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") + 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 23 + 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) + 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) + 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 + 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 + 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") + 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") + 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", ["--fail"])] Nothing []) `shouldBe` (ExitFailure 1, + fromLeft (parseOptions [("~/.hspec", ["--print"])] Nothing [] []) `shouldBe` (ExitFailure 1, unlines [ - "my-spec: option `--fail' is ambiguous; could be one of:" - , " --fail-on-focused fail on focused spec items" - , " --fail-fast abort on first failure" - , " --failure-report=FILE read/write a failure report for use with --rerun" + "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 + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] [] `shouldBe` Right ColorAlways - context "when given an environment variable" $ do - it "uses options from environment variable" $ do - configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever + 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 + 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") + 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 diff --git a/test/Test/Hspec/Core/Config/UtilSpec.hs b/test/Test/Hspec/Core/Config/UtilSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/Config/UtilSpec.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Test.Hspec.Core.Config.UtilSpec (spec) where - -import Helper - -import System.Console.GetOpt - -import Test.Hspec.Core.Config.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" - ] - - describe "formatOrList" $ do - it "formats a list of or-options" $ do - formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar or baz" diff --git a/test/Test/Hspec/Core/ConfigSpec.hs b/test/Test/Hspec/Core/ConfigSpec.hs --- a/test/Test/Hspec/Core/ConfigSpec.hs +++ b/test/Test/Hspec/Core/ConfigSpec.hs @@ -1,20 +1,32 @@ +{-# LANGUAGE CPP #-} module Test.Hspec.Core.ConfigSpec (spec) where +import Prelude () import Helper + import System.Directory -import System.FilePath import Test.Hspec.Core.Config spec :: Spec -spec = do - describe "readConfigFiles" $ around_ inTempDirectory $ around_ (withEnvironment [("HOME", "/foo")]) $ do +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" - readConfigFiles `shouldReturn` [(name, ["--diff"])] + 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" @@ -31,3 +43,4 @@ 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 --- a/test/Test/Hspec/Core/Example/LocationSpec.hs +++ b/test/Test/Hspec/Core/Example/LocationSpec.hs @@ -3,17 +3,18 @@ {-# 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 Control.Exception import Test.Hspec.Core.Example import Test.Hspec.Core.Example.Location class SomeClass a where - someMethod :: a -> IO () + someMethod :: a -> IO () instance SomeClass () where @@ -33,7 +34,7 @@ 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 + let location = Just $ Location file (__LINE__ + 2) 13 Left e <- try $ do Just n <- return Nothing return (n :: Int) @@ -42,12 +43,12 @@ #if !MIN_VERSION_base(4,12,0) context "in Either" $ do it "extracts Location" $ do - let location = Just $ Location __FILE__ (__LINE__ + 4) 15 + let location = Just $ Location file (__LINE__ + 4) 15 let foo :: Either () () foo = do 23 <- Right (42 :: Int) - return () + pass Left e <- try (evaluate foo) extractLocation e `shouldBe` location #endif @@ -56,11 +57,7 @@ it "extracts Location" $ do let location = -#if MIN_VERSION_base(4,9,0) - Just $ Location __FILE__ (__LINE__ + 4) 34 -#else - Nothing -#endif + Just $ Location file (succ __LINE__) 34 Left e <- try (evaluate (undefined :: ())) extractLocation e `shouldBe` location @@ -68,13 +65,13 @@ context "with single-line source span" $ do it "extracts Location" $ do let - location = Just $ Location __FILE__ (__LINE__ + 1) 40 + 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 + let location = Just $ Location file (__LINE__ + 1) 36 Left e <- try (evaluate (case Nothing of Just n -> n :: Int )) @@ -83,38 +80,63 @@ context "with RecConError" $ do it "extracts Location" $ do let - location = Just $ Location __FILE__ (__LINE__ + 1) 39 + 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__ 18 10) + extractLocation e `shouldBe` Just (Location file 19 10) context "with AssertionFailed" $ do it "extracts Location" $ do let - location = Just $ Location __FILE__ (__LINE__ + 1) 36 + 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 = unlines [ + 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) + 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) + 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) + 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) + 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,18 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module Test.Hspec.Core.ExampleSpec (spec) where +import Prelude () import Helper + import Mock -import Control.Exception import Test.HUnit (assertFailure, assertEqual) -import Test.Hspec.Core.Example (Result(..), ResultStatus(..) -#if MIN_VERSION_base(4,8,1) - , Location(..) -#endif - , FailureReason(..)) +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 @@ -30,8 +29,54 @@ 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 @@ -41,23 +86,13 @@ context "when used with `pending`" $ do it "returns Pending" $ do result <- safeEvaluateExample (H.pending) - let location = -#if MIN_VERSION_base(4,8,1) - Just $ Location __FILE__ (__LINE__ - 3) 42 -#else - Nothing -#endif + 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 = -#if MIN_VERSION_base(4,8,1) - Just $ Location __FILE__ (__LINE__ - 3) 42 -#else - Nothing -#endif + let location = mkLocation __FILE__ (pred __LINE__) 42 result `shouldBe` Result "" (Pending location $ Just "foo") describe "evaluateExample" $ do @@ -141,7 +176,7 @@ it "returns Failure if property does not hold" $ do Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int) - return () + pass it "shows what falsified it" $ do Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False @@ -196,36 +231,26 @@ context "when used with `pending`" $ do it "returns Pending" $ do - let location = -#if MIN_VERSION_base(4,8,1) - Just $ Location __FILE__ (__LINE__ + 4) 37 -#else - Nothing -#endif + 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 - let location = -#if MIN_VERSION_base(4,8,1) - Just $ Location __FILE__ (__LINE__ + 4) 39 -#else - Nothing -#endif + 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 --- a/test/Test/Hspec/Core/FailureReportSpec.hs +++ b/test/Test/Hspec/Core/FailureReportSpec.hs @@ -1,9 +1,9 @@ module Test.Hspec.Core.FailureReportSpec (spec) where +import Prelude () import Helper import System.IO -import qualified Control.Exception as E import Test.Hspec.Core.FailureReport import Test.Hspec.Core.Config @@ -11,7 +11,7 @@ spec = do describe "writeFailureReport" $ do it "prints a warning on unexpected exceptions" $ do - r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (E.throw (E.ErrorCall "some error")) + 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 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 --- a/test/Test/Hspec/Core/Formatters/DiffSpec.hs +++ b/test/Test/Hspec/Core/Formatters/DiffSpec.hs @@ -2,18 +2,102 @@ module Test.Hspec.Core.Formatters.DiffSpec (spec) where import Prelude () -import Test.Hspec.Core.Compat - import Helper import Data.Char -import Test.Hspec.Core.Formatters.Diff +import Test.Hspec.Core.Formatters.Diff as Diff dropQuotes :: String -> String -dropQuotes = init . tail +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 @@ -28,12 +112,12 @@ let char = dropQuotes (show [c]) isEscaped = length char > 1 - escape = tail char + 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 (tail $ show ys) + expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys) in isEscaped ==> actual `shouldBe` expected describe "breakList" $ do diff --git a/test/Test/Hspec/Core/Formatters/InternalSpec.hs b/test/Test/Hspec/Core/Formatters/InternalSpec.hs --- a/test/Test/Hspec/Core/Formatters/InternalSpec.hs +++ b/test/Test/Hspec/Core/Formatters/InternalSpec.hs @@ -1,26 +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 - describe "overwriteWith" $ do - context "when old is null" $ do - it "returns new" $ do - ("" `overwriteWith` "foo") `shouldBe` "foo" + forM_ [ + ("extraChunk", extraChunk, Red) + , ("missingChunk", missingChunk, Green) + ] $ \ (name, chunk, color) -> do - context "when old and new have the same length" $ do - it "overwrites old" $ do - ("foo" `overwriteWith` "bar") `shouldBe` "\rbar" + describe name $ do + it "colorizes chunks" $ do + capture_ $ runFormatM formatConfig $ do + chunk "foo" + `shouldReturn` colorize Foreground color "foo" - context "when old is shorter than new" $ do - it "overwrites old" $ do - ("ba" `overwriteWith` "foo") `shouldBe` "\rfoo" + context "with an all-spaces chunk" $ do + it "colorizes background" $ do + capture_ $ runFormatM formatConfig $ do + chunk " " + `shouldReturn` colorize Background color " " - context "when old is longer than new" $ do - it "overwrites old" $ do - ("foobar" `overwriteWith` "foo") `shouldBe` "\rfoo " + 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,314 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Test.Hspec.Core.FormattersSpec (spec) where - -import Prelude () -import Helper -import Data.String -import Control.Monad.IO.Class -import Control.Monad.Trans.Writer -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 -import qualified Test.Hspec.Core.Formatters.Monad as H -import Test.Hspec.Core.Formatters.Monad hiding (interpretWith) - -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 -, 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 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" - ] - - 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 \"//\"" - , "" -#if __GLASGOW_HASKELL__ == 800 - , "WARNING:" - , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - , " Source locations may not work as expected." - , "" - , " Please consider upgrading GHC!" - , "" -#endif - , "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" (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 - 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/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs --- a/test/Test/Hspec/Core/HooksSpec.hs +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (spec) where @@ -5,8 +6,6 @@ import Helper import Mock -import Control.Exception - import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Spec as H import Test.Hspec.Core.Format @@ -17,26 +16,30 @@ evalSpec_ :: H.Spec -> IO () evalSpec_ = void . evalSpec + evalSpec :: H.Spec -> IO [([String], Item)] -evalSpec = fmap normalize . (H.specToEvalForest H.defaultConfig >=> runFormatter config) +evalSpec = fmap normalize . (toEvalForest >=> runFormatter config) where config = EvalConfig { - evalConfigFormat = format + evalConfigFormat = \ _ -> pass , evalConfigConcurrentJobs = 1 - , evalConfigFastFail = False - } - format = Format { - formatRun = id - , formatGroupStarted = \ _ -> return () - , formatGroupDone = \ _ -> return () - , formatProgress = \ _ _ -> return () - , formatItemStarted = \ _ -> return () - , formatItemDone = \ _ _ -> return () + , evalConfigFailFast = False + , evalConfigColorMode = ColorEnabled } normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item) - normalizeItem item = item {itemLocation = Nothing, itemDuration = 0} + 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]) @@ -143,14 +146,14 @@ n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero - , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)")) + , 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 evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do - return () + pass retrieve `shouldReturn` [] describe "beforeAll_" $ do @@ -234,7 +237,7 @@ n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero - , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)")) + , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith") ] context "when used with an empty list of examples" $ do @@ -242,7 +245,7 @@ (rec, retrieve) <- mkAppend evalSpec_ $ H.beforeAll (return (23 :: Int)) $ H.beforeAllWith (\_ -> rec "beforeAllWith" >> return "value") $ do - return () + pass retrieve `shouldReturn` [] describe "after" $ do @@ -318,23 +321,23 @@ , "foo" , "before" , "bar" - , "before" , "from before" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do evalSpec $ H.before undefined $ H.afterAll undefined $ do - return () + pass `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do H.it "foo" $ \a -> a `shouldBe` "from before" + H.it "bar" $ \a -> a `shouldBe` "from before" `shouldReturn` [ item ["foo"] Success - , item ["afterAll-hook"] divideByZero + , item ["bar"] $ divideByZeroIn "afterAll" ] describe "afterAll_" $ do @@ -350,7 +353,6 @@ , "foo" , "before" , "bar" - , "before" , "afterAll_" ] @@ -370,7 +372,7 @@ it "does not run specified action" $ do (rec, retrieve) <- mkAppend evalSpec_ $ H.afterAll_ (rec "afterAll_") $ do - return () + pass retrieve `shouldReturn` [] context "when action is pending" $ do @@ -378,9 +380,10 @@ evalSpec $ do H.afterAll_ H.pending $ do H.it "foo" True + H.it "bar" True `shouldReturn` [ item ["foo"] Success - , item ["afterAll-hook"] (Pending Nothing) + , item ["bar"] (Pending Nothing Nothing) ] context "when action throws an exception" $ do @@ -388,15 +391,16 @@ evalSpec $ do H.afterAll_ throwException $ do H.it "foo" True + H.it "bar" True `shouldReturn` [ item ["foo"] Success - , item ["afterAll-hook"] divideByZero + , item ["bar"] $ divideByZeroIn "afterAll_" ] context "when action is successful" $ do - it "does not report anythig" $ do + it "does not report anything" $ do evalSpec $ do - H.afterAll_ (return ()) $ do + H.afterAll_ pass $ do H.it "foo" True `shouldReturn` [ item ["foo"] Success @@ -498,6 +502,36 @@ , "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 @@ -513,24 +547,26 @@ , "2" , "3" ] - mockCounter mock `shouldReturn` 4 + 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 ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)")) + , 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 ["afterAll-hook"] divideByZero + , item ["bar"] $ divideByZeroIn "aroundAll_" ] describe "aroundAllWith" $ do @@ -547,29 +583,93 @@ , "1" , "1" ] - mockCounter mock `shouldReturn` 4 + 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 - , item ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)")) ] 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 ["afterAll-hook"] divideByZero + , 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 divideByZero :: Result - divideByZero = Failure (Error Nothing $ toException DivideByZero) + 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,239 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Test.Hspec.Core.QuickCheckUtilSpec (spec) where - -import Helper - -import qualified Test.QuickCheck.Property as QCP - -import Test.Hspec.Core.QuickCheckUtil - -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" - , "" - , "+++ OK, passed 2 tests." - , "" - , "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 - let info = intercalate "\n\n" (replicate 799 "Passed:") - 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/Runner/EvalSpec.hs b/test/Test/Hspec/Core/Runner/EvalSpec.hs --- a/test/Test/Hspec/Core/Runner/EvalSpec.hs +++ b/test/Test/Hspec/Core/Runner/EvalSpec.hs @@ -1,29 +1,75 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Runner.EvalSpec (spec) where import Prelude () import Helper -import Test.Hspec.Core.Tree +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 "" [Node "" [Leaf 1, Node "" [Leaf 2, Leaf 3]], Leaf 4] + 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] - - describe "runSequentially" $ do - it "runs actions sequentially" $ do - ref <- newIORef [] - (_, actionA) <- runSequentially $ \ _ -> modifyIORef ref (23 :) - (_, actionB) <- runSequentially $ \ _ -> modifyIORef ref (42 :) - (_, ()) <- actionB (\_ -> return ()) - readIORef ref `shouldReturn` [42 :: Int] - (_, ()) <- actionA (\_ -> return ()) - readIORef ref `shouldReturn` [23, 42] 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,39 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - -#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) --- Control.Concurrent.QSem is deprecated in base-4.6.0.* -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.RunnerSpec (spec) where import Prelude () import Helper -import System.IO (stderr) -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 System.Console.ANSI 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 -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 @@ -41,27 +36,42 @@ 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 ("--format=silent" : args) . H.hspec - hspec_ = hspec [] + hspec args = withArgs args . hspecSilent + hspec_ = hspecSilent it "evaluates examples Unmasked" $ do mvar <- newEmptyMVar hspec_ $ do H.it "foo" $ do - E.getMaskingState >>= putMVar mvar - takeMVar mvar `shouldReturn` E.Unmasked + 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) `E.finally` + (putMVar mvar () >> threadDelay 10000000) `finally` writeIORef ref "ran finalizer" takeMVar mvar cancel a @@ -110,66 +120,99 @@ ] } - 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 $ \(name, accessor) -> do - it ("reuses same " ++ name) $ do - [name, "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 "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 @@ -189,28 +232,22 @@ 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/\"" - , "" -#if __GLASGOW_HASKELL__ == 800 - , "WARNING:" - , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - , " Source locations may not work as expected." - , "" - , " Please consider upgrading GHC!" + , " To rerun use: --match \"/foo/\" --seed 23" , "" -#endif , "Randomized with seed 23" , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" ] it "throws UserInterrupt" $ do @@ -221,21 +258,21 @@ 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 + 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" @@ -256,75 +293,119 @@ readIORef ref `shouldReturn` False context "with --focused-only" $ do - let run = captureLines . withArgs ["--focused-only"] . H.hspec + let run = hspecCapture ["--focused-only"] context "when there aren't any focused spec items" $ do it "does not run anything" $ do - r <- run $ do + run $ do H.it "foo" True H.it "bar" True - normalizeSummary r `shouldBe` [ + `shouldReturn` unlines [ "" , "" , "Finished in 0.0000 seconds" , "0 examples, 0 failures" ] - context "with --fail-on-focused" $ do - let run = captureLines . ignoreExitCode . withArgs ["--fail-on-focused", "--seed", "23"] . H.hspec . removeLocations + 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 - r <- run $ do + run $ do H.it "foo" True H.fit "bar" True - normalizeSummary r `shouldBe` [ + `shouldReturn` unlines [ "" - , "bar FAILED [1]" + , "bar [✘]" , "" , "Failures:" , "" , " 1) bar" - , " item is focused; failing due to --fail-on-focused" + , " item is focused; failing due to --fail-on=focused" , "" - , " To rerun use: --match \"/bar/\"" + , " To rerun use: --match \"/bar/\" --seed 23" , "" -#if __GLASGOW_HASKELL__ == 800 - , "WARNING:" - , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - , " Source locations may not work as expected." + , "Randomized with seed 23" , "" - , " Please consider upgrading GHC!" + , "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) [✘]" , "" -#endif + , "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" - , "1 example, 1 failure" + , "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/\"" - , "" -#if __GLASGOW_HASKELL__ == 800 - , "WARNING:" - , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - , " Source locations may not work as expected." - , "" - , " Please consider upgrading GHC!" + , " To rerun use: --match \"/bar/\" --seed 23" , "" -#endif , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" @@ -344,41 +425,53 @@ 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") `E.finally` signalQSem parent + (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/\"" - , "" -#if __GLASGOW_HASKELL__ == 800 - , "WARNING:" - , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." - , " Source locations may not work as expected." - , "" - , " Please consider upgrading GHC!" + , " To rerun use: --match \"/foo/bar/\" --seed 23" , "" -#endif , "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 @@ -422,14 +515,151 @@ 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: " ++ reset ++ red ++ "42" ++ reset - , red ++ " but got: " ++ reset ++ green ++ "23" ++ reset + red " expected: " ++ red "42" + , red " but got: " ++ green "23" ] context "with --no-diff" $ do @@ -438,10 +668,94 @@ H.it "foo" $ do 23 `H.shouldBe` (42 :: Int) r `shouldContain` unlines [ - red ++ " expected: " ++ reset ++ "42" - , red ++ " but got: " ++ reset ++ "23" + 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 @@ -458,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 - hspec ["--qc-max-success", "23"] $ 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"] @@ -513,22 +866,22 @@ 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 ("--format=silent" : args) . H.hspecResult - hspecResult_ = hspecResult [] + hspecResult args = withArgs args . hspecResultSilent + hspecResult_ = hspecResultSilent it "returns a summary of the test run" $ do hspecResult_ $ do @@ -544,18 +897,22 @@ 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 <- hspecResult_ $ do H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined) @@ -581,40 +938,90 @@ atomicModifyIORef highRef $ \x -> (max x current, ()) stop = atomicModifyIORef currentRef $ \x -> (pred x, ()) r <- hspecResult ["-j", show j] . H.parallel $ do - replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t + 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} - summary = H.Summary 1 0 + result = SpecResult [] True context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do it "returns True" $ do - H.rerunAll config (Just report) summary `shouldBe` True + H.rerunAll config (Just report) result `shouldBe` True context "without --rerun" $ do it "returns False" $ do - H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False + 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) summary `shouldBe` False + 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 = []}) summary `shouldBe` False + H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False context "without failure report" $ do it "returns False" $ do - H.rerunAll config Nothing summary `shouldBe` False + H.rerunAll config Nothing result `shouldBe` False context "on failure" $ do it "returns False" $ do - H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False - where - green = setSGRCode [SetColor Foreground Dull Green] - red = setSGRCode [SetColor Foreground Dull Red] - reset = setSGRCode [Reset] + 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 --- a/test/Test/Hspec/Core/ShuffleSpec.hs +++ b/test/Test/Hspec/Core/ShuffleSpec.hs @@ -32,8 +32,8 @@ it "recurses into NodeWithCleanup" $ do shuffleForest 1 - [NodeWithCleanup () [NodeWithCleanup () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe` - [NodeWithCleanup () [NodeWithCleanup () [Leaf 2, Leaf 3, Leaf 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 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 @@ -6,18 +6,36 @@ 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 extract :: (Item () -> a) -> H.Spec -> IO [Tree () a] -extract f = fmap (H.bimapForest (const ()) f) . runSpecM +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 @@ -29,17 +47,12 @@ context "when no description is given" $ do it "uses a default description" $ do [Node d _] <- runSpecM (H.describe "" (pure ())) -#if MIN_VERSION_base(4,8,1) - d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":33]" -#else - d `shouldBe` "(no description given)" -#endif + 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) - r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Result "" (Pending Nothing Nothing) + runItem item `shouldReturn` Result "" (Pending Nothing Nothing) describe "it" $ do it "takes a description of a desired behavior" $ do @@ -48,33 +61,17 @@ it "takes an example of that behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) - r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Result "" Success + runItem item `shouldReturn` Result "" Success it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) - let location = -#if MIN_VERSION_base(4,8,1) - Just $ H.Location __FILE__ (__LINE__ - 3) 32 -#else - Nothing -#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) -#if MIN_VERSION_base(4,8,1) - itemRequirement item `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":34]" -#else - itemRequirement item `shouldBe` "(unspecified behavior)" -#endif - describe "xit" $ do it "creates a pending spec item" $ do [Leaf item] <- runSpecM (H.xit "whatever" True) - r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Result "" (Pending Nothing Nothing) + runItem item `shouldReturn` Result "" (Pending Nothing Nothing) describe "pending" $ do it "specifies a pending example" $ do diff --git a/test/Test/Hspec/Core/TimerSpec.hs b/test/Test/Hspec/Core/TimerSpec.hs --- a/test/Test/Hspec/Core/TimerSpec.hs +++ b/test/Test/Hspec/Core/TimerSpec.hs @@ -1,5 +1,6 @@ module Test.Hspec.Core.TimerSpec (spec) where +import Prelude () import Helper -- import Test.Hspec.Core.Timer @@ -7,7 +8,7 @@ spec :: Spec spec = do describe "timer action provided by withTimer" $ do - return () -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352 + pass -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352 {- let 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,8 +1,9 @@ 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 @@ -20,12 +21,12 @@ describe "formatException" $ do it "converts exception to string" $ do - formatException (E.toException E.DivideByZero) `shouldBe` "ArithException\ndivide by zero" + formatException (toException DivideByZero) `shouldBe` "ArithException\ndivide by zero" context "when used with an IOException" $ do it "includes the IOErrorType" $ do inTempDirectory $ do - Left e <- E.try (readFile "foo") + Left e <- try (readFile "foo") formatException e `shouldBe` intercalate "\n" [ "IOException of type NoSuchThing" , "foo: openFile: does not exist (No such file or directory)" @@ -42,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) @@ -49,21 +62,21 @@ it "returns Left on exception" $ do Left e <- safeTry throwException - E.fromException e `shouldBe` Just E.DivideByZero + 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 @@ -93,7 +106,7 @@ 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/vendor/Control/Concurrent/Async.hs b/vendor/Control/Concurrent/Async.hs deleted file mode 100644 --- a/vendor/Control/Concurrent/Async.hs +++ /dev/null @@ -1,870 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes, - ExistentialQuantification #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS -Wall #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Concurrent.Async --- Copyright : (c) Simon Marlow 2012 --- License : BSD3 (see the file LICENSE) --- --- Maintainer : Simon Marlow --- Stability : provisional --- Portability : non-portable (requires concurrency) --- --- This module provides a set of operations for running IO operations --- asynchronously and waiting for their results. It is a thin layer --- over the basic concurrency operations provided by --- "Control.Concurrent". The main additional functionality it --- provides is the ability to wait for the return value of a thread, --- but the interface also provides some additional safety and --- robustness over using threads and @MVar@ directly. --- --- The basic type is @'Async' a@, which represents an asynchronous --- @IO@ action that will return a value of type @a@, or die with an --- exception. An @Async@ corresponds to a thread, and its 'ThreadId' --- can be obtained with 'asyncThreadId', although that should rarely --- be necessary. --- --- For example, to fetch two web pages at the same time, we could do --- this (assuming a suitable @getURL@ function): --- --- > do a1 <- async (getURL url1) --- > a2 <- async (getURL url2) --- > page1 <- wait a1 --- > page2 <- wait a2 --- > ... --- --- where 'async' starts the operation in a separate thread, and --- 'wait' waits for and returns the result. If the operation --- throws an exception, then that exception is re-thrown by --- 'wait'. This is one of the ways in which this library --- provides some additional safety: it is harder to accidentally --- forget about exceptions thrown in child threads. --- --- A slight improvement over the previous example is this: --- --- > withAsync (getURL url1) $ \a1 -> do --- > withAsync (getURL url2) $ \a2 -> do --- > page1 <- wait a1 --- > page2 <- wait a2 --- > ... --- --- 'withAsync' is like 'async', except that the 'Async' is --- automatically killed (using 'uninterruptibleCancel') if the --- enclosing IO operation returns before it has completed. Consider --- the case when the first 'wait' throws an exception; then the second --- 'Async' will be automatically killed rather than being left to run --- in the background, possibly indefinitely. This is the second way --- that the library provides additional safety: using 'withAsync' --- means we can avoid accidentally leaving threads running. --- Furthermore, 'withAsync' allows a tree of threads to be built, such --- that children are automatically killed if their parents die for any --- reason. --- --- The pattern of performing two IO actions concurrently and waiting --- for their results is packaged up in a combinator 'concurrently', so --- we can further shorten the above example to: --- --- > (page1, page2) <- concurrently (getURL url1) (getURL url2) --- > ... --- --- The 'Functor' instance can be used to change the result of an --- 'Async'. For example: --- --- > ghci> a <- async (return 3) --- > ghci> wait a --- > 3 --- > ghci> wait (fmap (+1) a) --- > 4 - ------------------------------------------------------------------------------ - -module Control.Concurrent.Async ( - - -- * Asynchronous actions - Async, - -- ** Spawning - async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, - - -- ** Spawning with automatic 'cancel'ation - withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, - withAsyncOnWithUnmask, - - -- ** Querying 'Async's - wait, poll, waitCatch, asyncThreadId, - cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..), - - -- ** STM operations - waitSTM, pollSTM, waitCatchSTM, - - -- ** Waiting for multiple 'Async's - waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, - waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, - waitEither_, - waitBoth, - - -- ** Waiting for multiple 'Async's in STM - waitAnySTM, waitAnyCatchSTM, - waitEitherSTM, waitEitherCatchSTM, - waitEitherSTM_, - waitBothSTM, - - -- ** Linking - link, link2, ExceptionInLinkedThread(..), - - -- * Convenient utilities - race, race_, - concurrently, concurrently_, - mapConcurrently, forConcurrently, - mapConcurrently_, forConcurrently_, - replicateConcurrently, replicateConcurrently_, - Concurrently(..), - compareAsyncs, - - ) where - -import Control.Concurrent.STM -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,9,0) && !MIN_VERSION_base(4,13,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 'Async's that may have different types -compareAsyncs :: Async a -> Async b -> Ordering -compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2 - --- | Spawn an asynchronous action in a separate thread. -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 `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 = atomically . waitSTM - --- | 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 - --- | 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'. --- --- 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 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` mapM_ cancel 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'. --- --- 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 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` mapM_ cancel 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` (cancel left >> cancel 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` (cancel left >> cancel 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 = atomically (waitBothSTM left right) - --- | 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 - show (ExceptionInLinkedThread (Async t _) e) = - "ExceptionInLinkedThread " ++ show t ++ " " ++ show 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. 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) - -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) - -#define USE_ASYNC_VERSIONS 0 - -#if USE_ASYNC_VERSIONS - -race left right = - withAsync left $ \a -> - withAsync right $ \b -> - waitEither a b - -race_ left right = - withAsync left $ \a -> - withAsync right $ \b -> - waitEither_ a b - -concurrently left right = - withAsync left $ \a -> - withAsync right $ \b -> - waitBoth a b - -#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 - -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 - -#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"] --- -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, --- just like @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, --- just like @forM_ -forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO () -forConcurrently_ = flip mapConcurrently_ - --- | 'concurrently', but ignore the result values --- --- @since 2.1.1 -concurrently_ :: IO a -> IO b -> IO () -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 - --- | 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 - -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 - --- ---------------------------------------------------------------------------- - --- | 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 action = IO $ \ s -> - case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) - -{-# INLINE rawForkOn #-} -rawForkOn :: Int -> IO () -> IO ThreadId -rawForkOn (I# cpu) action = IO $ \ s -> - case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) diff --git a/vendor/Data/Algorithm/Diff.hs b/vendor/Data/Algorithm/Diff.hs --- a/vendor/Data/Algorithm/Diff.hs +++ b/vendor/Data/Algorithm/Diff.hs @@ -1,4 +1,9 @@ +{-# 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 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 --- a/version.yaml +++ b/version.yaml @@ -1,1 +1,7 @@ -&version 2.7.10 +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/