Merge pull request #62 from timjb/repeat-tests

Add --repeat flag for running each test multiple times

HTF.cabal

@@ -237,7 +237,7 @@ Test-Suite TestHTF
   Other-Modules:
     Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime,
     MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi,
-    Tutorial
+    Tutorial, Repeat
 
 Test-Suite TestThreadPools
   Main-is:           ThreadPoolTest.hs

Test/Framework/CmdlineOptions.hs

@@ -89,8 +89,9 @@ data CmdlineOptions = CmdlineOptions {
     , opts_sortByPrevTime :: Bool       -- ^ Sort tests by their previous run times (ascending). Default: 'False'
     , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run.
     , opts_maxCurTimeMs :: Maybe Milliseconds  -- ^ Abort tests that run more than the given milliseconds.
-    , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previosu run.
+    , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run.
     , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error.
+    , opts_repeat :: Int                 -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.
     }
 
 {- |
@@ -117,6 +118,7 @@ defaultCmdlineOptions = CmdlineOptions {
     , opts_maxCurTimeMs = Nothing
     , opts_prevFactor = Nothing
     , opts_timeoutIsSuccess = False
+    , opts_repeat = 1
     }
 
 processorCount :: Int
@@ -181,6 +183,10 @@ optionDescriptions =
     , Option []        ["timeout-is-success"]
              (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True }))
              "Do not regard a test timeout as an error."
+    , Option []        ["repeat"]
+             (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) ->
+                              Right $ o { opts_repeat = i}) "NUMBER")
+             "Execute the tests selected on the command line NUMBER times."
     , Option ['h']     ["help"]
              (NoArg (\o -> Right $ o { opts_help = True }))
              "Display this message."
@@ -301,6 +307,7 @@ testConfigFromCmdlineOptions opts =
                            , tc_maxSingleTestTime = opts_maxCurTimeMs opts
                            , tc_prevFactor = opts_prevFactor opts
                            , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts
+                           , tc_repeat = opts_repeat opts
                            }
     where
 #ifdef mingw32_HOST_OS

Test/Framework/TestManager.hs

@@ -244,16 +244,28 @@ mkFlatTestRunner tc ft = (pre, action, post)
       pre = reportTestStart ft
       action _ =
           let run = performTestHTF (wto_payload (ft_payload ft))
-          in case maxRunTime tc ft of
-               Nothing ->
-                   do (res, time) <- measure run
-                      return (PrimTestResultNoTimeout res, time)
-               Just maxMs ->
-                    do mx <- timeout (1000 * maxMs) $ measure run
-                       case mx of
-                         Nothing -> return (PrimTestResultTimeout, maxMs)
-                         Just (res, time) ->
-                             return (PrimTestResultNoTimeout res, time)
+              runWithTimeout =
+                  case maxRunTime tc ft of
+                    Nothing ->
+                        do (res, time) <- measure run
+                           return (PrimTestResultNoTimeout res, time)
+                    Just maxMs ->
+                         do mx <- timeout (1000 * maxMs) $ measure run
+                            case mx of
+                              Nothing -> return (PrimTestResultTimeout, maxMs)
+                              Just (res, time) ->
+                                  return (PrimTestResultNoTimeout res, time)
+              isPass primTestRes =
+                  case primTestRes of
+                    PrimTestResultNoTimeout fullTestRes ->
+                        ftr_result fullTestRes == Just Pass
+                    PrimTestResultTimeout -> False
+              iterRunWithTimeout i =
+                  do (primTestRes, time) <- runWithTimeout
+                     if isPass primTestRes && i >= 2
+                       then iterRunWithTimeout (i-1)
+                       else return (primTestRes, time)
+          in iterRunWithTimeout (tc_repeat tc)
       post excOrResult =
           let (testResult, time) =
                  case excOrResult of

Test/Framework/TestTypes.hs

@@ -205,6 +205,7 @@ data TestConfig
       , tc_timeoutIsSuccess :: Bool     -- ^ Do not regard timeout as an error
       , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run
       , tc_prevFactor :: Maybe Double   -- ^ Maximum factor a single test is allowed to run slower than its previous execution
+      , tc_repeat :: Int                -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.
       }
 
 instance Show TestConfig where
@@ -226,6 +227,7 @@ instance Show TestConfig where
         showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) .
         showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) .
         showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) .
+        showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) .
         showString " }"
 
 -- | A 'TestReporter' provides hooks to customize the output of HTF.

tests/TestHTF.hs

@@ -61,6 +61,7 @@ import MaxPrevTime
 import UniqTests1
 import UniqTests2
 import PrevFactor
+import Repeat
 import SortByPrevTime
 import Quasi
 
@@ -298,7 +299,7 @@ checkOutput output =
                                                                                       ,"line" .= J.toJSON (97+lineOffset)]]]])
     where
       lineOffset :: Int
-      lineOffset = 31
+      lineOffset = 32
       checkStatus tuple@(pass, fail, error, pending, timedOut) json =
           {-
             {"location":null
@@ -409,6 +410,7 @@ main =
          "MaxCurTime.hs":rest -> maxCurTimeMain rest
          "MaxPrevTime.hs":rest -> maxPrevTimeMain rest
          "PrevFactor.hs":rest -> prevFactorMain rest
+         "Repeat.hs":rest -> repeatMain rest
          "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest
          "UniqTests1.hs":rest -> uniqTests1Main rest
          "UniqTests2.hs":rest -> uniqTests2Main rest

tests/real-bbt/Repeat.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}
+module Repeat (repeatMain) where
+
+import Test.Framework
+
+import Data.IORef
+import System.IO.Unsafe
+
+globalBool :: IORef Bool
+globalBool = unsafePerformIO (newIORef True)
+{-# NOINLINE globalBool #-}
+
+readGlobalBool ::  IO Bool
+readGlobalBool =
+    do b <- readIORef globalBool
+       writeIORef globalBool False
+       return b
+
+test_globalMVarIsTrue =
+    do b <- readGlobalBool
+       assertEqual b True
+
+repeatMain args = htfMainWithArgs args htf_thisModulesTests

tests/real-bbt/Repeat.sh

@@ -0,0 +1,13 @@
+#!/bin/bash
+
+source $(dirname $0)/lib
+
+rm -f .HTF/TestHTF.history
+
+run_test Repeat.hs --repeat 1
+check_success
+check_counts 1 1 0 0 0 0 0
+
+run_test Repeat.hs --repeat 2
+check_fail
+check_counts 1 0 0 1 0 0 0