diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.13.1.0 +Version: 0.13.2.1 License: LGPL License-File: LICENSE Copyright: (c) 2005-2015 Stefan Wehr @@ -30,59 +30,6 @@ blog article () demonstrating HTF's coloring, pretty-printing and diff functionality. - . - - /HEADS UP, backwards incomatibility with prior versions:/ - - . - - In version 0.10.0.0, the following changes could break code compiled against version 0.9.*: - - . - - * "Test.Framework" now longer exports all of "Test.Framework.TestManager" and - "Test.Framework.BlackBoxTest". For modules that only define tests, no changes - should be necessary. However, you likely need to adjust your test runner - module by importing "Test.Framework.TestManager" and possibly "Test.Framework.BlackBoxTest". - - . - - * Some reorganization in "Test.Framework.TestManager" and related modules, introduction - of "Test.Framework.TestTypes". Usually, your code should not be affected - by these changes. - - . - Starting with version 0.9.0.0, HTF uses a new strategy - for collecting the testcases defined in your project - (see "Test.Framework.Tutorial" for a description of this strategy). - If you used version 0.8.* or earlier of HTF, this /will break your build!/ - However, it's rather easy to bring you project in line with the new HTF - version. Here are the steps that will most likely resolve - your backwards incompatibility problems: - - . - - * If a module exports the @allHTFTests@ symbol, this export must - be changed to @htf_thisModulesTests@. - - . - - * If an import declaration of some module hides the @allHTFTests@ - symbol, you can simply remove the hiding clause for @allHTFTests@. - - . - - * If a module collects and executes tests from several other modules, - the collecting module has to be changed as follows: add - @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ to the top - of the collecting module, import - the other modules with the @{-@ HTF_TESTS @-}@ - annotation, use the symbol @htf_importedTests@ for referencing - the imported tests. See "Test.Framework.Tutorial" for details. - -Tested-With: - GHC==7.6.2, - GHC==7.8.2 Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: @@ -90,7 +37,6 @@ TODO.org ChangeLog tests/bbt/should_fail/BBTArgs - -- tests/bbt/should_fail/*.in tests/bbt/should_fail/*.err tests/bbt/should_fail/*.out tests/bbt/should_fail/*.x @@ -125,8 +71,9 @@ sample/bbt-dir/should-fail/z.num sample/bbt-dir/should-pass/x.num sample/bbt-dir/should-pass/x.out - run-all-tests-for-all-compilers.sh - run-all-tests.sh + scripts/local-htfpp + scripts/run-sample + Source-Repository head Type: git Location: http://github.com/skogsbaer/HTF.git @@ -153,7 +100,7 @@ Build-Depends: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3, - aeson >= 0.6, + aeson < 0.10 || >= 0.11, array, base == 4.*, base64-bytestring, @@ -236,7 +183,8 @@ Default-language: Haskell2010 Other-Modules: Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime, - MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi + MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi, + Tutorial, Repeat Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # HTF - The Haskell Test Framework +[![Build Status](https://travis-ci.org/skogsbaer/HTF.svg?branch=master)](https://travis-ci.org/skogsbaer/HTF) +[![Hackage](https://img.shields.io/hackage/v/HTF.svg)](http://hackage.haskell.org/package/HTF) + * Documentation: http://hackage.haskell.org/package/HTF * Source Repository: https://github.com/skogsbaer/HTF/ * Issue tracker: https://github.com/skogsbaer/HTF/issues?state=open @@ -9,8 +12,8 @@ ## Summary The Haskell Test Framework (HTF for short) lets you define unit tests -(http://hunit.sourceforge.net), QuickCheck properties -(http://www.cs.chalmers.se/~rjmh/QuickCheck/), and black box tests in an +(http://hackage.haskell.org/package/HUnit), QuickCheck properties +(https://hackage.haskell.org/package/QuickCheck), and black box tests in an easy and convenient way. HTF uses a custom preprocessor that collects test definitions automatically. Furthermore, the preprocessor allows HTF to report failing test cases with exact file name and line number diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -37,7 +37,8 @@ module Test.Framework.AssertM, -- * Organizing tests - TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest + TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest, + TM.WrappableHTF(..) ) where diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs --- a/Test/Framework/CmdlineOptions.hs +++ b/Test/Framework/CmdlineOptions.hs @@ -89,8 +89,9 @@ , opts_sortByPrevTime :: Bool -- ^ Sort tests by their previous run times (ascending). Default: 'False' , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run. , opts_maxCurTimeMs :: Maybe Milliseconds -- ^ Abort tests that run more than the given milliseconds. - , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previosu run. + , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run. , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error. + , opts_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } {- | @@ -117,6 +118,7 @@ , opts_maxCurTimeMs = Nothing , opts_prevFactor = Nothing , opts_timeoutIsSuccess = False + , opts_repeat = 1 } processorCount :: Int @@ -140,9 +142,9 @@ , 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 [] ["shuffle"] + (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL") + "Shuffle test order. Default: false" , Option ['o'] ["output-file"] (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE") "Name of output file." @@ -181,6 +183,10 @@ , Option [] ["timeout-is-success"] (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True })) "Do not regard a test timeout as an error." + , Option [] ["repeat"] + (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) -> + Right $ o { opts_repeat = i}) "NUMBER") + "Execute the tests selected on the command line NUMBER times." , Option ['h'] ["help"] (NoArg (\o -> Right $ o { opts_help = True })) "Display this message." @@ -213,7 +219,7 @@ > -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. +> --shuffle=BOOL Shuffle test order. Default: false > -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. @@ -235,6 +241,10 @@ case getOpt Permute optionDescriptions args of (optTrans, tests, []) -> do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans + when (opts_shuffle opts && opts_sortByPrevTime opts) $ + Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " ++ + "Can only use one of both.\n\n" ++ + usageInfo usageHeader optionDescriptions) case (opts_outputFile opts, opts_split opts) of (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions) @@ -297,6 +307,7 @@ , tc_maxSingleTestTime = opts_maxCurTimeMs opts , tc_prevFactor = opts_prevFactor opts , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts + , tc_repeat = opts_repeat opts } where #ifdef mingw32_HOST_OS diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances, - ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -- -- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de @@ -33,6 +37,7 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs, withQCArgs, WithQCArgs, setReplayFromString, + QCAssertion, -- * Pending properties qcPending, @@ -195,11 +200,11 @@ argsModifier :: a -> (Args -> Args) testable :: a -> AnyTestable -instance Testable a => QCAssertion a where +instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where argsModifier _ = id testable = AnyTestable -instance Testable a => QCAssertion (WithQCArgs a) where +instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where argsModifier (WithQCArgs f _) = f testable (WithQCArgs _ x) = AnyTestable x diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -37,12 +37,16 @@ -- * Organzing tests TestableHTF, + WrappableHTF(..), makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, - flattenTest + flattenTest, + + -- * Tests (for internal use) + wrappableTests ) where import Control.Monad.RWS @@ -68,6 +72,7 @@ import Test.Framework.ThreadPool import Test.Framework.History +import qualified Test.HUnit as HU -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test @@ -101,6 +106,26 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') +-- | Kind of specialised 'Functor' type class for tests, which allows you to +-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any +-- test code. +-- +-- E.g. if you want to add timeouts to all tests of a module, you could write: +-- +-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded" +-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests +class WrappableHTF t where + wrap :: (Assertion -> Assertion) -> t -> t + +instance WrappableHTF TestSuite where + wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests + wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests + +instance WrappableHTF Test where + wrap wrapper (BaseTest ts tid loc topt assertion) = + BaseTest ts tid loc topt (wrapper assertion) + wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite + -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where @@ -219,16 +244,28 @@ pre = reportTestStart ft action _ = let run = performTestHTF (wto_payload (ft_payload ft)) - in case maxRunTime tc ft of - Nothing -> - do (res, time) <- measure run - return (PrimTestResultNoTimeout res, time) - Just maxMs -> - do mx <- timeout (1000 * maxMs) $ measure run - case mx of - Nothing -> return (PrimTestResultTimeout, maxMs) - Just (res, time) -> - return (PrimTestResultNoTimeout res, time) + runWithTimeout = + case maxRunTime tc ft of + Nothing -> + do (res, time) <- measure run + return (PrimTestResultNoTimeout res, time) + Just maxMs -> + do mx <- timeout (1000 * maxMs) $ measure run + case mx of + Nothing -> return (PrimTestResultTimeout, maxMs) + Just (res, time) -> + return (PrimTestResultNoTimeout res, time) + isPass primTestRes = + case primTestRes of + PrimTestResultNoTimeout fullTestRes -> + ftr_result fullTestRes == Just Pass + PrimTestResultTimeout -> False + iterRunWithTimeout i = + do (primTestRes, time) <- runWithTimeout + if isPass primTestRes && i >= 2 + then iterRunWithTimeout (i-1) + else return (primTestRes, time) + in iterRunWithTimeout (tc_repeat tc) post excOrResult = let (testResult, time) = case excOrResult of @@ -282,31 +319,31 @@ Fail -> DoStop Error -> DoStop -runAllFlatTests :: TestConfig -> [FlatTest] -> TR () -runAllFlatTests tc tests' = - do reportGlobalStart tests - tc <- ask +runAllFlatTests :: [FlatTest] -> TR () +runAllFlatTests tests' = + do tc <- ask + tests <- orderTests tc tests' + reportGlobalStart tests case tc_threads tc of Nothing -> 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 tc) ptests + 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, _) = + orderTests tc ts + | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts + | tc_shuffle tc = shuffleTests ts + | otherwise = return ts + shuffleTests = liftIO . shuffleIO + sortByPrevTime tc ts = + map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts) + compareTests tc (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))) @@ -407,7 +444,7 @@ startTime <- getCurrentTime ((_, s, _), time) <- measure $ - runRWST (runAllFlatTests tc activeTests) tc initTestState + runRWST (runAllFlatTests 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 @@ -458,3 +495,14 @@ htfMainWithArgs args tests = do ecode <- runTestWithArgs args tests exitWith ecode + +testWrapCanCauseFailure :: IO () +testWrapCanCauseFailure = + do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest + HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest + where + unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ()) + wrappedUnitTest = wrap wrapper unitTest + wrapper test = HU.assertFailure "Fail" >> test + +wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)] diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs --- a/Test/Framework/TestTypes.hs +++ b/Test/Framework/TestTypes.hs @@ -205,6 +205,7 @@ , tc_timeoutIsSuccess :: Bool -- ^ Do not regard timeout as an error , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run , tc_prevFactor :: Maybe Double -- ^ Maximum factor a single test is allowed to run slower than its previous execution + , tc_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } instance Show TestConfig where @@ -226,6 +227,7 @@ showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) . showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) . showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) . + showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) . showString " }" -- | A 'TestReporter' provides hooks to customize the output of HTF. diff --git a/Test/Framework/ThreadPool.hs b/Test/Framework/ThreadPool.hs --- a/Test/Framework/ThreadPool.hs +++ b/Test/Framework/ThreadPool.hs @@ -184,7 +184,7 @@ runTestParallel :: Int -> Int -> IO () runTestParallel nEntries n = - do putStrLn ("Running test " ++ show n) + do debug ("Running test " ++ show n) boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i) return (mvar, i)) [1..nEntries] @@ -193,7 +193,7 @@ debug ("Checking boxes in test " ++ show n) --runSequentially entries mapM_ assertBox boxes - putStrLn ("Test " ++ show n ++ " successful") + debug ("Test " ++ show n ++ " successful") where mkEntry (mvar, i) = let pre = myThreadId diff --git a/run-all-tests-for-all-compilers.sh b/run-all-tests-for-all-compilers.sh deleted file mode 100644 --- a/run-all-tests-for-all-compilers.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/bash - -compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal | tr -d ,) - -for x in $compilers -do - switch-ghc $x > /dev/null - ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g') - if [ "$x" != "$ghc_version" ] - then - echo "Could not switch to GHC version $x as requested, version is now $ghc_version" - exit 1 - fi - echo - echo - echo "============================================================" - echo "============================================================" - echo "==> Running tests for GHC version $ghc_version <==" - echo "==> Running tests for GHC version $ghc_version <==" - echo "==> Running tests for GHC version $ghc_version <==" - echo "============================================================" - echo "============================================================" - echo - ./run-all-tests.sh - ecode=$? - if [ $ecode -eq 0 ] - then - result="ok" - else - result="FAIL" - fi - RESULT="$RESULT\nResult for GHC version $ghc_version: $result" - if [ $ecode -ne 0 ] - then - exit 1 - fi -done - -echo -echo -e $RESULT diff --git a/run-all-tests.sh b/run-all-tests.sh deleted file mode 100644 --- a/run-all-tests.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash - -SANDBOX_FILE="cabal.sandbox.config" -SANDBOX_DIR=".cabal-sandbox" -CABAL=$HOME/bin/cabal-with-cpphs - -if [ ! -x "$CABAL" ]; then - CABAL=cabal -fi - -set -e -if [ -e "$SANDBOX_FILE" ] -then - have_sandbox=yes - cabal sandbox hc-pkg unregister HTF || true -else - have_sandbox=no - ghc-pkg unregister HTF || true -fi - -$CABAL configure --enable-tests || exit 1 -$CABAL build || exit 1 -$CABAL test || exit 1 -$CABAL install || exit 1 - -cd sample || exit 1 - -if [ "$have_sandbox" == "yes" ] -then - rm -f cabal.sandbox.config - cabal sandbox init --sandbox ../"$SANDBOX_DIR" -fi - -$CABAL configure --enable-tests || exit 1 -$CABAL build || exit 1 -$CABAL test || exit 1 diff --git a/sample/TestMain.hs b/sample/TestMain.hs --- a/sample/TestMain.hs +++ b/sample/TestMain.hs @@ -9,5 +9,5 @@ import {-@ HTF_TESTS @-} MyPkg.B main = - do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs + do bbts <- blackBoxTests "bbt-dir" "../scripts/run-sample" ".num" defaultBBTArgs htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts]) diff --git a/sample/sample-HTF.cabal b/sample/sample-HTF.cabal --- a/sample/sample-HTF.cabal +++ b/sample/sample-HTF.cabal @@ -1,6 +1,7 @@ name: sample-HTF version: 0.1.0.0 synopsis: Sample project showing how to use HTF +description: Sample project showing how to use HTF homepage: https://github.com/skogsbaer/HTF/ license: BSD3 license-file: LICENSE @@ -13,12 +14,12 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.13.* + build-depends: base == 4.*, HTF == 0.13.* default-language: Haskell2010 test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.13.* + build-depends: base == 4.*, HTF == 0.13.* default-language: Haskell2010 diff --git a/scripts/local-htfpp b/scripts/local-htfpp new file mode 100644 --- /dev/null +++ b/scripts/local-htfpp @@ -0,0 +1,11 @@ +#!/bin/bash + +TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P) +d=$(stack $HTF_TRAVIS_STACK_ARGS path --dist-dir) +bin="$TOP/$d/build/htfpp/htfpp" + +if [ ! -x "$bin" ]; then + echo "No executable found at $bin" >&2 + exit 1 +fi +"$bin" "$@" diff --git a/scripts/run-sample b/scripts/run-sample new file mode 100644 --- /dev/null +++ b/scripts/run-sample @@ -0,0 +1,3 @@ +#!/bin/bash + +stack exec sample -- "$@" diff --git a/tests/Foo/A.hs b/tests/Foo/A.hs --- a/tests/Foo/A.hs +++ b/tests/Foo/A.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} {-# LANGUAGE CPP #-} module Foo.A where diff --git a/tests/Foo/B.hs b/tests/Foo/B.hs --- a/tests/Foo/B.hs +++ b/tests/Foo/B.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Foo.B (htf_thisModulesTests) where diff --git a/tests/MiscTest.hs b/tests/MiscTest.hs --- a/tests/MiscTest.hs +++ b/tests/MiscTest.hs @@ -21,10 +21,11 @@ import Test.Framework.Preprocessor import Test.Framework.PrettyHaskell import Test.Framework.HUnitWrapper +import Test.Framework.TestManager import System.Exit import Test.HUnit -allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests +allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests ++ wrappableTests main :: IO () main = diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -5,7 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} -- -- Copyright (c) 2005,2010 Stefan Wehr - http://www.stefanwehr.de -- @@ -61,6 +61,7 @@ import UniqTests1 import UniqTests2 import PrevFactor +import Repeat import SortByPrevTime import Quasi @@ -298,7 +299,7 @@ ,"line" .= J.toJSON (97+lineOffset)]]]]) where lineOffset :: Int - lineOffset = 31 + lineOffset = 32 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null @@ -381,13 +382,13 @@ T.unpack $ T.decodeUtf8With T.lenientDecode $ BSL.toStrict $ - J.encodePretty' (J.Config 2 J.compare) json + J.encodePretty' J.defConfig json 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 }) + (defaultBBTArgs { bbtArgs_verbose = True }) ecode <- runTest bbts case ecode of ExitFailure _ -> fail ("real blackbox tests failed!") @@ -401,7 +402,7 @@ (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests when ("--help" `elem` args || "-h" `elem` args) $ - do hPutStrLn stderr ("USAGE: dist/build/test/test [--direct]") + do hPutStrLn stderr ("USAGE: PROG [--direct]") ecode <- runTestWithArgs ["--help"] ([] :: [Test]) exitWith ecode case args of @@ -409,6 +410,7 @@ "MaxCurTime.hs":rest -> maxCurTimeMain rest "MaxPrevTime.hs":rest -> maxPrevTimeMain rest "PrevFactor.hs":rest -> prevFactorMain rest + "Repeat.hs":rest -> repeatMain rest "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest "UniqTests1.hs":rest -> uniqTests1Main rest "UniqTests2.hs":rest -> uniqTests2Main rest @@ -421,7 +423,7 @@ _ -> do withSystemTempFile "HTF-out" $ \outFile h -> do hClose h - ecode <- runTestWithArgs ["-j4", "--deterministic", + ecode <- runTestWithArgs ["-j4", "--shuffle=false", "--json", "--output-file=" ++ outFile] tests case ecode of ExitFailure _ -> checkOutput outFile diff --git a/tests/TestHTFHunitBackwardsCompatible.hs b/tests/TestHTFHunitBackwardsCompatible.hs --- a/tests/TestHTFHunitBackwardsCompatible.hs +++ b/tests/TestHTFHunitBackwardsCompatible.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp -optF --hunit #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp -optF --hunit #-} module TestHTFHunitBackwardsCompatible where import Test.Framework diff --git a/tests/Tutorial.hs b/tests/Tutorial.hs --- a/tests/Tutorial.hs +++ b/tests/Tutorial.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Tutorial where import System.Environment ( getArgs ) diff --git a/tests/compile-errors/Test1.hs b/tests/compile-errors/Test1.hs --- a/tests/compile-errors/Test1.hs +++ b/tests/compile-errors/Test1.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework +import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int diff --git a/tests/compile-errors/Test2.hs b/tests/compile-errors/Test2.hs --- a/tests/compile-errors/Test2.hs +++ b/tests/compile-errors/Test2.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework +import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int foo i = i + "Stefan" diff --git a/tests/compile-errors/Test3.hs b/tests/compile-errors/Test3.hs --- a/tests/compile-errors/Test3.hs +++ b/tests/compile-errors/Test3.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework +import "HTF" Test.Framework -- error must be in line 7 test_foo :: Int diff --git a/tests/compile-errors/Test4.hs b/tests/compile-errors/Test4.hs --- a/tests/compile-errors/Test4.hs +++ b/tests/compile-errors/Test4.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework +import "HTF" Test.Framework data D = D -- error must be in line 7 prop_foo :: D -> Bool diff --git a/tests/compile-errors/run-tests.sh b/tests/compile-errors/run-tests.sh --- a/tests/compile-errors/run-tests.sh +++ b/tests/compile-errors/run-tests.sh @@ -2,30 +2,20 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package base -package-db ../../dist/package.conf.inplace -package HTF --make" -SANDBOX_FILE="../../cabal.sandbox.config" -SANDBOX_DIR="../../.cabal-sandbox" -GHC_VERSION=$(ghc --version | sed 's/.*version //g') - -if [ -e "$SANDBOX_FILE" ] -then - for pkg_db in $(ls -d -1 $SANDBOX_DIR/*$GHC_VERSION*-packages.conf.d) - do - FLAGS="$FLAGS -package-db $pkg_db" - done -fi -echo $FLAGS - lineno=7 function check() { test="$1" - ghc $FLAGS "$test" 2>&1 | grep "$test":$lineno + command -v grep >/dev/null 2>&1 || \ + { echo >&2 "Test $0 requires ``grep'' but it's not installed. Aborting."; exit 1; } + compile_cmd="stack $HTF_TRAVIS_STACK_ARGS ghc -- -XPackageImports $test" + $compile_cmd 2>&1 | grep "$test":$lineno grep_ecode=${PIPESTATUS[1]} if [ "$grep_ecode" != "0" ] then echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}" - ghc $FLAGS "$test" + echo "Here is the output of the compiler:" + $compile_cmd exit 1 fi } diff --git a/tests/real-bbt/FailFast.hs b/tests/real-bbt/FailFast.hs --- a/tests/real-bbt/FailFast.hs +++ b/tests/real-bbt/FailFast.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module FailFast (failFastMain) where import Test.Framework diff --git a/tests/real-bbt/MaxCurTime.hs b/tests/real-bbt/MaxCurTime.hs --- a/tests/real-bbt/MaxCurTime.hs +++ b/tests/real-bbt/MaxCurTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxCurTime (maxCurTimeMain) where import Test.Framework diff --git a/tests/real-bbt/MaxPrevTime.hs b/tests/real-bbt/MaxPrevTime.hs --- a/tests/real-bbt/MaxPrevTime.hs +++ b/tests/real-bbt/MaxPrevTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxPrevTime (maxPrevTimeMain) where import Test.Framework diff --git a/tests/real-bbt/PrevFactor.hs b/tests/real-bbt/PrevFactor.hs --- a/tests/real-bbt/PrevFactor.hs +++ b/tests/real-bbt/PrevFactor.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module PrevFactor (prevFactorMain) where import Test.Framework diff --git a/tests/real-bbt/Repeat.hs b/tests/real-bbt/Repeat.hs new file mode 100644 --- /dev/null +++ b/tests/real-bbt/Repeat.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} +module Repeat (repeatMain) where + +import Test.Framework + +import Data.IORef +import System.IO.Unsafe + +globalBool :: IORef Bool +globalBool = unsafePerformIO (newIORef True) +{-# NOINLINE globalBool #-} + +readGlobalBool :: IO Bool +readGlobalBool = + do b <- readIORef globalBool + writeIORef globalBool False + return b + +test_globalMVarIsTrue = + do b <- readGlobalBool + assertEqual b True + +repeatMain args = htfMainWithArgs args htf_thisModulesTests diff --git a/tests/real-bbt/SortByPrevTime.hs b/tests/real-bbt/SortByPrevTime.hs --- a/tests/real-bbt/SortByPrevTime.hs +++ b/tests/real-bbt/SortByPrevTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module SortByPrevTime (sortByPrevTimeMain) where import Test.Framework diff --git a/tests/real-bbt/UniqTests1.hs b/tests/real-bbt/UniqTests1.hs --- a/tests/real-bbt/UniqTests1.hs +++ b/tests/real-bbt/UniqTests1.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests1 (uniqTests1Main) where import Test.Framework diff --git a/tests/real-bbt/UniqTests2.hs b/tests/real-bbt/UniqTests2.hs --- a/tests/real-bbt/UniqTests2.hs +++ b/tests/real-bbt/UniqTests2.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests2 (uniqTests2Main) where import Test.Framework