1{-# LANGUAGE CPP #-} 2 3-- | 4-- Stability: provisional 5module Test.Hspec.Core.Runner ( 6-- * Running a spec 7 hspec 8, runSpec 9 10-- * Config 11, Config (..) 12, ColorMode (..) 13, Path 14, defaultConfig 15, configAddFilter 16, readConfig 17 18-- * Summary 19, Summary (..) 20, isSuccess 21, evaluateSummary 22 23-- * Legacy 24-- | The following primitives are deprecated. Use `runSpec` instead. 25, hspecWith 26, hspecResult 27, hspecWithResult 28 29#ifdef TEST 30, rerunAll 31, specToEvalForest 32#endif 33) where 34 35import Prelude () 36import Test.Hspec.Core.Compat 37 38import Data.Maybe 39import System.IO 40import System.Environment (getArgs, withArgs) 41import System.Exit 42import qualified Control.Exception as E 43import System.Random 44import Control.Monad.ST 45import Data.STRef 46 47import System.Console.ANSI (hHideCursor, hShowCursor) 48import qualified Test.QuickCheck as QC 49 50import Test.Hspec.Core.Util (Path) 51import Test.Hspec.Core.Spec 52import Test.Hspec.Core.Config 53import Test.Hspec.Core.Formatters 54import Test.Hspec.Core.Formatters.Internal 55import Test.Hspec.Core.FailureReport 56import Test.Hspec.Core.QuickCheckUtil 57import Test.Hspec.Core.Shuffle 58 59import Test.Hspec.Core.Runner.Eval 60 61applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree] 62applyFilterPredicates c = filterForestWithLabels p 63 where 64 include :: Path -> Bool 65 include = fromMaybe (const True) (configFilterPredicate c) 66 67 skip :: Path -> Bool 68 skip = fromMaybe (const False) (configSkipPredicate c) 69 70 p :: [String] -> EvalItem -> Bool 71 p groups item = include path && not (skip path) 72 where 73 path = (groups, evalItemDescription item) 74 75applyDryRun :: Config -> [EvalTree] -> [EvalTree] 76applyDryRun c 77 | configDryRun c = bimapForest removeCleanup markSuccess 78 | otherwise = id 79 where 80 removeCleanup :: IO () -> IO () 81 removeCleanup _ = return () 82 83 markSuccess :: EvalItem -> EvalItem 84 markSuccess item = item {evalItemAction = \ _ -> return $ Result "" Success} 85 86-- | Run a given spec and write a report to `stdout`. 87-- Exit with `exitFailure` if at least one spec item fails. 88-- 89-- /Note/: `hspec` handles command-line options and reads config files. This 90-- is not always desired. Use `runSpec` if you need more control over these 91-- aspects. 92hspec :: Spec -> IO () 93hspec spec = 94 getArgs 95 >>= readConfig defaultConfig 96 >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec 97 >>= evaluateSummary 98 99-- Add a seed to given config if there is none. That way the same seed is used 100-- for all properties. This helps with --seed and --rerun. 101ensureSeed :: Config -> IO Config 102ensureSeed c = case configQuickCheckSeed c of 103 Nothing -> do 104 seed <- newSeed 105 return c {configQuickCheckSeed = Just (fromIntegral seed)} 106 _ -> return c 107 108-- | Run given spec with custom options. 109-- This is similar to `hspec`, but more flexible. 110hspecWith :: Config -> Spec -> IO () 111hspecWith config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary 112 113-- | `True` if the given `Summary` indicates that there were no 114-- failures, `False` otherwise. 115isSuccess :: Summary -> Bool 116isSuccess summary = summaryFailures summary == 0 117 118-- | Exit with `exitFailure` if the given `Summary` indicates that there was at 119-- least one failure. 120evaluateSummary :: Summary -> IO () 121evaluateSummary summary = unless (isSuccess summary) exitFailure 122 123-- | Run given spec and returns a summary of the test run. 124-- 125-- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec 126-- items. If you need this, you have to check the `Summary` yourself and act 127-- accordingly. 128hspecResult :: Spec -> IO Summary 129hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec 130 131-- | Run given spec with custom options and returns a summary of the test run. 132-- 133-- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec 134-- items. If you need this, you have to check the `Summary` yourself and act 135-- accordingly. 136hspecWithResult :: Config -> Spec -> IO Summary 137hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec 138 139-- | 140-- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in 141-- terms of @runSpec@: 142-- 143-- @ 144-- hspec spec = 145-- `getArgs` 146-- >>= `readConfig` `defaultConfig` 147-- >>= `withArgs` [] . runSpec spec 148-- >>= `evaluateSummary` 149-- @ 150runSpec :: Spec -> Config -> IO Summary 151runSpec spec c_ = do 152 oldFailureReport <- readFailureReportOnRerun c_ 153 154 c <- ensureSeed (applyFailureReport oldFailureReport c_) 155 156 if configRerunAllOnSuccess c 157 -- With --rerun-all we may run the spec twice. For that reason GHC can not 158 -- optimize away the spec tree. That means that the whole spec tree has to 159 -- be constructed in memory and we loose constant space behavior. 160 -- 161 -- By separating between rerunAllMode and normalMode here, we retain 162 -- constant space behavior in normalMode. 163 -- 164 -- see: https://github.com/hspec/hspec/issues/169 165 then rerunAllMode c oldFailureReport 166 else normalMode c 167 where 168 normalMode c = runSpec_ c spec 169 rerunAllMode c oldFailureReport = do 170 summary <- runSpec_ c spec 171 if rerunAll c oldFailureReport summary 172 then runSpec spec c_ 173 else return summary 174 175failFocused :: Item a -> Item a 176failFocused item = item {itemExample = example} 177 where 178 failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused") 179 example 180 | itemIsFocused item = \ params hook p -> do 181 Result info status <- itemExample item params hook p 182 return $ Result info $ case status of 183 Success -> failure 184 Pending _ _ -> failure 185 Failure{} -> status 186 | otherwise = itemExample item 187 188failFocusedItems :: Config -> Spec -> Spec 189failFocusedItems config spec 190 | configFailOnFocused config = mapSpecItem_ failFocused spec 191 | otherwise = spec 192 193focusSpec :: Config -> Spec -> Spec 194focusSpec config spec 195 | configFocusedOnly config = spec 196 | otherwise = focus spec 197 198runSpec_ :: Config -> Spec -> IO Summary 199runSpec_ config spec = do 200 filteredSpec <- specToEvalForest config spec 201 withHandle config $ \h -> do 202 let formatter = fromMaybe specdoc (configFormatter config) 203 seed = (fromJust . configQuickCheckSeed) config 204 qcArgs = configQuickCheckArgs config 205 206 concurrentJobs <- case configConcurrentJobs config of 207 Nothing -> getDefaultConcurrentJobs 208 Just n -> return n 209 210 useColor <- doesUseColor h config 211 212 results <- withHiddenCursor useColor h $ do 213 let 214 formatConfig = FormatConfig { 215 formatConfigHandle = h 216 , formatConfigUseColor = useColor 217 , formatConfigUseDiff = configDiff config 218 , formatConfigHtmlOutput = configHtmlOutput config 219 , formatConfigPrintCpuTime = configPrintCpuTime config 220 , formatConfigUsedSeed = seed 221 } 222 evalConfig = EvalConfig { 223 evalConfigFormat = formatterToFormat formatter formatConfig 224 , evalConfigConcurrentJobs = concurrentJobs 225 , evalConfigFastFail = configFastFail config 226 } 227 runFormatter evalConfig filteredSpec 228 229 let failures = filter resultItemIsFailure results 230 231 dumpFailureReport config seed qcArgs (map fst failures) 232 233 return Summary { 234 summaryExamples = length results 235 , summaryFailures = length failures 236 } 237 238specToEvalForest :: Config -> Spec -> IO [EvalTree] 239specToEvalForest config spec = do 240 let 241 seed = (fromJust . configQuickCheckSeed) config 242 focusedSpec = focusSpec config (failFocusedItems config spec) 243 params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) 244 randomize 245 | configRandomize config = randomizeForest seed 246 | otherwise = id 247 randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec 248 249toEvalForest :: Params -> [SpecTree ()] -> [EvalTree] 250toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused 251 where 252 toEvalItem :: Item () -> EvalItem 253 toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit) 254 255 withUnit :: ActionWith () -> IO () 256 withUnit action = action () 257 258dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () 259dumpFailureReport config seed qcArgs xs = do 260 writeFailureReport config FailureReport { 261 failureReportSeed = seed 262 , failureReportMaxSuccess = QC.maxSuccess qcArgs 263 , failureReportMaxSize = QC.maxSize qcArgs 264 , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs 265 , failureReportPaths = xs 266 } 267 268doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a 269doNotLeakCommandLineArgumentsToExamples = withArgs [] 270 271withHiddenCursor :: Bool -> Handle -> IO a -> IO a 272withHiddenCursor useColor h 273 | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) 274 | otherwise = id 275 276doesUseColor :: Handle -> Config -> IO Bool 277doesUseColor h c = case configColorMode c of 278 ColorAuto -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb) 279 ColorNever -> return False 280 ColorAlways -> return True 281 282withHandle :: Config -> (Handle -> IO a) -> IO a 283withHandle c action = case configOutputFile c of 284 Left h -> action h 285 Right path -> withFile path WriteMode action 286 287rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool 288rerunAll _ Nothing _ = False 289rerunAll config (Just oldFailureReport) summary = 290 configRerunAllOnSuccess config 291 && configRerun config 292 && isSuccess summary 293 && (not . null) (failureReportPaths oldFailureReport) 294 295isDumb :: IO Bool 296isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" 297 298-- | Summary of a test run. 299data Summary = Summary { 300 summaryExamples :: Int 301, summaryFailures :: Int 302} deriving (Eq, Show) 303 304instance Monoid Summary where 305 mempty = Summary 0 0 306#if !MIN_VERSION_base(4,11,0) 307 (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) 308#else 309instance Semigroup Summary where 310 (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) 311#endif 312 313randomizeForest :: Integer -> [Tree c a] -> [Tree c a] 314randomizeForest seed t = runST $ do 315 ref <- newSTRef (mkStdGen $ fromIntegral seed) 316 shuffleForest ref t 317