diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +* 0.12.0 + - support for several new commandline options: + --history=FILE Path to the history file. Default: ./.HTF/.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 diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -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 diff --git a/TODO.org b/TODO.org --- a/TODO.org +++ b/TODO.org @@ -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 diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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 diff --git a/Test/Framework/AssertM.hs b/Test/Framework/AssertM.hs --- a/Test/Framework/AssertM.hs +++ b/Test/Framework/AssertM.hs @@ -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 diff --git a/Test/Framework/BlackBoxTest.hs b/Test/Framework/BlackBoxTest.hs --- a/Test/Framework/BlackBoxTest.hs +++ b/Test/Framework/BlackBoxTest.hs @@ -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 diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs --- a/Test/Framework/CmdlineOptions.hs +++ b/Test/Framework/CmdlineOptions.hs @@ -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/.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/.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/.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 diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -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 diff --git a/Test/Framework/History.hs b/Test/Framework/History.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/History.hs @@ -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 "" + +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 " . + 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 diff --git a/Test/Framework/JsonOutput.hs b/Test/Framework/JsonOutput.hs --- a/Test/Framework/JsonOutput.hs +++ b/Test/Framework/JsonOutput.hs @@ -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 diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -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 -> diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -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>>>" - in throwIO (HUnitFailure exc') + ioProperty $ action >> return True diff --git a/Test/Framework/TestInterface.hs b/Test/Framework/TestInterface.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TestInterface.hs @@ -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) diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -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 diff --git a/Test/Framework/TestManagerInternal.hs b/Test/Framework/TestManagerInternal.hs deleted file mode 100644 --- a/Test/Framework/TestManagerInternal.hs +++ /dev/null @@ -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 "<< (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 diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs --- a/Test/Framework/TestReporter.hs +++ b/Test/Framework/TestReporter.hs @@ -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 diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs --- a/Test/Framework/TestTypes.hs +++ b/Test/Framework/TestTypes.hs @@ -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=" . 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 () diff --git a/Test/Framework/ThreadPool.hs b/Test/Framework/ThreadPool.hs --- a/Test/Framework/ThreadPool.hs +++ b/Test/Framework/ThreadPool.hs @@ -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 () diff --git a/Test/Framework/XmlOutput.hs b/Test/Framework/XmlOutput.hs --- a/Test/Framework/XmlOutput.hs +++ b/Test/Framework/XmlOutput.hs @@ -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) diff --git a/tests/Foo/A.hs b/tests/Foo/A.hs --- a/tests/Foo/A.hs +++ b/tests/Foo/A.hs @@ -7,5 +7,5 @@ #include "test.h" -test_a = +test_a_FAIL = assertEqual x y diff --git a/tests/Foo/B.hs b/tests/Foo/B.hs --- a/tests/Foo/B.hs +++ b/tests/Foo/B.hs @@ -4,4 +4,4 @@ import qualified Test.Framework as HTF -test_b = assertEqual 1 1 +test_b_OK = assertEqual 1 1 diff --git a/tests/MiscTest.hs b/tests/MiscTest.hs new file mode 100644 --- /dev/null +++ b/tests/MiscTest.hs @@ -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) diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -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 diff --git a/tests/TestHTFHunitBackwardsCompatible.hs b/tests/TestHTFHunitBackwardsCompatible.hs --- a/tests/TestHTFHunitBackwardsCompatible.hs +++ b/tests/TestHTFHunitBackwardsCompatible.hs @@ -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) diff --git a/tests/ThreadPoolTest.hs b/tests/ThreadPoolTest.hs --- a/tests/ThreadPoolTest.hs +++ b/tests/ThreadPoolTest.hs @@ -31,6 +31,7 @@ [x] -> return (read x, 100) [x, y] -> return (read x, read y) _ -> usage + threadPoolTestStop threadPoolTest (1, i) nEntries return () where diff --git a/tests/bbt/should_fail/not_ok_because_stderr2.err b/tests/bbt/should_fail/not_ok_because_stderr2.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stderr2.err diff --git a/tests/bbt/should_fail/not_ok_because_stdout2.out b/tests/bbt/should_fail/not_ok_because_stdout2.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stdout2.out diff --git a/tests/bbt/should_pass/not_ok_because_stderr2.err b/tests/bbt/should_pass/not_ok_because_stderr2.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stderr2.err diff --git a/tests/bbt/should_pass/not_ok_because_stdout2.out b/tests/bbt/should_pass/not_ok_because_stdout2.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stdout2.out diff --git a/tests/run-tests.sh b/tests/run-tests.sh deleted file mode 100644 --- a/tests/run-tests.sh +++ /dev/null @@ -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" diff --git a/tests/test-HTF.cabal b/tests/test-HTF.cabal deleted file mode 100644 --- a/tests/test-HTF.cabal +++ /dev/null @@ -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