diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,23 @@ +* 0.10.0.0 (2012-12-06) + - machine-readable output: the --json option provides a way for getting + machine-readable output in a simple JSON-based format + - support for subAssert (allows abstraction over assertions but keeps error locations) + - don't depend on unix under Windows + - added timing information to the output + - possibility to list all tests + - several bugfixes, especially related to location information in presence + of an extra cpp invocation + - HTF itself now has a test suite + - removed upper bounds from .cabal files + - backwards incompatibilities: + + 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. + * 0.9.0.0 (2012-09-26) NOTE: this version is NOT backwards compatible with 0.8.*. The documentation on hackage describes what you need to do in order to upgrade. diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.9.0.0 +Version: 0.10.0.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2012 Stefan Wehr @@ -34,6 +34,23 @@ /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). @@ -62,13 +79,55 @@ annotation, use the symbol @htf_importedTests@ for referencing the imported tests. See "Test.Framework.Tutorial" for details. -Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1 +Tested-With: + GHC==7.0.4, + GHC==7.2.1, + GHC==7.4.2, + GHC==7.6.1 Build-Type: Simple -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.10 Extra-Source-Files: README.md 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 + tests/bbt/should_pass/*.in + tests/bbt/should_pass/*.err + tests/bbt/should_pass/*.out + tests/bbt/should_pass/*.x + tests/bbt/Skip/BBTArgs + tests/bbt/Skip/some_unknown_but_skipped_file.x + tests/bbt/Verbose/BBTArgs + tests/bbt/Verbose/not_ok_because_stdout1.out + tests/bbt/Verbose/not_ok_because_stdout1.x + 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 + tests/compile-errors/Test2.hs + sample/LICENSE + sample/Main.hs + sample/MyPkg/A.hs + sample/MyPkg/B.hs + sample/README + sample/sample-HTF.cabal + sample/Setup.hs + sample/TestMain.hs + sample/bbt-dir/should-fail/BBTArgs + sample/bbt-dir/should-fail/z.err + 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 Source-Repository head Type: git @@ -77,40 +136,73 @@ Executable htfpp Main-Is: HTFPP.hs Build-Depends: cpphs >= 1.12, - haskell-src-exts >= 1.11 && < 1.14, - base == 4.* + haskell-src-exts >= 1.11, + old-time >= 1.0, + directory >= 1.0, + base >= 4 && < 42 Other-Modules: Test.Framework.Preprocessor Test.Framework.HaskellParser + Default-language: Haskell2010 Library - Build-Depends: HUnit == 1.2.*, - QuickCheck >= 2.3 && < 2.6, - base == 4.*, - random == 1.0.*, - containers >= 0.3 && < 0.6, - process >= 1.0 && < 1.2, - directory >= 1.0 && < 1.3, + Build-Depends: HUnit >= 1.2.5, + QuickCheck >= 2.3, + base >= 4 && < 42, + random >= 1.0, + containers >= 0.3, + process >= 1.0, + directory >= 1.0, mtl >= 1.1 && < 2.2, - pretty >= 1.0 && < 1.2, - Diff >= 0.1.3 && < 0.2, - unix >= 2.4 && < 2.7, - bytestring >= 0.9 && < 0.11, - regex-compat >= 0.92 && < 0.96, - haskell-src-exts >= 1.11 && < 1.14 + monad-control >= 0.3, + lifted-base >= 0.1, + pretty >= 1.0, + Diff >= 0.1.3, + bytestring >= 0.9, + regex-compat >= 0.92, + haskell-src-exts >= 1.11, + aeson >= 0.6, + text >= 0.11, + old-time >= 1.0 + if !os(windows) + Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework Test.Framework.HUnitWrapper Test.Framework.TestManager + Test.Framework.TestTypes + Test.Framework.TestReporter + Test.Framework.CmdlineOptions Test.Framework.QuickCheckWrapper Test.Framework.BlackBoxTest Test.Framework.Location Test.Framework.Tutorial Test.Framework.Pretty + Test.Framework.JsonOutput Other-Modules: Test.Framework.TestManagerInternal Test.Framework.Utils Test.Framework.Colors Test.Framework.Diff Test.Framework.Process - Test.Framework.TestConfig + Default-language: Haskell2010 + -- Ghc-Options: -fwarn-unused-imports -fwarn-unused-binds + +Test-Suite TestHTF + Main-is: TestHTF.hs + Hs-Source-Dirs: tests + Type: exitcode-stdio-1.0 + Build-depends: base >= 4 && < 42, + bytestring >= 0.9, + aeson >= 0.6, + unordered-containers >= 0.2, + temporary >= 1.1, + text >= 0.11, + process >= 1.0, + filepath >= 1.1, + directory >= 1.0, + regex-compat >= 0.92, + HTF + Default-language: Haskell2010 + Other-Modules: + Foo.A, Foo.B, TestHTFHunitBackwardsCompatible diff --git a/HTFPP.hs b/HTFPP.hs --- a/HTFPP.hs +++ b/HTFPP.hs @@ -26,8 +26,10 @@ import System.Exit import Control.Monad import Control.Exception +import Data.Version import Test.Framework.Preprocessor +import qualified Paths_HTF usage :: IO () usage = @@ -47,6 +49,9 @@ "that is backwards-compatible with the corresponding functions of the\n" ++ "HUnit library.") +outputVersion :: IO () +outputVersion = + hPutStrLn stderr (showVersion Paths_HTF.version) saveOpenFile :: FilePath -> IOMode -> IO Handle saveOpenFile path mode = openFile path mode `catch` exHandler @@ -64,6 +69,9 @@ "--help" `elem` args) $ do usage exitWith (ExitFailure 1) + when ("--version" `elem` args) $ + do outputVersion + exitWith ExitSuccess let (restArgs, hunitBackwardsCompat) = case reverse args of "--hunit":rrest -> (reverse rrest, True) diff --git a/TODO.org b/TODO.org --- a/TODO.org +++ b/TODO.org @@ -1,3 +1,14 @@ -* Replace haskell-src-exts by the GHC parser -* diff if assertEqualsP fails -* LATER: Support for Smallcheck and/or Lazy Smallcheck +* Release 0.10 +** Write changelog +* Relase 0.11 +** Parallel test execution +*** Options --threads=[N] or -j [N] +*** Some test cannot be run in parallel + +** Support for timeouts (--timeout=SECS) +** Proper test suite +* External interface for integrating other test frameworks +** Support for Smallcheck and/or Lazy Smallcheck +** Configuration file for htfpp +* Other ideas +** option --xml-result to output a junit-style XML document summarizing the test results diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- -- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- @@ -18,19 +16,29 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- | + +Top-level module that re-exports functionality from sub-modules. +Modules that only define unit tests and quickcheck properties typically +only need to import this module. +Your test driver should additionally import 'Test.Framework.TestManager' and, +if needed, 'Test.Framework.BlackBoxTest'. + +-} module Test.Framework ( - module Test.Framework.HUnitWrapper, - module Test.Framework.QuickCheckWrapper, - module Test.Framework.BlackBoxTest, - module Test.Framework.TestManager, + -- * Unit tests + module Test.Framework.HUnitWrapper, TM.makeUnitTest, - Loc.makeLoc + -- * Quickcheck + module Test.Framework.QuickCheckWrapper, TM.makeQuickCheckTest, + -- * Organizing tests + TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc + ) where import Test.Framework.HUnitWrapper import Test.Framework.QuickCheckWrapper -import Test.Framework.BlackBoxTest -import Test.Framework.TestManager +import qualified Test.Framework.TestManager as TM import qualified Test.Framework.Location as Loc diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/CmdlineOptions.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} +-- +-- 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 commandline options of the test driver provided by HTF. + +-} +module Test.Framework.CmdlineOptions ( + + CmdlineOptions(..), defaultCmdlineOptions, parseTestArgs, helpString, + testConfigFromCmdlineOptions + +) where + +import Test.Framework.TestReporter +import Test.Framework.TestTypes +import Test.Framework.Colors +import Test.Framework.Utils + +import Data.Char (toLower) +import Data.Maybe + +import System.IO + +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) +#endif + +#ifdef COMPILER_GHC +import GHC.Conc ( numCapabilities ) +#endif + +-- +-- CmdlineOptions +-- + +-- | Commandline options for running tests. +data CmdlineOptions = CmdlineOptions { + opts_quiet :: Bool -- ^ Be quiet or not. + , opts_filter :: TestFilter -- ^ Run only tests matching this filter. + , 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 (currently unused). + , opts_machineOutput :: Bool -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON 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'). + } + +{- | +The default 'CmdlineOptions'. +-} +defaultCmdlineOptions :: CmdlineOptions +defaultCmdlineOptions = CmdlineOptions { + opts_quiet = False + , opts_filter = const True + , opts_help = False + , opts_negated = [] +-- , opts_threads = Nothing + , opts_machineOutput = False + , opts_useColors = Nothing + , opts_outputFile = Nothing + , opts_listTests = False + , opts_split = False + } + +processorCount :: Int +#ifdef COMPILER_GHC +processorCount = numCapabilities +#else +processorCount = 1 +#endif + +optionDescriptions :: [OptDescr (CmdlineOptions -> 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 ['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" + , 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" + ] + where + parseThreads Nothing = processorCount + parseThreads (Just s) = + case readM s of + Just i -> i + Nothing -> error ("invalid number of threads: " ++ s) + parseBool s = + if map toLower s `elem` ["1", "true", "yes", "on"] then True else False + +{- | + +Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis +of the format of the commandline arguments: + +> USAGE: COMMAND [OPTION ...] PATTERN ... +> +> 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 +> -o FILE --output-file=FILE name of output file +> --json output results in machine-readable JSON 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 +-} + +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 + (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ + usageInfo usageHeader optionDescriptions) + _ -> Right opts + (_,_,errs) -> + Left (concat errs ++ usageInfo usageHeader optionDescriptions) + where + matches r s = isJust $ R.matchRegex r s + mkRegex s = R.mkRegexWithOpts s True False + +usageHeader :: String +usageHeader = ("USAGE: COMMAND [OPTION ...] PATTERN ...\n\n" ++ + " where PATTERN is a posix regular expression matching\n" ++ + " the names of the tests to run.\n") + +-- | The string displayed for the @--help@ option. +helpString :: String +helpString = usageInfo usageHeader optionDescriptions + +-- +-- TestConfig +-- + +-- | Turn the 'CmdlineOptions' into a 'TestConfig'. +testConfigFromCmdlineOptions :: CmdlineOptions -> IO TestConfig +testConfigFromCmdlineOptions opts = + do (output, colors) <- + case (opts_outputFile opts, opts_split opts) of + (Just fname, True) -> return (TestOutputSplitted fname, False) + _ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile + colors <- checkColors mOutputFd + return (TestOutputHandle outputHandle closeOutput, colors) + setUseColors colors +-- let threads = opts_threads opts + let reporters = defaultTestReporters False {-(isJust threads)-} (opts_machineOutput opts) + return $ TestConfig { tc_quiet = opts_quiet opts +-- , tc_threads = threads + , tc_output = output + , tc_reporters = reporters + , tc_filter = opts_filter opts } + where +#ifdef mingw32_HOST_OS + openOutputFile = + case opts_outputFile opts of + Nothing -> return (stdout, False, Nothing) + Just fname -> + do f <- openFile fname WriteMode + return (f, True, Nothing) + checkColors mOutputFd = + case opts_useColors opts of + Just b -> return b + Nothing -> return False +#else + openOutputFile = + case opts_outputFile opts of + Nothing -> return (stdout, False, Just stdOutput) + Just fname -> + do f <- openFile fname WriteMode + return (f, True, Nothing) + checkColors mOutputFd = + case opts_useColors opts of + Just b -> return b + Nothing -> + do mterm <- getEnv "TERM" + case mterm of + Nothing -> return False + Just s | map toLower s == "dumb" -> return False + _ -> do mx <- getEnv "HTF_NO_COLORS" + case mx of + Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False + _ -> case mOutputFd of + Just fd -> queryTerminal fd + _ -> return False +#endif diff --git a/Test/Framework/Colors.hs b/Test/Framework/Colors.hs --- a/Test/Framework/Colors.hs +++ b/Test/Framework/Colors.hs @@ -23,9 +23,11 @@ , firstDiffColor, secondDiffColor, skipDiffColor, diffColor , warningColor, testStartColor, testOkColor, pendingColor + , setUseColors, useColors ) where -import Test.Framework.TestConfig +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef -- REVERSE = "\033[2m" @@ -78,3 +80,15 @@ colorize c s = do b <- useColors return $ if b then withColor c s else s + +-- We store the info about the use of colors in a global variable instead of the TestConfigs because +-- hunit tests must known whether to colorize diffs. +_useColors :: IORef Bool +_useColors = unsafePerformIO (newIORef False) +{-# NOINLINE _useColors #-} + +useColors :: IO Bool +useColors = readIORef _useColors + +setUseColors :: Bool -> IO () +setUseColors b = atomicModifyIORef _useColors (\_ -> (b, ())) diff --git a/Test/Framework/Diff.hs b/Test/Framework/Diff.hs --- a/Test/Framework/Diff.hs +++ b/Test/Framework/Diff.hs @@ -31,20 +31,13 @@ import Control.Exception (catch, finally, IOException) import qualified Data.List as List +import Data.Char import Data.Algorithm.Diff -import Data.Char (isDigit) -import Test.QuickCheck -import Text.PrettyPrint -import Debug.Trace (trace) - import Test.Framework.Colors -import Test.Framework.TestConfig -- for testing import System.IO -import System.Environment import System.Directory -import System.IO.Unsafe (unsafePerformIO) import System.Exit import System.Process diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + -- -- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de -- @@ -70,33 +72,41 @@ assertNothingNoShow_, assertNothingNoShowVerbose_, -- * General failure - assertFailure, unitTestPending, unitTestPending' + assertFailure_, + -- * Pending unit tests + unitTestPending, unitTestPending', + + -- * Sub assertions + subAssert_, subAssertVerbose_ ) where -import System.IO ( stderr ) -import Data.List ( (\\) ) import Control.Exception -import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Control import qualified Test.HUnit as HU hiding ( assertFailure ) -import qualified Language.Haskell.Exts.Parser as HE import qualified Language.Haskell.Exts.Pretty as HE +import qualified Language.Haskell.Exts.Parser as HE -import Test.Framework.TestManager +import Data.List ( (\\) ) + import Test.Framework.TestManagerInternal import Test.Framework.Location -import Test.Framework.Utils import Test.Framework.Diff import Test.Framework.Colors import Test.Framework.Pretty -- WARNING: do not forget to add a preprocessor macro for new assertions!! +assertFailure__ :: Location -> String -> IO a +assertFailure__ loc s = unitTestFail (Just loc) s + {- | -Fail with the given reason. +Fail with the given reason, supplying the error location and the error message. -} -assertFailure :: String -> IO a -assertFailure s = unitTestFail s +assertFailure_ :: Location -> String -> IO a +assertFailure_ loc s = + assertFailure__ loc (mkMsg "assertFailure" "" ("failed at " ++ showLoc loc) ++ ": " ++ s) {- | Use @unitTestPending' msg test@ to mark the given test as pending @@ -145,7 +155,7 @@ _assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion _assertBool_ name loc s False = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertBool_ _ _ _ True = return () DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.) @@ -202,7 +212,7 @@ _assertEqual_ name loc s expected actual = if expected /= actual then do x <- equalityFailedMessage (show expected) (show actual) - assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return () DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal. @@ -215,7 +225,7 @@ _assertNotEqual_ name loc s expected actual = if expected == actual then do x <- notEqualityFailedMessage (show expected) - assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return () DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal. @@ -228,7 +238,7 @@ _assertEqualPretty_ name loc s expected actual = if expected /= actual then do x <- equalityFailedMessage (showPretty expected) (showPretty actual) - assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return () DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal. @@ -241,7 +251,7 @@ _assertNotEqualPretty_ name loc s expected actual = if expected == actual then do x <- notEqualityFailedMessage (showPretty expected) - assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return () DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal. The first parameter denotes the expected value. Use these two functions @@ -252,7 +262,7 @@ => String -> Location -> String -> a -> a -> HU.Assertion _assertEqualNoShow_ name loc s expected actual = if expected /= actual - then assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) else return () DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal. The first parameter denotes the expected value. Use these two functions @@ -264,7 +274,7 @@ => String -> Location -> String -> a -> a -> HU.Assertion _assertNotEqualNoShow_ name loc s expected actual = if expected == actual - then assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) else return () DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal. The first parameter denotes the expected value. Use these two functions @@ -283,13 +293,13 @@ na = length actual in case () of _| ne /= na -> - assertFailure (mkMsg name s + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ "\n expected length: " ++ show ne ++ "\n actual length: " ++ show na)) | not (unorderedEq expected actual) -> do x <- equalityFailedMessage (show expected) (show actual) - assertFailure (mkMsg "assertSetEqual" s + assertFailure__ loc (mkMsg "assertSetEqual" s ("failed at " ++ showLoc loc ++ x)) | otherwise -> return () where unorderedEq l1 l2 = @@ -301,14 +311,14 @@ _assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertNotEmpty_ name loc s [] = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertNotEmpty_ _ _ _ (_:_) = return () DocAssertion(assertNotEmpty, Fail if the given list is empty.) CreateAssertions(assertNotEmpty, [a]) _assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertEmpty_ name loc s (_:_) = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertEmpty_ _ _ _ [] = return () DocAssertion(assertEmpty, Fail if the given list is a non-empty list.) CreateAssertions(assertEmpty, [a]) @@ -322,11 +332,11 @@ _assertThrowsIO_ name loc s x f = do res <- try x case res of - Right _ -> assertFailure (mkMsg name s + Right _ -> assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": no exception was thrown")) Left e -> if f e then return () - else assertFailure (mkMsg name s + else assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": wrong exception was thrown: " ++ @@ -363,7 +373,7 @@ => String -> Location -> String -> Either a b -> IO a _assertLeft_ _ _ _ (Left x) = return x _assertLeft_ name loc s (Right x) = - assertFailure (mkMsg name s + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected a Left value, given " ++ show (Right x :: Either b b))) @@ -374,7 +384,7 @@ _assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a _assertLeftNoShow_ _ _ _ (Left x) = return x _assertLeftNoShow_ name loc s (Right _) = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected a Left value, given a Right value")) DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.) CreateAssertionsRet(assertLeftNoShow, Either a b, IO a) @@ -383,7 +393,7 @@ => String -> Location -> String -> Either a b -> IO b _assertRight_ _ _ _ (Right x) = return x _assertRight_ name loc s (Left x) = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected a Right value, given " ++ show (Left x :: Either a a))) DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'. @@ -393,7 +403,7 @@ _assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b _assertRightNoShow_ _ _ _ (Right x) = return x _assertRightNoShow_ name loc s (Left _) = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected a Right value, given a Left value")) DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.) CreateAssertionsRet(assertRightNoShow, Either a b, IO b) @@ -405,7 +415,7 @@ _assertJust_ :: String -> Location -> String -> Maybe a -> IO a _assertJust_ _ _ _ (Just x) = return x _assertJust_ name loc s Nothing = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected a Just value, given Nothing")) DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.) CreateAssertionsRet(assertJust, Maybe a, IO a) @@ -414,7 +424,7 @@ => String -> Location -> String -> Maybe a -> HU.Assertion _assertNothing_ _ _ _ Nothing = return () _assertNothing_ name loc s jx = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected Nothing, given " ++ show jx)) DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'. Use this function if @a@ is an instance of 'Show'.) @@ -423,7 +433,33 @@ _assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion _assertNothingNoShow_ _ _ _ Nothing = return () _assertNothingNoShow_ name loc s _ = - assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": expected Nothing, given a Just value")) DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.) CreateAssertions(assertNothingNoShow, Maybe a) + +-- +-- Sub assertions +-- + +-- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location +-- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write +-- +-- > assertIsPositive :: Int -> Assertion +-- > assertIsPositive n = assertBool (n > 0) +-- +-- You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly +-- you will lose location information: if @assertIsPositive i@ fails you will only get the location where +-- @assertIsPositive@ is defined but not from where it has been called. +-- +-- To recover the location information you simply use @subAssert (assertIsPositive i)@. +-- In this case, if @i@ is not positive, you will get the location of the caller. +-- +-- /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@. +subAssert_ :: MonadBaseControl IO m => Location -> m () -> m() +subAssert_ loc ass = unitTestSubAssert loc Nothing ass + + +-- | Same as 'subAssert_' but with an additional error message. +subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m () -> m () +subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs --- a/Test/Framework/HaskellParser.hs +++ b/Test/Framework/HaskellParser.hs @@ -18,7 +18,7 @@ module Test.Framework.HaskellParser where import Data.Maybe -import Data.Char ( isSpace ) +import Data.Char ( isSpace, isDigit ) import qualified Data.List as List import Control.Exception ( evaluate, catch, SomeException ) #if !MIN_VERSION_base(4,6,0) @@ -56,6 +56,25 @@ , imp_alias :: Maybe Name , imp_loc :: Location } +-- Returns for lines of the form '# ""' +-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output) +-- the value 'Just ""' +parseCppLineInfoOut :: String -> Maybe (String, String) +parseCppLineInfoOut line = + case line of + '#':' ':c:rest + | isDigit c -> + case List.span isDigit rest of + (restDigits, ' ' : '"' : rest) -> + case dropWhile (/= '"') (reverse rest) of + '"' : fileNameRev -> + let line = (c:restDigits) + file = "\"" ++ reverse fileNameRev ++ "\"" + in Just (line, file) + _ -> Nothing + _ -> Nothing + _ -> Nothing + parse :: FilePath -> String -> IO (ParseResult Module) parse originalFileName input = do r <- (evaluate $ Exts.parseFileContentsWithComments parseMode fixedInput) @@ -67,14 +86,20 @@ where -- fixedInput serves two purposes: -- 1. add a trailing \n - -- 2. comment out lines starting with # + -- 2. turn lines of the form '# ""' into GHC line pragmas '{-# LINE #-}' + -- 2. turn lines of the form '#line ""' into GHC line pragmas '{-# LINE #-}' + -- 3. comment out lines starting with # fixedInput :: String fixedInput = (unlines . map fixLine . lines) input where fixLine s = - case dropWhile isSpace s of - '#':_ -> "-- " ++ s - _ -> s + case parseCppLineInfoOut s of + Just (line, file) -> "{-# LINE " ++ line ++ " " ++ file ++ " #-}" + Nothing -> + case dropWhile isSpace s of + '#':'l':'i':'n':'e':rest -> "{-# LINE " ++ rest ++ " #-}" + '#':_ -> "-- " ++ s + _ -> s {- FIXME: fixities needed for all operators. Heuristic: all operators are considered to be any sequence of the symbols _:"'>!#$%&*+./<=>?@\^|-~ with at most length 8 -} diff --git a/Test/Framework/JsonOutput.hs b/Test/Framework/JsonOutput.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/JsonOutput.hs @@ -0,0 +1,213 @@ +{- | + +HTF's machine-readable output is a sequence of JSON messages. Each message is terminated +by a newline followed by two semicolons followed again by a newline. + +There are four types of JSON messages. Each JSON object has a "type" attribute denoting +this type. The types are: @test-start@, @test-end@, and @test-list@, @test-results@. +Their haskell representations are 'TestStartEventObj', 'TestEndEventObj', 'TestListObj', and +'TestResultsObj'. The corresponding JSON rendering is defined in this module. + + * The @test-start@ message denotes the start of a single test case. Example (whitespace inserted for better readability): + +> {"test": {"flatName": "Main:nonEmpty", +> "location": {"file": "Tutorial.hs", "line": 17}, +> "path": ["Main","nonEmpty"], +> "sort": "unit-test"}, +> "type":"test-start"} + + * The @test-end@ message denotes the end of a single test case. It contains information about the outcome of the test. Example: + +> {"result": "pass", +> "message":"", +> "test":{"flatName": "Main:nonEmpty", +> "location": {"file": "Tutorial.hs", "line": 17}, +> "path": ["Main","nonEmpty"], +> "sort": "unit-test"}, +> "wallTime": 0, // in milliseconds +> "type": "test-end", +> "location":null} + + * The @test-results@ message occurs after all tests have been run and summarizes their results. Example: + +> {"failures": 0, +> "passed": 4, +> "pending": 0, +> "wallTime": 39, // in milliseconds +> "errors": 0, +> "type":"test-results"} + + * The @test-list@ message contains all tests defined. It is used for the --list commandline options. Example: + +> {"tests": [{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"}, +> {"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"}, +> {"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"}, +> {"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"}], +> "type":"test-list"} + +For an exact specification, please have a look at the code of this module. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Test.Framework.JsonOutput ( + + TestStartEventObj, TestEndEventObj, TestListObj, TestObj, TestResultsObj, + + mkTestStartEventObj, mkTestEndEventObj, mkTestListObj, mkTestResultsObj, + + decodeObj, HTFJsonObj + +) where + +import Test.Framework.TestTypes +import Test.Framework.Location + +import qualified Data.Aeson as J +import Data.Aeson ((.=)) + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC + +class J.ToJSON a => HTFJsonObj a + +-- "test-start" message +data TestStartEventObj + = TestStartEventObj + { ts_test :: TestObj } + +instance J.ToJSON TestStartEventObj where + toJSON ts = + J.object ["type" .= J.String "test-start" + ,"test" .= J.toJSON (ts_test ts)] + +instance HTFJsonObj TestStartEventObj + +-- "test-end" message +data TestEndEventObj + = TestEndEventObj + { te_test :: TestObj + , te_result :: TestResult + , te_location :: Maybe Location + , te_callers :: [(Maybe String, Location)] + , te_message :: String + , te_wallTimeMs :: Int + } + +instance J.ToJSON TestEndEventObj where + toJSON te = + J.object ["type" .= J.String "test-end" + ,"test" .= J.toJSON (te_test te) + ,"location" .= J.toJSON (te_location te) + ,"callers" .= J.toJSON (map (\(msg, loc) -> J.object ["message" .= J.toJSON msg + ,"location" .= J.toJSON loc]) + (te_callers te)) + ,"result" .= J.toJSON (te_result te) + ,"message" .= J.toJSON (te_message te) + ,"wallTime" .= J.toJSON (te_wallTimeMs 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 + { tlm_tests :: [TestObj] + } + +instance J.ToJSON TestListObj where + toJSON tl = + J.object ["type" .= J.String "test-list" + ,"tests" .= J.toJSON (tlm_tests tl)] + +instance HTFJsonObj TestListObj + +-- "test-results" +data TestResultsObj + = TestResultsObj + { tr_wallTimeMs :: Int + , tr_passed :: Int + , tr_pending :: Int + , tr_failed :: Int + , tr_errors :: Int + } + +instance J.ToJSON TestResultsObj where + toJSON r = J.object ["type" .= J.String "test-results" + ,"passed" .= J.toJSON (tr_passed r) + ,"pending" .= J.toJSON (tr_pending r) + ,"failures" .= J.toJSON (tr_failed r) + ,"errors" .= J.toJSON (tr_errors r) + ,"wallTime" .= J.toJSON (tr_wallTimeMs r)] + +instance HTFJsonObj TestResultsObj + +data TestObj + = TestObj + { to_flatName :: String + , to_path :: TestPath + , to_location :: Maybe Location + , to_sort :: TestSort + } + +instance J.ToJSON TestObj where + toJSON t = J.object (["flatName" .= J.toJSON (to_flatName t) + ,"path" .= J.toJSON (to_path t) + ,"sort" .= J.toJSON (to_sort t)] ++ + (case to_location t of + Just loc -> ["location" .= J.toJSON loc] + Nothing -> [])) + +instance J.ToJSON TestPath where + toJSON p = J.toJSON (testPathToList p) + +instance J.ToJSON TestSort where + toJSON s = + case s of + UnitTest -> J.String "unit-test" + QuickCheckTest -> J.String "quickcheck-property" + BlackBoxTest -> J.String "blackbox-test" + + +instance J.ToJSON Location where + toJSON loc = J.object ["file" .= J.toJSON (fileName loc) + ,"line" .= J.toJSON (lineNumber loc)] + + +mkTestObj :: GenFlatTest a -> String -> TestObj +mkTestObj ft flatName = + TestObj flatName (ft_path ft) (ft_location ft) (ft_sort ft) + +mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj +mkTestStartEventObj ft flatName = + TestStartEventObj (mkTestObj ft flatName) + +mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj +mkTestEndEventObj ftr flatName = + let r = ft_payload ftr + in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r) + (rr_message r) (rr_wallTimeMs 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 = + TestResultsObj + { tr_wallTimeMs = time + , tr_passed = passed + , tr_pending = pending + , tr_failed = failed + , tr_errors = errors + } + +decodeObj :: HTFJsonObj a => a -> BSL.ByteString +decodeObj x = + J.encode x `BSL.append` (BSLC.pack "\n;;\n") diff --git a/Test/Framework/Location.hs b/Test/Framework/Location.hs --- a/Test/Framework/Location.hs +++ b/Test/Framework/Location.hs @@ -35,7 +35,7 @@ -- | An abstract type representing locations in a file. data Location = Location String Int - deriving (Eq, Ord) + deriving (Eq, Ord, Show, Read) -- | Render a 'Location' as a 'String'. showLoc :: Location -> String diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -20,7 +20,7 @@ module Test.Framework.Preprocessor ( transform, progName ) where -import Data.Char ( toLower ) +import Data.Char ( toLower, isSpace, isDigit ) import Data.Maybe ( mapMaybe ) import qualified Data.List as List import System.IO ( hPutStrLn, stderr ) @@ -84,11 +84,12 @@ ,"assertJust" ,"assertNothing" ,"assertNothingNoShow" + ,"subAssert" ] assertDefines :: Bool -> String -> [(String, String)] assertDefines hunitBackwardsCompat prefix = - concatMap fun allAsserts + concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")] where fun a = if hunitBackwardsCompat @@ -170,15 +171,27 @@ ParseError loc err -> do warn ("Parsing of " ++ originalFileName ++ " failed at line " ++ show (lineNumber loc) ++ ": " ++ err) - preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE") + preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE") input ParseOK info -> - preprocess info + preprocess info input where - preprocess :: ModuleInfo -> IO String - preprocess info = + preprocess :: ModuleInfo -> String -> IO String + preprocess info input = do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName - input + fixedInput return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n" + where + -- fixedInput serves two purposes: + -- 1. add a trailing \n + -- 2. turn lines of the form '# ""' into line directives '#line ' + -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output). + fixedInput :: String + fixedInput = (unlines . map fixLine . lines) input + where + fixLine s = + case parseCppLineInfoOut s of + Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName + _ -> s cpphsOptions :: ModuleInfo -> CpphsOptions cpphsOptions info = defaultCpphsOptions { defines = @@ -210,12 +223,14 @@ importedTestListCode :: ModuleInfo -> String importedTestListCode info = let l = mi_htfImports info - in importedTestListFullName (mi_moduleName info) - ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++ - importedTestListFullName (mi_moduleName info) - ++ " = [\n " ++ - List.intercalate ",\n " (map htfTestsInModule l) ++ - "\n ]\n" + in case l of + [] -> "" + _ -> (importedTestListFullName (mi_moduleName info) + ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++ + importedTestListFullName (mi_moduleName info) + ++ " = [\n " ++ + List.intercalate ",\n " (map htfTestsInModule l) ++ + "\n ]\n") htfTestsInModule :: ImportDecl -> String htfTestsInModule imp = qualify imp (thisModulesTestsFullName (imp_moduleName imp)) qualify :: ImportDecl -> String -> String diff --git a/Test/Framework/Process.hs b/Test/Framework/Process.hs --- a/Test/Framework/Process.hs +++ b/Test/Framework/Process.hs @@ -31,18 +31,25 @@ import Control.Concurrent (forkIO) import qualified Control.Exception -popenShell :: String -> Maybe String -> IO (String,String,ExitCode) +-- | Run a command using the shell. +popenShell :: String -- ^ Command + -> Maybe String -- ^ Content of stdin + -> IO (String,String,ExitCode) -- ^ (stdout, stderr, exit code) popenShell cmd = popen' $ runInteractiveCommand cmd -popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ExitCode) -popen file args = +-- | Run a command. +popen :: FilePath -- ^ Binary + -> [String] -- ^ Arguments + -> Maybe String -- ^ Content of stdin + -> IO (String,String,ExitCode) -- ^ (stdout, stderr, exit code) +popen file args = popen' $ runInteractiveProcess file args Nothing Nothing -popen' :: IO (Handle, Handle, Handle, ProcessHandle) +popen' :: IO (Handle, Handle, Handle, ProcessHandle) -> Maybe String -> IO (String,String,ExitCode) -popen' run minput = - Control.Exception.handle (\ (e :: Control.Exception.SomeException) -> +popen' run minput = + Control.Exception.handle (\ (e :: Control.Exception.SomeException) -> return ([],show e,error (show e))) $ do (inp,out,err,pid) <- run diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -43,22 +43,18 @@ ) where -import qualified Data.Map as Map -import Control.Concurrent.MVar #if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..), throw, catch, catches, evaluate ) -import System.IO -import System.IO.Unsafe -import System.Random -import Data.List( group, sort, intersperse, isPrefixOf ) -import Data.Char import Data.Typeable (Typeable) +import Data.Char +import qualified Data.List as List +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent.MVar import Test.QuickCheck -import Test.QuickCheck.Property hiding (reason) import Test.Framework.TestManager import Test.Framework.TestManagerInternal @@ -119,7 +115,7 @@ Right (Success { output=msg }) -> quickCheckTestPass (adjustOutput msg) Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) -> - if pendingPrefix `isPrefixOf` 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 diff --git a/Test/Framework/TestConfig.hs b/Test/Framework/TestConfig.hs deleted file mode 100644 --- a/Test/Framework/TestConfig.hs +++ /dev/null @@ -1,64 +0,0 @@ --- --- 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.TestConfig ( - - TestConfig(..), defaultTestConfig, ReportLevel(..), report - , useColors - -) where - -import Data.Char (toLower) -import Control.Monad (unless) -import System.IO - -import System.Posix.Terminal -import System.Posix.IO (stdOutput) -import System.Posix.Types (Fd) -import System.Posix.Env (getEnv) - -data TestConfig = TestConfig { tc_quiet :: Bool } - deriving (Read,Show,Eq) - -defaultTestConfig :: TestConfig -defaultTestConfig = TestConfig { tc_quiet = False } - -data ReportLevel = Debug | Info - deriving (Eq,Ord) - -reportHandle :: Handle -reportHandle = stdout -- keep in sync with reportFd! - -reportFd :: Fd -reportFd = stdOutput -- keep in sync with reportHandle! - -report :: TestConfig -> ReportLevel -> String -> IO () -report tc level msg = - unless (tc_quiet tc && level < Info) $ do hPutStrLn reportHandle msg - hFlush reportHandle - -useColors :: IO Bool -useColors = - do mterm <- getEnv "TERM" - case mterm of - Nothing -> return False - Just s | map toLower s == "dump" -> return False - _ -> do mx <- getEnv "HTF_NO_COLORS" - case mx of - Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False - _ -> queryTerminal reportFd diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -26,67 +26,49 @@ module Test.Framework.TestManager ( - -- * Running tests - htfMain, runTest, runTestWithArgs, runTestWithOptions, + -- * Re-exports + module Test.Framework.TestTypes, - -- * Options for running tests - TestOptions(..), defaultTestOptions, parseTestArgs, + -- * Running tests + htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs', + runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig', -- * Organzing tests - TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..), TestableHTF, makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, - ) where -import Control.Monad import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs) -import Data.List ( isInfixOf, isPrefixOf, partition ) -import Text.PrettyPrint -import qualified Data.List as List -import Data.Maybe (isJust) +import Control.Exception (finally) -import System.Directory (getTemporaryDirectory, removeFile) import System.IO -import System.Console.GetOpt -import GHC.IO.Handle -import qualified Data.ByteString.Lazy as BSL -import qualified Text.Regex as R import qualified Test.HUnit.Lang as HU +import Test.Framework.Utils +import Test.Framework.TestManagerInternal +import Test.Framework.TestTypes +import Test.Framework.CmdlineOptions +import Test.Framework.TestReporter import Test.Framework.Location -import Test.Framework.Utils ( readM, ensureNewline ) -import {-# SOURCE #-} Test.Framework.TestManagerInternal -import Test.Framework.TestConfig -import Test.Framework.Colors --- | An assertion is just an 'IO' action. -type Assertion = IO () - --- | Type for naming tests. -type TestID = String - -- | Construct a test where the given 'Assertion' checks a quick check property. --- See 'Test.Framework.QuickCheckWrapper'. --- Mainly used internally. +-- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass -- | Construct a unit test from the given 'IO' action. --- See 'Test.Framework.HUnitWrapper'. --- Mainly used internally. +-- Mainly used internally by the htfpp preprocessor. makeUnitTest :: TestID -> Location -> IO a -> Test makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ()) -- | Construct a black box test from the given 'Assertion'. --- See 'Test.Framework.BlackBoxTest'. -- Mainly used internally. makeBlackBoxTest :: TestID -> Assertion -> Test makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass @@ -108,31 +90,16 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') --- | Type for distinguishing different sorts of tests. -data TestSort = UnitTest | QuickCheckTest | BlackBoxTest - deriving (Eq,Show,Read) - --- | Abstract type for tests. -data Test = BaseTest TestSort TestID (Maybe Location) Assertion - | CompoundTest TestSuite - --- | Abstract type for test suites. -data TestSuite = TestSuite TestID [Test] - | AnonTestSuite [Test] - --- | Type for flattened tests. -data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion - -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where flatten :: t -> [FlatTest] instance TestableHTF Test where - flatten = flattenTest Nothing + flatten = flattenTest instance TestableHTF TestSuite where - flatten = flattenTestSuite Nothing + flatten = flattenTestSuite instance TestableHTF t => TestableHTF [t] where flatten = concatMap flatten @@ -140,312 +107,149 @@ instance TestableHTF (IO a) where flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action) -type Path = Maybe String - -flattenTest :: Path -> Test -> [FlatTest] -flattenTest path (BaseTest sort id mloc ass) = - [FlatTest sort (path `concatPath` id) mloc ass] -flattenTest path (CompoundTest ts) = - flattenTestSuite path ts - -flattenTestSuite :: Path -> TestSuite -> [FlatTest] -flattenTestSuite path (TestSuite id ts) = - concatMap (flattenTest (Just (path `concatPath` id))) ts -flattenTestSuite path (AnonTestSuite ts) = - concatMap (flattenTest path) ts - -concatPath :: Path -> String -> String -concatPath Nothing s = s -concatPath (Just s1) s2 = s1 ++ pathSep ++ s2 - where pathSep = ":" - -data TestState = TestState { ts_passed :: [String] - , ts_failed :: [String] - , ts_error :: [String] - , ts_pending :: [String] } - -initTestState :: TestState -initTestState = TestState [] [] [] [] - -type TR = RWST TestConfig () TestState IO - -data HandleRedirection = HandleRedirection { hr_original :: Handle - , hr_originalCopy :: Handle - , hr_newHandle :: Handle - , hr_newFilePath :: FilePath } - -redirectHandle :: String -> Handle -> IO HandleRedirection -redirectHandle nameTmpl h = - do tmpDir <- getTemporaryDirectory - (path, new) <- openBinaryTempFile tmpDir nameTmpl - copy <- hDuplicate h - hDuplicateTo new h - return $ HandleRedirection { hr_original = h - , hr_originalCopy = copy - , hr_newHandle = new - , hr_newFilePath = path } - -unredirectHandle :: HandleRedirection -> IO () -unredirectHandle hr = - do hClose (hr_newHandle hr) - hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore +flattenTest :: Test -> [FlatTest] +flattenTest (BaseTest sort id mloc x) = + [FlatTest sort (TestPathBase id) mloc x] +flattenTest (CompoundTest ts) = + flattenTestSuite ts -cleanupRedirection :: Bool -> HandleRedirection -> IO () -cleanupRedirection printOutput hr = - do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr) - BSL.hPut (hr_original hr) x - hFlush (hr_original hr) - removeFile (hr_newFilePath hr) +flattenTestSuite :: TestSuite -> [FlatTest] +flattenTestSuite (TestSuite id ts) = + let fts = concatMap flattenTest ts + in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts +flattenTestSuite (AnonTestSuite ts) = + let fts = concatMap flattenTest ts + in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -runFlatTest :: FlatTest -> TR () -runFlatTest (FlatTest sort id mloc ass) = - do let name = id ++ case mloc of - Nothing -> "" - Just loc -> " (" ++ showLoc loc ++ ")" - x <- atStart name - res <- liftIO $ HU.performTestCase ass - let (testResult, msg) = +runFlatTest :: FlatTest -> TR FlatTestResult +runFlatTest ft = + do reportTestStart ft + (res, time) <- liftIO $ measure $ HU.performTestCase (ft_payload ft) + let (testResult, (mLoc, callers, msg)) = case res of - Nothing -> (Pass, "") + Nothing -> (Pass, (Nothing, [], "")) Just (isFailure, msg') -> - if sort /= QuickCheckTest - then if isFailure - then case extractPendingMessage msg' of - Nothing -> (Fail, msg') - Just msg'' -> (Pending, msg'') - else (Error, msg') - else case readM msg' :: Maybe (TestResult, Maybe String) of - Nothing -> - error ("ERROR: " ++ - "Cannot deserialize QuickCheck " ++ - "error message.\n[BEGIN]\n" ++ - show msg' ++ "\n[END]\n") - Just (r, ms) -> - case ms of - Nothing -> (r, "") - Just s -> (r, s) - afterRunning x name testResult - case testResult of - Pass -> reportSuccess name msg - Pending -> - do modify (\s -> s { ts_pending = name : (ts_pending s) }) - reportPending msg - Fail -> - do modify (\s -> s { ts_failed = name : (ts_failed s) }) - reportFailure msg - Error -> - do modify (\s -> s { ts_error = name : (ts_error s) }) - reportError msg - atEnd testResult - where - testStartMessage name = - do t <- colorize testStartColor "[TEST] " - return $ t ++ name - atStart name = - do tc <- ask - if tc_quiet tc - then liftIO $ - do stdoutRedir <- redirectHandle "HTF.out" stdout - stderrRedir <- redirectHandle "HTF.err" stderr - return $ Just (stdoutRedir, stderrRedir) - else do msg <- liftIO $ testStartMessage name - reportTR Debug msg - return Nothing - afterRunning x name testResult = - do tc <- ask - if tc_quiet tc - then case x of - Just (stdoutRedir, stderrRedir) -> liftIO $ - do unredirectHandle stderrRedir - unredirectHandle stdoutRedir - let printOutput = needsReport testResult - when printOutput $ - do msg <- testStartMessage name - report tc Info msg - cleanupRedirection printOutput stderrRedir - cleanupRedirection printOutput stdoutRedir - else return () - atEnd testResult = - do tc <- ask - if not (tc_quiet tc) || needsReport testResult - then reportTR Info "" - else return () - needsReport testResult = testResult `elem` [Fail, Error, Pending] - reportSuccess name msg = - do modify (\s -> s { ts_passed = name : (ts_passed s) }) - pref <- okPrefix - reportTR Debug (ensureNewline msg ++ pref) - reportPending msg = - do pref <- pendingPrefix - reportMessage Info msg pref - reportFailure msg = - do pref <- failurePrefix - reportMessage Info msg pref - reportError msg = - do pref <- errorPrefix - reportMessage Info msg pref - reportMessage isImportant msg prefix = - reportTR isImportant (ensureNewline msg ++ prefix) - failurePrefix = liftIO $ colorize warningColor "*** Failed! " - errorPrefix = liftIO $ colorize warningColor "@@@ Error! " - pendingPrefix = liftIO $ colorize pendingColor "^^^ Pending! " - okPrefix = liftIO $ colorize testOkColor "+++ OK" + 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)) + else let (r, s) = deserializeQuickCheckMsg msg' + in (r, (Nothing, [], s)) + 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 } + return rr -runFlatTests :: [FlatTest] -> TR () -runFlatTests = mapM_ runFlatTest +handleRunResult :: FlatTestResult -> TR () +handleRunResult r = + do modify (\s -> s { ts_results = r : ts_results s }) + reportTestResult r --- | Run something testable using the 'defaultTestOptions'. +runAllFlatTests :: [FlatTest] -> TR () +runAllFlatTests tests = + do reportGlobalStart tests + mapM_ (\ft -> runFlatTest ft >>= handleRunResult) tests + +-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t -- ^ Testable thing - -> IO ExitCode -- See 'runTestWithOptions' for a specification of the 'ExitCode' result -runTest = runTestWithOptions defaultTestOptions + -> IO ExitCode -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result +runTest = runTestWithOptions defaultCmdlineOptions -optionDescriptions :: [OptDescr (TestOptions -> TestOptions)] -optionDescriptions = - [ Option ['v'] ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output" - , 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) }) - "TEST_PATTERN") "tests to exclude" - , Option ['h'] ["help"] (NoArg (\o -> o { opts_help = True })) "display this message" - ] +-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. +runTest' :: TestableHTF t => t -- ^ Testable thing + -> IO (IO (), ExitCode) -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result +runTest' = runTestWithOptions' defaultCmdlineOptions --- | Run something testable, parse the 'TestOptions' from the given commandline arguments. +-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments. +-- Does not print the overall test results but returns an 'IO' action for doing so. runTestWithArgs :: TestableHTF t => [String] -- ^ Commandline arguments -> t -- ^ Testable thing - -> IO ExitCode -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result + -> IO ExitCode -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result. runTestWithArgs args t = + do (printSummary, ecode) <- runTestWithArgs' args t + printSummary + return ecode + + +-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments. +runTestWithArgs' :: TestableHTF t => [String] -- ^ Commandline arguments + -> t -- ^ Testable thing + -> IO (IO (), ExitCode) -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result. +runTestWithArgs' args t = case parseTestArgs args of Left err -> do hPutStrLn stderr err - return $ ExitFailure 1 + return $ (return (), ExitFailure 1) Right opts -> - runTestWithOptions opts t - -{- | - -Parse commandline arguments into 'TestOptions'. Here's a synopsis -of the format of the commandline arguments: - -> [OPTION ...] TEST_PATTERN ... -> -> where TEST_PATTERN is a posix regular expression matching -> the names of the tests to run. -> -> -v --verbose chatty output -> -q --quiet only display errors -> -n TEST_PATTERN --not=TEST_PATTERN tests to exclude -> -h --help display this message + runTestWithOptions' opts t --} +-- | Runs something testable with the given 'CmdlineOptions'. +-- See 'runTestWithConfig' for a specification of the 'ExitCode' result. +runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode +runTestWithOptions opts t = + do (printSummary, ecode) <- runTestWithOptions' opts t + printSummary + return ecode -parseTestArgs :: [String] -> Either String TestOptions -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 _ id _ _) = - if (any (\s -> s `matches` id) neg) - then False - else null pos || any (\s -> s `matches` id) pos - opts = (foldr ($) defaultTestOptions optTrans) { opts_filter = pred } - in Right opts - (_,_,errs) -> - Left (concat errs ++ usageInfo usageHeader optionDescriptions) +-- | Runs something testable with the given 'CmdlineOptions'. Does not +-- print the overall test results but returns an 'IO' action for doing so. +-- See 'runTestWithConfig' for a specification of the 'ExitCode' result. +runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode) +runTestWithOptions' opts t = + if opts_help opts + then do hPutStrLn stderr helpString + return $ (return (), ExitFailure 1) + else do tc <- testConfigFromCmdlineOptions opts + (printSummary, ecode) <- + (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) where - matches r s = isJust $ R.matchRegex r s - mkRegex s = R.mkRegexWithOpts s True False - -usageHeader :: String -usageHeader = ("USAGE: COMMAND [OPTION ...] TEST_PATTERN ...\n\n" ++ - " where TEST_PATTERN is a posix regular expression matching\n" ++ - " the names of the tests to run.\n") - --- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. -type Filter = FlatTest -> Bool - --- | Options for running tests. -data TestOptions = TestOptions { - opts_quiet :: Bool -- ^ Be quiet or not. - , opts_filter :: Filter -- ^ Run only tests matching this filter. - , opts_help :: Bool -- ^ If 'True', display a help message and exit. - , opts_negated :: [String] -- ^ Regular expressions matching test names which should /not/ run. - } - -defaultTestOptions :: TestOptions -{- | The default 'TestOptions': - -> TestOptions { -> opts_quiet = False -> , opts_filter = const True -> , opts_help = False -> , opts_negated = [] -> } - --} -defaultTestOptions = TestOptions { - opts_quiet = False - , opts_filter = const True - , opts_help = False - , opts_negated = [] - } + cleanup tc = + case tc_output tc of + TestOutputHandle h True -> hClose h + _ -> return () --- | Runs something testable with the given 'TestOptions'. +-- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully, -- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates -- that failures but no errors occurred, otherwise the error code @2@ is used. -- -- 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. -runTestWithOptions :: TestableHTF t => TestOptions -> t -> IO ExitCode -runTestWithOptions opts t = - if opts_help opts - then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions) - return $ ExitFailure 1 - else - do let pred = opts_filter opts - tc = optsToConfig opts - (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc initTestState - let passed = length (ts_passed s) - pending = length (ts_pending s) - failed = length (ts_failed s) - error = length (ts_error s) - total = passed + failed + error + pending - pendings <- colorize pendingColor "* Pending:" - failures <- colorize warningColor "* Failures:" - errors <- colorize warningColor "* Errors:" - report tc Info ("* Tests: " ++ show total ++ "\n" ++ - "* Passed: " ++ show passed ++ "\n" ++ - pendings ++ " " ++ show pending ++ "\n" ++ - failures ++ " " ++ show failed ++ "\n" ++ - errors ++ " " ++ show error ) - when (pending > 0) $ - reportDoc tc Info - (text ('\n' : pendings) $$ renderTestNames (reverse (ts_pending s))) - when (failed > 0) $ - reportDoc tc Info - (text ('\n' : failures) $$ renderTestNames (reverse (ts_failed s))) - when (error > 0) $ - reportDoc tc Info - (text ('\n' : errors) $$ renderTestNames (reverse (ts_error s))) - return $ case () of - _| failed == 0 && error == 0 -> ExitSuccess - | error == 0 -> ExitFailure 1 - | otherwise -> ExitFailure 2 - where - renderTestNames l = - nest 2 (vcat (map (\name -> text "*" <+> text name) l)) - optsToConfig opts = - TestConfig { tc_quiet = opts_quiet opts } - -reportDoc :: TestConfig -> ReportLevel -> Doc -> IO () -reportDoc tc level doc = report tc level (render doc) +runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode +runTestWithConfig tc t = + do (printSummary, ecode) <- runTestWithConfig' tc t + printSummary + return ecode -reportTR :: ReportLevel -> String -> TR () -reportTR level msg = - do tc <- ask - liftIO $ report tc level msg +-- | 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' tc t = + do ((_, s, _), time) <- + measure $ + runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) 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 + let printSummary = + runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run + return (printSummary >> return (), + case () of + _| length failed == 0 && length error == 0 -> ExitSuccess + | length error == 0 -> ExitFailure 1 + | otherwise -> ExitFailure 2) -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'. diff --git a/Test/Framework/TestManagerInternal.hs b/Test/Framework/TestManagerInternal.hs --- a/Test/Framework/TestManagerInternal.hs +++ b/Test/Framework/TestManagerInternal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- -- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de -- @@ -18,36 +19,23 @@ module Test.Framework.TestManagerInternal ( - extractPendingMessage, - quickCheckTestFail, quickCheckTestError, quickCheckTestPending, - quickCheckTestPass, - unitTestFail, unitTestPending, blackBoxTestFail, + UnitTestResult(..), - TestResult(..) + quickCheckTestFail, quickCheckTestError, quickCheckTestPending, + quickCheckTestPass, deserializeQuickCheckMsg, + unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert, + blackBoxTestFail, ) where -import Data.List ( isPrefixOf ) -import qualified Test.HUnit.Lang as HU - -import Test.Framework.TestManager - -data TestResult = Error | Fail | Pending | Pass - deriving (Show, Read, Eq) - --- A pending test case is treated as a failed testcase, but the error message --- starts with the given prefix. -pendingPrefix :: String -pendingPrefix = "__PENDING__" - -makePendingMessage :: String -> String -makePendingMessage = (++) pendingPrefix +import Test.Framework.TestTypes +import Test.Framework.Utils +import Test.Framework.Location -extractPendingMessage :: String -> Maybe String -extractPendingMessage msg = - if pendingPrefix `isPrefixOf` msg - then Just $ drop (length pendingPrefix) msg - else Nothing +import qualified Test.HUnit.Lang as HU +import Control.Monad.Trans +import Control.Monad.Trans.Control +import qualified Control.Exception.Lifted as Exc assertFailureHTF :: String -> Assertion -- Important: force the string argument, otherwise an error embedded @@ -68,14 +56,48 @@ quickCheckTestPass :: String -> Assertion quickCheckTestPass m = assertFailureHTF (show (Pass, Just m)) -unitTestFail :: String -> IO a -unitTestFail s = - do assertFailureHTF s +deserializeQuickCheckMsg :: String -> (TestResult, String) +deserializeQuickCheckMsg msg = + case readM msg of + Nothing -> + (Error, msg) + Just (r, ms) -> + case ms of + Nothing -> (r, "") + Just s -> (r, s) + +-- 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 :: String + , utr_pending :: Bool + } deriving (Eq, Show, Read) + +unitTestFail :: Maybe Location -> String -> IO a +unitTestFail loc s = + do assertFailureHTF (show (UnitTestResult loc [] s False)) error "unitTestFail: UNREACHABLE" --- |Mark a unit test as pending without removing it from the test suite. +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 = unitTestFail (makePendingMessage s) +unitTestPending s = + do assertFailureHTF (show (UnitTestResult Nothing [] s True)) + error "unitTestFail: UNREACHABLE" + +deserializeHUnitMsg :: String -> UnitTestResult +deserializeHUnitMsg msg = + case readM msg of + Just r -> r + _ -> UnitTestResult Nothing [] msg False blackBoxTestFail :: String -> Assertion blackBoxTestFail = assertFailureHTF diff --git a/Test/Framework/TestManagerInternal.hs-boot b/Test/Framework/TestManagerInternal.hs-boot deleted file mode 100644 --- a/Test/Framework/TestManagerInternal.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module Test.Framework.TestManagerInternal where - -data TestResult = Error | Fail | Pending | Pass -instance Read TestResult -instance Show TestResult -instance Eq TestResult - -extractPendingMessage :: String -> Maybe String diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TestReporter.hs @@ -0,0 +1,295 @@ +{-| + +This module defines functions for notifying all test reporters registered about +particular events in the lifecycle of a test run. + +Further, it defines the standard test reporters for HTF's various output formats. + +-} +module Test.Framework.TestReporter ( + + reportAllTests, reportGlobalStart, reportTestStart, reportTestResult, + reportGlobalResults, defaultTestReporters + +) where + +import Test.Framework.TestTypes +import Test.Framework.Location +import Test.Framework.Colors +import Test.Framework.Utils +import Test.Framework.JsonOutput + +import System.IO +import Control.Monad.RWS +import Text.PrettyPrint + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +-- | Invokes 'tr_reportAllTests' on all test reporters registered. +reportAllTests :: ReportAllTests +reportAllTests tests = + do reps <- asks tc_reporters + mapM_ (\r -> tr_reportAllTests r tests) reps + +-- | Invokes 'tr_reportGlobalStart' on all test reporters registered. +reportGlobalStart :: ReportGlobalStart +reportGlobalStart tests = + do reps <- asks tc_reporters + mapM_ (\r -> tr_reportGlobalStart r tests) reps + +-- | Invokes 'tr_reportTestStart' on all test reporters registered. +reportTestStart :: ReportTestStart +reportTestStart t = + do reps <- asks tc_reporters + mapM_ (\r -> tr_reportTestStart r t) reps + +-- | Invokes 'tr_reportTestResult' on all test reporters registered. +reportTestResult :: ReportTestResult +reportTestResult t = + do reps <- asks tc_reporters + mapM_ (\r -> tr_reportTestResult r t) reps + +-- | Invokes 'tr_reportGlobalResults' on all test reporters registered. +reportGlobalResults :: ReportGlobalResults +reportGlobalResults t l1 l2 l3 l4 = + do reps <- asks tc_reporters + mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps + +-- | The default test reporters for HTF. +defaultTestReporters :: Bool -- ^ 'True' if tests are run in parallel + -> Bool -- ^ 'True' if machine output should be produced + -> [TestReporter] +defaultTestReporters inParallel forMachine = + case (inParallel, forMachine) of + (False, False) -> + [TestReporter + { tr_id = "rep_seq_human" + , tr_reportAllTests = reportAllTestsH + , tr_reportGlobalStart = reportGlobalStartHS + , tr_reportTestStart = reportTestStartHS + , tr_reportTestResult = reportTestResultHS + , tr_reportGlobalResults = reportGlobalResultsH + }] + (True, False) -> + [TestReporter + { tr_id = "rep_par_human" + , tr_reportAllTests = reportAllTestsH + , tr_reportGlobalStart = reportGlobalStartHP + , tr_reportTestStart = reportTestStartHP + , tr_reportTestResult = reportTestResultHP + , tr_reportGlobalResults = reportGlobalResultsH + }] + (False, True) -> + [TestReporter + { tr_id = "rep_seq_machine" + , tr_reportAllTests = reportAllTestsM + , tr_reportGlobalStart = reportGlobalStartMS + , tr_reportTestStart = reportTestStartMS + , tr_reportTestResult = reportTestResultMS + , tr_reportGlobalResults = reportGlobalResultsM + }] + (True, True) -> + [TestReporter + { tr_id = "rep_par_machine" + , tr_reportAllTests = reportAllTestsM + , tr_reportGlobalStart = reportGlobalStartMP + , tr_reportTestStart = reportTestStartMP + , tr_reportTestResult = reportTestResultMP + , tr_reportGlobalResults = reportGlobalResultsM + }] + +-- +-- output for humans +-- + +humanTestName :: GenFlatTest a -> String +humanTestName ft = + flatName (ft_path ft) ++ + case ft_location ft of + Nothing -> "" + Just loc -> " (" ++ showLoc loc ++ ")" + +reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR () +reportHumanTestStartMessage level ft = + do t <- liftIO $ colorize testStartColor "[TEST] " + reportTR level (t ++ (humanTestName ft)) + +-- sequential +reportGlobalStartHS :: ReportGlobalStart +reportGlobalStartHS _ = return () + +reportTestStartHS :: ReportTestStart +reportTestStartHS ft = reportHumanTestStartMessage Debug ft + +reportTestResultHS :: ReportTestResult +reportTestResultHS ftr = + let res = rr_result (ft_payload ftr) + msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr)) + in case res of + Pass -> + do suf <- okSuffix + reportMessage Debug msg suf + Pending -> + do reportHumanTestStartMessageIfNeeded + suf <- pendingSuffix + reportMessage Info msg suf + Fail -> + do reportHumanTestStartMessageIfNeeded + suf <- failureSuffix + reportMessage Info msg suf + Error -> + do reportHumanTestStartMessageIfNeeded + suf <- errorSuffix + reportMessage Info msg suf + where + attachCallStack msg callStack = + case reverse callStack of + [] -> msg + l -> ensureNewline msg ++ + unlines (map formatCallStackElem l) + formatCallStackElem (mMsg, loc) = + " called from " ++ showLoc loc ++ (case mMsg of + Nothing -> "" + Just s -> " (" ++ s ++ ")") + reportHumanTestStartMessageIfNeeded = + do tc <- ask + when (tc_quiet tc) (reportHumanTestStartMessage Info ftr) + reportMessage level msg suffix = + reportTR level (ensureNewline msg ++ suffix ++ timeStr) + timeStr = " (" ++ show (rr_wallTimeMs (ft_payload ftr)) ++ "ms)\n" + failureSuffix = liftIO $ colorize warningColor "*** Failed!" + errorSuffix = liftIO $ colorize warningColor "@@@ Error!" + pendingSuffix = liftIO $ colorize pendingColor "^^^ Pending!" + okSuffix = liftIO $ colorize testOkColor "+++ OK" + +-- parallel +reportGlobalStartHP :: ReportGlobalStart +reportGlobalStartHP _ = return () + +reportTestStartHP :: ReportTestStart +reportTestStartHP ft = + do reportTR Debug ("Starting " ++ (humanTestName ft)) + +reportTestResultHP :: ReportTestResult +reportTestResultHP ftr = + do reportHumanTestStartMessage Debug ftr + reportTestResultHS ftr + +-- results and all tests +reportAllTestsH :: ReportAllTests +reportAllTestsH l = + reportDoc Info (renderTestNames l) + +reportGlobalResultsH :: ReportGlobalResults +reportGlobalResultsH t passedL pendingL failedL errorL = + do let passed = length passedL + pending = length pendingL + failed = length failedL + error = length errorL + total = passed + failed + error + pending + pendings <- liftIO $ colorize pendingColor "* Pending:" + failures <- liftIO $ colorize warningColor "* Failures:" + errors <- liftIO $ colorize warningColor "* Errors:" + reportTR Info ("* Tests: " ++ show total ++ "\n" ++ + "* Passed: " ++ show passed ++ "\n" ++ + pendings ++ " " ++ show pending ++ "\n" ++ + failures ++ " " ++ show failed ++ "\n" ++ + errors ++ " " ++ show error) + when (pending > 0) $ + reportDoc Info + (text ('\n' : pendings) $$ renderTestNames' (reverse pendingL)) + when (failed > 0) $ + reportDoc Info + (text ('\n' : failures) $$ renderTestNames' (reverse failedL)) + when (error > 0) $ + reportDoc Info + (text ('\n' : errors) $$ renderTestNames' (reverse errorL)) + reportTR Info ("\nTotal execution time: " ++ show t ++ "ms") + where + renderTestNames' rrs = + nest 2 $ renderTestNames rrs + +renderTestNames :: [GenFlatTest a] -> Doc +renderTestNames l = + vcat (map (\ft -> text "*" <+> + text (humanTestName ft)) l) + +-- +-- output for machines +-- + +-- sequential +reportGlobalStartMS :: ReportGlobalStart +reportGlobalStartMS _ = return () + +reportTestStartMS :: ReportTestStart +reportTestStartMS ft = + let json = mkTestStartEventObj ft (flatName (ft_path ft)) + in reportJsonTR json + +reportTestResultMS :: ReportTestResult +reportTestResultMS ftr = + let json = mkTestEndEventObj ftr (flatName (ft_path ftr)) + in reportJsonTR json + +-- parallel +reportGlobalStartMP :: ReportGlobalStart +reportGlobalStartMP _ = return () + +reportTestStartMP :: ReportTestStart +reportTestStartMP = reportTestStartMS + +reportTestResultMP :: ReportTestResult +reportTestResultMP = reportTestResultMS + +-- results and all tests +reportAllTestsM :: ReportAllTests +reportAllTestsM l = + let json = mkTestListObj (map (\ft -> (ft, flatName (ft_path ft))) l) + in reportJsonTR json + +reportGlobalResultsM :: ReportGlobalResults +reportGlobalResultsM t pass pending failed errors = + let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors) + in reportJsonTR json + +-- +-- General reporting routines +-- + +reportDoc :: ReportLevel -> Doc -> TR () +reportDoc level doc = reportTR level (render doc) + +reportTR :: ReportLevel -> String -> TR () +reportTR level msg = + do tc <- ask + reportGen tc level (\h -> hPutStrLn h msg) + +reportBytesTR :: ReportLevel -> BS.ByteString -> TR () +reportBytesTR level msg = + do tc <- ask + reportGen tc level (\h -> BS.hPut h msg) + +reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR () +reportLazyBytesTR level msg = + do tc <- ask + reportGen tc level (\h -> BSL.hPut h msg) + +reportJsonTR :: HTFJsonObj a => a -> TR () +reportJsonTR x = reportLazyBytesTR Info (decodeObj x) + +data ReportLevel = Debug | Info + deriving (Eq,Ord) + +reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR () +reportGen tc level fun = + unless (tc_quiet tc && level < Info) $ + case tc_output tc of + TestOutputHandle h _ -> liftIO (fun h) + TestOutputSplitted fp -> + do -- split mode: one file for each result to avoid locking on windows + ix <- gets ts_index + let realFp = fp ++ (show ix) -- just append the index at the end of the file given as output parameter + modify (\x -> x { ts_index = ts_index x + 1 }) + liftIO $ withFile realFp WriteMode fun diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TestTypes.hs @@ -0,0 +1,176 @@ +{-| + +This module defines types (and small auxiliary functions) +for organizing tests, for configuring the execution of +tests, and for representing and reporting their results. + +-} +module Test.Framework.TestTypes ( + + -- * Organizing tests + TestID, Assertion, Test(..), TestSuite(..), TestSort(..), + TestPath(..), GenFlatTest(..), FlatTest, TestFilter, + testPathToList, flatName, + + -- * Executing tests + TR, TestState(..), initTestState, TestConfig(..), TestOutput(..), + + -- * Reporting results + ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, + TestReporter(..), + + -- * Specifying results. + TestResult(..), FlatTestResult, Milliseconds, RunResult(..) + +) where + +import Test.Framework.Location + +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 () + +-- | Type for naming tests. +type TestID = String + +-- | Type for distinguishing different sorts of tests. +data TestSort = UnitTest | QuickCheckTest | BlackBoxTest + deriving (Eq,Show,Read) + +-- | Abstract type for tests and their results. +data Test = BaseTest TestSort TestID (Maybe Location) Assertion + | CompoundTest TestSuite + +-- | Abstract type for test suites and their results. +data TestSuite = TestSuite TestID [Test] + | AnonTestSuite [Test] + +-- | A type denoting the hierarchical name of a test. +data TestPath = TestPathBase TestID + | TestPathCompound (Maybe TestID) TestPath + +-- | Splits a 'TestPath' into a list of test identifiers. +testPathToList :: TestPath -> [Maybe TestID] +testPathToList (TestPathBase i) = [Just i] +testPathToList (TestPathCompound mi p) = + mi : testPathToList p + +-- | Creates a string representation from a 'TestPath'. +flatName :: TestPath -> String +flatName p = + List.intercalate ":" (map (fromMaybe "") (testPathToList p)) + +-- | Generic type for flattened tests and their results. +data GenFlatTest a + = FlatTest + { ft_sort :: TestSort -- ^ The sort of the test. + , ft_path :: TestPath -- ^ Hierarchival path. + , ft_location :: Maybe Location -- ^ Place of definition. + , ft_payload :: a -- ^ A generic payload. + } + +-- | Flattened representation of tests. +type FlatTest = GenFlatTest 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 + +-- | The result of a test run. +data RunResult + = RunResult + { rr_result :: TestResult -- ^ The summary result of the test. + , rr_location :: Maybe Location -- ^ The location where the test failed (if applicable). + , rr_callers :: [(Maybe String, Location)] -- ^ Information about the callers of the location where the test failed + , rr_message :: String -- ^ A message describing the result. + , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds. + } + +-- | The result of running a 'FlatTest' +type FlatTestResult = GenFlatTest RunResult + +-- | The state type for the 'TR' monad. +data TestState = TestState { ts_results :: [FlatTestResult] -- ^ Results collected so far. + , ts_index :: Int -- ^ Current index for splitted output. + } + +-- | The initial test state. +initTestState :: TestState +initTestState = TestState [] 0 + +-- | The 'TR' (test runner) monad. +type TR = RWST TestConfig () TestState IO + +-- | The destination of progress and result messages from HTF. +data TestOutput = TestOutputHandle Handle Bool -- ^ Output goes to 'Handle', boolean flag indicates whether the handle should be closed at the end. + | TestOutputSplitted FilePath -- ^ Output goes to files whose names are derived from 'FilePath' by appending a number to it. Numbering starts at zero. + deriving (Show, Eq) + +-- | Configuration of test execution. +data TestConfig + = TestConfig + { tc_quiet :: Bool -- ^ If set, displays messages only for failed tests. + +-- , tc_threads :: Maybe Int Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution (currently unused). + , tc_output :: TestOutput -- ^ Output destination of progress and result messages. + , tc_filter :: TestFilter -- ^ Filter for the tests to run. + , tc_reporters :: [TestReporter] -- ^ Test reporters to use. + } + +instance Show TestConfig where + showsPrec prec tc = + showParen (prec > 0) $ + showString "TestConfig { " . + showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) . +-- showString ", tc_threads=" . showsPrec 1 (tc_threads tc) . + showString ", tc_output=" . showsPrec 1 (tc_output tc) . + showString ", tc_filter=" . + showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) . + showString " }" + +-- | A 'TestReporter' provides hooks to customize the output of HTF. +data TestReporter + = TestReporter + { tr_id :: String + , tr_reportAllTests :: ReportAllTests -- ^ Called to report the IDs of all tests available. + , tr_reportGlobalStart :: ReportGlobalStart -- ^ Called to report the start of test execution. + , tr_reportTestStart :: ReportTestStart -- ^ Called to report the start of a single test. + , tr_reportTestResult :: ReportTestResult -- ^ Called to report the result of a single test. + , tr_reportGlobalResults :: ReportGlobalResults -- ^ Called to report the overall results of all tests. + } + +instance Show TestReporter where + showsPrec _ x = showString (tr_id x) + +instance Eq TestReporter where + x == y = (tr_id x) == (tr_id y) + +-- | Reports the IDs of all tests available. +type ReportAllTests = [FlatTest] -> TR () + +-- | Signals that test execution is about to start. +type ReportGlobalStart = [FlatTest] -> TR () + +-- | Reports the start of a single test. +type ReportTestStart = FlatTest -> TR () + +-- | Reports the result of a single test. +type ReportTestResult = FlatTestResult -> TR () + +-- | 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 () diff --git a/Test/Framework/Tutorial.hs b/Test/Framework/Tutorial.hs --- a/Test/Framework/Tutorial.hs +++ b/Test/Framework/Tutorial.hs @@ -1,5 +1,3 @@ -module Test.Framework.Tutorial ( - {- | This module provides a short tutorial on how to use the HTF. It assumes that you are using GHC for compiling your Haskell code. (It is @@ -14,6 +12,8 @@ -} +module Test.Framework.Tutorial ( + -- * A simple example {- | @@ -92,39 +92,49 @@ Executable tutorial Type: exitcode-stdio-1.0 Main-is: Tutorial.hs - Build-depends: base == 4.*, HTF == 0.9.* + Build-depends: base == 4.*, HTF == 0.10.* Default-language: Haskell2010 @ Compiling the program just shown (you must include the code for @myReverse@ as well), and then running the resulting program with no -further commandline arguments yields the following output: +further commandline arguments yields the following output (colors had to +be omitted, so the diff output does not look very useful): > [TEST] Main:nonEmpty (Tutorial.hs:17) > assertEqual failed at Tutorial.hs:18 > * expected: [3, 2, 1] > * but got: [3] > * diff: [3, 2, 1] -> *** Failed! +> *** Failed! (0ms) > > [TEST] Main:empty (Tutorial.hs:19) -> +++ OK +> +++ OK (0ms) > > [TEST] Main:reverse (Tutorial.hs:22) -> Falsifiable (after 7 tests and 4 shrinks): +> Falsifiable (after 6 tests and 5 shrinks): > [0,0] -> Replay argument: "Just (1982441876 2147483392,6)" -> *** Failed! +> Replay argument: "Just (200055706 2147483393,5)" +> *** Failed! (0ms) > -> * Tests: 3 +> [TEST] Main:reverseReplay (Tutorial.hs:24) +> Falsifiable (after 1 test and 2 shrinks): +> [0,0] +> Replay argument: "Just (1060394807 2147483396,2)" +> *** Failed! (0ms) +> +> * Tests: 4 > * Passed: 1 > * Pending: 0 -> * Failures: 2 +> * Failures: 3 > * Errors: 0 > > * Failures: -> * Main:nonEmpty (Tutorial.hs:17) +> * Main:reverseReplay (Tutorial.hs:24) > * Main:reverse (Tutorial.hs:22) +> * Main:nonEmpty (Tutorial.hs:17) +> +> Total execution time: 4ms (To check only specific tests, you can pass commandline arguments to the program: the HTF then runs only those tests whose name @@ -164,24 +174,26 @@ desired result: > [TEST] Main:nonEmpty (Tutorial.hs:17) -> +++ OK +> +++ OK (0ms) > > [TEST] Main:empty (Tutorial.hs:19) -> +++ OK +> +++ OK (0ms) > > [TEST] Main:reverse (Tutorial.hs:22) > Passed 100 tests. -> +++ OK +> +++ OK (20ms) > > [TEST] Main:reverseReplay (Tutorial.hs:24) > Passed 100 tests. -> +++ OK +> +++ OK (4ms) > > * Tests: 4 > * Passed: 4 > * Pending: 0 > * Failures: 0 > * Errors: 0 +> +> Total execution time: 28ms The HTF also allows the definition of black box tests. Essentially, black box tests allow you to verify that the output of your program matches your expectations. @@ -253,11 +265,49 @@ module Main where import Test.Framework +import Test.Framework.BlackBoxTest import {-@ HTF_TESTS @-} MyPkg.A import {-@ HTF_TESTS @-} MyPkg.B main = htfMain htf_importedTests @ + +-} + +-- * Machine-readable output + +{- | + +For better integration with your testing environment, HTF provides the ability to produce +machine-readable output in JSON format. Here is a short example how the JSON output looks like, +for details see "Test.Framework.JsonOutput": + + +> {"test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"type":"test-start"} +> ;; +> {"result":"pass","message":"","test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null} +> ;; +> {"test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"type":"test-start"} +> ;; +> {"result":"pass","message":"","test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null} +> ;; +> {"test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"type":"test-start"} +> ;; +> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"wallTime":19,"type":"test-end","location":null} +> ;; +> {"test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"type":"test-start"} +> ;; +> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"wallTime":4,"type":"test-end","location":null} +> ;; +> {"failures":0,"passed":4,"pending":0,"wallTime":39,"errors":0,"type":"test-results"} +> ;; + +Machine-readable ouput is requested by the @--json@ flag. You can specify a dedicated output file +using the @--output-file=@ option. On some platforms (e.g. Windows) it might not be possible to read +from the output file while the tests are running (due to file-locking). In this case, you might want +to use the @--split@ option. With this option, HTF writes each JSON message to a separate ouput file. +The name of the output file is derived from the name given with the @--output-file=@ flag by +appending an index (starting at 0) that is incremented for every message. -} diff --git a/Test/Framework/Utils.hs b/Test/Framework/Utils.hs --- a/Test/Framework/Utils.hs +++ b/Test/Framework/Utils.hs @@ -21,6 +21,7 @@ import System.Directory import Data.Char +import System.Time hiding (diffClockTimes) infixr 6 @@ -130,3 +131,21 @@ strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- Measures execution time of the given IO action in milliseconds +measure :: IO a -> IO (a, Int) +measure ma = + do t0 <- getClockTime + a <- ma + t1 <- a `seq` getClockTime + let diffMicro = t1 `diffClockTimes` t0 + return (a, fromInteger (diffMicro `div` 1000)) + +diffClockTimes :: ClockTime -> ClockTime -> Integer +diffClockTimes (TOD s1 p1) (TOD s0 p0) = + (picoseconds p1 + seconds s1) - + (picoseconds p0 + seconds s0) + where + -- bring all into microseconds + picoseconds i = i `div` (1000 * 1000) + seconds i = i * 1000000 diff --git a/run-all-tests-for-all-compilers.sh b/run-all-tests-for-all-compilers.sh new file mode 100644 --- /dev/null +++ b/run-all-tests-for-all-compilers.sh @@ -0,0 +1,27 @@ +#!/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 "Running tests for GHC version $ghc_version" + ./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" +done + +echo +echo -e $RESULT diff --git a/run-all-tests.sh b/run-all-tests.sh new file mode 100644 --- /dev/null +++ b/run-all-tests.sh @@ -0,0 +1,22 @@ +#!/bin/bash + +set -e + +cabal configure --enable-tests +cabal build +cabal test +cabal install + +cd tests +mkdir -p dist/build/htfpp +cp ../dist/build/htfpp/htfpp dist/build/htfpp +cabal configure --enable-tests +cabal build +cabal test + +cd ../sample +mkdir -p dist/build/htfpp +cp ../dist/build/htfpp/htfpp dist/build/htfpp +cabal configure --enable-tests +cabal build +cabal test diff --git a/sample/LICENSE b/sample/LICENSE new file mode 100644 --- /dev/null +++ b/sample/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Stefan Wehr + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Stefan Wehr nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/sample/Main.hs b/sample/Main.hs new file mode 100644 --- /dev/null +++ b/sample/Main.hs @@ -0,0 +1,34 @@ +module Main where + +-- A simple main program. The program reads the contents of the +-- given input file, checks whether the content is a number, and +-- then ouputs the results of apply funA and funB to this number. + +import MyPkg.A +import MyPkg.B + +import Test.Framework +import System.Environment (getArgs) +import System.Exit +import System.IO + +main = + do args <- getArgs + case args of + ["-h"] -> usage + ["--help"] -> usage + [file] -> doWork file + _ -> usage + where + usage = + do hPutStrLn stderr "Usage: sample [-h|--help] FILE" + exitWith (ExitFailure 1) + doWork file = + do s <- readFile file + case reads s of + [(n, "")] -> + do putStrLn $ show (funA n) + putStrLn $ show (funB n) + exitWith ExitSuccess + _ -> do hPutStrLn stderr "invalid input" + exitWith (ExitFailure 1) diff --git a/sample/MyPkg/A.hs b/sample/MyPkg/A.hs new file mode 100644 --- /dev/null +++ b/sample/MyPkg/A.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module MyPkg.A (funA, htf_thisModulesTests) where + +import Test.Framework + +funA :: Int -> Int +funA x = x + 1 + +test_funA1 = assertEqual (funA 41) 42 + +test_funA2 = assertEqual (funA 2) 3 diff --git a/sample/MyPkg/B.hs b/sample/MyPkg/B.hs new file mode 100644 --- /dev/null +++ b/sample/MyPkg/B.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module MyPkg.B (funB, htf_thisModulesTests) where + +import Test.Framework + +funB :: Int -> Int +funB x = x * 2 + +test_funB1 = assertEqual (funB 21) 42 + +test_funB2 = assertEqual (funB 0) 0 diff --git a/sample/README b/sample/README new file mode 100644 --- /dev/null +++ b/sample/README @@ -0,0 +1,12 @@ +A very simple and trivial sample project showing how to use HTF, +the Haskell Test Framework (https://github.com/skogsbaer/HTF/). + +Usage: + +$ cabal configure --enable-tests +$ cabal build +$ cabal test + +To execute the tests directly, run + +$ dist/build/sample-tests/sample-tests diff --git a/sample/Setup.hs b/sample/Setup.hs new file mode 100644 --- /dev/null +++ b/sample/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sample/TestMain.hs b/sample/TestMain.hs new file mode 100644 --- /dev/null +++ b/sample/TestMain.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +-- The main test program. + +import Test.Framework +import Test.Framework.BlackBoxTest +import {-@ HTF_TESTS @-} MyPkg.A +import {-@ HTF_TESTS @-} MyPkg.B + +main = + do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs + htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts]) diff --git a/sample/bbt-dir/should-fail/BBTArgs b/sample/bbt-dir/should-fail/BBTArgs new file mode 100644 --- /dev/null +++ b/sample/bbt-dir/should-fail/BBTArgs @@ -0,0 +1,1 @@ +Fail diff --git a/sample/bbt-dir/should-fail/z.err b/sample/bbt-dir/should-fail/z.err new file mode 100644 --- /dev/null +++ b/sample/bbt-dir/should-fail/z.err @@ -0,0 +1,1 @@ +invalid input diff --git a/sample/bbt-dir/should-fail/z.num b/sample/bbt-dir/should-fail/z.num new file mode 100644 --- /dev/null +++ b/sample/bbt-dir/should-fail/z.num @@ -0,0 +1,1 @@ +hello world diff --git a/sample/bbt-dir/should-pass/x.num b/sample/bbt-dir/should-pass/x.num new file mode 100644 --- /dev/null +++ b/sample/bbt-dir/should-pass/x.num @@ -0,0 +1,1 @@ +42 diff --git a/sample/bbt-dir/should-pass/x.out b/sample/bbt-dir/should-pass/x.out new file mode 100644 --- /dev/null +++ b/sample/bbt-dir/should-pass/x.out @@ -0,0 +1,2 @@ +43 +84 diff --git a/sample/sample-HTF.cabal b/sample/sample-HTF.cabal new file mode 100644 --- /dev/null +++ b/sample/sample-HTF.cabal @@ -0,0 +1,24 @@ +name: sample-HTF +version: 0.1.0.0 +synopsis: Sample project showing how to use HTF +homepage: https://github.com/skogsbaer/HTF/ +license: BSD3 +license-file: LICENSE +author: Stefan Wehr +maintainer: mail@stefanwehr.de +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable sample + main-is: Main.hs + other-modules: MyPkg.A MyPkg.B + build-depends: base, HTF == 0.10.* + 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.10.* + default-language: Haskell2010 diff --git a/tests/Foo/A.hs b/tests/Foo/A.hs new file mode 100644 --- /dev/null +++ b/tests/Foo/A.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# LANGUAGE CPP #-} + +module Foo.A where + +import Test.Framework + +#include "test.h" + +test_a = + assertEqual x y diff --git a/tests/Foo/B.hs b/tests/Foo/B.hs new file mode 100644 --- /dev/null +++ b/tests/Foo/B.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} + +module Foo.B (htf_thisModulesTests) where + +import qualified Test.Framework as HTF + +test_b = assertEqual 1 1 diff --git a/tests/Foo/test.h b/tests/Foo/test.h new file mode 100644 --- /dev/null +++ b/tests/Foo/test.h @@ -0,0 +1,6 @@ + +x :: Int +x = 1 + +y :: Int +y = 2 diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs new file mode 100644 --- /dev/null +++ b/tests/TestHTF.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +-- +-- Copyright (c) 2005,2010 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 +import Test.Framework.TestManager +import Test.Framework.BlackBoxTest + +import System.Environment +import System.Directory +import System.FilePath +import System.Process +import System.Exit +import System.IO +import System.IO.Temp +import Control.Exception +import qualified Data.HashMap.Strict as M +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 Text.Regex as R +import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible +import {-@ HTF_TESTS @-} qualified Foo.A as A +import {-@ HTF_TESTS @-} Foo.B + +data T = A | B + deriving Eq + +{- +stringGap = "hello \ + \world!" +-} +stringGap = "hello world!" + +handleExc :: a -> SomeException -> a +handleExc x _ = x + +test_assertFailure = + assertFailure "I'm a failure" + +test_stringGap = assertEqual stringGap "hello world!" + +test_assertEqual = assertEqual 1 2 + +test_assertEqualV = assertEqualVerbose "blub" 1 2 + +test_assertEqualNoShow = assertEqualNoShow A B + +test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2] + +test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1] + +test_assertNotEmpty = assertNotEmpty [] + +test_assertEmpty = assertEmpty [1] + +test_assertThrows = assertThrows (return () :: IO ()) (handleExc True) + +test_assertThrows' = assertThrows (error "ERROR") (handleExc False) + +test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False) + +test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True) + +test_someError = error "Bart Simpson!!" + +test_pendingTest = unitTestPending "This test is pending" + +test_subAssert = subAssert anotherSub + where + anotherSub = subAssertVerbose "I'm another sub" (assertNegative 42) + assertNegative n = assertBool (n < 0) + +data Expr = PlusExpr Expr Expr + | MultExpr Expr Expr + | Literal Int + | Variable String + deriving (Eq, Show) + +test_diff = + assertEqual (mkExpr 1) (mkExpr 2) + where + mkExpr i = + PlusExpr (PlusExpr (MultExpr (PlusExpr (Variable "foo") + (MultExpr (Literal 42) (Variable "bar"))) + (PlusExpr (Literal i) (Literal 2))) + (Literal 581)) + (Variable "egg") + +prop_ok :: [Int] -> Property +prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) + +prop_fail :: [Int] -> Bool +prop_fail xs = xs == (reverse xs) + +prop_pendingProp :: Int -> Bool +prop_pendingProp x = qcPending "This property is pending" (x == 0) + +prop_exhaust = False ==> True + +prop_error :: Bool +prop_error = 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_fail' = + withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop + where prop xs = xs == (reverse xs) + where types = xs::[Int] + +prop_error' :: TestableWithQCArgs +prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool) + +checkOutput output = + do bsl <- BSL.readFile output + let jsons = map (fromJust . J.decode) (splitJson bsl) + check jsons (J.object ["type" .= J.String "test-results"]) + (J.object ["failures" .= J.toJSON (30::Int) + ,"passed" .= J.toJSON (12::Int) + ,"pending" .= J.toJSON (2::Int) + ,"errors" .= J.toJSON (1::Int)]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Main:diff"]]) + (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs$" + ,"line" .= J.toJSON (101::Int)]] + ,"location" .= J.object ["file" .= J.String "TestHTF.hs$" + ,"line" .= J.toJSON (102::Int)]]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]]) + (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"]]) + (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null + ,"location" .= J.object ["file" .= J.String "TestHTF.hs$" + ,"line" .= J.toJSON (90::Int)]] + ,J.object ["message" .= J.String "I'm another sub" + ,"location" .= J.object ["file" .= J.String "TestHTF.hs$" + ,"line" .= J.toJSON (92::Int)]]]]) + where + check jsons pred assert = + case filter (\j -> matches j pred) jsons of + [json] -> + if not (matches json assert) + then error ("Predicate " ++ show pred ++ " match JSON " ++ show json ++ ", but assertion " ++ + show assert ++ " not satisfied") + else return () + l -> error ("not exactly one JSON matches predicate " ++ show pred ++ " but " ++ show l) + matches :: J.Value -> J.Value -> Bool + matches json pred = + case (json, pred) of + (J.Object objJson, J.Object objPred) -> + M.foldrWithKey (\k vPred b -> + b && case M.lookup k objJson of + Just vJson -> matches vJson vPred + Nothing -> False) + True objPred + (J.String strJson, J.String strPred) -> + regexMatches (mkRegex strPred) strJson + (arrJson@(J.Array _), arrPred@(J.Array _)) -> + let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson + J.Success (listPred :: [J.Value]) = J.fromJSON arrPred + in length listJson == length listPred && + all (\(x, y) -> matches x y) (zip listJson listPred) + _ -> json == pred + regexMatches r s = isJust $ R.matchRegex r (T.unpack s) + mkRegex s = R.mkRegexWithOpts (T.unpack s) True False + splitJson bsl = + if BSL.null bsl + then [] + else case BSL.span (/= 10) bsl of + (start, rest) -> + if BSLC.pack "\n;;\n" `BSL.isPrefixOf` rest + then start : splitJson (BSL.drop 4 rest) + else case splitJson rest of + [] -> error "invalid json output from HTF" + (x:xs) -> (start `BSL.append` x : xs) + +main = + do args <- getArgs + b <- doesDirectoryExist "tests/bbt" + let dirPrefix = if b then "tests" else "" + bbts <- blackBoxTests (dirPrefix "bbt") (dirPrefix "./run-bbt.sh") ".x" + (defaultBBTArgs { bbtArgs_verbose = False }) + let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests + case args of + "--interactive":rest -> + do ecode <- runTestWithArgs rest tests + case ecode of + ExitFailure _ -> return () + _ -> fail ("unexpected exit code: " ++ show ecode) + _ -> + do withSystemTempFile "HTF-out" $ \outFile h -> + do hClose h + ecode <- runTestWithArgs ["--json", "--output-file=" ++ outFile] tests + case ecode of + ExitFailure _ -> checkOutput outFile + _ -> fail ("unexpected exit code: " ++ show ecode) + `onException` (do s <- readFile outFile + hPutStrLn stderr s) + ecode <- system (dirPrefix "compile-errors/run-tests.sh") + exitWith ecode diff --git a/tests/TestHTFHunitBackwardsCompatible.hs b/tests/TestHTFHunitBackwardsCompatible.hs new file mode 100644 --- /dev/null +++ b/tests/TestHTFHunitBackwardsCompatible.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp -optF --hunit #-} +module TestHTFHunitBackwardsCompatible where + +import Test.Framework + +test_1 = do assertEqual "1 == 2" 1 2 + assertEqualHTF 1 1 + +test_2 = do assertJust "foo" (Just 1) + assertJustHTF (Just 1) diff --git a/tests/Tutorial.hs b/tests/Tutorial.hs new file mode 100644 --- /dev/null +++ b/tests/Tutorial.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +import System.Environment ( getArgs ) +import System.Exit ( exitWith ) +import Test.Framework + +{- +myReverse :: [a] -> [a] +myReverse [] = [] +myReverse [x] = [x] +myReverse (x:xs) = myReverse xs +-} + +myReverse :: [a] -> [a] +myReverse [] = [] +myReverse (x:xs) = myReverse xs ++ [x] + +test_nonEmpty = do assertEqual [1] (myReverse [1]) + assertEqual [3,2,1] (myReverse [1,2,3]) +test_empty = assertEqual ([] :: [Int]) (myReverse []) + +prop_reverse :: [Int] -> Bool +prop_reverse xs = xs == (myReverse (myReverse xs)) + +prop_reverseReplay = + withQCArgs (\a -> a { replay = read "Just (1060394807 2147483396,2)" }) + prop_reverse + +main = htfMain htf_thisModulesTests diff --git a/tests/bbt/Skip/BBTArgs b/tests/bbt/Skip/BBTArgs new file mode 100644 --- /dev/null +++ b/tests/bbt/Skip/BBTArgs @@ -0,0 +1,1 @@ +Skip diff --git a/tests/bbt/Skip/some_unknown_but_skipped_file.x b/tests/bbt/Skip/some_unknown_but_skipped_file.x new file mode 100644 --- /dev/null +++ b/tests/bbt/Skip/some_unknown_but_skipped_file.x diff --git a/tests/bbt/Verbose/BBTArgs b/tests/bbt/Verbose/BBTArgs new file mode 100644 --- /dev/null +++ b/tests/bbt/Verbose/BBTArgs @@ -0,0 +1,1 @@ +Verbose diff --git a/tests/bbt/Verbose/not_ok_because_stdout1.out b/tests/bbt/Verbose/not_ok_because_stdout1.out new file mode 100644 --- /dev/null +++ b/tests/bbt/Verbose/not_ok_because_stdout1.out @@ -0,0 +1,1 @@ +x diff --git a/tests/bbt/Verbose/not_ok_because_stdout1.x b/tests/bbt/Verbose/not_ok_because_stdout1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/Verbose/not_ok_because_stdout1.x diff --git a/tests/bbt/should_fail/BBTArgs b/tests/bbt/should_fail/BBTArgs new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/BBTArgs @@ -0,0 +1,1 @@ +Fail diff --git a/tests/bbt/should_fail/not_ok_because_stderr1.err b/tests/bbt/should_fail/not_ok_because_stderr1.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stderr1.err @@ -0,0 +1,1 @@ +x diff --git a/tests/bbt/should_fail/not_ok_because_stderr1.x b/tests/bbt/should_fail/not_ok_because_stderr1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stderr1.x diff --git a/tests/bbt/should_fail/not_ok_because_stderr2.x b/tests/bbt/should_fail/not_ok_because_stderr2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stderr2.x diff --git a/tests/bbt/should_fail/not_ok_because_stdout1.out b/tests/bbt/should_fail/not_ok_because_stdout1.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stdout1.out @@ -0,0 +1,1 @@ +x diff --git a/tests/bbt/should_fail/not_ok_because_stdout1.x b/tests/bbt/should_fail/not_ok_because_stdout1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stdout1.x diff --git a/tests/bbt/should_fail/not_ok_because_stdout2.x b/tests/bbt/should_fail/not_ok_because_stdout2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_stdout2.x diff --git a/tests/bbt/should_fail/not_ok_because_succeeds.x b/tests/bbt/should_fail/not_ok_because_succeeds.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/not_ok_because_succeeds.x diff --git a/tests/bbt/should_fail/ok1.out b/tests/bbt/should_fail/ok1.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/ok1.out diff --git a/tests/bbt/should_fail/ok1.x b/tests/bbt/should_fail/ok1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/ok1.x diff --git a/tests/bbt/should_fail/ok2.err b/tests/bbt/should_fail/ok2.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/ok2.err @@ -0,0 +1,1 @@ +y diff --git a/tests/bbt/should_fail/ok2.out b/tests/bbt/should_fail/ok2.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/ok2.out @@ -0,0 +1,1 @@ +x diff --git a/tests/bbt/should_fail/ok2.x b/tests/bbt/should_fail/ok2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_fail/ok2.x diff --git a/tests/bbt/should_pass/not_ok_because_fails.x b/tests/bbt/should_pass/not_ok_because_fails.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_fails.x diff --git a/tests/bbt/should_pass/not_ok_because_stderr1.err b/tests/bbt/should_pass/not_ok_because_stderr1.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stderr1.err @@ -0,0 +1,1 @@ +1 diff --git a/tests/bbt/should_pass/not_ok_because_stderr1.x b/tests/bbt/should_pass/not_ok_because_stderr1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stderr1.x diff --git a/tests/bbt/should_pass/not_ok_because_stderr2.x b/tests/bbt/should_pass/not_ok_because_stderr2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stderr2.x diff --git a/tests/bbt/should_pass/not_ok_because_stdout1.out b/tests/bbt/should_pass/not_ok_because_stdout1.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stdout1.out @@ -0,0 +1,1 @@ +1 diff --git a/tests/bbt/should_pass/not_ok_because_stdout1.x b/tests/bbt/should_pass/not_ok_because_stdout1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stdout1.x diff --git a/tests/bbt/should_pass/not_ok_because_stdout2.x b/tests/bbt/should_pass/not_ok_because_stdout2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/not_ok_because_stdout2.x diff --git a/tests/bbt/should_pass/ok1.out b/tests/bbt/should_pass/ok1.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/ok1.out diff --git a/tests/bbt/should_pass/ok1.x b/tests/bbt/should_pass/ok1.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/ok1.x diff --git a/tests/bbt/should_pass/ok2.err b/tests/bbt/should_pass/ok2.err new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/ok2.err @@ -0,0 +1,1 @@ +y diff --git a/tests/bbt/should_pass/ok2.out b/tests/bbt/should_pass/ok2.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/ok2.out @@ -0,0 +1,1 @@ +x diff --git a/tests/bbt/should_pass/ok2.x b/tests/bbt/should_pass/ok2.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/ok2.x diff --git a/tests/bbt/should_pass/stdin_ok.in b/tests/bbt/should_pass/stdin_ok.in new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/stdin_ok.in @@ -0,0 +1,5 @@ +1 +2 +3 +4 +5 diff --git a/tests/bbt/should_pass/stdin_ok.out b/tests/bbt/should_pass/stdin_ok.out new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/stdin_ok.out @@ -0,0 +1,5 @@ +1 +2 +3 +4 +5 diff --git a/tests/bbt/should_pass/stdin_ok.x b/tests/bbt/should_pass/stdin_ok.x new file mode 100644 --- /dev/null +++ b/tests/bbt/should_pass/stdin_ok.x diff --git a/tests/compile-errors/Foo.h b/tests/compile-errors/Foo.h new file mode 100644 --- /dev/null +++ b/tests/compile-errors/Foo.h @@ -0,0 +1,3 @@ +-- 1 +-- 2 +-- 3 diff --git a/tests/compile-errors/Test1.hs b/tests/compile-errors/Test1.hs new file mode 100644 --- /dev/null +++ b/tests/compile-errors/Test1.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} + +import Test.Framework +#include "Foo.h" + +foo :: Int -> Int +foo i = i + "Stefan" + +main :: IO () +main = return () diff --git a/tests/compile-errors/Test2.hs b/tests/compile-errors/Test2.hs new file mode 100644 --- /dev/null +++ b/tests/compile-errors/Test2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-} + +import Test.Framework +#include "Foo.h" +foo :: Int -> Int +foo i = i + "Stefan" + +main :: IO () +main = return () diff --git a/tests/compile-errors/run-tests.sh b/tests/compile-errors/run-tests.sh new file mode 100644 --- /dev/null +++ b/tests/compile-errors/run-tests.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +cd "$(dirname $0)" + +FLAGS="-hide-all-packages -package HTF -package base --make" +lineno=7 + +function check() +{ + grep_ecode="$1" + test="$2" + if [ "$grep_ecode" != "0" ] + then + echo "Compile error for test $test did not occur in line $lineno, exit code of grep: ${grep_ecode}" + exit 1 + fi +} + +ghc $FLAGS Test1.hs 2>&1 | grep Test1.hs:$lineno +grep_ecode=${PIPESTATUS[1]} +check $grep_ecode 1 + +ghc $FLAGS Test2.hs 2>&1 | grep Test2.hs:$lineno +grep_ecode=${PIPESTATUS[1]} +check $grep_ecode 2 diff --git a/tests/run-bbt.sh b/tests/run-bbt.sh new file mode 100644 --- /dev/null +++ b/tests/run-bbt.sh @@ -0,0 +1,66 @@ +#!/bin/sh + +case "$1" in + *bbt/should_fail/ok1.x) + exit 1 + ;; + *bbt/should_fail/ok2.x) + echo x + echo y 1>&2 + exit 2 + ;; + *bbt/should_fail/not_ok_because_succeeds.x) + exit 0 + ;; + *bbt/should_fail/not_ok_because_stdout1.x) + exit 1 + ;; + *bbt/should_fail/not_ok_because_stdout2.x) + echo x + exit 1 + ;; + *bbt/should_fail/not_ok_because_stderr1.x) + exit 1 + ;; + *bbt/should_fail/not_ok_because_stderr2.x) + echo x 1>&2 + exit 1 + ;; + + *bbt/should_pass/ok1.x) + exit 0 + ;; + *bbt/should_pass/ok2.x) + echo x + echo y 1>&2 + exit 0 + ;; + *bbt/should_pass/stdin_ok.x) + cat + exit 0 + ;; + *bbt/should_pass/not_ok_because_fails.x) + exit 6 + ;; + *bbt/should_pass/not_ok_because_stdout1.x) + exit 0 + ;; + *bbt/should_pass/not_ok_because_stdout2.x) + echo x + exit 0 + ;; + *bbt/should_pass/not_ok_because_stderr1.x) + exit 0 + ;; + *bbt/should_pass/not_ok_because_stderr2.x) + echo x 1>&2 + exit 0 + ;; + *bbt/Verbose/not_ok_because_stdout1.x) + exit 0 + ;; + *) + echo "$0: Illegal failname: <$1>" + exit 127 + ;; +esac diff --git a/tests/run-tests.sh b/tests/run-tests.sh new file mode 100644 --- /dev/null +++ b/tests/run-tests.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +if [ "$1" != "--no-clean" ] +then + cabal clean || exit 1 +fi +mkdir -p dist/build/htfpp || exit 1 +cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1 +cabal configure || exit 1 +cabal 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 new file mode 100644 --- /dev/null +++ b/tests/test-HTF.cabal @@ -0,0 +1,25 @@ +Name: test-HTF +Version: 0.1 +Cabal-Version: >= 1.10 +Build-type: Simple + +Executable test + Main-is: TestHTF.hs + Build-depends: base >= 4, + HTF, + 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 + Default-language: Haskell2010 + +Test-Suite tutorial + Type: exitcode-stdio-1.0 + Main-is: Tutorial.hs + Build-depends: base >= 4, HTF == 0.10.* + Default-language: Haskell2010