HTF 0.11.4.0 → 0.12.0.0

raw patch · 31 files changed

+1157/−502 lines, 31 filesdep +timedep +vectordep ~HUnitdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: time, vector

Dependency ranges changed: HUnit, base, containers, mtl, random

API changes (from Hackage documentation)

Files

• ChangeLog +12/−0
• HTF.cabal +15/−10
• TODO.org +1/−1
• Test/Framework.hs +1/−1
• Test/Framework/AssertM.hs +3/−3
• Test/Framework/BlackBoxTest.hs +27/−25
• Test/Framework/CmdlineOptions.hs +169/−52
• Test/Framework/HUnitWrapper.hs +10/−3
• Test/Framework/History.hs +163/−0
• Test/Framework/JsonOutput.hs +17/−17
• Test/Framework/Preprocessor.hs +5/−2
• Test/Framework/QuickCheckWrapper.hs +34/−27
• Test/Framework/TestInterface.hs +104/−0
• Test/Framework/TestManager.hs +216/−47
• Test/Framework/TestManagerInternal.hs +0/−134
• Test/Framework/TestReporter.hs +40/−20
• Test/Framework/TestTypes.hs +43/−21
• Test/Framework/ThreadPool.hs +55/−13
• Test/Framework/XmlOutput.hs +9/−13
• tests/Foo/A.hs +1/−1
• tests/Foo/B.hs +1/−1
• tests/MiscTest.hs +34/−0
• tests/TestHTF.hs +192/−48
• tests/TestHTFHunitBackwardsCompatible.hs +4/−4
• tests/ThreadPoolTest.hs +1/−0
• tests/bbt/should_fail/not_ok_because_stderr2.err +0/−0
• tests/bbt/should_fail/not_ok_because_stdout2.out +0/−0
• tests/bbt/should_pass/not_ok_because_stderr2.err +0/−0
• tests/bbt/should_pass/not_ok_because_stdout2.out +0/−0
• tests/run-tests.sh +0/−18
• tests/test-HTF.cabal +0/−41

@@ -1,3 +1,15 @@+* 0.12.0+  - support for several new commandline options:+      --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+      --fail-fast                 Fail and abort test run as soon as the first test fails.+      --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+      --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+      --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+      --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+      --timeout-is-success        Do not regard a test timeout as an error.+  - potential backward incompatibility: JSON output format changed,+    several new keys were introduced.+ * 0.11.3.4 (2014-04-10)   - completed changelog 

@@ -1,5 +1,5 @@ Name:             HTF-Version:          0.11.4.0+Version:          0.12.0.0 License:          LGPL License-File:     LICENSE Copyright:        (c) 2005-2012 Stefan Wehr@@ -106,8 +106,6 @@   tests/Foo/test.h   tests/Tutorial.hs   tests/run-bbt.sh-  tests/test-HTF.cabal-  tests/run-tests.sh   tests/compile-errors/Foo.h   tests/compile-errors/run-tests.sh   tests/compile-errors/Test1.hs@@ -170,15 +168,19 @@                     old-time >= 1.0,                     array,                     xmlgen >= 0.6,-                    base64-bytestring+                    base64-bytestring,+                    vector,+                    time   if !os(windows)     Build-Depends:   unix >= 2.4   Exposed-Modules:     Test.Framework     Test.Framework.HUnitWrapper     Test.Framework.TestManager+    Test.Framework.TestInterface     Test.Framework.TestTypes     Test.Framework.TestReporter+    Test.Framework.History     Test.Framework.CmdlineOptions     Test.Framework.QuickCheckWrapper     Test.Framework.BlackBoxTest@@ -189,10 +191,9 @@     Test.Framework.XmlOutput     Test.Framework.ThreadPool     Test.Framework.AssertM+    Test.Framework.Colors   Other-Modules:-    Test.Framework.TestManagerInternal     Test.Framework.Utils-    Test.Framework.Colors     Test.Framework.Diff     Test.Framework.Process   Default-language:  Haskell2010@@ -200,7 +201,7 @@  Test-Suite TestHTF   Main-is:           TestHTF.hs-  Hs-Source-Dirs:    tests+  Hs-Source-Dirs:    tests, tests/real-bbt   Type:              exitcode-stdio-1.0   Build-depends:     base == 4.*,                      bytestring >= 0.9,@@ -228,9 +229,13 @@                      HTF   Default-language:  Haskell2010 -Test-Suite Tutorial+Test-Suite MiscTests+  Main-is:           MiscTest.hs   Type:              exitcode-stdio-1.0-  Main-is:           Tutorial.hs   Hs-Source-Dirs:    tests-  Build-depends:     base >= 4, HTF+  Build-depends:     base == 4.*,+                     random,+                     mtl,+                     HTF,+                     HUnit   Default-language:  Haskell2010

@@ -1,4 +1,4 @@-* Relase 0.12+* Relase 0.13 ** New parser *** Add support for MultiWayIf and LambdaCase to haskell-src-exts *** Allow default Fixities for haskell-src-exts

@@ -37,7 +37,7 @@   module Test.Framework.AssertM,    -- * Organizing tests-  TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc+  TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc  ) where 

@@ -13,7 +13,7 @@ import Data.Maybe import qualified Data.Text as T -import Test.Framework.TestManagerInternal+import Test.Framework.TestInterface import Test.Framework.Location import Test.Framework.Colors @@ -23,8 +23,8 @@     genericSubAssert :: Location -> Maybe String -> m a -> m a  instance AssertM IO where-    genericAssertFailure__ loc s = unitTestFail (Just loc) s-    genericSubAssert loc mMsg action = unitTestSubAssert loc mMsg action+    genericAssertFailure__ loc s = failHTF (FullTestResult (Just loc) [] (Just s) (Just Fail))+    genericSubAssert loc mMsg action = subAssertHTF loc mMsg action  -- | Stack trace element for generic assertions. data AssertStackElem

@@ -50,19 +50,19 @@ import qualified Data.Map as Map  import Test.Framework.Process+import Test.Framework.TestInterface import Test.Framework.TestManager-import Test.Framework.TestManagerInternal import Test.Framework.Utils  {- | The type of a function comparing the content of a file against a string, similar to the unix tool @diff@. The first parameter is the name of the file containing the-expected output. If this parameter is 'Nothing', then no output-is expected. The second parameter is the actual output produced.+expected output. If this parameter is 'Nothing', then output+should not be checked. The second parameter is the actual output produced. If the result is 'Nothing' then no difference was found. Otherwise, a 'Just' value contains a string explaining the-different.+difference. -} type Diff = Maybe FilePath -> String -> IO (Maybe String) @@ -121,6 +121,9 @@ endOfOutput :: String -> String endOfOutput s = "[end of " ++ s ++ "]" +blackBoxTestFail :: String -> Assertion+blackBoxTestFail s = failHTF $ mkFullTestResult Fail (Just s)+ {- | Use a value of this datatype to customize various aspects of your black box tests.@@ -128,8 +131,8 @@ data BBTArgs = BBTArgs { bbtArgs_stdinSuffix    :: String -- ^ File extension for the file used as stdin.                        , bbtArgs_stdoutSuffix   :: String -- ^ File extension for the file specifying expected output on stdout.                        , bbtArgs_stderrSuffix   :: String -- ^ File extension for the file specifying expected output on stderr.-                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format.-                       , bbtArgs_verbose        :: Bool   -- ^ Ge verbose or not.+                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. Default: BBTArgs+                       , bbtArgs_verbose        :: Bool   -- ^ Be verbose or not.                        , bbtArgs_stdoutDiff     :: Diff   -- ^ Diff program for comparing output on stdout with the expected value.                        , bbtArgs_stderrDiff     :: Diff   -- ^ Diff program for comparing output on stderr with the expected value.                        }@@ -162,24 +165,21 @@ -} defaultDiff :: Diff defaultDiff expectFile real =-    do mexe <- findExecutable "diff"-       let exe = case mexe of-                   Just p -> p-                   Nothing -> error ("diff command not in path")-       case expectFile of-         Nothing | null real -> return Nothing-                 | otherwise -> return $ Just ("no output expected, but " ++-                                               "given:\n" ++ real ++-                                               (endOfOutput "given output"))-         Just expect ->-             do (out, err, exitCode) <- popen exe ["-u", expect, "-"]-                                          (Just real)-                case exitCode of-                  ExitSuccess -> return Nothing       -- no difference-                  ExitFailure 1 ->                    -- files differ-                      return $ Just (out ++ (endOfOutput "diff output"))-                  ExitFailure i -> error ("diff command failed with exit " ++-                                          "code " ++ show i ++ ": " ++ err)+    case expectFile of+      Nothing -> return Nothing+      Just expect ->+          do mexe <- findExecutable "diff"+             let exe = case mexe of+                         Just p -> p+                         Nothing -> error ("diff command not in path")+             (out, err, exitCode) <- popen exe ["-u", expect, "-"]+                                        (Just real)+             case exitCode of+               ExitSuccess -> return Nothing       -- no difference+               ExitFailure 1 ->                    -- files differ+                   return $ Just (out ++ (endOfOutput "diff output"))+               ExitFailure i -> error ("diff command failed with exit " +++                                       "code " ++ show i ++ ": " ++ err)  {- | Collects all black box tests with the given file extension stored in a specific directory.@@ -198,13 +198,15 @@ with @bbt-dir\/should-pass\/x.num@ as the last commandline argument. The other commandline arguments are taken from the flags specification given in the file whose name is stored in the 'bbtArgs_dynArgsName' field of the 'BBTArgs' record-(see below).+(see below, default is BBTArgs).  If @bbt-dir\/should-pass\/x.in@ existed, its content would be used as stdin. The tests succeeds if the exit code of the program is zero and the output on stdout and stderr matches the contents of @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively.+If @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@ do+not exist, then output is not checked.  The 'bbtArgs_dynArgsName' field of the 'BBTArgs' record specifies a filename that contains some more configuration flags for the tests. The following

@@ -1,4 +1,6 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- -- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de --@@ -31,26 +33,36 @@  import Test.Framework.TestReporter import Test.Framework.TestTypes+import Test.Framework.History import Test.Framework.Utils +#if !MIN_VERSION_base(4,6,0)+import Prelude hiding ( catch )+#endif+import Control.Exception+ import Data.Char (toLower) import Data.Maybe  import System.IO-+import System.Environment hiding (getEnv)+import System.Directory import System.Console.GetOpt import qualified Text.Regex as R  #ifndef mingw32_HOST_OS import System.Posix.Terminal import System.Posix.IO (stdOutput)-import System.Posix.Env (getEnv)+import System.Posix.Env #endif  #ifdef __GLASGOW_HASKELL__ import GHC.Conc ( numCapabilities ) #endif +import qualified Data.ByteString as BS+import Control.Monad+ -- -- CmdlineOptions --@@ -62,13 +74,20 @@     , opts_help :: Bool                 -- ^ If 'True', display a help message and exit.     , opts_negated :: [String]          -- ^ Regular expressions matching test names which should /not/ run.     , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.-    , opts_shuffle :: Bool              -- ^ If 'True' (the default), shuffle tests when running them in parallel.+    , opts_shuffle :: Bool              -- ^ If 'True', shuffle tests when running them in parallel. Default: 'False'     , opts_machineOutput :: Bool        -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format.     , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format.     , opts_useColors :: Maybe Bool      -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors.     , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout     , opts_listTests :: Bool            -- ^ If 'True', lists all tests available and exits.     , opts_split :: Bool                -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile').+    , opts_historyFile :: Maybe FilePath -- ^ History file, default: @./.HTF/<ProgramName>.history@+    , opts_failFast :: Bool             -- ^ Fail and terminate test run as soon as the first test fails. Default: 'False'+    , 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_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error.     }  {- |@@ -81,13 +100,20 @@     , opts_help = False     , opts_negated = []     , opts_threads = Nothing-    , opts_shuffle = True+    , opts_shuffle = False     , opts_machineOutput = False     , opts_machineOutputXml = Nothing     , opts_useColors = Nothing     , opts_outputFile = Nothing     , opts_listTests = False     , opts_split = False+    , opts_historyFile = Nothing+    , opts_failFast = False+    , opts_sortByPrevTime = False+    , opts_maxPrevTimeMs = Nothing+    , opts_maxCurTimeMs = Nothing+    , opts_prevFactor = Nothing+    , opts_timeoutIsSuccess = False     }  processorCount :: Int@@ -97,35 +123,78 @@ processorCount = 1 #endif -optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+optionDescriptions :: [OptDescr (CmdlineOptions -> Either String CmdlineOptions)] optionDescriptions =-    [ Option ['q']     ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"-    , Option ['n']     ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })-                                           "PATTERN") "tests to exclude"-    , Option ['l']     ["list"]   (NoArg (\o -> o { opts_listTests = True })) "list all matching tests"-    , Option ['j']     ["threads"]   (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N")-                                      ("run N tests in parallel, default N=" ++ show processorCount)-    , Option []        ["deterministic"] (NoArg (\o -> o { opts_shuffle = False })) "do not shuffle tests when executing them in parallel."-    , Option ['o']     ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s })-                                               "FILE") "name of output file"-    , Option []        ["json"] (NoArg (\o -> o { opts_machineOutput = True }))-                               "output results in machine-readable JSON format (incremental)"-    , Option []        ["xml"] (ReqArg (\s o -> o { opts_machineOutputXml = Just s }) "FILE")-                               "output results in junit-style XML format"-    , Option []        ["split"] (NoArg (\o -> o { opts_split = True }))-                               "splits results in separate files to avoid file locking (requires -o/--output-file)"-    , Option []        ["colors"]  (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) })-                                           "BOOL") "use colors or not"-    , Option ['h']     ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"+    [ Option ['q']     ["quiet"]+             (NoArg (\o -> Right $ o { opts_quiet = True }))+             "Only display errors."+    , Option ['n']     ["not"]+             (ReqArg (\s o -> Right $ o { opts_negated = s : (opts_negated o) }) "PATTERN")+             "Tests to exclude."+    , Option ['l']     ["list"]+             (NoArg (\o -> Right $ o { opts_listTests = True }))+             "List all matching tests."+    , Option ['j']     ["threads"]+             (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N")+             ("Run N tests in parallel, default N=" ++ show processorCount ++ ".")+    , Option []        ["deterministic"]+             (NoArg (\o -> Right $ o { opts_shuffle = False }))+             "Do not shuffle tests when executing them in parallel."+    , Option ['o']     ["output-file"]+             (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE")+             "Name of output file."+    , Option []        ["json"]+             (NoArg (\o -> Right $ o { opts_machineOutput = True }))+             "Output results in machine-readable JSON format (incremental)."+    , Option []        ["xml"]+             (ReqArg (\s o -> Right $ o { opts_machineOutputXml = Just s }) "FILE")+             "Output results in junit-style XML format."+    , Option []        ["split"]+             (NoArg (\o -> Right $ o { opts_split = True }))+             "Splits results in separate files to avoid file locking (requires -o/--output-file)."+    , Option []        ["colors"]+             (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_useColors = Just b }) "BOOL")+             "Use colors or not."+    , Option []        ["history"]+             (ReqArg (\s o -> Right $ o { opts_historyFile = Just s }) "FILE")+             "Path to the history file. Default: ./.HTF/<ProgramName>.history"+    , Option []        ["fail-fast"]+             (NoArg (\o -> Right $ o { opts_failFast = True }))+             "Fail and abort test run as soon as the first test fails."+    , Option []        ["sort-by-prev-time"]+             (NoArg (\o -> Right $ o { opts_sortByPrevTime = True }))+             "Sort tests ascending by their execution of the previous test run (if available). Default: false"+    , Option []        ["max-prev-ms"]+             (ReqArg (\s o -> parseRead "--max-prev-ms" s >>= \(ms::Int) -> Right $ o { opts_maxPrevTimeMs = Just ms }) "MILLISECONDS")+             "Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run."+    , Option []        ["max-cur-ms"]+             (ReqArg (\s o -> parseRead "--max-cur-ms" s >>= \(ms::Int) ->+                              Right $ o { opts_maxCurTimeMs = Just ms }) "MILLISECONDS")+             "Abort a test that runs more than MILLISECONDS."+    , Option []        ["prev-factor"]+             (ReqArg (\s o -> parseRead "--prev-factor" s >>= \(ms::Double) ->+                              Right $ o { opts_prevFactor = Just ms }) "DOUBLE")+             "Abort a test that runs more than DOUBLE times slower than in a previous run."+    , Option []        ["timeout-is-success"]+             (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True }))+             "Do not regard a test timeout as an error."+    , Option ['h']     ["help"]+             (NoArg (\o -> Right $ o { opts_help = True }))+             "Display this message."     ]     where-      parseThreads Nothing = processorCount+      parseThreads Nothing = Right processorCount       parseThreads (Just s) =           case readM s of-            Just i -> i-            Nothing -> error ("invalid number of threads: " ++ s)+            Just i -> Right i+            Nothing -> Left ("invalid number of threads: " ++ s)       parseBool s =+          Right $           if map toLower s `elem` ["1", "true", "yes", "on"] then True else False+      parseRead opt s =+          case readM s of+            Just i -> Right i+            Nothing -> Left ("invalid value for option " ++ opt ++ ": " ++ s)  {- | @@ -137,38 +206,45 @@ >   where PATTERN is a posix regular expression matching >   the names of the tests to run. >->   -q          --quiet             only display errors->   -n PATTERN  --not=PATTERN       tests to exclude->   -l          --list              list all matching tests->   -j[N]       --threads[=N]       run N tests in parallel, default N=4->               --deterministic     do not shuffle tests when executing them in parallel.->   -o FILE     --output-file=FILE  name of output file->               --json              output results in machine-readable JSON format (incremental)->               --xml=FILE          output results in junit-style XML format->               --split             splits results in separate files to avoid file locking (requires -o/--output-file)->               --colors=BOOL       use colors or not->   -h          --help              display this message+>   -q          --quiet                     Only display errors.+>   -n PATTERN  --not=PATTERN               Tests to exclude.+>   -l          --list                      List all matching tests.+>   -j[N]       --threads[=N]               Run N tests in parallel, default N=1.+>               --deterministic             Do not shuffle tests when executing them in parallel.+>   -o FILE     --output-file=FILE          Name of output file.+>               --json                      Output results in machine-readable JSON format (incremental).+>               --xml=FILE                  Output results in junit-style XML format.+>               --split                     Splits results in separate files to avoid file locking (requires -o/--output-file).+>               --colors=BOOL               Use colors or not.+>               --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+>               --fail-fast                 Fail and abort test run as soon as the first test fails.+>               --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+>               --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+>               --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+>               --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+>               --timeout-is-success        Do not regard a test timeout as an error.+>   -h          --help                      Display this message.  -}  parseTestArgs :: [String] -> Either String CmdlineOptions parseTestArgs args =     case getOpt Permute optionDescriptions args of-      (optTrans, tests, []  ) ->-          let posStrs = tests-              negStrs = opts_negated opts-              pos = map mkRegex posStrs-              neg = map mkRegex negStrs-              pred (FlatTest _ path _ _) =-                  let flat = flatName path-                  in if (any (\s -> s `matches` flat) neg)-                        then False-                        else null pos || any (\s -> s `matches` flat) pos-              opts = (foldr ($) defaultCmdlineOptions optTrans) { opts_filter = pred }-          in case (opts_outputFile opts, opts_split opts) of+      (optTrans, tests, []) ->+          do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans+             case (opts_outputFile opts, opts_split opts) of                (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++                                         usageInfo usageHeader optionDescriptions)-               _ -> Right opts+               _ -> let posStrs = tests+                        negStrs = opts_negated opts+                        pos = map mkRegex posStrs+                        neg = map mkRegex negStrs+                        pred (FlatTest _ path _ _) =+                            let flat = flatName path+                            in if (any (\s -> s `matches` flat) neg)+                                  then False+                                  else null pos || any (\s -> s `matches` flat) pos+                    in Right (opts { opts_filter = pred })       (_,_,errs) ->           Left (concat errs ++ usageInfo usageHeader optionDescriptions)     where@@ -201,14 +277,24 @@            reporters = defaultTestReporters (isParallelFromBool $ isJust threads)                                             (if opts_machineOutput opts then JsonOutput else NoJsonOutput)                                             (if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput)+       historyFile <- getHistoryFile+       history <- getHistory historyFile        return $ TestConfig { tc_quiet = opts_quiet opts                            , tc_threads = threads                            , tc_shuffle = opts_shuffle opts                            , tc_output = output                            , tc_outputXml = opts_machineOutputXml opts                            , tc_reporters = reporters-                           , tc_filter = opts_filter opts-                           , tc_useColors = colors }+                           , tc_filter = opts_filter opts `mergeFilters` (historicFilter history)+                           , tc_useColors = colors+                           , tc_historyFile = historyFile+                           , tc_history = history+                           , tc_sortByPrevTime = opts_sortByPrevTime opts+                           , tc_failFast = opts_failFast opts+                           , tc_maxSingleTestTime = opts_maxCurTimeMs opts+                           , tc_prevFactor = opts_prevFactor opts+                           , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts+                           }     where #ifdef mingw32_HOST_OS       openOutputFile =@@ -243,3 +329,34 @@                                       Just fd -> queryTerminal fd                                       _ -> return False #endif+      getHistoryFile =+          case opts_historyFile opts of+            Just fp -> return fp+            Nothing ->+                do x <- getProgName+                   createDirectoryIfMissing False ".HTF"+                   return (".HTF/" ++ x ++ ".history")+      getHistory fp =+          do b <- doesFileExist fp+             if not b+             then return emptyTestHistory+             else do bs <- BS.readFile fp+                     case deserializeTestHistory bs of+                       Right history -> return history+                       Left err ->+                           do hPutStrLn stderr ("Error deserializing content of history file " ++ fp ++ ": " ++ err)+                              return emptyTestHistory+                  `catch` (\(e::IOException) ->+                               do hPutStrLn stderr ("Error reading history file " ++ fp ++ ": " ++ show e)+                                  return emptyTestHistory)+      mergeFilters f1 f2 t =+          f1 t && f2 t+      historicFilter history t =+          case opts_maxPrevTimeMs opts of+            Nothing -> True+            Just ms ->+                case max (fmap htr_timeMs (findHistoricTestResult (historyKey t) history))+                         (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey t) history))+                of+                  Nothing -> True+                  Just t -> t <= ms

@@ -121,7 +121,7 @@ import Data.List ( (\\) ) import System.IO.Unsafe (unsafePerformIO) -import Test.Framework.TestManagerInternal+import Test.Framework.TestInterface import Test.Framework.Location import Test.Framework.Diff import Test.Framework.Colors@@ -143,6 +143,13 @@ assertFailure_ = gassertFailure_  {- |+Signals that the current unit test is pending.+-}+unitTestPending :: String -> IO a+unitTestPending s =+    failHTF (FullTestResult Nothing [] (Just $ noColor s) (Just Pending))++{- | Use @unitTestPending' msg test@ to mark the given test as pending without removing it from the test suite and without deleting or commenting out the test code. -}@@ -566,7 +573,7 @@ -- -- /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@. subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a-subAssert_ loc ass = unitTestSubAssert loc Nothing ass+subAssert_ loc ass = subAssertHTF loc Nothing ass  -- | Generic variant of 'subAssert_'. gsubAssert_ :: AssertM m => Location -> m a -> m a@@ -574,7 +581,7 @@  -- | Same as 'subAssert_' but with an additional error message. subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a-subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass+subAssertVerbose_ loc msg ass = subAssertHTF loc (Just msg) ass  -- | Generic variant of 'subAssertVerbose_'. gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a

@@ -0,0 +1,163 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Framework.History (++    TestHistory, HistoricTestResult(..), emptyTestHistory, Milliseconds, TestResult(..)+  , serializeTestHistory, deserializeTestHistory+  , findHistoricTestResult, findHistoricSuccessfulTestResult+  , updateTestHistory, mkTestRunHistory+  , historyTests++) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.List as L+import qualified Data.Vector as V+import Data.Time.Clock+import Test.HUnit+import Data.Aeson hiding (Error)+import Data.Aeson.TH+import Test.Framework.TestInterface++-- | A type synonym for time in milliseconds.+type Milliseconds = Int++data TestHistory+    = TestHistory+      { th_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+      , th_index :: !(Map T.Text (HistoricTestResult))+      , th_successfulIndex :: !(Map T.Text (HistoricTestResult))+      }+    deriving (Eq)++instance Show (TestHistory) where+    showsPrec _ _ = showString "<TestHistory>"++emptyTestHistory :: TestHistory+emptyTestHistory =+    TestHistory V.empty Map.empty Map.empty++data TestRunHistory+    = TestRunHistory+      { trh_startTime :: !UTCTime+      , trh_tests :: !(V.Vector (HistoricTestResult))+      }+    deriving (Eq)++instance Show TestRunHistory where+    showsPrec d trh =+        showParen (d > 10) $+        showString "TestRunHistory <hidden time> " .+        showsPrec 11 (trh_tests trh)++data HistoricTestResult+    = HistoricTestResult+      { htr_testId :: !T.Text+      , htr_result :: !TestResult+      , htr_timedOut :: !Bool+      , htr_timeMs :: !Milliseconds+      }+    deriving (Show, Eq)++mkTestRunHistory :: UTCTime -> [HistoricTestResult] -> TestRunHistory+mkTestRunHistory time results = TestRunHistory {+                                  trh_startTime = time+                                , trh_tests = V.fromList results+                                }++isSuccess :: HistoricTestResult -> Bool+isSuccess r = htr_result r == Pass && not (htr_timedOut r)++updateTestHistory :: TestRunHistory -> TestHistory -> TestHistory+updateTestHistory runHistory history =+    let runs = runHistory : V.toList (th_runs history)+    in TestHistory (V.fromList runs) (createIndex runs (const True)) (createIndex runs isSuccess)++-- The [TestRunHistory] list is sorted reverse chronologically+createIndex :: [TestRunHistory] -> (HistoricTestResult -> Bool) -> Map T.Text (HistoricTestResult)+createIndex list pred =+    L.foldl' updateMap Map.empty flatRunHistory+    where+      updateMap m res =+          Map.insertWith (\_new old -> old) (htr_testId res) res m+      flatRunHistory =+          filter pred $ concatMap (\trh -> V.toList (trh_tests trh)) list++findHistoricTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricTestResult id hist = Map.lookup id (th_index hist)++findHistoricSuccessfulTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricSuccessfulTestResult id hist = Map.lookup id (th_successfulIndex hist)++data SerializableTestHistory+    = SerializableTestHistory+      { sth_version :: Int+      , sth_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+      }++_CURRENT_VERSION_ :: Int+_CURRENT_VERSION_ = 0++serializeTestHistory :: TestHistory -> BS.ByteString+serializeTestHistory hist =+    let serHist = SerializableTestHistory {+                    sth_version = _CURRENT_VERSION_+                  , sth_runs = th_runs hist+                  }+    in BSL.toStrict $ encode serHist++deserializeTestHistory :: BS.ByteString -> Either String (TestHistory)+deserializeTestHistory bs =+    -- assume version 0 for now. Later we have to look into the json, find the version and then decide which parser to user+    case decodeStrict bs of+      Nothing -> Left ("could not decode JSON: " ++ show bs)+      Just !serHist ->+          let list = V.toList (sth_runs serHist)+          in Right (TestHistory (sth_runs serHist) (createIndex list (const True)) (createIndex list isSuccess))++testCreateIndex =+    do time <- getCurrentTime+       let index = createIndex (historyList time) (const True)+       if index == expectedIndex+       then return ()+       else assertFailure ("== Expected index:\n" ++ show expectedIndex +++                           "\n== Given index:\n" ++ show index)+    where+      historyList time =+          [mkHist time [mkRes "foo" 1]+          ,mkHist time [mkRes "foo" 2, mkRes "bar" 10]+          ,mkHist time [mkRes "bar" 20, mkRes "egg" 3]]+      expectedIndex = Map.fromList [("foo", mkRes "foo" 1)+                                   ,("bar", mkRes "bar" 10)+                                   ,("egg", mkRes "egg" 3)]+      mkHist time l = TestRunHistory time (V.fromList l)+      mkRes id ms = HistoricTestResult id Pass False ms++historyTests = [("testCreateIndex", testCreateIndex)]++testResultStringMapping :: [(TestResult, T.Text)]+testResultStringMapping =+    [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")]++instance ToJSON TestResult where+    toJSON r = String $+        case L.lookup r testResultStringMapping of+          Just s -> s+          Nothing -> error ("TestResult " ++ show r ++ " not defined in testResultStringMapping")++instance FromJSON TestResult where+    parseJSON v =+        case v of+          String s+              | Just r <- L.lookup s (map (\(x, y) -> (y, x)) testResultStringMapping)+                       -> return r+          _ -> fail ("could not parse JSON value as a test result: " ++ show v)++deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult

@@ -93,6 +93,7 @@       , te_callers :: [(Maybe String, Location)]       , te_message :: T.Text       , te_wallTimeMs :: Int+      , te_timedOut :: Bool       }  instance J.ToJSON TestEndEventObj where@@ -105,18 +106,11 @@                                              (te_callers te))                  ,"result" .= J.toJSON (te_result te)                  ,"message" .= J.toJSON (te_message te)-                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)]+                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)+                 ,"timedOut" .= J.toJSON (te_timedOut te)]  instance HTFJsonObj TestEndEventObj -instance J.ToJSON TestResult where-    toJSON r = J.String $-        case r of-          Pass -> "pass"-          Pending -> "pending"-          Fail -> "fail"-          Error -> "error"- -- "test-list" message data TestListObj     = TestListObj@@ -138,6 +132,8 @@       , tr_pending :: Int       , tr_failed :: Int       , tr_errors :: Int+      , tr_timedOut :: Int+      , tr_filtered :: Int       }  instance J.ToJSON TestResultsObj where@@ -146,6 +142,8 @@                         ,"pending" .= J.toJSON (tr_pending r)                         ,"failures" .= J.toJSON (tr_failed r)                         ,"errors" .= J.toJSON (tr_errors r)+                        ,"timedOut" .= J.toJSON (tr_timedOut r)+                        ,"filtered" .= J.toJSON (tr_filtered r)                         ,"wallTime" .= J.toJSON (tr_wallTimeMs r)]  instance HTFJsonObj TestResultsObj@@ -195,20 +193,22 @@     let r = ft_payload ftr         msg = renderColorString (rr_message r) False     in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r)-                       msg (rr_wallTimeMs r)+                       msg (rr_wallTimeMs r) (rr_timeout r)  mkTestListObj :: [(FlatTest, String)] -> TestListObj mkTestListObj l =     TestListObj (map (\(ft, flatName) -> mkTestObj ft flatName) l) -mkTestResultsObj :: Milliseconds -> Int -> Int -> Int -> Int -> TestResultsObj-mkTestResultsObj time passed pending failed errors =+mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj+mkTestResultsObj arg =     TestResultsObj-    { tr_wallTimeMs = time-    , tr_passed = passed-    , tr_pending = pending-    , tr_failed = failed-    , tr_errors = errors+    { tr_wallTimeMs = rgra_timeMs arg+    , tr_passed = length (rgra_passed arg)+    , tr_pending = length (rgra_pending arg)+    , tr_failed = length (rgra_failed arg)+    , tr_errors = length (rgra_errors arg)+    , tr_timedOut = length (rgra_timedOut arg)+    , tr_filtered = length (rgra_filtered arg)     }  decodeObj :: HTFJsonObj a => a -> BSL.ByteString

@@ -128,7 +128,7 @@  data Definition = TestDef String Location String                 | PropDef String Location String-                  deriving (Show)+                  deriving (Eq, Show)  data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma                   deriving (Show)@@ -197,7 +197,10 @@     let (modName, defs, impDecls) = doAna (zip [1..] (lines inputString)) ("", [], [])     in return $ ModuleInfo "Test.Framework." impDecls defs modName     where-      doAna [] (modName, revDefs, impDecls) = (modName, reverse revDefs, reverse impDecls)+      defEqByName (TestDef n1 _ _) (TestDef n2 _ _) = n1 == n2+      defEqByName (PropDef n1 _ _) (PropDef n2 _ _) = n1 == n2+      defEqByName _ _ = False+      doAna [] (modName, revDefs, impDecls) = (modName, reverse (List.nubBy defEqByName revDefs), reverse impDecls)       doAna ((lineNo, line) : restLines) (modName, defs, impDecls) =           case line of             'm':'o':'d':'u':'l':'e':rest ->

@@ -52,23 +52,23 @@ import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..),-                           throw, throwIO, catch, catches, evaluate )+                           throw, catch, catches, evaluate ) import Data.Typeable (Typeable) import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef-import qualified Data.ByteString.Char8 as BSC-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Base64 as Base64  import Test.QuickCheck import Test.QuickCheck.Property hiding (reason)-import Test.Framework.TestManager-import Test.Framework.TestManagerInternal-import Test.HUnit.Lang (HUnitFailure(..))+import Test.Framework.TestInterface +_DEBUG_ :: Bool+_DEBUG_ = False++debug :: String -> IO ()+debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return ()+ data QCState = QCState { qc_args :: !Args }  qcState :: IORef QCState@@ -98,6 +98,18 @@  instance Exception QCPendingException +quickCheckTestError :: Maybe String -> Assertion+quickCheckTestError m = failHTF $ mkFullTestResult Error m++quickCheckTestFail :: Maybe String -> Assertion+quickCheckTestFail m = failHTF $ mkFullTestResult Fail m++quickCheckTestPending :: String -> Assertion+quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m)++quickCheckTestPass :: String -> Assertion+quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m)+ -- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function -- is used internally in the code generated by @htfpp@, do not use it directly. qcAssertion :: (QCAssertion t) => t -> Assertion@@ -119,23 +131,23 @@                                  AnyTestable t' -> quickCheckWithResult args t'                           return (Right x)                       `catches`-                       [Handler $ \(QCPendingException msg) -> return $ Left (True, msg)-                       ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]+                       [Handler $ \(QCPendingException msg) -> return $ Left msg]+                debug ("QuickCheck result: " ++ show res)                 case res of-                  Left (isPending, err) ->-                      if isPending-                         then quickCheckTestPending err-                         else quickCheckTestError (Just err)+                  Left err ->+                      quickCheckTestPending err                   Right (Success { output=msg }) ->                       quickCheckTestPass (adjustOutput msg)                   Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->-                      if pendingPrefix `List.isPrefixOf` reason-                         then let pendingMsg = let s = drop (length pendingPrefix) reason-                                               in take (length s - length pendingSuffix) s-                              in quickCheckTestPending pendingMsg-                         else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))-                                     out = adjustOutput msg-                                 quickCheckTestFail (Just (out ++ "\n" ++ replay))+                      case () of+                        _| pendingPrefix `List.isPrefixOf` reason ->+                             let pendingMsg = let s = drop (length pendingPrefix) reason+                                              in take (length s - length pendingSuffix) s+                             in quickCheckTestPending pendingMsg+                          | otherwise ->+                              let replay = "Replay argument: " ++ (show (show (Just (gen, size))))+                                  out = adjustOutput msg+                              in quickCheckTestFail (Just (out ++ "\n" ++ replay))                   Right (GaveUp { output=msg }) ->                       quickCheckTestFail (Just (adjustOutput msg))                   Right (NoExpectedFailure { output=msg }) ->@@ -192,9 +204,4 @@  assertionAsProperty :: IO () -> Property assertionAsProperty action =-    ioProperty $ catch action transHUnitFail >> return True-    where-      transHUnitFail exc@(HUnitFailure msg) =-          let exc' = "<<<HTF<<<" ++ (BSC.unpack $ Base64.encode $ T.encodeUtf8 $ T.pack msg)-                     ++ ">>>HTF>>>"-          in throwIO (HUnitFailure exc')+    ioProperty $ action >> return True

@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+--+-- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{- |++This module defines the API for HTF plugins.++-}++module Test.Framework.TestInterface (++    Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..), failHTF, subAssertHTF+  , mkFullTestResult++) where++import Test.Framework.Location+import Test.Framework.Colors++import Control.Monad.Trans.Control+import Data.Typeable+import qualified Control.Exception as Exc+import qualified Control.Exception.Lifted as ExcLifted++{- | An assertion is just an 'IO' action. Internally, the body of any test+in HTF is of type 'Assertion'. If a test specification of a certain plugin+has a type different from 'Assertion', the plugin's preprocessor pass must+inject wrapper code to convert the test specification into an assertion.++Assertions may use 'failHTF' to signal a 'TestResult' different from+'Pass'. If the assertion finishes successfully, the tests passes+implicitly.++Please note: the assertion must not swallow any exceptions! Otherwise,+timeouts and other things might not work as expected.+-}+type Assertion = IO ()++-- | The summary result of a test.+data TestResult = Pass | Pending | Fail | Error+                deriving (Show, Read, Eq)++-- | The full result of a test, as used by HTF plugins.+data FullTestResult+    = FullTestResult+      { ftr_location :: Maybe Location                     -- ^ The location of a possible failure+      , ftr_callingLocations :: [(Maybe String, Location)] -- ^ The "stack" to the location of a possible failure+      , ftr_message :: Maybe ColorString                   -- ^ An error message+      , ftr_result :: Maybe TestResult                     -- ^ The outcome of the test, 'Nothing' means timeout+      } deriving (Eq, Show, Read)++-- | Auxiliary function for contructing a 'FullTestResult'.+mkFullTestResult :: TestResult -> Maybe String -> FullTestResult+mkFullTestResult r msg =+    FullTestResult+    { ftr_location = Nothing+    , ftr_callingLocations = []+    , ftr_message = fmap noColor msg+    , ftr_result = Just r+    }++-- Internal exception type for propagating exceptions.+data HTFFailureException+    = HTFFailure FullTestResult+      deriving (Show, Typeable)++instance Exc.Exception HTFFailureException++{- |+Terminate a HTF test, usually to signal a failure. The result of the test+is given in the 'FullTestResult' argument.+-}+failHTF :: MonadBaseControl IO m => FullTestResult -> m a+-- Important: force the string argument, otherwise an error embedded+-- lazily inside the string might escape.+failHTF r = length (show r) `seq` ExcLifted.throwIO (HTFFailure r)++{- |+Opens a new assertion stack frame to allow for sensible location information.+-}+subAssertHTF :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a+subAssertHTF loc mMsg action =+    action `ExcLifted.catch`+               (\(HTFFailure res) ->+                    let newRes = res { ftr_callingLocations = (mMsg, loc) : ftr_callingLocations res }+                    in failHTF newRes)

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} -- -- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de --@@ -30,7 +32,7 @@   module Test.Framework.TestTypes,    -- * Running tests-  htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',+  htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs',   runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',    -- * Organzing tests@@ -45,22 +47,25 @@ import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs)-import Control.Exception (finally)+import qualified Control.Exception as Exc import Data.Maybe+import Data.Time import qualified Data.List as List+import qualified Data.ByteString as BS+import Data.IORef+import Control.Concurrent  import System.IO -import qualified Test.HUnit.Lang as HU- import Test.Framework.Utils-import Test.Framework.TestManagerInternal+import Test.Framework.TestInterface import Test.Framework.TestTypes import Test.Framework.CmdlineOptions import Test.Framework.TestReporter import Test.Framework.Location import Test.Framework.Colors import Test.Framework.ThreadPool+import Test.Framework.History  -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor.@@ -126,63 +131,190 @@     let fts = concatMap flattenTest ts     in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int)-mkFlatTestRunner ft = (pre, action, post)+maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds+maxRunTime tc ft =+    let mt1 = tc_maxSingleTestTime tc+        mt2 =+            case tc_prevFactor tc of+              Nothing -> Nothing+              Just d ->+                  case max (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey ft) (tc_history tc)))+                           (fmap htr_timeMs (findHistoricTestResult (historyKey ft) (tc_history tc)))+                  of+                    Nothing -> Nothing+                    Just t -> Just $ ceiling (fromInteger (toInteger t) * d)+    in case (mt1, mt2) of+         (Just t1, Just t2) -> Just (min t1 t2)+         (_, Nothing) -> mt1+         (Nothing, _) -> mt2++-- | HTF uses this function to execute the given assertion as a HTF test.+performTestHTF :: Assertion -> IO FullTestResult+performTestHTF action =+    do action+       return (mkFullTestResult Pass Nothing)+     `Exc.catches`+      [Exc.Handler (\(HTFFailure res) -> return res)+      ,Exc.Handler handleUnexpectedException]     where+      handleUnexpectedException exc =+          case Exc.fromException exc of+            Just (async :: Exc.AsyncException) ->+                case async of+                  Exc.StackOverflow -> exceptionAsError exc+                  _ -> Exc.throwIO exc+            _ -> exceptionAsError exc+      exceptionAsError exc =+          return (mkFullTestResult Error (Just $ show (exc :: Exc.SomeException)))++data TimeoutResult a+    = TimeoutResultOk a+    | TimeoutResultException Exc.SomeException+    | TimeoutResultTimeout++timeout :: Int -> IO a -> IO (Maybe a)+timeout microSecs action+    | microSecs < 0 = fmap Just action+    | microSecs == 0 = return Nothing+    | otherwise =+        do resultChan <- newChan+           finishedVar <- newIORef False+           workerTid <- forkIO (wrappedAction resultChan finishedVar)+           _ <- forkIO (threadDelay microSecs >> writeChan resultChan TimeoutResultTimeout)+           res <- readChan resultChan+           case res of+             TimeoutResultTimeout ->+                 do atomicModifyIORef finishedVar (\_ -> (True, ()))+                    killThread workerTid+                    return Nothing+             TimeoutResultOk x ->+                 return (Just x)+             TimeoutResultException exc ->+                 Exc.throwIO exc+    where+      wrappedAction resultChan finishedVar =+          Exc.mask $ \restore ->+                   (do x <- restore action+                       writeChan resultChan (TimeoutResultOk x))+                   `Exc.catch`+                   (\(exc::Exc.SomeException) ->+                        do b <- shouldReraiseException exc finishedVar+                           if b then Exc.throwIO exc else writeChan resultChan (TimeoutResultException exc))+      shouldReraiseException exc finishedVar =+          case Exc.fromException exc of+            Just (async :: Exc.AsyncException) ->+                case async of+                  Exc.ThreadKilled -> atomicModifyIORef finishedVar (\old -> (old, old))+                  _ -> return False+            _ -> return False++data PrimTestResult+    = PrimTestResultNoTimeout FullTestResult+    | PrimTestResultTimeout++mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)+mkFlatTestRunner tc ft = (pre, action, post)+    where       pre = reportTestStart ft-      action _ = measure $ HU.performTestCase (wto_payload (ft_payload 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)       post excOrResult =-          let (testResult, (mLoc, callers, msg, time)) =+          let (testResult, time) =                  case excOrResult of-                   Left exc -> (Error, (Nothing,-                                        [],-                                        noColor ("Running test unexpectedly failed: " ++ show exc),-                                        (-1)))+                   Left exc ->+                       (FullTestResult+                        { ftr_location = Nothing+                        , ftr_callingLocations = []+                        , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc)+                        , ftr_result = Just Error+                        }+                       ,(-1))                    Right (res, time) ->                        case res of-                         Nothing -> (Pass, (Nothing, [], emptyColorString, time))-                         Just (isFailure, msg') ->-                           if ft_sort ft /= QuickCheckTest-                              then let utr = deserializeHUnitMsg msg'-                                       r = case () of-                                             _| utr_pending utr -> Pending-                                              | isFailure -> Fail-                                              | otherwise -> Error-                                   in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time))-                              else let (r, mUnitTestResult, s) = deserializeQuickCheckMsg msg'-                                       loc = join $ fmap utr_location mUnitTestResult-                                       callers = fromMaybe [] $ fmap utr_callingLocations mUnitTestResult-                                       msg =-                                           case mUnitTestResult of-                                             Just utr -> utr_message utr +++ noColor "\n" +++ noColor s-                                             Nothing -> noColor s-                                   in (r, (loc, callers, msg, time))+                         PrimTestResultTimeout ->+                             (FullTestResult+                              { ftr_location = Nothing+                              , ftr_callingLocations = []+                              , ftr_message = Just $ colorize warningColor "timeout"+                              , ftr_result = Nothing+                              }+                             ,time)+                         PrimTestResultNoTimeout res ->+                             let res' =+                                     if isNothing (ftr_message res) && isNothing (ftr_result res)+                                     then res { ftr_message = Just (colorize warningColor "timeout") }+                                     else res+                             in (res', time)+              (sumRes, isTimeout) =+                  case ftr_result testResult of+                    Just x -> (x, False)+                    Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True)               rr = FlatTest+                      { ft_sort = ft_sort ft                      , ft_path = ft_path ft                      , ft_location = ft_location ft-                     , ft_payload = RunResult testResult mLoc callers msg time }+                     , ft_payload = RunResult sumRes (ftr_location testResult)+                                              (ftr_callingLocations testResult)+                                              (fromMaybe emptyColorString (ftr_message testResult))+                                              time isTimeout+                     }           in do modify (\s -> s { ts_results = rr : ts_results s })                 reportTestResult rr+                return (stopFlag sumRes)+      stopFlag result =+          if not (tc_failFast tc)+          then DoNotStop+          else case result of+                 Pass -> DoNotStop+                 Pending -> DoNotStop+                 Fail -> DoStop+                 Error -> DoStop -runAllFlatTests :: [FlatTest] -> TR ()-runAllFlatTests tests =+runAllFlatTests :: TestConfig -> [FlatTest] -> TR ()+runAllFlatTests tc tests' =     do reportGlobalStart tests        tc <- ask        case tc_threads tc of          Nothing ->-             let entries = map mkFlatTestRunner tests+             let entries = map (mkFlatTestRunner tc) tests              in tp_run sequentialThreadPool entries          Just i ->              let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests-                 pentries' = map mkFlatTestRunner ptests-                 sentries = map mkFlatTestRunner stests+                 pentries' = map (mkFlatTestRunner tc) ptests+                 sentries = map (mkFlatTestRunner tc) stests              in do tp <- parallelThreadPool i                    pentries <- if tc_shuffle tc                                then liftIO (shuffleIO pentries')                                else return pentries'                    tp_run tp pentries                    tp_run sequentialThreadPool sentries+    where+      tests = sortTests tests'+      sortTests ts =+          if not (tc_sortByPrevTime tc)+          then ts+          else map snd $ List.sortBy compareTests (map (\t -> (historyKey t, t)) ts)+      compareTests (t1, _) (t2, _) =+          case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc)))+                    (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc)))+               ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc)))+                    (fmap htr_timeMs (findHistoricTestResult t2 (tc_history tc))))+          of+            (Just t1, Just t2) -> compare t1 t2+            (Just _, Nothing) -> GT+            (Nothing, Just _) -> LT+            (Nothing, Nothing) -> EQ  -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t              -- ^ Testable thing@@ -238,13 +370,17 @@                    (if opts_listTests opts                       then let fts = filter (opts_filter opts) (flatten t)                            in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)-                      else runTestWithConfig' tc t)-               return (printSummary `finally` cleanup tc, ecode)+                      else do (printSummary, ecode, history) <- runTestWithConfig' tc t+                              storeHistory (tc_historyFile tc) history+                              return (printSummary, ecode))+               return (printSummary `Exc.finally` cleanup tc, ecode)     where       cleanup tc =           case tc_output tc of             TestOutputHandle h True -> hClose h             _ -> return ()+      storeHistory file history =+          BS.writeFile file (serializeTestHistory history)  -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,@@ -253,32 +389,59 @@ -- -- A test is /successful/ if the test terminates and no assertion fails. -- A test is said to /fail/ if an assertion fails but no other error occur.-runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode+runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory) runTestWithConfig tc t =-    do (printSummary, ecode) <- runTestWithConfig' tc t+    do (printSummary, ecode, history) <- runTestWithConfig' tc t        printSummary-       return ecode+       return (ecode, history)  -- | Runs something testable with the given 'TestConfig'. Does not -- print the overall test results but returns an 'IO' action for doing so. -- See 'runTestWithConfig' for a specification of the 'ExitCode' result.-runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode)+runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory) runTestWithConfig' tc t =-     do ((_, s, _), time) <-+     do let allTests = flatten t+            activeTests = filter (tc_filter tc) allTests+            filteredTests = filter (not . tc_filter tc) allTests+        startTime <- getCurrentTime+        ((_, s, _), time) <-             measure $-            runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState+            runRWST (runAllFlatTests tc activeTests) tc initTestState         let results = reverse (ts_results s)             passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results             pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results             failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results             error = filter (\ft -> (rr_result . ft_payload) ft == Error) results+            timedOut = filter (\ft -> (rr_timeout . ft_payload) ft) results+            arg = ReportGlobalResultsArg+                  { rgra_timeMs = time+                  , rgra_passed = passed+                  , rgra_pending = pending+                  , rgra_failed = failed+                  , rgra_errors = error+                  , rgra_timedOut = timedOut+                  , rgra_filtered = filteredTests+    }         let printSummary =-                runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run+                runRWST (reportGlobalResults arg) tc (TestState [] (ts_index s)) -- keep index from run+            !newHistory = updateHistory startTime results (tc_history tc)         return (printSummary >> return (),                 case () of                    _| length failed == 0 && length error == 0 -> ExitSuccess                     | length error == 0 -> ExitFailure 1-                    | otherwise -> ExitFailure 2)+                    | otherwise -> ExitFailure 2+               ,newHistory)+    where+      updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory+      updateHistory time results history =+          let runHistory = mkTestRunHistory time (map (\res -> HistoricTestResult {+                                                                 htr_testId = historyKey res+                                                               , htr_result = rr_result (ft_payload res)+                                                               , htr_timedOut = rr_timeout (ft_payload res)+                                                               , htr_timeMs = rr_wallTimeMs (ft_payload res)+                                                               })+                                                      results)+          in updateTestHistory runHistory history  -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.@@ -286,5 +449,11 @@ htfMain :: TestableHTF t => t -> IO () htfMain tests =     do args <- getArgs-       ecode <- runTestWithArgs args tests+       htfMainWithArgs args tests++-- | Runs something testable by parsing the commandline arguments as test options+-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.+htfMainWithArgs :: TestableHTF t => [String] -> t -> IO ()+htfMainWithArgs args tests =+    do ecode <- runTestWithArgs args tests        exitWith ecode

@@ -1,134 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}------ Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.TestManagerInternal (--  UnitTestResult(..),--  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,-  quickCheckTestPass, deserializeQuickCheckMsg,-  unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert,-  blackBoxTestFail,--) where--import Test.Framework.TestTypes-import Test.Framework.Utils-import Test.Framework.Location-import Test.Framework.Colors--import qualified Test.HUnit.Lang as HU-import Control.Monad.Trans.Control-import qualified Control.Exception.Lifted as Exc-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Base64 as Base64-import qualified Data.ByteString.Char8 as BSC--assertFailureHTF :: String -> Assertion--- Important: force the string argument, otherwise an error embedded--- lazily inside the string might escape.-assertFailureHTF s = length s `seq` HU.assertFailure s---- This is a HACK: we encode a custom error message for QuickCheck--- failures and errors in a string, which is later parsed using read!-quickCheckTestError :: Maybe String -> Assertion-quickCheckTestError m = assertFailureHTF (show (Error, m))--quickCheckTestFail :: Maybe String -> Assertion-quickCheckTestFail m = assertFailureHTF (show (Fail, m))--quickCheckTestPending :: String -> Assertion-quickCheckTestPending m = assertFailureHTF (show (Pending, Just m))--quickCheckTestPass :: String -> Assertion-quickCheckTestPass m = assertFailureHTF (show (Pass, Just m))--deserializeQuickCheckMsg :: String -> (TestResult, Maybe UnitTestResult, String)-deserializeQuickCheckMsg msg =-    case readM msg of-      Nothing ->-          (Error, Nothing, msg)-      Just (r, ms) ->-          case ms of-            Nothing -> (r, Nothing, "")-            Just s ->-                let (utr, msg) = extractUnitTestResult (T.pack s)-                in (r, utr, T.unpack msg)-    where-      extractUnitTestResult t =-          case breakOn (T.pack "<<<HTF<<<") t of-            Nothing -> (Nothing, t)-            Just (pref, rest) ->-                case breakOn (T.pack ">>>HTF>>>") rest of-                  Nothing -> (Nothing, t)-                  Just (serUtr, suf) ->-                      case Base64.decode (BSC.pack (T.unpack serUtr)) of-                        Left _ -> (Nothing, t)-                        Right bs ->-                            case T.decodeUtf8' bs of-                              Left _ -> (Nothing, t)-                              Right x ->-                                  case readM (T.unpack x) of-                                    Nothing -> (Nothing, t)-                                    Just utr ->-                                        (Just utr,-                                         pref `T.append` suf)-      breakOn x t =-          case T.breakOn x t of-            (pref, suf) ->-                if T.null suf-                then Nothing-                else Just (pref, T.drop (T.length x) suf)---- This is a HACK: we encode location and pending information as a datatype--- that we show and parse later using read.-data UnitTestResult-    = UnitTestResult-      { utr_location :: Maybe Location-      , utr_callingLocations :: [(Maybe String, Location)]-      , utr_message :: ColorString-      , utr_pending :: Bool-      } deriving (Eq, Show, Read)--unitTestFail :: Maybe Location -> ColorString -> IO a-unitTestFail loc s =-    do assertFailureHTF (show (UnitTestResult loc [] s False))-       error "unitTestFail: UNREACHABLE"--unitTestSubAssert :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a-unitTestSubAssert loc mMsg action =-    action `Exc.catch` (\(HU.HUnitFailure s) -> let res = deserializeHUnitMsg s-                                                    newRes = res { utr_callingLocations = (mMsg, loc) : utr_callingLocations res }-                                                in Exc.throwIO (HU.HUnitFailure $ show newRes))---- Mark a unit test as pending without removing it from the test suite.-unitTestPending :: String -> IO a-unitTestPending s =-    do assertFailureHTF (show (UnitTestResult Nothing [] (noColor s) True))-       error "unitTestFail: UNREACHABLE"--deserializeHUnitMsg :: String -> UnitTestResult-deserializeHUnitMsg msg =-    case readM msg of-      Just r -> r-      _ -> UnitTestResult Nothing [] (noColor msg) False--blackBoxTestFail :: String -> Assertion-blackBoxTestFail = assertFailureHTF

@@ -54,9 +54,9 @@  -- | Invokes 'tr_reportGlobalResults' on all test reporters registered. reportGlobalResults :: ReportGlobalResults-reportGlobalResults t l1 l2 l3 l4 =+reportGlobalResults arg =     do reps <- asks tc_reporters-       mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps+       mapM_ (\r -> tr_reportGlobalResults r arg) reps  data IsParallel = Parallel | NonParallel @@ -188,30 +188,50 @@     reportStringTR Info (render (renderTestNames l))  reportGlobalResultsH :: ReportGlobalResults-reportGlobalResultsH t passedL pendingL failedL errorL =-    do let passed = length passedL-           pending = length pendingL-           failed = length failedL-           error = length errorL+reportGlobalResultsH arg =+    do let passed = length (rgra_passed arg)+           pending = length (rgra_pending arg)+           failed = length (rgra_failed arg)+           error = length (rgra_errors arg)+           timedOut = length (rgra_timedOut arg)+           filtered = length (rgra_filtered arg)            total = passed + failed + error + pending        let pendings = colorize pendingColor "* Pending:"            failures = colorize warningColor "* Failures:"            errors = colorize warningColor "* Errors:"-       reportTR Info ("* Tests:    " +++ showC total +++ "\n" +++-                      "* Passed:   " +++ showC passed +++ "\n" +++-                      pendings +++ "  " +++ showC pending +++ "\n" +++-                      failures +++ " " +++ showC failed +++ "\n" +++-                      errors +++ "   " +++ showC error)+       reportTR Info ("* Tests:     " +++ showC total +++ "\n" ++++                      "* Passed:    " +++ showC passed +++ "\n" ++++                      pendings +++ "   " +++ showC pending +++ "\n" ++++                      failures +++ "  " +++ showC failed +++ "\n" ++++                      errors +++ "    " +++ showC error +++ "\n" ++++                      "* Timed out: " +++ showC timedOut +++ "\n" ++++                      "* Filtered:  " +++ showC filtered)+       when (timedOut > 0) $+            if timedOut < 10+            then+                reportTR Info+                    ("\n" +++ noColor "* Timed out:" +++ "\n" +++ renderTestNames' (reverse (rgra_timedOut arg)))+            else+                reportTR Info+                  ("\n" +++ noColor "* Timed out: (" +++ showC timedOut +++ noColor ", too many to list)")+       when (filtered > 0) $+            if filtered < 10+            then+                reportTR Info+                  ("\n" +++ noColor "* Filtered:" +++ "\n" +++ renderTestNames' (reverse (rgra_filtered arg)))+            else+                reportTR Info+                  ("\n" +++ noColor "* Filtered: (" +++ showC filtered +++ noColor ", too many to list)")        when (pending > 0) $           reportTR Info-              ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse pendingL))+              ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg)))        when (failed > 0) $           reportTR Info-              ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse failedL))+              ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg)))        when (error > 0) $           reportTR Info-              ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse errorL))-       reportStringTR Info ("\nTotal execution time: " ++ show t ++ "ms")+              ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse (rgra_errors arg)))+       reportStringTR Info ("\nTotal execution time: " ++ show (rgra_timeMs arg) ++ "ms")     where       showC x = noColor (show x)       renderTestNames' rrs =@@ -257,13 +277,13 @@     in reportJsonTR json  reportGlobalResultsM :: ReportGlobalResults-reportGlobalResultsM t pass pending failed errors =-    let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors)+reportGlobalResultsM arg =+    let json = mkTestResultsObj arg     in reportJsonTR json  reportGlobalResultsXml :: ReportGlobalResults-reportGlobalResultsXml t pass pending failed errors =-    do let xml = mkGlobalResultsXml t pass pending failed errors+reportGlobalResultsXml arg =+    do let xml = mkGlobalResultsXml arg        tc <- ask        case tc_outputXml tc of          Just fname -> liftIO $ withFile fname WriteMode $ \h -> BSL.hPut h xml

@@ -9,16 +9,16 @@ module Test.Framework.TestTypes (    -- * Organizing tests-  TestID, Assertion, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),+  TestID, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),   TestSuite(..), TestSort(..),   TestPath(..), GenFlatTest(..), FlatTest, TestFilter,-  testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions,+  testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey,    -- * Executing tests   TR, TestState(..), initTestState, TestConfig(..), TestOutput(..),    -- * Reporting results-  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults,+  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..),   TestReporter(..), emptyTestReporter, attachCallStack, CallStack,    -- * Specifying results.@@ -28,14 +28,14 @@  import Test.Framework.Location import Test.Framework.Colors+import Test.Framework.History+import Test.Framework.TestInterface  import Control.Monad.RWS import System.IO import Data.Maybe import qualified Data.List as List---- | An assertion is just an 'IO' action.-type Assertion = IO ()+import qualified Data.Text as T  -- | Type for naming tests. type TestID = String@@ -91,6 +91,7 @@ -- | A type denoting the hierarchical name of a test. data TestPath = TestPathBase TestID               | TestPathCompound (Maybe TestID) TestPath+                deriving (Show)  -- | Splits a 'TestPath' into a list of test identifiers. testPathToList :: TestPath -> [Maybe TestID]@@ -130,19 +131,16 @@       , ft_payload :: a               -- ^ A generic payload.       } +-- | Key of a flat test for the history database.+historyKey :: GenFlatTest a -> T.Text+historyKey ft = T.pack (flatName (ft_path ft))+ -- | Flattened representation of tests. type FlatTest = GenFlatTest (WithTestOptions Assertion)  -- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. type TestFilter = FlatTest -> Bool --- | The summary result of a test.-data TestResult = Pass | Pending | Fail | Error-                deriving (Show, Read, Eq)---- | A type synonym for time in milliseconds.-type Milliseconds = Int- -- | A type for call-stacks type CallStack = [(Maybe String, Location)] @@ -154,6 +152,7 @@       , rr_callers :: CallStack       -- ^ Information about the callers of the location where the test failed       , rr_message :: ColorString     -- ^ A message describing the result.       , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds.+      , rr_timeout :: Bool            -- ^ 'True' if the execution took too long       }  attachCallStack :: ColorString -> CallStack -> ColorString@@ -199,6 +198,13 @@       , tc_filter :: TestFilter         -- ^ Filter for the tests to run.       , tc_reporters :: [TestReporter]  -- ^ Test reporters to use.       , tc_useColors :: Bool            -- ^ Whether to use colored output+      , tc_historyFile :: FilePath      -- ^ Path to history file+      , tc_history :: TestHistory       -- ^ History of previous test runs+      , tc_sortByPrevTime :: Bool       -- ^ Sort ascending by previous execution times+      , tc_failFast :: Bool             -- ^ Stop test run as soon as one test fails+      , 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       }  instance Show TestConfig where@@ -206,10 +212,20 @@         showParen (prec > 0) $         showString "TestConfig { " .         showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .---        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_shuffle=" . showsPrec 1 (tc_shuffle tc) .         showString ", tc_output=" . showsPrec 1 (tc_output tc) .+        showString ", tc_outputXml=" . showsPrec 1 (tc_outputXml tc) .         showString ", tc_filter=<filter>" .         showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) .+        showString ", tc_useColors=" . showsPrec 1 (tc_useColors tc) .+        showString ", tc_historyFile=" . showsPrec 1 (tc_historyFile tc) .+        showString ", tc_history=" . showsPrec 1 (tc_history tc) .+        showString ", tc_sortByPrevTime=" . showsPrec 1 (tc_sortByPrevTime tc) .+        showString ", tc_failFast=" . showsPrec 1 (tc_failFast tc) .+        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 " }"  -- | A 'TestReporter' provides hooks to customize the output of HTF.@@ -231,7 +247,7 @@       , tr_reportGlobalStart = \_ -> return ()       , tr_reportTestStart = \_ -> return ()       , tr_reportTestResult = \_ -> return ()-      , tr_reportGlobalResults = \_ _ _ _ _ -> return ()+      , tr_reportGlobalResults = \_ -> return ()       }  instance Show TestReporter where@@ -252,10 +268,16 @@ -- | Reports the result of a single test. type ReportTestResult = FlatTestResult -> TR () +data ReportGlobalResultsArg+    = ReportGlobalResultsArg+    { rgra_timeMs :: Milliseconds+    , rgra_passed :: [FlatTestResult]+    , rgra_pending :: [FlatTestResult]+    , rgra_failed :: [FlatTestResult]+    , rgra_errors :: [FlatTestResult]+    , rgra_timedOut :: [FlatTestResult]+    , rgra_filtered :: [FlatTest]+    }+ -- | Reports the overall results of all tests.-type ReportGlobalResults = Milliseconds     -- ^ wall time in ms-                        -> [FlatTestResult] -- ^ passed tests-                        -> [FlatTestResult] -- ^ pending tests-                        -> [FlatTestResult] -- ^ failed tests-                        -> [FlatTestResult] -- ^ erroneous tests-                        -> TR ()+type ReportGlobalResults = ReportGlobalResultsArg -> TR ()

@@ -19,8 +19,8 @@  module Test.Framework.ThreadPool ( -    ThreadPoolEntry, ThreadPool(..), sequentialThreadPool, parallelThreadPool-  , threadPoolTest+    ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool+  , threadPoolTest, threadPoolTestStop  ) where @@ -32,9 +32,14 @@ -- for tests import System.Random +data StopFlag+    = DoStop+    | DoNotStop+      deriving (Eq, Show, Read)+ type ThreadPoolEntry m a b = ( m a        -- pre-action, must not throw exceptions                              , a -> IO b  -- action-                             , Either Ex.SomeException b -> m ()  -- post-action, must not throw exceptions+                             , Either Ex.SomeException b -> m StopFlag  -- post-action, must not throw exceptions. If the result is DoStop, the thread pool is terminated asap.                              )  data ThreadPool m a b@@ -51,14 +56,18 @@  runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m () runSequentially entries =-    mapM_ run entries+    loop entries     where+      loop [] = return ()+      loop (e:es) =+          do b <- run e+             if b == DoStop then return () else loop es       run (pre, action, post) =           do a <- pre              b <- liftIO $ Ex.try (action a)              post b -data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m ()) | Done+data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m StopFlag) | Done  instance Show (WorkItem m b) where     show (Work _ _) = "Work"@@ -69,7 +78,7 @@  type ToWorker m b = NamedMVar (WorkItem m b) -data WorkResult m b = WorkResult (m ()) (ToWorker m b)+data WorkResult m b = WorkResult (m StopFlag) (ToWorker m b)  instance Show (WorkResult m b) where     show _ = "WorkResult"@@ -91,21 +100,23 @@       loop fromWorker nWorkers [] =           cleanup fromWorker nWorkers       loop fromWorker nWorkers (x:xs) =-          do toWorker <- waitForWorkerResult fromWorker-             runEntry x toWorker-             loop fromWorker nWorkers xs+          do (toWorker, stop) <- waitForWorkerResult fromWorker+             if stop == DoStop+             then return ()+             else do runEntry x toWorker+                     loop fromWorker nWorkers xs       cleanup :: FromWorker m b -> Int -> m ()       -- n is the number of workers that will still write to fromWorker       cleanup fromWorker n =           do debug ("cleanup, n=" ++ show n)-             toWorker <- waitForWorkerResult fromWorker+             (toWorker, _) <- waitForWorkerResult fromWorker              liftIO $ putNamedMVar toWorker Done              when (n > 1) $ cleanup fromWorker (n - 1)-      waitForWorkerResult :: FromWorker m b -> m (ToWorker m b)+      waitForWorkerResult :: FromWorker m b -> m (ToWorker m b, StopFlag)       waitForWorkerResult fromWorker =           do WorkResult postAction toWorker <- liftIO $ readNamedChan fromWorker-             postAction-             return toWorker+             b <- postAction+             return (toWorker, b)       runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m ()       runEntry (pre, action, post) toWorker =           do a <- pre@@ -190,6 +201,7 @@                          Left err -> fail ("Exception in worker thread: " ++ show err)                          Right y -> do tid <- myThreadId                                        putNamedMVar mvar (y, tid)+                                       return DoNotStop               action x = do tid <- myThreadId                             j <- randomIO                             let micros = (j `mod` 50)@@ -213,3 +225,33 @@     mapM (runTestParallel nEntries) [i..j] `Ex.catch`              (\(e::Ex.BlockedIndefinitelyOnMVar) ->                   fail ("main-thread blocked " ++ show e))++threadPoolTestStop =+    do putStrLn ("Running test to see of STOP works")+       boxesAndEntries <- mapM mkEntry [1..100]+       let (boxes, entries) = unzip boxesAndEntries+       runParallel numberOfThreads entries+       debug ("Checking boxes...")+       mapM_ checkBox (zip [1..] boxes)+       putStrLn ("Test for STOP successful")+    where+      mkEntry i =+          do mvar <- newEmptyNamedMVar ("box-" ++ show i)+             let pre = return ()+                 action () =+                     do putNamedMVar mvar ()+                        return ()+                 post _exc  = return (if i >= numberOfThreads then DoStop else DoNotStop)+             return (mvar, (pre, action, post))+      numberOfThreads = 10+      checkBox (i, (name, box)) =+          do isEmpty <- isEmptyMVar box+             if isEmpty+             then if i > 20+                  then return ()+                  else if i <= 10+                       then fail ("Box " ++ name ++ " is still empty")+                       else return ()+             else if i > 20+                  then fail ("Box " ++ name ++ " not empty")+                  else return ()

@@ -172,23 +172,19 @@ millisToSeconds millis =     fromInteger (toInteger millis) / 1000.0 -mkGlobalResultsXml :: Milliseconds     -- ^ wall time in ms-                   -> [FlatTestResult] -- ^ passed tests-                   -> [FlatTestResult] -- ^ pending tests-                   -> [FlatTestResult] -- ^ failed tests-                   -> [FlatTestResult] -- ^ erroneous tests-                   -> BSL.ByteString-mkGlobalResultsXml t pass pending failed errors =-    let nPassed = length pass-        nPending = length pending-        nFailed = length failed-        nErrors = length errors-        byModules = groupByModule (pass ++ pending ++ failed ++ errors)+mkGlobalResultsXml :: ReportGlobalResultsArg -> BSL.ByteString+mkGlobalResultsXml arg =+    let nPassed = length (rgra_passed arg)+        nPending = length (rgra_pending arg)+        nFailed = length (rgra_failed arg)+        nErrors = length (rgra_errors arg)+        byModules = groupByModule (rgra_passed arg ++ rgra_pending arg +++                                   rgra_failed arg ++ rgra_errors arg)         suites = map mkTestSuite (zip [0..] byModules)         root = Testsuites                { tss_tests = nPassed + nPending + nFailed + nErrors                , tss_failures = nFailed                , tss_errors = nErrors-               , tss_time = millisToSeconds t+               , tss_time = millisToSeconds (rgra_timeMs arg)                , tss_suites = suites }     in renderAsXml (JunitXmlOutput root)

@@ -7,5 +7,5 @@  #include "test.h" -test_a =+test_a_FAIL =     assertEqual x y

@@ -4,4 +4,4 @@  import qualified Test.Framework as HTF -test_b = assertEqual 1 1+test_b_OK = assertEqual 1 1

@@ -0,0 +1,34 @@+--+-- Copyright (c) 2013   Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++import Test.Framework.History+import System.Exit+import Test.HUnit++allTests = historyTests++main :: IO ()+main =+    do counts <- runTestTT hunitTests+       if errors counts /= 0 || failures counts /= 0+       then exitWith (ExitFailure 1)+       else exitWith ExitSuccess+    where+      hunitTests =+          TestList (map (\(name, code) -> TestLabel name (TestCase code)) allTests)

@@ -34,17 +34,27 @@ import Control.Exception import Control.Monad import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as Set import qualified Data.Aeson as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe import qualified Data.Text as T+import qualified Data.List as List import qualified Text.Regex as R import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B +import FailFast+import MaxCurTime+import MaxPrevTime+import UniqTests1+import UniqTests2+import PrevFactor+import SortByPrevTime+ import Tutorial hiding (main)  data T = A | B@@ -58,41 +68,40 @@ handleExc :: a -> SomeException -> a handleExc x _ = x -test_assertFailure =-    assertFailure "I'm a failure"+test_assertFailure_FAIL = assertFailure "I'm a failure" -test_stringGap = assertEqual stringGap "hello world!"+test_stringGap_OK = assertEqual stringGap "hello world!" -test_assertEqual = assertEqual 1 2+test_assertEqual_FAIL = assertEqual 1 2 -test_assertEqualV = assertEqualVerbose "blub" 1 2+test_assertEqualV_FAIL = assertEqualVerbose "blub" 1 2 -test_assertEqualNoShow = withOptions (\opts -> opts { to_parallel = False }) $-                         assertEqualNoShow A B+test_assertEqualNoShow_FAIL = withOptions (\opts -> opts { to_parallel = False }) $+                              assertEqualNoShow A B -test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2]+test_assertListsEqualAsSets_FAIL = assertListsEqualAsSets [1,2] [2] -test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1]+test_assertSetEqualSuccess_OK = assertListsEqualAsSets [1,2] [2,1] -test_assertNotEmpty = assertNotEmpty []+test_assertNotEmpty_FAIL = assertNotEmpty [] -test_assertEmpty = assertEmpty [1]+test_assertEmpty_FAIL = assertEmpty [1] -test_assertElem = assertElem 1 [0,2,3]+test_assertElem_FAIL = assertElem 1 [0,2,3] -test_assertThrows = assertThrows (return () :: IO ()) (handleExc True)+test_assertThrows_FAIL = assertThrows (return () :: IO ()) (handleExc True) -test_assertThrows' = assertThrows (error "ERROR") (handleExc False)+test_assertThrows'_FAIL = assertThrows (error "ERROR") (handleExc False) -test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False)+test_assertThrowsIO1_FAIL = assertThrows (fail "ERROR" :: IO ()) (handleExc False) -test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True)+test_assertThrowsIO2_OK = assertThrowsIO (fail "ERROR") (handleExc True) -test_someError = error "Bart Simpson!!" :: IO ()+test_someError_ERROR = error "Bart Simpson!!" :: IO () -test_pendingTest = unitTestPending "This test is pending"+test_pendingTest_PENDING = unitTestPending "This test is pending" -test_subAssert = subAssert anotherSub+test_subAssert_FAIL = subAssert anotherSub     where       anotherSub = subAssertVerbose "I'm another sub" (assertNegative 42)       assertNegative n = assertBool (n < 0)@@ -103,7 +112,7 @@           | Variable String             deriving (Eq, Show) -test_diff =+test_diff_FAIL =     assertEqual (mkExpr 1) (mkExpr 2)     where       mkExpr i =@@ -113,35 +122,35 @@                              (Literal 581))                    (Variable "egg") -prop_ok :: [Int] -> Property-prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs))+prop_ok_OK :: [Int] -> Property+prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) -prop_fail :: [Int] -> Bool-prop_fail xs = xs == (reverse xs)+prop_fail_FAIL :: [Int] -> Bool+prop_fail_FAIL xs = xs == (reverse xs) -prop_pendingProp :: Int -> Bool-prop_pendingProp x = qcPending "This property is pending" (x == 0)+prop_pendingProp_PENDING :: Int -> Bool+prop_pendingProp_PENDING x = qcPending "This property is pending" (x == 0) -prop_exhaust = False ==> True+prop_exhaust_FAIL = False ==> True -prop_error :: Bool-prop_error = error "Lisa"+prop_error_FAIL :: Bool+prop_error_FAIL = error "Lisa"  changeArgs args = args { maxSuccess = 1 } -prop_ok' = withQCArgs (\a -> a { maxSuccess = 1}) $-                     \xs -> classify (null xs) "trivial" $-                            (xs::[Int]) == (reverse (reverse xs))+prop_ok'_OK = withQCArgs (\a -> a { maxSuccess = 1}) $+                        \xs -> classify (null xs) "trivial" $+                               (xs::[Int]) == (reverse (reverse xs)) -prop_fail' =+prop_fail'_FAIL =     withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop     where prop xs = xs == (reverse xs)               where types = xs::[Int] -prop_error' :: WithQCArgs Bool-prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool)+prop_error'_FAIL :: WithQCArgs Bool+prop_error'_FAIL = withQCArgs changeArgs $ (error "Lisa" :: Bool) -test_genericAssertions =+test_genericAssertions_OK =     case test1 of       AssertOk _ -> fail "did not expect AssertOk"       AssertFailed stack ->@@ -157,35 +166,151 @@       test1 = gsubAssert test2       test2 = gassertEqual 1 (2::Int) +-- find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_PENDING" | sed 's/test_//g; s/prop_//g' | sort -u+pendingTests :: [T.Text]+pendingTests =+    ["pendingProp_PENDING"+    ,"pendingTest_PENDING"]++failedTests :: [T.Text]+failedTests =+-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_FAIL" | sed 's/test_//g; s/prop_//g' | sort -u+    ["1_FAIL"+    ,"a_FAIL"+    ,"assertElem_FAIL"+    ,"assertEmpty_FAIL"+    ,"assertEqualNoShow_FAIL"+    ,"assertEqualV_FAIL"+    ,"assertEqual_FAIL"+    ,"assertFailure_FAIL"+    ,"assertListsEqualAsSets_FAIL"+    ,"assertNotEmpty_FAIL"+    ,"assertThrows'_FAIL"+    ,"assertThrowsIO1_FAIL"+    ,"assertThrows_FAIL"+    ,"diff_FAIL"+    ,"error'_FAIL"+    ,"error_FAIL"+    ,"exhaust_FAIL"+    ,"fail'_FAIL"+    ,"fail_FAIL"+    ,"subAssert_FAIL"+-- $ find bbt -name '*not_ok*.x'+    ,"bbt/should_fail/not_ok_because_stderr1.x"+    ,"bbt/should_fail/not_ok_because_stderr2.x"+    ,"bbt/should_fail/not_ok_because_stdout1.x"+    ,"bbt/should_fail/not_ok_because_stdout2.x"+    ,"bbt/should_fail/not_ok_because_succeeds.x"+    ,"bbt/should_pass/not_ok_because_fails.x"+    ,"bbt/should_pass/not_ok_because_stderr1.x"+    ,"bbt/should_pass/not_ok_because_stderr2.x"+    ,"bbt/should_pass/not_ok_because_stdout1.x"+    ,"bbt/should_pass/not_ok_because_stdout2.x"+    ,"bbt/Verbose/not_ok_because_stdout1.x"]++-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_ERROR" | sed 's/test_//g; s/prop_//g' | sort -u+errorTests :: [T.Text]+errorTests = ["someError_ERROR"]++passedTests :: [T.Text]+passedTests =+    -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_OK" | sed 's/test_//g; s/prop_//g' | sort -u+    ["2_OK"+    ,"assertSetEqualSuccess_OK"+    ,"assertThrowsIO2_OK"+    ,"b_OK"+    ,"genericAssertions_OK"+    ,"ok'_OK"+    ,"ok_OK"+    ,"stringGap_OK"+-- $ find bbt -name '*ok*.x' | grep -v not_ok+    ,"bbt/should_fail/ok1.x"+    ,"bbt/should_fail/ok2.x"+    ,"bbt/should_pass/ok1.x"+    ,"bbt/should_pass/ok2.x"+    ,"bbt/should_pass/stdin_ok.x"]++timedOutTests = []+ checkOutput output =     do bsl <- BSL.readFile output        let jsons = map (fromJust . J.decode) (splitJson bsl)+       let (pass, fail, error, pending, timedOut) = foldl checkStatus ([], [], [], [], []) jsons+       checkAsSet "passed" passedTests pass+       checkAsSet "failed" failedTests fail+       checkAsSet "errors" errorTests error+       checkAsSet "pending" pendingTests pending+       checkAsSet "timed-out" timedOutTests timedOut        check jsons (J.object ["type" .= J.String "test-results"])-                   (J.object ["failures" .= J.toJSON (31::Int)-                             ,"passed" .= J.toJSON (13::Int)-                             ,"pending" .= J.toJSON (2::Int)-                             ,"errors" .= J.toJSON (1::Int)])+                   (J.object ["failures" .= J.toJSON (length failedTests)+                             ,"passed" .= J.toJSON (length passedTests)+                             ,"pending" .= J.toJSON (length pendingTests)+                             ,"errors" .= J.toJSON (length errorTests)+                             ,"timedOut" .= J.toJSON (length timedOutTests)])        check jsons (J.object ["type" .= J.String "test-end"-                             ,"test" .= J.object ["flatName" .= J.String "Main:diff"]])+                             ,"test" .= J.object ["flatName" .= J.String "Main:diff_FAIL"]])                    (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs"-                                                                         ,"line" .= J.toJSON (106::Int)]]+                                                                         ,"line" .= J.toJSON (106+lineOffset)]]                              ,"location" .= J.object ["file" .= J.String "TestHTF.hs"-                                                     ,"line" .= J.toJSON (107::Int)]])+                                                     ,"line" .= J.toJSON (107+lineOffset)]])        check jsons (J.object ["type" .= J.String "test-end"-                             ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]])+                             ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]])                    (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs"                                                                          ,"line" .= J.toJSON (10::Int)]]                              ,"location" .= J.object ["file" .= J.String "./Foo/A.hs"                                                      ,"line" .= J.toJSON (11::Int)]])        check jsons (J.object ["type" .= J.String "test-end"-                             ,"test" .= J.object ["flatName" .= J.String "Main:subAssert"]])+                             ,"test" .= J.object ["flatName" .= J.String "Main:subAssert_FAIL"]])                    (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null                                                               ,"location" .= J.object ["file" .= J.String "TestHTF.hs"-                                                                                      ,"line" .= J.toJSON (95::Int)]]+                                                                                      ,"line" .= J.toJSON (95+lineOffset)]]                                                     ,J.object ["message" .= J.String "I'm another sub"                                                               ,"location" .= J.object ["file" .= J.String "TestHTF.hs"-                                                                                      ,"line" .= J.toJSON (97::Int)]]]])+                                                                                      ,"line" .= J.toJSON (97+lineOffset)]]]])     where+      lineOffset :: Int+      lineOffset = 9+      checkStatus tuple@(pass, fail, error, pending, timedOut) json =+          {-+            {"location":null+            ,"test":{"path":["Main","tests/bbt/should_pass/stdin_ok.x"],"sort":"blackbox-test","flatName":"Main:tests/bbt/should_pass/stdin_ok.x"}+            ,"callers":[]+            ,"result":"pass"+            ,"timedOut":false+            ,"type":"test-end"+            ,"message":""+            ,"wallTime":11}+           -}+          case json of+            J.Object objJson | Just (J.Object testObj) <- M.lookup "test" objJson+                             , Just (J.String flatName) <- M.lookup "flatName" testObj+                             , Just (J.String "test-end") <- M.lookup "type" objJson+                             , Just (J.String result) <- M.lookup "result" objJson+                             , Just (J.Bool to) <- M.lookup "timedOut" objJson ->+                let shortName =+                        let t = T.tail (T.dropWhile (/= ':') flatName)+                        in if "tests/" `T.isPrefixOf` t+                           then T.drop (T.length "tests/") t+                           else t+                    newTimedOut = if to then shortName : timedOut else timedOut+                in case () of+                     _| result == "pass" -> (shortName : pass, fail, error, pending, newTimedOut)+                     _| result == "fail" -> (pass, shortName : fail, error, pending, newTimedOut)+                     _| result == "error" -> (pass, fail, shortName : error, pending, newTimedOut)+                     _| result == "pending" -> (pass, fail, error, shortName : pending, newTimedOut)+            _ -> tuple+      checkAsSet what expList givenList =+          let expSet = Set.fromList expList+              givenSet = Set.fromList givenList+          in if expSet == givenSet+             then return ()+             else do let unexpected = givenSet `Set.difference` expSet+                         notGiven = expSet `Set.difference` givenSet+                     fail ("Mismatch for " ++ what ++ ":" +++                           "\nExpected: " ++ show expList +++                           "\nGiven: " ++ show givenList +++                           "\nUnexpected elements: " ++ show unexpected +++                           "\nElements expected but not present: " ++ show notGiven)       check jsons pred assert =           case filter (\j -> matches j pred) jsons of             [json] ->@@ -224,6 +349,16 @@                                   [] -> error "invalid json output from HTF"                                   (x:xs) -> (start `BSL.append` x : xs) +runRealBlackBoxTests =+    do b <- doesDirectoryExist "tests/bbt"+       let dirPrefix = if b then "tests" else ""+       bbts <- blackBoxTests (dirPrefix </> "real-bbt") ("/bin/bash") ".sh"+                 (defaultBBTArgs { bbtArgs_verbose = False })+       ecode <- runTest bbts+       case ecode of+         ExitFailure _ -> fail ("real blackbox tests failed!")+         _ -> return ()+ main =     do args <- getArgs        b <- doesDirectoryExist "tests/bbt"@@ -232,10 +367,18 @@                  (defaultBBTArgs { bbtArgs_verbose = False })        let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests        when ("--help" `elem` args || "-h" `elem` args) $-            do hPutStrLn stderr ("USGAGE: dist/build/test/test [--direct]")+            do hPutStrLn stderr ("USAGE: dist/build/test/test [--direct]")                ecode <- runTestWithArgs ["--help"] ([] :: [Test])                exitWith ecode        case args of+         "FailFast.hs":rest -> failFastMain rest+         "MaxCurTime.hs":rest -> maxCurTimeMain rest+         "MaxPrevTime.hs":rest -> maxPrevTimeMain rest+         "PrevFactor.hs":rest -> prevFactorMain rest+         "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest+         "UniqTests1.hs":rest -> uniqTests1Main rest+         "UniqTests2.hs":rest -> uniqTests2Main rest+         x:_ | ".hs" `List.isSuffixOf` x -> fail ("Unkown real-bbt test: " ++ x)          "--direct":rest ->              do ecode <- runTestWithArgs rest tests                 case ecode of@@ -251,5 +394,6 @@                        _ -> fail ("unexpected exit code: " ++ show ecode)                      `onException` (do s <- readFile outFile                                        hPutStrLn stderr s)+                runRealBlackBoxTests                 ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")                 exitWith ecode

@@ -3,8 +3,8 @@  import Test.Framework -test_1 = do assertEqual "1 == 2" 1 2-            assertEqualHTF 1 1+test_1_FAIL = do assertEqual "1 == 2" 1 2+                 assertEqualHTF 1 1 -test_2 = do assertJust "foo" (Just 1)-            assertJustHTF (Just 1)+test_2_OK = do assertJust "foo" (Just 1)+               assertJustHTF (Just 1)

@@ -31,6 +31,7 @@                           [x] -> return (read x, 100)                           [x, y] -> return (read x, read y)                           _ -> usage+       threadPoolTestStop        threadPoolTest (1, i) nEntries        return ()     where

@@ -1,18 +0,0 @@-#!/bin/bash--if [ "$1" != "--no-clean" ]-then-    cabal clean || exit 1-fi-mkdir -p dist/build/htfpp || exit 1-pushd ..-cabal build || exit 1-popd-cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1-cabal-1.16.0 configure || exit 1-cabal-1.16.0 build || exit 1-dist/build/test/test || exit 1-echo "Tests ok"--./compile-errors/run-tests.sh || exit 1-echo "Line numbers in compile errors ok"

@@ -1,41 +0,0 @@-Name:          test-HTF-Version:       0.1-Cabal-Version: >= 1.10-Build-type:    Simple--Executable test-  Main-is: TestHTF.hs-  Build-depends:     base >= 4,-                     bytestring >= 0.9,-                     aeson >= 0.6,-                     unordered-containers >= 0.2,-                     temporary >= 1.1,-                     text >= 0.11,-                     directory >= 1.0,-                     filepath >= 1.1,-                     process >= 1.0,-                     regex-compat >= 0.92,-                     random,-                     mtl,-                     pretty,-                     containers,-                     xmlgen,-                     unix,-                     array,-                     old-time,-                     lifted-base,-                     monad-control,-                     HUnit,-                     QuickCheck,-                     Diff,-                     haskell-src-exts,-                     base64-bytestring-  Default-language:  Haskell2010-  Ghc-options: -threaded-  Hs-source-dirs: ., ..--Test-Suite tutorial-  Type:              exitcode-stdio-1.0-  Main-is:           Tutorial.hs-  Build-depends:     base >= 4, HTF == 0.10.*-  Default-language:  Haskell2010