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