diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +* 0.11.0.0 (2013-08-31) + - fallback to pure Haskell diff if no diff binary found (thanks JP Moresmau) + - use cabal test feature (thanks Tom Brow) + - parallel execution of tests + - bugfix: enable DoAndIfThenElse + - bugfix: use default fixities for all operators + - two new assertions for dealing with exceptions: assertThrowsM and assertThrowsSomeM + +* 0.10.0.7 (2012-12-07) + - fixed problem building against Diff 0.1.3 + * 0.10.0.6 (2012-12-06) - support for Diff 0.2. diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.10.0.7 +Version: 0.11.0.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2012 Stefan Wehr @@ -81,10 +81,8 @@ the imported tests. See "Test.Framework.Tutorial" for details. Tested-With: - GHC==7.0.4, - GHC==7.2.1, GHC==7.4.2, - GHC==7.6.1 + GHC==7.6.2 Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: @@ -138,9 +136,11 @@ Executable htfpp Main-Is: HTFPP.hs Build-Depends: cpphs >= 1.12, - haskell-src-exts >= 1.11, + haskell-src-exts >= 1.14, old-time >= 1.0, directory >= 1.0, + array, + random >= 1.0, base == 4.* Other-Modules: Test.Framework.Preprocessor @@ -148,24 +148,27 @@ Default-language: Haskell2010 Library - Build-Depends: HUnit >= 1.2.5, + Build-Depends: + HUnit >= 1.2.5, QuickCheck >= 2.3, base == 4.*, random >= 1.0, - containers >= 0.3, + containers >= 0.5, process >= 1.0, directory >= 1.0, mtl >= 1.1 && < 2.2, monad-control >= 0.3, lifted-base >= 0.1, pretty >= 1.0, - Diff >= 0.1.3, + Diff >= 0.3, bytestring >= 0.9, regex-compat >= 0.92, haskell-src-exts >= 1.11, aeson >= 0.6, text >= 0.11, - old-time >= 1.0 + old-time >= 1.0, + array, + xmlgen >= 0.6 if !os(windows) Build-Depends: unix >= 2.4 Exposed-Modules: @@ -181,6 +184,8 @@ Test.Framework.Tutorial Test.Framework.Pretty Test.Framework.JsonOutput + Test.Framework.XmlOutput + Test.Framework.ThreadPool Other-Modules: Test.Framework.TestManagerInternal Test.Framework.Utils @@ -188,7 +193,7 @@ Test.Framework.Diff Test.Framework.Process Default-language: Haskell2010 - -- Ghc-Options: -fwarn-unused-imports -fwarn-unused-binds + Ghc-Options: -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind Test-Suite TestHTF Main-is: TestHTF.hs @@ -208,3 +213,20 @@ Default-language: Haskell2010 Other-Modules: Foo.A, Foo.B, TestHTFHunitBackwardsCompatible + +Test-Suite TestThreadPools + Main-is: ThreadPoolTest.hs + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Build-depends: base == 4.*, + random, + mtl, + HTF + Default-language: Haskell2010 + +Test-Suite Tutorial + Type: exitcode-stdio-1.0 + Main-is: Tutorial.hs + Hs-Source-Dirs: tests + Build-depends: base >= 4, HTF + Default-language: Haskell2010 diff --git a/TODO.org b/TODO.org --- a/TODO.org +++ b/TODO.org @@ -1,11 +1,11 @@ -* Relase 0.11 -** Fallback parser -*** Use the lexer of haskell-src-exts -** Parallel test execution -*** Options --threads=[N] or -j [N] -*** Some test cannot be run in parallel - +* Relase 0.12 +** New parser +*** Add support for MultiWayIf and LambdaCase to haskell-src-exts +*** Allow default Fixities for haskell-src-exts ** Support for timeouts (--timeout=SECS) ** External interface for integrating other test frameworks *** Support for Smallcheck and/or Lazy Smallcheck *** Configuration file for htfpp +**** Expansion templates (extensible!) +** Support for benchmarks +** Collect testmodules with a new preprocessor (new preprocessor runs on the main module) diff --git a/Test/Framework/BlackBoxTest.hs b/Test/Framework/BlackBoxTest.hs --- a/Test/Framework/BlackBoxTest.hs +++ b/Test/Framework/BlackBoxTest.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -- --- Copyright (c) 2005,2009,2012 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005,2009,2012,2013 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 @@ -45,13 +45,9 @@ import Prelude hiding ( catch ) #endif -import System.IO import System.Exit -import Control.Exception import System.Directory -import Data.List ( mapAccumL ) import qualified Data.Map as Map -import Control.Monad import Test.Framework.Process import Test.Framework.TestManager @@ -74,8 +70,8 @@ { bbtCfg_shouldFail :: Bool , bbtCfg_cmd :: String , bbtCfg_stdinFile :: Maybe FilePath - , bbtCfg_stdoutFile :: Maybe FilePath - , bbtCfg_stderrFile :: Maybe FilePath + , bbtCfg_stdoutFile :: Maybe FilePath -- ^ path to file holding expected output on stdout + , bbtCfg_stderrFile :: Maybe FilePath -- ^ path to file holding expected output on stderr , bbtCfg_verbose :: Bool -- functions for comparing output on stdout and stderr. , bbtCfg_stdoutCmp :: Diff @@ -145,7 +141,7 @@ defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix = \".in\" , bbtArgs_stdoutSuffix = \".out\" , bbtArgs_stderrSuffix = \".err\" - , bbtArgs_dynArgsName = "BBTArgs" + , bbtArgs_dynArgsName = \"BBTArgs\" , bbtArgs_stdoutDiff = defaultDiff , bbtArgs_stderrDiff = defaultDiff , bbtArgs_verbose = False } @@ -198,17 +194,21 @@ Suppose that one of the @.num@ files is @bbt-dir\/should-pass\/x.num@. Running the corresponding 'Test' invokes -@dist\/build\/sample\/sample@ (the program under test) with @bbt-dir\/should-pass\/x.num@ -as input file. If @bbt-dir\/should-pass\/x.num@ existed, its content +@dist\/build\/sample\/sample@ (the program under test) +with @bbt-dir\/should-pass\/x.num@ as the last commandline argument. +The other commandline arguments are taken from the flags specification given in the +file whose name is stored in the 'bbtArgs_dynArgsName' field of the 'BBTArgs' record +(see below). + +If @bbt-dir\/should-pass\/x.in@ existed, its content would be used as stdin. The tests succeeds if the exit code of the program is zero and the output on stdout and stderr matches the contents of @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively. -The directory @bbt-dir\/should-fail@ contains the file @BBTArgs@. If this file -exists, then its content specifies various -arguments for the test run. The file defines the arguments separated by newlines. -Supported arguments: +The 'bbtArgs_dynArgsName' field of the 'BBTArgs' record specifies a filename +that contains some more configuration flags for the tests. The following +flags (separated by newlines) are supported: [@Skip@] Skips all tests in the same directory as the argument file. diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs --- a/Test/Framework/CmdlineOptions.hs +++ b/Test/Framework/CmdlineOptions.hs @@ -31,7 +31,6 @@ import Test.Framework.TestReporter import Test.Framework.TestTypes -import Test.Framework.Colors import Test.Framework.Utils import Data.Char (toLower) @@ -48,7 +47,7 @@ import System.Posix.Env (getEnv) #endif -#ifdef COMPILER_GHC +#ifdef __GLASGOW_HASKELL__ import GHC.Conc ( numCapabilities ) #endif @@ -62,8 +61,10 @@ , 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_threads :: Maybe Int -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution. + , opts_shuffle :: Bool -- ^ If 'True' (the default), shuffle tests when running them in parallel. , opts_machineOutput :: Bool -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format. + , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format. , opts_useColors :: Maybe Bool -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors. , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout , opts_listTests :: Bool -- ^ If 'True', lists all tests available and exits. @@ -79,8 +80,10 @@ , opts_filter = const True , opts_help = False , opts_negated = [] --- , opts_threads = Nothing + , opts_threads = Nothing + , opts_shuffle = True , opts_machineOutput = False + , opts_machineOutputXml = Nothing , opts_useColors = Nothing , opts_outputFile = Nothing , opts_listTests = False @@ -88,7 +91,7 @@ } processorCount :: Int -#ifdef COMPILER_GHC +#ifdef __GLASGOW_HASKELL__ processorCount = numCapabilities #else processorCount = 1 @@ -100,12 +103,15 @@ , 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 ['j'] ["threads"] (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N") + ("run N tests in parallel, default N=" ++ show processorCount) + , Option [] ["deterministic"] (NoArg (\o -> o { opts_shuffle = False })) "do not shuffle tests when executing them in parallel." , Option ['o'] ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s }) "FILE") "name of output file" , Option [] ["json"] (NoArg (\o -> o { opts_machineOutput = True })) - "output results in machine-readable JSON format" + "output results in machine-readable JSON format (incremental)" + , Option [] ["xml"] (ReqArg (\s o -> o { opts_machineOutputXml = Just s }) "FILE") + "output results in junit-style XML format" , Option [] ["split"] (NoArg (\o -> o { opts_split = True })) "splits results in separate files to avoid file locking (requires -o/--output-file)" , Option [] ["colors"] (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) }) @@ -134,11 +140,15 @@ > -q --quiet only display errors > -n PATTERN --not=PATTERN tests to exclude > -l --list list all matching tests +> -j[N] --threads[=N] run N tests in parallel, default N=4 +> --deterministic do not shuffle tests when executing them in parallel. > -o FILE --output-file=FILE name of output file -> --json output results in machine-readable JSON format +> --json output results in machine-readable JSON format (incremental) +> --xml=FILE output results in junit-style XML format > --split splits results in separate files to avoid file locking (requires -o/--output-file) > --colors=BOOL use colors or not > -h --help display this message + -} parseTestArgs :: [String] -> Either String CmdlineOptions @@ -156,7 +166,7 @@ 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" ++ + (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions) _ -> Right opts (_,_,errs) -> @@ -187,14 +197,18 @@ _ -> 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) + let threads = opts_threads opts + reporters = defaultTestReporters (isParallelFromBool $ isJust threads) + (if opts_machineOutput opts then JsonOutput else NoJsonOutput) + (if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput) return $ TestConfig { tc_quiet = opts_quiet opts --- , tc_threads = threads + , tc_threads = threads + , tc_shuffle = opts_shuffle opts , tc_output = output + , tc_outputXml = opts_machineOutputXml opts , tc_reporters = reporters - , tc_filter = opts_filter opts } + , tc_filter = opts_filter opts + , tc_useColors = colors } where #ifdef mingw32_HOST_OS openOutputFile = diff --git a/Test/Framework/Colors.hs b/Test/Framework/Colors.hs --- a/Test/Framework/Colors.hs +++ b/Test/Framework/Colors.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} -- -- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de -- @@ -18,18 +20,19 @@ module Test.Framework.Colors ( - Color(..), PrimColor(..), startColor, withColor, colorize - , reset + Color(..), PrimColor(..), ColorString(..), PrimColorString(..) , firstDiffColor, secondDiffColor, skipDiffColor, diffColor , warningColor, testStartColor, testOkColor, pendingColor + , emptyColorString, (+++), unlinesColorString, colorStringFind, ensureNewlineColorString + , colorize, colorizeText, colorize', colorizeText' + , noColor, noColorText, noColor', noColorText' + , renderColorString - , setUseColors, useColors ) where -import System.IO.Unsafe (unsafePerformIO) -import Data.IORef - --- REVERSE = "\033[2m" +import qualified Data.Text as T +import Data.String +import Control.Monad firstDiffColor = Color Magenta False secondDiffColor = Color Blue False @@ -41,14 +44,15 @@ pendingColor = Color Cyan True data Color = Color PrimColor Bool + deriving (Eq, Show, Read) data PrimColor = Black | Blue | Green | Cyan | Red | Magenta | Brown | Gray | DarkGray | LightBlue | LightGreen | LightCyan | LightRed | LightMagenta | Yellow | White | NoColor - deriving (Eq, Show) + deriving (Eq, Show, Read) -startColor :: Color -> String +startColor :: Color -> T.Text startColor (Color c isBold) = (case c of Black -> "\ESC[0;30m" @@ -67,28 +71,113 @@ LightMagenta -> "\ESC[1;35m" Yellow -> "\ESC[1;33m" White -> "\ESC[1;37m" - NoColor -> "") ++ + NoColor -> "") `T.append` (if isBold then "\ESC[1m" else "") -reset :: String +reset :: T.Text reset = "\ESC[0;0m" -withColor :: Color -> String -> String -withColor c s = startColor c ++ s ++ reset +data PrimColorString = PrimColorString Color T.Text (Maybe T.Text) {- no-color fallback -} + deriving (Eq, Show, Read) -colorize :: Color -> String -> IO String -colorize c s = - do b <- useColors - return $ if b then withColor c s else s +newtype ColorString = ColorString { unColorString :: [PrimColorString] } + deriving (Eq, Show, Read) --- 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 #-} +instance IsString ColorString where + fromString = noColor -useColors :: IO Bool -useColors = readIORef _useColors +emptyColorString :: ColorString +emptyColorString = noColor "" -setUseColors :: Bool -> IO () -setUseColors b = atomicModifyIORef _useColors (\_ -> (b, ())) +unlinesColorString :: [ColorString] -> ColorString +unlinesColorString l = + concatColorString $ + map (\x -> appendPrimColorString x (PrimColorString (Color NoColor False) (T.pack "\n") Nothing)) l + where + appendPrimColorString (ColorString l) x = + ColorString (l ++ [x]) + +concatColorString :: [ColorString] -> ColorString +concatColorString l = + ColorString $ concatMap (\(ColorString l) -> l) l + +colorStringFind :: (Char -> Bool) -> ColorString -> Bool -> Maybe Char +colorStringFind pred (ColorString l) c = + let f = if c then pcolorStringFindColor else pcolorStringFindNoColor + in msum (map f l) + where + pcolorStringFindColor (PrimColorString _ t _) = tfind t + pcolorStringFindNoColor (PrimColorString _ t Nothing) = tfind t + pcolorStringFindNoColor (PrimColorString _ _ (Just t)) = tfind t + tfind t = T.find pred t + +ensureNewlineColorString :: ColorString -> ColorString +ensureNewlineColorString cs@(ColorString l) = + let (colors, noColors) = unzip $ map colorsAndNoColors (reverse l) + nlColor = needsNl colors + nlNoColor = needsNl noColors + in if not nlColor && not nlNoColor + then cs + else ColorString (l ++ + [PrimColorString (Color NoColor False) (mkNl nlColor) + (Just (mkNl nlNoColor))]) + where + mkNl True = "\n" + mkNl False = "" + colorsAndNoColors (PrimColorString _ t1 (Just t2)) = (t1, t2) + colorsAndNoColors (PrimColorString _ t1 Nothing) = (t1, t1) + needsNl [] = False + needsNl (t:ts) = + let t' = T.dropWhileEnd (\c -> c == ' ') t + in if T.null t' + then needsNl ts + else T.last t' /= '\n' + +colorize :: Color -> String -> ColorString +colorize c s = colorizeText c (T.pack s) + +colorizeText :: Color -> T.Text -> ColorString +colorizeText !c !t = ColorString [PrimColorString c t Nothing] + +colorize' :: Color -> String -> String -> ColorString +colorize' c s x = colorizeText' c (T.pack s) (T.pack x) + +colorizeText' :: Color -> T.Text -> T.Text -> ColorString +colorizeText' !c !t !x = ColorString [PrimColorString c t (Just x)] + +noColor :: String -> ColorString +noColor = colorize (Color NoColor False) + +noColorText :: T.Text -> ColorString +noColorText = colorizeText (Color NoColor False) + +noColor' :: String -> String -> ColorString +noColor' s1 s2 = colorize' (Color NoColor False) s1 s2 + +noColorText' :: T.Text -> T.Text -> ColorString +noColorText' t1 t2 = colorizeText' (Color NoColor False) t1 t2 + +infixr 5 +++ + +(+++) :: ColorString -> ColorString -> ColorString +cs1 +++ cs2 = + case (cs1, cs2) of + (ColorString [PrimColorString c1 t1 m1], ColorString (PrimColorString c2 t2 m2 : rest)) + | c1 == c2 -> + let m3 = case (m1, m2) of + (Nothing, Nothing) -> Nothing + (Just x1, Just x2) -> Just (x1 `T.append` x2) + (Just x1, Nothing) -> Just (x1 `T.append` t2) + (Nothing, Just x2) -> Just (t1 `T.append` x2) + in ColorString (PrimColorString c1 (t1 `T.append` t2) m3 : rest) + (ColorString ps1, ColorString ps2) -> ColorString (ps1 ++ ps2) + +renderColorString :: ColorString -> Bool -> T.Text +renderColorString (ColorString l) useColor = + T.concat (map render l) + where + render = if useColor then renderColors else renderNoColors + renderNoColors (PrimColorString _ _ (Just t)) = t + renderNoColors (PrimColorString _ t Nothing) = t + renderColors (PrimColorString c t _) = + T.concat [startColor c, t, reset] diff --git a/Test/Framework/Diff.hs b/Test/Framework/Diff.hs --- a/Test/Framework/Diff.hs +++ b/Test/Framework/Diff.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- -- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de -- @@ -19,9 +19,7 @@ module Test.Framework.Diff ( - DiffConfig(..), noColorsDiffConfig, coloredDiffConfig - , defaultTerminalDiffConfig, defaultNoColorsDiffConfig - , diffWithSensibleConfig, diff + DiffConfig(..), diffWithSensibleConfig, diff, main ) where @@ -33,6 +31,7 @@ import qualified Data.List as List import Data.Char import qualified Data.Algorithm.Diff as D +import Data.Algorithm.DiffOutput import Test.Framework.Colors -- for testing @@ -40,6 +39,8 @@ import System.Directory import System.Exit import System.Process +import System.Environment (getArgs) +import qualified Data.Text as T data Pos = First | Middle | Last | FirstLast deriving (Eq) @@ -54,89 +55,53 @@ isFirst FirstLast = True isFirst _ = False -isMiddle :: Pos -> Bool -isMiddle Middle = True -isMiddle _ = False - data DiffConfig = DiffConfig { -- for single line diffs - dc_fromFirstPrefix :: String - , dc_fromFirstSuffix :: String - , dc_fromSecondPrefix :: String - , dc_fromSecondSuffix :: String - , dc_fromBothPrefix :: String - , dc_fromBothSuffix :: String - , dc_sep :: String - , dc_skipPrefix :: String - , dc_skipSuffix :: String + dc_fromFirst :: String -> ColorString + , dc_fromSecond :: String -> ColorString + , dc_fromBoth :: String -> ColorString + , dc_sep :: ColorString + , dc_skip :: String -> ColorString -- for multi-line diffs - , dc_lineFromFirstPrefix :: String - , dc_lineFromSecondPrefix :: String - , dc_lineFromFirstSuffix :: String - , dc_lineFromSecondSuffix :: String - } - -noColorsDiffConfig :: Char -> Char -> DiffConfig -noColorsDiffConfig f s = DiffConfig { - dc_fromFirstPrefix = f : " " - , dc_fromFirstSuffix = "" - , dc_fromSecondPrefix = s : " " - , dc_fromSecondSuffix = "" - , dc_fromBothPrefix = "C " - , dc_fromBothSuffix = "" - , dc_skipPrefix = "<..." - , dc_skipSuffix = "...>" - , dc_sep = "\n" - , dc_lineFromFirstPrefix = "" - , dc_lineFromSecondPrefix = "" - , dc_lineFromFirstSuffix = "" - , dc_lineFromSecondSuffix = "" + , dc_lineFromFirst :: String -> ColorString + , dc_lineFromSecond :: String -> ColorString } -coloredDiffConfig :: Color -> Color -> Color -> DiffConfig -coloredDiffConfig c1 c2 c3 = DiffConfig { - dc_fromFirstPrefix = startColor c1 - , dc_fromFirstSuffix = reset - , dc_fromSecondPrefix = startColor c2 - , dc_fromSecondSuffix = reset - , dc_fromBothPrefix = "" - , dc_fromBothSuffix = "" - , dc_skipPrefix = startColor c3 ++ "..." - , dc_skipSuffix = "..." ++ reset - , dc_sep = "" - , dc_lineFromFirstPrefix = startColor c1 - , dc_lineFromSecondPrefix = startColor c2 - , dc_lineFromFirstSuffix = reset - , dc_lineFromSecondSuffix = reset +mkDefaultDiffConfig :: Color -> Color -> Color -> Char -> Char -> DiffConfig +mkDefaultDiffConfig c1 c2 c3 f s = DiffConfig { + dc_fromFirst = \x -> colorize' c1 x (f : " " ++ x) + , dc_fromSecond = \x -> colorize' c2 x (s : " " ++ x) + , dc_fromBoth = \x -> noColor' x ("C " ++ x) + , dc_skip = \x -> colorize' c3 ("..." ++ x ++ "...") ("<..." ++ x ++ "...>") + , dc_sep = noColor' "" "\n" + , dc_lineFromFirst = colorize c1 + , dc_lineFromSecond = colorize c2 } -defaultTerminalDiffConfig :: DiffConfig -defaultTerminalDiffConfig = coloredDiffConfig firstDiffColor secondDiffColor skipDiffColor - -defaultNoColorsDiffConfig :: DiffConfig -defaultNoColorsDiffConfig = noColorsDiffConfig 'F' 'S' +defaultDiffConfig :: DiffConfig +defaultDiffConfig = mkDefaultDiffConfig firstDiffColor secondDiffColor skipDiffColor 'F' 'S' contextSize :: Int contextSize = 10 -singleLineDiff :: DiffConfig -> String -> String -> String +singleLineDiff :: DiffConfig -> String -> String -> ColorString singleLineDiff dc s1 s2 - | s1 == s2 = "" + | s1 == s2 = emptyColorString | otherwise = let groups = D.getGroupedDiff s1 s2 in foldr (\(group, pos) string -> - (showDiffGroup pos group) ++ - (if not (isLast pos) then dc_sep dc else "") ++ + (showDiffGroup pos group) +++ + (if not (isLast pos) then dc_sep dc else emptyColorString) +++ string) - "" (addPositions groups) + emptyColorString (addPositions groups) where #if MIN_VERSION_Diff(0,2,0) - showDiffGroup _ (D.First s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc - showDiffGroup _ (D.Second s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc + showDiffGroup _ (D.First s) = dc_fromFirst dc s + showDiffGroup _ (D.Second s) = dc_fromSecond dc s showDiffGroup pos (D.Both inBoth _) = #else - showDiffGroup _ (D.F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc - showDiffGroup _ (D.S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc + showDiffGroup _ (D.F, s) = dc_fromFirst dc s + showDiffGroup _ (D.S, s) = dc_fromSecond dc s showDiffGroup pos (D.B, inBoth) = #endif let showStart = not $ isFirst pos @@ -150,11 +115,11 @@ (if showEnd then "" else e) in (start, ign, end) middle = let n = length ignored - replText = dc_skipPrefix dc ++ "skipped " ++ show n ++ " chars" ++ - dc_skipSuffix dc - in if n <= length replText then ignored else replText - in dc_fromBothPrefix dc ++ contextStart ++ middle ++ contextEnd ++ - dc_fromBothSuffix dc + replText = "skipped " ++ show n ++ " chars" + in if n <= length replText + then dc_skip dc ignored + else dc_skip dc replText + in dc_fromBoth dc contextStart +++ middle +++ dc_fromBoth dc contextEnd addPositions [] = [] addPositions (x:[]) = (x, FirstLast) : [] addPositions (x:xs) = (x, First) : addPositions' xs @@ -162,7 +127,7 @@ addPositions' (x:[]) = (x, Last) : [] addPositions' (x:xs) = (x, Middle) : addPositions' xs -multiLineDiff :: DiffConfig -> String -> String -> IO String +multiLineDiff :: DiffConfig -> String -> String -> IO ColorString multiLineDiff cfg left right = withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) -> do write hLeft left @@ -170,14 +135,14 @@ doDiff fpLeft fpRight where doDiff leftFile rightFile = - do (ecode, out, err) <- readProcessWithExitCode "diff" [leftFile, rightFile] "" - case ecode of - ExitSuccess -> return (format out) - ExitFailure 1 -> return (format out) - ExitFailure i -> - return ("'diff " ++ leftFile ++ " " ++ rightFile ++ - "' failed with exit code " ++ show i ++ - ": " ++ show err) + (do (ecode, out, _err) <- readProcessWithExitCode "diff" [leftFile, rightFile] "" + case ecode of + ExitSuccess -> return (format out) + ExitFailure 1 -> return (format out) + ExitFailure _i -> return $ multiLineDiffHaskell left right) + -- if we can't launch diff, use the Haskell code. + -- We don't write the exception anywhere to not pollute test results. + `catch` (\(_::IOException) -> return $ multiLineDiffHaskell left right) saveRemove fp = removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException))) withTempFiles action = @@ -189,199 +154,42 @@ write h s = do hPutStr h s hClose h - format out = unlines $ map formatLine (lines out) + format out = unlinesColorString $ map formatLine (lines out) formatLine l = case l of ('<' : _) -> fromFirst l ('>' : _) -> fromSecond l (c : _) | isDigit c -> case List.span (\c -> c /= 'a' && c /= 'c' && c /= 'd') l of - (left, c:right) -> fromFirst left ++ [c] ++ fromSecond right - (left, []) -> left - | otherwise -> l + (left, c:right) -> fromFirst left +++ + noColor [c] +++ + fromSecond right + (left, []) -> noColor left + | otherwise -> noColor l + [] -> noColor l where - fromFirst s = dc_fromFirstPrefix cfg ++ s ++ dc_fromFirstSuffix cfg - fromSecond s = dc_fromSecondPrefix cfg ++ s ++ dc_fromSecondSuffix cfg + fromFirst s = dc_fromFirst cfg s + fromSecond s = dc_fromSecond cfg s -diff :: DiffConfig -> String -> String -> IO String +diff :: DiffConfig -> String -> String -> IO ColorString diff cfg left right = case (lines left, lines right) of - ([], []) -> return "" + ([], []) -> return emptyColorString ([], [_]) -> return $ singleLineDiff cfg left right ([_], []) -> return $ singleLineDiff cfg left right ([_], [_]) -> return $ singleLineDiff cfg left right _ -> multiLineDiff cfg left right -diffWithSensibleConfig :: String -> String -> IO String +diffWithSensibleConfig :: String -> String -> IO ColorString diffWithSensibleConfig s1 s2 = - do b <- useColors - let dc = if b then defaultTerminalDiffConfig else defaultNoColorsDiffConfig - diff dc s1 s2 + diff defaultDiffConfig s1 s2 {- -NOTE: This is *nearly* working. Originally, I wanted to implemented a pure Haskell -diff solution. At some point, however, I decided that it would be better to implement -a solution based on the diff tool. For now, I leave the code as it is. - -type PrimDiff = [(DI, Char)] -type LineNo = Int - -data Line = Line { line_number :: LineNo - , line_content :: String {- without trailing \n -} - } - deriving (Show) - -data LineRange = LineRange { lr_numbers :: (LineNo, LineNo) - , lr_contents :: [String] {- without trailing \n -} - } - deriving (Show) - -data Diff a = OnlyInLeft a LineNo - | OnlyInRight a LineNo - | InBoth a a - deriving (Show) - -instance Functor Diff where - fmap f d = case d of - OnlyInLeft x n -> OnlyInLeft (f x) n - OnlyInRight x n -> OnlyInRight (f x) n - InBoth x y -> InBoth (f x) (f y) - -multiLineDiff :: DiffConfig -> String -> String -> String -multiLineDiff cfg left right = - let diff = getDiff left right :: PrimDiff - diffByLine = List.unfoldr nextLine diff - diffLines = let (_, _, l) = foldl diffLine (1, 1, []) diffByLine - in reverse l - diffLineRanges = maximize diffLines - in debug ("diff: " ++ show diff ++ - "\ndiffByLine: " ++ show diffByLine ++ - "\ndiffLines: " ++ show diffLines ++ - "\ndiffLineRanges: " ++ show diffLineRanges) $ - render $ prettyDiffs diffLineRanges - where - nextLine :: PrimDiff -> Maybe (PrimDiff, PrimDiff) - nextLine [] = Nothing - nextLine diff = - -- FIXME: add support for \r\n - case List.span (\d -> d /= (B, '\n')) diff of - ([], _ : rest) -> nextLine rest - (l, _ : rest) -> Just (l, rest) - (l, []) -> Just (l, []) - diffLine :: (Int, Int, [Diff Line]) -> PrimDiff -> (Int, Int, [Diff Line]) - diffLine (leftLineNo, rightLineNo, l) diff = - case (\(x, y) -> (reverse x, reverse y)) $ - foldl (\(l, r) d -> case d of - (F, c) -> (c : l, r) - (S, c) -> (l, c : r) - (B, c) -> (c : l, c : r)) - ([], []) diff - of ([], rightLine) -> (leftLineNo, rightLineNo + 1, - OnlyInRight (Line rightLineNo rightLine) leftLineNo : l) - (leftLine, []) -> (leftLineNo + 1, rightLineNo, - OnlyInLeft (Line leftLineNo leftLine) rightLineNo : l) - (leftLine, rightLine) - | leftLine /= rightLine -> - (leftLineNo + 1, rightLineNo + 1, - InBoth (Line leftLineNo leftLine) (Line rightLineNo rightLine) : l) - | otherwise -> - (leftLineNo + 1, rightLineNo + 1, l) - maximize :: [Diff Line] -> [Diff LineRange] - maximize [] = [] - maximize (x : l) = maximize' (fmap (\a -> [a]) x) l - where - maximize' (OnlyInLeft xs rightLineNo) (OnlyInLeft y _ : rest) = - maximize' (OnlyInLeft (y : xs) rightLineNo) rest - maximize' (OnlyInRight xs leftLineNo) (OnlyInRight y _ : rest) = - maximize' (OnlyInRight (y : xs) leftLineNo) rest - maximize' (InBoth xs ys) (InBoth x y : rest) = - maximize' (InBoth (x:xs) (y:ys)) rest - maximize' acc rest = fmap mkLineRange acc : maximize rest - mkLineRange :: [Line] -> LineRange - mkLineRange [] = error ("multilineDiff: cannot convert an empty list of lines " ++ - "into a LineRange") - mkLineRange r@(Line lastLineNo _ : _) = - case reverse r of - l@(Line firstLineNo _ : _) -> LineRange (firstLineNo, lastLineNo) - (map line_content l) - -prettyDiffs :: [Diff LineRange] -> Doc -prettyDiffs [] = empty -prettyDiffs (d : rest) = prettyDiff d $$ prettyDiffs rest - where - prettyDiff (OnlyInLeft inLeft lineNoRight) = - prettyRange (lr_numbers inLeft) <> char 'd' <> int lineNoRight $$ - prettyLines '<' (lr_contents inLeft) - prettyDiff (OnlyInRight inRight lineNoLeft) = - int lineNoLeft <> char 'a' <> prettyRange (lr_numbers inRight) $$ - prettyLines '>' (lr_contents inRight) - prettyDiff (InBoth inLeft inRight) = - prettyRange (lr_numbers inLeft) <> char 'c' <> prettyRange (lr_numbers inRight) $$ - prettyLines '<' (lr_contents inLeft) $$ - text "---" $$ - prettyLines '>' (lr_contents inRight) - prettyRange (start, end) = - if start == end then int start else int start <> comma <> int end - prettyLines start lines = - vcat (map (\l -> char start <+> text l) lines) - --- --- Tests for diff --- - -prop_diffOk :: DiffInput -> Bool -prop_diffOk inp = - multiLineDiff cfg (di_left inp) (di_right inp) == - unsafePerformIO (runDiff (di_left inp) (di_right inp)) - where - cfg = noColorsDiffConfig 'l' 'r' - runDiff left right = - do leftFile <- writeTemp left - rightFile <- writeTemp right - (ecode, out, err) <- - readProcessWithExitCode "diff" [leftFile, rightFile] "" - -- putStrLn ("OUT:\n" ++ out) - -- putStrLn ("ERR:\n" ++ err) - -- putStrLn ("ECODE:\n" ++ show ecode) - case ecode of - ExitSuccess -> return out - ExitFailure 1 -> return out - ExitFailure i -> error ("'diff " ++ leftFile ++ " " ++ rightFile ++ - "' failed with exit code " ++ show i ++ - ": " ++ show err) - writeTemp s = - do dir <- getTemporaryDirectory - (fp, h) <- openTempFile dir "HTF-diff.txt" - hPutStr h s - hClose h - return fp - -data DiffInput = DiffInput { di_left :: String, di_right :: String } - deriving (Show) - -leftDiffInput = unlines ["1", "2", "3", "4", "", "5", "6", "7"] - -instance Arbitrary DiffInput where - arbitrary = - do let leftLines = lines leftDiffInput - rightLinesLines <- mapM modifyLine (leftLines ++ [""]) - return $ DiffInput (unlines leftLines) - (unlines (concat rightLinesLines)) - where - randomString = - do c <- (elements (['a'..'z'])) - return [c] - modifyLine :: String -> Gen [String] - modifyLine str = - do prefixLen <- frequency [(20-i, return i) | i <- [0..5]] - prefix <- mapM (\_ -> randomString) [1..prefixLen] - frequency [ (5, return (prefix ++ [str])) - , (3, return (prefix ++ ["XXX" ++ str])) - , (2, return prefix) - , (2, return [str])] - -debug = trace --- debug _ x = x +Haskell diff, in case the diff tool is not present +-} +multiLineDiffHaskell :: String -> String -> ColorString +multiLineDiffHaskell left right = + noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) -- this code is now part of the Diff library (hence the >0.3 in Cabal) main = do args <- getArgs @@ -392,8 +200,8 @@ _ -> fail ("USAGE: diff FILE1 FILE2") left <- readFile leftFp right <- readFile rightFp - diff <- return $ multiLineDiff defaultTerminalDiffConfig left right - putStr diff + diff <- return $ multiLineDiffHaskell left right + putStr $ T.unpack $ renderColorString diff True -- Testcases: -- @@ -401,4 +209,3 @@ -- vs. -- > 1 -- > 2 --} diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- -- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de @@ -59,6 +60,8 @@ assertThrowsSome_, assertThrowsSomeVerbose_, assertThrowsIO_, assertThrowsIOVerbose_, assertThrowsSomeIO_, assertThrowsSomeIOVerbose_, + assertThrowsM_, assertThrowsMVerbose_, + assertThrowsSomeM_, assertThrowsSomeMVerbose_, -- * Assertions on Either values assertLeft_, assertLeftVerbose_, @@ -82,8 +85,9 @@ ) where import Control.Exception -import Control.Monad.Trans +import qualified Control.Exception.Lifted as ExL import Control.Monad.Trans.Control +import Control.Monad.Trans import qualified Test.HUnit as HU hiding ( assertFailure ) import qualified Language.Haskell.Exts.Pretty as HE import qualified Language.Haskell.Exts.Parser as HE @@ -98,7 +102,7 @@ -- WARNING: do not forget to add a preprocessor macro for new assertions!! -assertFailure__ :: Location -> String -> IO a +assertFailure__ :: Location -> ColorString -> IO a assertFailure__ loc s = unitTestFail (Just loc) s {- | @@ -106,7 +110,8 @@ -} assertFailure_ :: Location -> String -> IO a assertFailure_ loc s = - assertFailure__ loc (mkMsg "assertFailure" "" ("failed at " ++ showLoc loc) ++ ": " ++ s) + assertFailure__ loc (mkMsg "assertFailure" "" + ("failed at " ++ showLoc loc ++ ": " ++ s)) {- | Use @unitTestPending' msg test@ to mark the given test as pending @@ -115,12 +120,16 @@ unitTestPending' :: String -> IO a -> IO a unitTestPending' msg _ = unitTestPending msg -mkMsg :: String -> String -> String -> String -mkMsg fun extraInfo s = - if null extraInfo - then fun ++ (' ':s) - else fun ++ " (" ++ extraInfo ++ ") " ++ s +mkMsg :: String -> String -> String -> ColorString +mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3) +mkColorMsg :: String -> String -> ColorString -> ColorString +mkColorMsg fun extraInfo s = + let pref = if null extraInfo + then fun ++ " " + else fun ++ " (" ++ extraInfo ++ ") " + in noColor pref +++ s + -- -- Dirty macro hackery (I'm too lazy ...) -- @@ -165,15 +174,15 @@ -- Equality Assertions -- -equalityFailedMessage :: String -> String -> IO String +equalityFailedMessage :: String -> String -> IO ColorString equalityFailedMessage exp act = do d <- diffWithSensibleConfig expP actP - expected_ <- colorize firstDiffColor "* expected:" - but_got_ <- colorize secondDiffColor "* but got:" - diff_ <- colorize diffColor "* diff:" - return ("\n" ++ expected_ ++ " " ++ withNewline expP ++ - "\n" ++ but_got_ ++ " " ++ withNewline actP ++ - "\n" ++ diff_ ++ " " ++ withNewline d ++ + let expected_ = colorize firstDiffColor "* expected:" + let but_got_ = colorize secondDiffColor "* but got:" + let diff_ = colorize diffColor "* diff:" + return ("\n" +++ expected_ +++ " " +++ noColor (withNewline expP) +++ + "\n" +++ but_got_ +++ " " +++ noColor (withNewline actP) +++ + "\n" +++ diff_ +++ " " +++ newlineBeforeDiff d +++ d +++ (if stringEq then "\nWARNING: strings are equal but actual values differ!" else "")) @@ -183,6 +192,11 @@ [] -> s [_] -> s _ -> '\n':s + newlineBeforeDiff d = + let f b = case colorStringFind (\c -> c == '\n') d b of + Just _ -> "\n" + Nothing -> "" + in noColor' (f True) (f False) (expP, actP, stringEq) = case (pp exp, pp act) of (Nothing, _) -> (exp, act, exp == act) @@ -212,7 +226,8 @@ _assertEqual_ name loc s expected actual = if expected /= actual then do x <- equalityFailedMessage (show expected) (show actual) - assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkColorMsg name s $ + noColor ("failed at " ++ showLoc loc) +++ x) else return () DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal. @@ -238,7 +253,8 @@ _assertEqualPretty_ name loc s expected actual = if expected /= actual then do x <- equalityFailedMessage (showPretty expected) (showPretty actual) - assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + assertFailure__ loc (mkColorMsg name s + (noColor ("failed at " ++ showLoc loc) +++ x)) else return () DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal. @@ -299,8 +315,8 @@ ++ "\n actual length: " ++ show na)) | not (unorderedEq expected actual) -> do x <- equalityFailedMessage (show expected) (show actual) - assertFailure__ loc (mkMsg "assertSetEqual" s - ("failed at " ++ showLoc loc ++ x)) + assertFailure__ loc (mkColorMsg "assertSetEqual" s + (noColor ("failed at " ++ showLoc loc) +++ x)) | otherwise -> return () where unorderedEq l1 l2 = null (l1 \\ l2) && null (l2 \\ l1) @@ -330,26 +346,44 @@ _assertThrowsIO_ :: Exception e => String -> Location -> String -> IO a -> (e -> Bool) -> HU.Assertion _assertThrowsIO_ name loc s x f = - do res <- try x + _assertThrowsM_ name loc s x f +DocAssertion(assertThrowsIO, Fail if executing the 'IO' action does not + throw an exception satisfying the given predicate @(e -> Bool)@.) +CreateAssertionsCtx(assertThrowsIO, Exception e, IO a -> (e -> Bool)) + +_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion +_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (_e::SomeException) -> True) +DocAssertion(assertThrowsSomeIO, Fail if executing the 'IO' action does not + throw an exception.) +CreateAssertions(assertThrowsSomeIO, IO a) + +_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e) + => String -> Location -> String -> m a -> (e -> Bool) -> m () +_assertThrowsM_ name loc s x f = + do res <- ExL.try x case res of - Right _ -> assertFailure__ loc (mkMsg name s + Right _ -> liftIO $ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": no exception was thrown")) Left e -> if f e then return () - else assertFailure__ loc (mkMsg name s + else liftIO $ + assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++ ": wrong exception was thrown: " ++ show e)) -DocAssertion(assertThrowsIO, Fail if executing the 'IO' action does not +DocAssertion(assertThrowsM, Fail if executing the 'm' action does not throw an exception satisfying the given predicate @(e -> Bool)@.) -CreateAssertionsCtx(assertThrowsIO, Exception e, IO a -> (e -> Bool)) +CreateAssertionsGeneric(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>, + m a -> (e -> Bool), m ()) -_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion -_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (e::SomeException) -> True) -DocAssertion(assertThrowsSomeIO, Fail if executing the 'IO' action does not +_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m) + => String -> Location -> String -> m a -> m () +_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True) +DocAssertion(assertThrowsSomeM, Fail if executing the 'm' action does not throw an exception.) -CreateAssertions(assertThrowsSomeIO, IO a) +CreateAssertionsGeneric(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ()) _assertThrows_ :: Exception e => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion @@ -360,7 +394,7 @@ _assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion _assertThrowsSome_ name loc s x = - _assertThrows_ name loc s x (\ (e::SomeException) -> True) + _assertThrows_ name loc s x (\ (_e::SomeException) -> True) DocAssertion(assertThrowsSome, Fail if evaluating the expression of type @a@ does not throw an exception.) CreateAssertions(assertThrowsSome, a) diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs --- a/Test/Framework/HaskellParser.hs +++ b/Test/Framework/HaskellParser.hs @@ -105,15 +105,51 @@ of the symbols _:"'>!#$%&*+./<=>?@\^|-~ with at most length 8 -} parseMode :: Parser.ParseMode parseMode = Parser.ParseMode { Parser.parseFilename = originalFileName + , Parser.baseLanguage = Ext.Haskell2010 , Parser.ignoreLanguagePragmas = False , Parser.ignoreLinePragmas = False - , Parser.extensions = - Ext.glasgowExts ++ - [Ext.BangPatterns, Ext.TemplateHaskell] - , Parser.fixities = - Just (Fix.baseFixities ++ - Fix.infixr_ 0 ["==>"]) + , Parser.extensions = (map Ext.EnableExtension + extensions) + , Parser.fixities = Nothing } + extensions = + [ Ext.ForeignFunctionInterface + , Ext.UnliftedFFITypes + , Ext.GADTs + , Ext.ScopedTypeVariables + , Ext.UnboxedTuples + , Ext.TypeSynonymInstances + , Ext.StandaloneDeriving + , Ext.DeriveDataTypeable + , Ext.FlexibleContexts + , Ext.FlexibleInstances + , Ext.ConstrainedClassMethods + , Ext.MultiParamTypeClasses + , Ext.FunctionalDependencies + , Ext.MagicHash + , Ext.PolymorphicComponents + , Ext.ExistentialQuantification + , Ext.UnicodeSyntax + , Ext.PostfixOperators + , Ext.PatternGuards + , Ext.LiberalTypeSynonyms + , Ext.RankNTypes + , Ext.ImpredicativeTypes + , Ext.TypeOperators + , Ext.RecursiveDo + , Ext.ParallelListComp + , Ext.EmptyDataDecls + , Ext.KindSignatures + , Ext.GeneralizedNewtypeDeriving + , Ext.TypeFamilies + , Ext.NamedFieldPuns + , Ext.RecordWildCards + , Ext.PackageImports + , Ext.ViewPatterns + , Ext.TupleSections + , Ext.NondecreasingIndentation + , Ext.DoAndIfThenElse + ] unknownLoc :: Syn.SrcLoc unknownLoc = Syn.SrcLoc originalFileName 0 0 transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls) diff --git a/Test/Framework/JsonOutput.hs b/Test/Framework/JsonOutput.hs --- a/Test/Framework/JsonOutput.hs +++ b/Test/Framework/JsonOutput.hs @@ -61,12 +61,14 @@ import Test.Framework.TestTypes import Test.Framework.Location +import Test.Framework.Colors 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 qualified Data.Text as T class J.ToJSON a => HTFJsonObj a @@ -89,7 +91,7 @@ , te_result :: TestResult , te_location :: Maybe Location , te_callers :: [(Maybe String, Location)] - , te_message :: String + , te_message :: T.Text , te_wallTimeMs :: Int } @@ -191,8 +193,9 @@ mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj mkTestEndEventObj ftr flatName = let r = ft_payload ftr + msg = renderColorString (rr_message r) False in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r) - (rr_message r) (rr_wallTimeMs r) + msg (rr_wallTimeMs r) mkTestListObj :: [(FlatTest, String)] -> TestListObj mkTestListObj l = diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -77,6 +77,8 @@ ,"assertThrowsSome" ,"assertThrowsIO" ,"assertThrowsSomeIO" + ,"assertThrowsM" + ,"assertThrowsSomeM" ,"assertLeft" ,"assertLeftNoShow" ,"assertRight" diff --git a/Test/Framework/Process.hs b/Test/Framework/Process.hs --- a/Test/Framework/Process.hs +++ b/Test/Framework/Process.hs @@ -67,8 +67,8 @@ -- data gets pulled as it becomes available. you have to force the -- output strings before waiting for the process to terminate. -- - forkIO (Control.Exception.evaluate (length output) >> return ()) - forkIO (Control.Exception.evaluate (length errput) >> return ()) + _ <- forkIO (Control.Exception.evaluate (length output) >> return ()) + _ <- forkIO (Control.Exception.evaluate (length errput) >> return ()) -- And now we wait. We must wait after we read, unsurprisingly. ecode <- waitForProcess pid -- blocks without -threaded, you're warned. diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -72,7 +72,7 @@ -- | Change the default 'Args' used to evaluate quick check properties. setDefaultArgs :: Args -> IO () setDefaultArgs args = - do withMVar qcState $ \state -> return (state { qc_args = args }) + do _ <- withMVar qcState $ \state -> return (state { qc_args = args }) return () -- | Retrieve the 'Args' currently used per default when evaluating quick check properties. @@ -92,7 +92,7 @@ withMVar qcState $ \state -> do eitherArgs <- (let a = (argsModifier t) (qc_args state) - in do evaluate (length (show a)) + in do _ <- evaluate (length (show a)) return (Right a)) `catch` (\e -> return $ Left (show (e :: SomeException))) diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -46,6 +46,7 @@ import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs) import Control.Exception (finally) +import qualified Data.List as List import System.IO @@ -57,21 +58,24 @@ import Test.Framework.CmdlineOptions import Test.Framework.TestReporter import Test.Framework.Location +import Test.Framework.Colors +import Test.Framework.ThreadPool -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test -makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass +makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass -- | Construct a unit test from the given 'IO' action. -- Mainly used internally by the htfpp preprocessor. -makeUnitTest :: TestID -> Location -> IO a -> Test -makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ()) +makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test +makeUnitTest id loc ass = + BaseTest UnitTest id (Just loc) (testOptions ass) (assertion ass) -- | Construct a black box test from the given 'Assertion'. -- Mainly used internally. makeBlackBoxTest :: TestID -> Assertion -> Test -makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass +makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass -- | Create a named 'TestSuite' from a list of 'Test' values. makeTestSuite :: TestID -> [Test] -> TestSuite @@ -108,8 +112,8 @@ flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action) flattenTest :: Test -> [FlatTest] -flattenTest (BaseTest sort id mloc x) = - [FlatTest sort (TestPathBase id) mloc x] +flattenTest (BaseTest sort id mloc opts x) = + [FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)] flattenTest (CompoundTest ts) = flattenTestSuite ts @@ -121,39 +125,57 @@ let fts = concatMap flattenTest ts in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -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, [], "")) - Just (isFailure, msg') -> - if ft_sort ft /= QuickCheckTest - then let utr = deserializeHUnitMsg msg' - r = case () of - _| utr_pending utr -> Pending - | isFailure -> Fail - | otherwise -> Error - in (r, (utr_location utr, utr_callingLocations utr, utr_message utr)) - 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 - -handleRunResult :: FlatTestResult -> TR () -handleRunResult r = - do modify (\s -> s { ts_results = r : ts_results s }) - reportTestResult r +mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int) +mkFlatTestRunner ft = (pre, action, post) + where + pre = reportTestStart ft + action _ = measure $ HU.performTestCase (wto_payload (ft_payload ft)) + post excOrResult = + let (testResult, (mLoc, callers, msg, time)) = + case excOrResult of + Left exc -> (Error, (Nothing, + [], + noColor ("Running test unexpectedly failed: " ++ show exc), + (-1))) + Right (res, time) -> + case res of + Nothing -> (Pass, (Nothing, [], emptyColorString, time)) + Just (isFailure, msg') -> + if ft_sort ft /= QuickCheckTest + then let utr = deserializeHUnitMsg msg' + r = case () of + _| utr_pending utr -> Pending + | isFailure -> Fail + | otherwise -> Error + in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time)) + else let (r, s) = deserializeQuickCheckMsg msg' + in (r, (Nothing, [], noColor s, time)) + 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 } + in do modify (\s -> s { ts_results = rr : ts_results s }) + reportTestResult rr runAllFlatTests :: [FlatTest] -> TR () runAllFlatTests tests = do reportGlobalStart tests - mapM_ (\ft -> runFlatTest ft >>= handleRunResult) tests + tc <- ask + case tc_threads tc of + Nothing -> + let entries = map mkFlatTestRunner tests + in tp_run sequentialThreadPool entries + Just i -> + let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests + pentries' = map mkFlatTestRunner ptests + sentries = map mkFlatTestRunner stests + in do tp <- parallelThreadPool i + pentries <- if tc_shuffle tc + then liftIO (shuffleIO pentries') + else return pentries' + tp_run tp pentries + tp_run sequentialThreadPool sentries -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t -- ^ Testable thing diff --git a/Test/Framework/TestManagerInternal.hs b/Test/Framework/TestManagerInternal.hs --- a/Test/Framework/TestManagerInternal.hs +++ b/Test/Framework/TestManagerInternal.hs @@ -31,9 +31,9 @@ import Test.Framework.TestTypes import Test.Framework.Utils import Test.Framework.Location +import Test.Framework.Colors import qualified Test.HUnit.Lang as HU -import Control.Monad.Trans import Control.Monad.Trans.Control import qualified Control.Exception.Lifted as Exc @@ -72,11 +72,11 @@ = UnitTestResult { utr_location :: Maybe Location , utr_callingLocations :: [(Maybe String, Location)] - , utr_message :: String + , utr_message :: ColorString , utr_pending :: Bool } deriving (Eq, Show, Read) -unitTestFail :: Maybe Location -> String -> IO a +unitTestFail :: Maybe Location -> ColorString -> IO a unitTestFail loc s = do assertFailureHTF (show (UnitTestResult loc [] s False)) error "unitTestFail: UNREACHABLE" @@ -90,14 +90,14 @@ -- Mark a unit test as pending without removing it from the test suite. unitTestPending :: String -> IO a unitTestPending s = - do assertFailureHTF (show (UnitTestResult Nothing [] s True)) + do assertFailureHTF (show (UnitTestResult Nothing [] (noColor s) True)) error "unitTestFail: UNREACHABLE" deserializeHUnitMsg :: String -> UnitTestResult deserializeHUnitMsg msg = case readM msg of Just r -> r - _ -> UnitTestResult Nothing [] msg False + _ -> UnitTestResult Nothing [] (noColor msg) False blackBoxTestFail :: String -> Assertion blackBoxTestFail = assertFailureHTF diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs --- a/Test/Framework/TestReporter.hs +++ b/Test/Framework/TestReporter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-| This module defines functions for notifying all test reporters registered about @@ -8,6 +9,7 @@ -} module Test.Framework.TestReporter ( + IsParallel(..), isParallelFromBool, IsJsonOutput(..), IsXmlOutput(..), reportAllTests, reportGlobalStart, reportTestStart, reportTestResult, reportGlobalResults, defaultTestReporters @@ -16,14 +18,14 @@ import Test.Framework.TestTypes import Test.Framework.Location import Test.Framework.Colors -import Test.Framework.Utils import Test.Framework.JsonOutput +import Test.Framework.XmlOutput import System.IO import Control.Monad.RWS import Text.PrettyPrint -import qualified Data.ByteString as BS +import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy as BSL -- | Invokes 'tr_reportAllTests' on all test reporters registered. @@ -56,13 +58,23 @@ do reps <- asks tc_reporters mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps +data IsParallel = Parallel | NonParallel + +isParallelFromBool :: Bool -> IsParallel +isParallelFromBool True = Parallel +isParallelFromBool False = NonParallel + +data IsJsonOutput = JsonOutput | NoJsonOutput +data IsXmlOutput = XmlOutput | NoXmlOutput + -- | The default test reporters for HTF. -defaultTestReporters :: Bool -- ^ 'True' if tests are run in parallel - -> Bool -- ^ 'True' if machine output should be produced +defaultTestReporters :: IsParallel + -> IsJsonOutput + -> IsXmlOutput -> [TestReporter] -defaultTestReporters inParallel forMachine = +defaultTestReporters inParallel forMachine doXml = case (inParallel, forMachine) of - (False, False) -> + (NonParallel, NoJsonOutput) -> [TestReporter { tr_id = "rep_seq_human" , tr_reportAllTests = reportAllTestsH @@ -70,8 +82,8 @@ , tr_reportTestStart = reportTestStartHS , tr_reportTestResult = reportTestResultHS , tr_reportGlobalResults = reportGlobalResultsH - }] - (True, False) -> + }] ++ xmlReporters + (Parallel, NoJsonOutput) -> [TestReporter { tr_id = "rep_par_human" , tr_reportAllTests = reportAllTestsH @@ -79,8 +91,8 @@ , tr_reportTestStart = reportTestStartHP , tr_reportTestResult = reportTestResultHP , tr_reportGlobalResults = reportGlobalResultsH - }] - (False, True) -> + }] ++ xmlReporters + (NonParallel, JsonOutput) -> [TestReporter { tr_id = "rep_seq_machine" , tr_reportAllTests = reportAllTestsM @@ -88,8 +100,8 @@ , tr_reportTestStart = reportTestStartMS , tr_reportTestResult = reportTestResultMS , tr_reportGlobalResults = reportGlobalResultsM - }] - (True, True) -> + }] ++ xmlReporters + (Parallel, JsonOutput) -> [TestReporter { tr_id = "rep_par_machine" , tr_reportAllTests = reportAllTestsM @@ -97,7 +109,14 @@ , tr_reportTestStart = reportTestStartMP , tr_reportTestResult = reportTestResultMP , tr_reportGlobalResults = reportGlobalResultsM - }] + }] ++ xmlReporters + where + xmlReporters = + case doXml of + NoXmlOutput -> [] + XmlOutput -> [(emptyTestReporter "rep_xml") { + tr_reportGlobalResults = reportGlobalResultsXml + }] -- -- output for humans @@ -112,8 +131,8 @@ reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR () reportHumanTestStartMessage level ft = - do t <- liftIO $ colorize testStartColor "[TEST] " - reportTR level (t ++ (humanTestName ft)) + do let t = colorize testStartColor "[TEST] " + reportTR level (t +++ noColor (humanTestName ft)) -- sequential reportGlobalStartHS :: ReportGlobalStart @@ -128,40 +147,27 @@ msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr)) in case res of Pass -> - do suf <- okSuffix - reportMessage Debug msg suf + reportMessage Debug msg okSuffix Pending -> do reportHumanTestStartMessageIfNeeded - suf <- pendingSuffix - reportMessage Info msg suf + reportMessage Info msg pendingSuffix Fail -> do reportHumanTestStartMessageIfNeeded - suf <- failureSuffix - reportMessage Info msg suf + reportMessage Info msg failureSuffix Error -> do reportHumanTestStartMessageIfNeeded - suf <- errorSuffix - reportMessage Info msg suf + reportMessage Info msg errorSuffix 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) + reportTR level (ensureNewlineColorString msg +++ suffix +++ noColor 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" + failureSuffix = colorize warningColor "*** Failed!" + errorSuffix = colorize warningColor "@@@ Error!" + pendingSuffix = colorize pendingColor "^^^ Pending!" + okSuffix = colorize testOkColor "+++ OK" -- parallel reportGlobalStartHP :: ReportGlobalStart @@ -169,7 +175,7 @@ reportTestStartHP :: ReportTestStart reportTestStartHP ft = - do reportTR Debug ("Starting " ++ (humanTestName ft)) + do reportStringTR Debug ("Starting " ++ (humanTestName ft)) reportTestResultHP :: ReportTestResult reportTestResultHP ftr = @@ -179,7 +185,7 @@ -- results and all tests reportAllTestsH :: ReportAllTests reportAllTestsH l = - reportDoc Info (renderTestNames l) + reportStringTR Info (render (renderTestNames l)) reportGlobalResultsH :: ReportGlobalResults reportGlobalResultsH t passedL pendingL failedL errorL = @@ -188,27 +194,28 @@ 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) + let pendings = colorize pendingColor "* Pending:" + failures = colorize warningColor "* Failures:" + errors = colorize warningColor "* Errors:" + reportTR Info ("* Tests: " +++ showC total +++ "\n" +++ + "* Passed: " +++ showC passed +++ "\n" +++ + pendings +++ " " +++ showC pending +++ "\n" +++ + failures +++ " " +++ showC failed +++ "\n" +++ + errors +++ " " +++ showC error) when (pending > 0) $ - reportDoc Info - (text ('\n' : pendings) $$ renderTestNames' (reverse pendingL)) + reportTR Info + ("\n" +++ pendings +++ renderTestNames' (reverse pendingL)) when (failed > 0) $ - reportDoc Info - (text ('\n' : failures) $$ renderTestNames' (reverse failedL)) + reportTR Info + ("\n" +++ failures +++ renderTestNames' (reverse failedL)) when (error > 0) $ - reportDoc Info - (text ('\n' : errors) $$ renderTestNames' (reverse errorL)) - reportTR Info ("\nTotal execution time: " ++ show t ++ "ms") + reportTR Info + ("\n" +++ errors +++ renderTestNames' (reverse errorL)) + reportStringTR Info ("\nTotal execution time: " ++ show t ++ "ms") where + showC x = noColor (show x) renderTestNames' rrs = - nest 2 $ renderTestNames rrs + noColor $ render $ nest 2 $ renderTestNames rrs renderTestNames :: [GenFlatTest a] -> Doc renderTestNames l = @@ -254,22 +261,28 @@ let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors) in reportJsonTR json +reportGlobalResultsXml :: ReportGlobalResults +reportGlobalResultsXml t pass pending failed errors = + do let xml = mkGlobalResultsXml t pass pending failed errors + tc <- ask + case tc_outputXml tc of + Just fname -> liftIO $ withFile fname WriteMode $ \h -> BSL.hPut h xml + Nothing -> liftIO $ BSL.putStr xml + -- -- General reporting routines -- -reportDoc :: ReportLevel -> Doc -> TR () -reportDoc level doc = reportTR level (render doc) - -reportTR :: ReportLevel -> String -> TR () +reportTR :: ReportLevel -> ColorString -> TR () reportTR level msg = do tc <- ask - reportGen tc level (\h -> hPutStrLn h msg) + let s = renderColorString msg (tc_useColors tc) + reportGen tc level (\h -> T.hPutStrLn h s) -reportBytesTR :: ReportLevel -> BS.ByteString -> TR () -reportBytesTR level msg = +reportStringTR :: ReportLevel -> String -> TR () +reportStringTR level msg = do tc <- ask - reportGen tc level (\h -> BS.hPut h msg) + reportGen tc level (\h -> hPutStrLn h msg) reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR () reportLazyBytesTR level msg = diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs --- a/Test/Framework/TestTypes.hs +++ b/Test/Framework/TestTypes.hs @@ -1,4 +1,5 @@ -{-| +{-# LANGUAGE FlexibleInstances #-} +{-| This module defines types (and small auxiliary functions) for organizing tests, for configuring the execution of @@ -8,16 +9,17 @@ module Test.Framework.TestTypes ( -- * Organizing tests - TestID, Assertion, Test(..), TestSuite(..), TestSort(..), + TestID, Assertion, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..), + TestSuite(..), TestSort(..), TestPath(..), GenFlatTest(..), FlatTest, TestFilter, - testPathToList, flatName, + testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, -- * Executing tests TR, TestState(..), initTestState, TestConfig(..), TestOutput(..), -- * Reporting results ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, - TestReporter(..), + TestReporter(..), emptyTestReporter, attachCallStack, CallStack, -- * Specifying results. TestResult(..), FlatTestResult, Milliseconds, RunResult(..) @@ -25,6 +27,7 @@ ) where import Test.Framework.Location +import Test.Framework.Colors import Control.Monad.RWS import System.IO @@ -41,8 +44,44 @@ data TestSort = UnitTest | QuickCheckTest | BlackBoxTest deriving (Eq,Show,Read) +-- | General options for tests +data TestOptions = TestOptions { + to_parallel :: Bool + } + deriving (Eq,Show,Read) + +-- | The default 'TestOptions' +defaultTestOptions :: TestOptions +defaultTestOptions = TestOptions { + to_parallel = True + } + +-- | Something with 'TestOptions' +data WithTestOptions a = WithTestOptions { + wto_options :: TestOptions + , wto_payload :: a + } + deriving (Eq,Show,Read) + +-- | Shortcut for constructing a 'WithTestOptions' value. +withOptions :: (TestOptions -> TestOptions) -> a -> WithTestOptions a +withOptions f x = WithTestOptions (f defaultTestOptions) x + +-- | A type class for an assertion with 'TestOptions'. +class AssertionWithTestOptions a where + testOptions :: a -> TestOptions + assertion :: a -> Assertion + +instance AssertionWithTestOptions (IO a) where + testOptions _ = defaultTestOptions + assertion io = io >> return () + +instance AssertionWithTestOptions (WithTestOptions (IO a)) where + testOptions (WithTestOptions opts _) = opts + assertion (WithTestOptions _ io) = io >> return () + -- | Abstract type for tests and their results. -data Test = BaseTest TestSort TestID (Maybe Location) Assertion +data Test = BaseTest TestSort TestID (Maybe Location) TestOptions Assertion | CompoundTest TestSuite -- | Abstract type for test suites and their results. @@ -62,8 +101,26 @@ -- | Creates a string representation from a 'TestPath'. flatName :: TestPath -> String flatName p = - List.intercalate ":" (map (fromMaybe "") (testPathToList p)) + flatNameFromList (testPathToList p) +flatNameFromList :: [Maybe TestID] -> String +flatNameFromList l = + List.intercalate ":" (map (fromMaybe "") l) + +-- | Returns the final name of a 'TestPath' +finalName :: TestPath -> String +finalName (TestPathBase i) = i +finalName (TestPathCompound _ p) = finalName p + +-- | Returns the name of the prefix of a test path. The prefix is everything except the +-- last element. +prefixName :: TestPath -> String +prefixName path = + let l = case reverse (testPathToList path) of + [] -> [] + (_:xs) -> reverse xs + in flatNameFromList l + -- | Generic type for flattened tests and their results. data GenFlatTest a = FlatTest @@ -74,7 +131,7 @@ } -- | Flattened representation of tests. -type FlatTest = GenFlatTest Assertion +type FlatTest = GenFlatTest (WithTestOptions Assertion) -- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. type TestFilter = FlatTest -> Bool @@ -86,16 +143,31 @@ -- | A type synonym for time in milliseconds. type Milliseconds = Int +-- | A type for call-stacks +type CallStack = [(Maybe String, Location)] + -- | 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_callers :: CallStack -- ^ Information about the callers of the location where the test failed + , rr_message :: ColorString -- ^ A message describing the result. , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds. } +attachCallStack :: ColorString -> CallStack -> ColorString +attachCallStack msg callStack = + case reverse callStack of + [] -> msg + l -> ensureNewlineColorString msg +++ + noColor (unlines (map formatCallStackElem l)) + where + formatCallStackElem (mMsg, loc) = + " called from " ++ showLoc loc ++ (case mMsg of + Nothing -> "" + Just s -> " (" ++ s ++ ")") + -- | The result of running a 'FlatTest' type FlatTestResult = GenFlatTest RunResult @@ -120,11 +192,13 @@ 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_threads :: Maybe Int -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution. + , tc_shuffle :: Bool -- ^ Shuffle tests before parallel execution , tc_output :: TestOutput -- ^ Output destination of progress and result messages. + , tc_outputXml :: Maybe FilePath -- ^ Output destination of XML result summary , tc_filter :: TestFilter -- ^ Filter for the tests to run. , tc_reporters :: [TestReporter] -- ^ Test reporters to use. + , tc_useColors :: Bool -- ^ Whether to use colored output } instance Show TestConfig where @@ -147,6 +221,17 @@ , 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. + } + +emptyTestReporter :: String -> TestReporter +emptyTestReporter id = + TestReporter + { tr_id = id + , tr_reportAllTests = \_ -> return () + , tr_reportGlobalStart = \_ -> return () + , tr_reportTestStart = \_ -> return () + , tr_reportTestResult = \_ -> return () + , tr_reportGlobalResults = \_ _ _ _ _ -> return () } instance Show TestReporter where diff --git a/Test/Framework/ThreadPool.hs b/Test/Framework/ThreadPool.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/ThreadPool.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- +-- Copyright (c) 2013 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.ThreadPool ( + + ThreadPoolEntry, ThreadPool(..), sequentialThreadPool, parallelThreadPool + , threadPoolTest + +) where + +import qualified Control.Exception as Ex +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent + +-- for tests +import System.Random + +type ThreadPoolEntry m a b = ( m a -- pre-action, must not throw exceptions + , a -> IO b -- action + , Either Ex.SomeException b -> m () -- post-action, must not throw exceptions + ) + +data ThreadPool m a b + = ThreadPool + { tp_run :: [ThreadPoolEntry m a b] -> m () } + +sequentialThreadPool :: MonadIO m => ThreadPool m a b +sequentialThreadPool = ThreadPool runSequentially + +parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) +parallelThreadPool n = + do when (n < 1) $ fail ("invalid number of workers: " ++ show n) + return (ThreadPool (runParallel n)) + +runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m () +runSequentially entries = + mapM_ run entries + where + run (pre, action, post) = + do a <- pre + b <- liftIO $ Ex.try (action a) + post b + +data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m ()) | Done + +instance Show (WorkItem m b) where + show (Work _ _) = "Work" + show Done = "Done" + +type NamedMVar a = (String, MVar a) +type NamedChan a = (String, Chan a) + +type ToWorker m b = NamedMVar (WorkItem m b) + +data WorkResult m b = WorkResult (m ()) (ToWorker m b) + +instance Show (WorkResult m b) where + show _ = "WorkResult" + +type FromWorker m b = NamedChan (WorkResult m b) + +runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () +runParallel _ [] = return () +runParallel n entries = + do when (n < 1) $ fail ("invalid number of workers: " ++ show n) + fromWorker <- liftIO $ newNamedChan "fromWorker" + let nWorkers = min n (length entries) + toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers] + let (initEntries, restEntries) = splitAt nWorkers entries + mapM_ (\(mvar, entry) -> runEntry entry mvar) (zip toWorkers initEntries) + loop fromWorker nWorkers restEntries + where + loop :: FromWorker m b -> Int -> [ThreadPoolEntry m a b] -> m () + loop fromWorker nWorkers [] = + cleanup fromWorker nWorkers + loop fromWorker nWorkers (x:xs) = + do toWorker <- waitForWorkerResult fromWorker + runEntry x toWorker + loop fromWorker nWorkers xs + cleanup :: FromWorker m b -> Int -> m () + -- n is the number of workers that will still write to fromWorker + cleanup fromWorker n = + do debug ("cleanup, n=" ++ show n) + toWorker <- waitForWorkerResult fromWorker + liftIO $ putNamedMVar toWorker Done + when (n > 1) $ cleanup fromWorker (n - 1) + waitForWorkerResult :: FromWorker m b -> m (ToWorker m b) + waitForWorkerResult fromWorker = + do WorkResult postAction toWorker <- liftIO $ readNamedChan fromWorker + postAction + return toWorker + runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m () + runEntry (pre, action, post) toWorker = + do a <- pre + liftIO $ putNamedMVar toWorker (Work (action a) post) + mkWorker :: Int -> FromWorker m b -> IO (ToWorker m b) + mkWorker i fromWorker = + do toWorker <- newEmptyNamedMVar ("worker" ++ show i) + let loop = do workItem <- takeNamedMVar toWorker + case workItem of + Done -> + do debug ("worker" ++ show i ++ " exiting!") + return () + Work action post -> + do res <- Ex.try action + _ <- Ex.evaluate res + writeNamedChan fromWorker (WorkResult (post res) toWorker) + loop + _ <- forkIO (loop `Ex.catch` (\(e::Ex.BlockedIndefinitelyOnMVar) -> + fail ("worker " ++ show i ++ ": " ++ show e))) + return toWorker + +-- +-- Debugging and testing +-- + +_DEBUG_ = False + +newNamedChan :: String -> IO (NamedChan a) +newNamedChan name = + do chan <- newChan + return (name, chan) + +readNamedChan :: Show a => NamedChan a -> IO a +readNamedChan (name, chan) = + do debug ("readChan[" ++ name ++ "]...") + x <- readChan chan + debug ("DONE readChan[" ++ name ++"]=" ++ show x) + return x + +writeNamedChan :: Show a => NamedChan a -> a -> IO () +writeNamedChan (name, chan) x = + do debug ("writeChan[" ++ name ++ "]=" ++ show x) + writeChan chan x + +newEmptyNamedMVar :: String -> IO (NamedMVar a) +newEmptyNamedMVar name = + do mvar <- newEmptyMVar + return (name, mvar) + +putNamedMVar :: Show a => NamedMVar a -> a -> IO () +putNamedMVar (name, mvar) x = + do debug ("putMVar[" ++ name ++ "]=" ++ show x ++ "...") + putMVar mvar x + debug ("DONE putMVar[" ++ name ++ "]=" ++ show x) + +takeNamedMVar :: Show a => NamedMVar a -> IO a +takeNamedMVar (name, mvar) = + do debug ("takeMVar[" ++ name ++ "]...") + x <- takeMVar mvar + debug ("DONE takeMVar[" ++ name ++ "]=" ++ show x) + return x + +debug :: MonadIO m => String -> m () +debug s = if _DEBUG_ then liftIO $ putStrLn s else return () + +runTestParallel :: Int -> Int -> IO () +runTestParallel nEntries n = + do putStrLn ("Running test " ++ show n) + boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i) + return (mvar, i)) + [1..nEntries] + let entries = map mkEntry boxes + runParallel n entries + debug ("Checking boxes in test " ++ show n) + --runSequentially entries + mapM_ assertBox boxes + putStrLn ("Test " ++ show n ++ " successful") + where + mkEntry (mvar, i) = + let pre = myThreadId + post x = case x of + Left err -> fail ("Exception in worker thread: " ++ show err) + Right y -> do tid <- myThreadId + putNamedMVar mvar (y, tid) + action x = do tid <- myThreadId + j <- randomIO + let micros = (j `mod` 50) + threadDelay micros + return (x, tid, i) + in (pre, action, post) + assertBox (mvar, i) = + do ((preTid, actionTid, i'), postTid) <- takeNamedMVar mvar + tid <- myThreadId + assertEq "pre-tid" tid preTid + assertEq "post-tid" tid postTid + assertNeq "action-tid" tid actionTid + assertEq "i" i i' + assertEq what exp act = + when (exp /= act) $ fail (what ++ " wrong, expected=" ++ show exp ++ ", actual=" ++ + show act) + assertNeq what exp act = + when (exp == act) $ fail (what ++ " wrong, did not expected " ++ show exp) + +threadPoolTest (i, j) nEntries = + mapM (runTestParallel nEntries) [i..j] `Ex.catch` + (\(e::Ex.BlockedIndefinitelyOnMVar) -> + fail ("main-thread blocked " ++ show e)) diff --git a/Test/Framework/Tutorial.hs b/Test/Framework/Tutorial.hs --- a/Test/Framework/Tutorial.hs +++ b/Test/Framework/Tutorial.hs @@ -36,11 +36,9 @@ This pragma instructs GHC to run the source file through @htfpp@, the custom preprocessor of the HTF. -The following @import@ statements are also needed: +The following @import@ statement is also needed: @ -import System.Environment ( getArgs ) -import System.Exit ( exitWith ) import Test.Framework @ @@ -89,7 +87,7 @@ Cabal-Version: >= 1.10 Build-type: Simple -Executable tutorial +Test-Suite tutorial Type: exitcode-stdio-1.0 Main-is: Tutorial.hs Build-depends: base == 4.*, HTF == 0.10.* @@ -370,6 +368,3 @@ -} ) where - -import Test.Framework -import qualified Test.HUnit.Base diff --git a/Test/Framework/Utils.hs b/Test/Framework/Utils.hs --- a/Test/Framework/Utils.hs +++ b/Test/Framework/Utils.hs @@ -22,6 +22,9 @@ import System.Directory import Data.Char import System.Time hiding (diffClockTimes) +import System.Random +import Data.Array.IO +import Control.Monad infixr 6 @@ -120,7 +123,7 @@ readM s | [x] <- parse = return x | otherwise = fail $ "Failed parse: " ++ show s where - parse = [x | (x,t) <- reads s] + parse = [x | (x, []) <- reads s] ensureNewline :: String -> String ensureNewline s = @@ -149,3 +152,19 @@ -- bring all into microseconds picoseconds i = i `div` (1000 * 1000) seconds i = i * 1000000 + +-- | Randomly shuffle a list +-- /O(N)/ +shuffleIO :: [a] -> IO [a] +shuffleIO xs = do + ar <- newArray n xs + forM [1..n] $ \i -> do + j <- randomRIO (i,n) + vi <- readArray ar i + vj <- readArray ar j + writeArray ar j vi + return vj + where + n = length xs + newArray :: Int -> [a] -> IO (IOArray Int a) + newArray n xs = newListArray (1,n) xs diff --git a/Test/Framework/XmlOutput.hs b/Test/Framework/XmlOutput.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/XmlOutput.hs @@ -0,0 +1,189 @@ +{- | + +See +for a description of the format used. + +The source code of this module also contains a rough specification of +the output format in terms of Haskell data types. + +-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Framework.XmlOutput ( + + mkGlobalResultsXml + +) where + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Text.Printf + +import Text.XML.Generator + +import Test.Framework.TestTypes +import Test.Framework.Colors + +-- A "specification" of the output format in terms of haskell data types +-- * The name of each data type corresponds to the name of an XML element +-- (lowercase first letter) +-- * The name of a field with a primitive corresponds to an attribute with +-- then same name as the field (without the prefix) +data JunitXmlOutput = JunitXmlOutput Testsuites + +type Seconds = Double + +data Testsuites + = Testsuites + { tss_tests :: Int + , tss_failures :: Int + , tss_errors :: Int + , tss_time :: Seconds + , tss_suites :: [Testsuite] } + +data Testsuite + = Testsuite + { ts_tests :: Int + , ts_failures :: Int + , ts_errors :: Int + , ts_time :: Seconds + , ts_id :: Int + , ts_name :: String + , ts_package :: String + , ts_testcases :: [Testcase] } + +data Testcase + = Testcase + { tc_classname :: String + , tc_name :: String + , tc_time :: Seconds + , tc_result :: Maybe Result } + +-- For this datatype, the elemName field specifies the name of the element +data Result + = Result + { r_elemName :: String + , r_message :: T.Text + , r_type :: String + , r_textContent :: T.Text } + +renderAsXml :: JunitXmlOutput -> BSL.ByteString +renderAsXml (JunitXmlOutput suites) = + xrender $ + doc defaultDocInfo $ + xelem "testsuites" $ + xattr "tests" (showT (tss_tests suites)) <> + xattr "failures" (showT (tss_failures suites)) <> + xattr "errors" (showT (tss_errors suites)) <> + xattr "time" (showTime (tss_time suites)) <#> + (map testsuiteXml (tss_suites suites)) + where + testsuiteXml suite = + xelem "testsuite" $ + xattr "id" (showT (ts_id suite)) <> + xattr "tests" (showT (ts_tests suite)) <> + xattr "failures" (showT (ts_failures suite)) <> + xattr "errors" (showT (ts_errors suite)) <> + xattr "time" (showTime (ts_time suite)) <> + xattr "name" (T.pack (ts_name suite)) <> + xattr "package" (T.pack (ts_package suite)) <#> + (map testcaseXml (ts_testcases suite)) + testcaseXml tc = + xelem "testcase" $ + xattr "classname" (T.pack (tc_classname tc)) <> + xattr "name" (T.pack (tc_name tc)) <> + xattr "time" (showTime (tc_time tc)) <#> + resultXml (tc_result tc) + resultXml Nothing = xempty + resultXml (Just res) = + xelem (T.pack (r_elemName res)) $ + xattr "type" (T.pack (r_type res)) <> + xattr "message" (r_message res) <#> + xtext (r_textContent res) + showT = T.pack . show + showTime = T.pack . printf "%.3f" + +groupByModule :: [FlatTestResult] -> [(String, [FlatTestResult])] +groupByModule l = + let m = List.foldl' (\m r -> Map.insertWith (++) (prefixName (ft_path r)) [r] m) Map.empty l + in Map.toList m + +mkTestSuite :: (Int, (String, [FlatTestResult])) -> Testsuite +mkTestSuite (id, (modName, results)) = + Testsuite + { ts_tests = nTests + , ts_failures = nFailures + , ts_errors = nErrors + , ts_time = millisToSeconds millis + , ts_id = id + , ts_name = modName + , ts_package = modName + , ts_testcases = map mkTestCase results } + where + (nTests, nFailures, nErrors, millis) = + List.foldl' (\(t, f, e, m) r -> (t + 1, f + failureInc r, e + errorInc r, + m + (rr_wallTimeMs . ft_payload) r)) + (0, 0, 0, 0) results + failureInc r = if isFailure r then 1 else 0 + errorInc r = if isError r then 1 else 0 + +isFailure :: FlatTestResult -> Bool +isFailure r = Fail == (rr_result . ft_payload) r + +isError :: FlatTestResult -> Bool +isError r = Error == (rr_result . ft_payload) r + +mkTestCase :: FlatTestResult -> Testcase +mkTestCase r = + Testcase + { tc_classname = modName + , tc_name = simpleName + , tc_time = millisToSeconds (rr_wallTimeMs payload) + , tc_result = result } + where + payload = ft_payload r + simpleName = prefix ++ finalName (ft_path r) + modName = prefixName (ft_path r) + prefix = case ft_sort r of + UnitTest -> "test_" + QuickCheckTest -> "prop_" + BlackBoxTest -> "bbt_" + result = + if isFailure r + then Just (mkResult "failure") + else if isError r + then Just (mkResult "error") + else Nothing + mkResult elemName = + Result + { r_elemName = elemName + , r_message = T.takeWhile (/= '\n') msg + , r_type = elemName + , r_textContent = msg } + msg = renderColorString (attachCallStack (rr_message payload) (rr_callers payload)) False + +millisToSeconds :: Milliseconds -> Seconds +millisToSeconds millis = + fromInteger (toInteger millis) / 1000.0 + +mkGlobalResultsXml :: Milliseconds -- ^ wall time in ms + -> [FlatTestResult] -- ^ passed tests + -> [FlatTestResult] -- ^ pending tests + -> [FlatTestResult] -- ^ failed tests + -> [FlatTestResult] -- ^ erroneous tests + -> BSL.ByteString +mkGlobalResultsXml t pass pending failed errors = + let nPassed = length pass + nPending = length pending + nFailed = length failed + nErrors = length errors + byModules = groupByModule (pass ++ pending ++ failed ++ errors) + suites = map mkTestSuite (zip [0..] byModules) + root = Testsuites + { tss_tests = nPassed + nPending + nFailed + nErrors + , tss_failures = nFailed + , tss_errors = nErrors + , tss_time = millisToSeconds t + , tss_suites = suites } + in renderAsXml (JunitXmlOutput root) diff --git a/run-all-tests-for-all-compilers.sh b/run-all-tests-for-all-compilers.sh --- a/run-all-tests-for-all-compilers.sh +++ b/run-all-tests-for-all-compilers.sh @@ -30,6 +30,10 @@ result="FAIL" fi RESULT="$RESULT\nResult for GHC version $ghc_version: $result" + if [ $ecode -ne 0 ] + then + exit 1 + fi done echo diff --git a/run-all-tests.sh b/run-all-tests.sh --- a/run-all-tests.sh +++ b/run-all-tests.sh @@ -1,22 +1,14 @@ #!/bin/bash set -e - -cabal configure --enable-tests -cabal build -cabal test -cabal install +ghc-pkg unregister HTF || true -cd tests -mkdir -p dist/build/htfpp -cp ../dist/build/htfpp/htfpp dist/build/htfpp -cabal configure --enable-tests -cabal build -cabal test +cabal configure --enable-tests || exit 1 +cabal build || exit 1 +cabal test || exit 1 +cabal install || exit 1 -cd ../sample -mkdir -p dist/build/htfpp -cp ../dist/build/htfpp/htfpp dist/build/htfpp -cabal configure --enable-tests -cabal build -cabal test +cd sample +cabal configure --enable-tests || exit 1 +cabal build || exit 1 +cabal test || exit 1 diff --git a/sample/sample-HTF.cabal b/sample/sample-HTF.cabal --- a/sample/sample-HTF.cabal +++ b/sample/sample-HTF.cabal @@ -13,12 +13,12 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.10.* + build-depends: base, HTF == 0.11.* 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.* + build-depends: base, HTF == 0.11.* default-language: Haskell2010 diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -32,6 +32,7 @@ import System.IO import System.IO.Temp import Control.Exception +import Control.Monad import qualified Data.HashMap.Strict as M import qualified Data.Aeson as J import Data.Aeson ( (.=) ) @@ -65,7 +66,8 @@ test_assertEqualV = assertEqualVerbose "blub" 1 2 -test_assertEqualNoShow = assertEqualNoShow A B +test_assertEqualNoShow = withOptions (\opts -> opts { to_parallel = False }) $ + assertEqualNoShow A B test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2] @@ -83,7 +85,7 @@ test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True) -test_someError = error "Bart Simpson!!" +test_someError = error "Bart Simpson!!" :: IO () test_pendingTest = unitTestPending "This test is pending" @@ -147,9 +149,9 @@ 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)]] + ,"line" .= J.toJSON (103::Int)]] ,"location" .= J.object ["file" .= J.String "TestHTF.hs$" - ,"line" .= J.toJSON (102::Int)]]) + ,"line" .= J.toJSON (104::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$" @@ -160,10 +162,10 @@ ,"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)]] + ,"line" .= J.toJSON (92::Int)]] ,J.object ["message" .= J.String "I'm another sub" ,"location" .= J.object ["file" .= J.String "TestHTF.hs$" - ,"line" .= J.toJSON (92::Int)]]]]) + ,"line" .= J.toJSON (94::Int)]]]]) where check jsons pred assert = case filter (\j -> matches j pred) jsons of @@ -210,8 +212,12 @@ bbts <- blackBoxTests (dirPrefix "bbt") (dirPrefix "./run-bbt.sh") ".x" (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests + when ("--help" `elem` args || "-h" `elem` args) $ + do hPutStrLn stderr ("USGAGE: dist/build/test/test [--direct]") + ecode <- runTestWithArgs ["--help"] ([] :: [Test]) + exitWith ecode case args of - "--interactive":rest -> + "--direct":rest -> do ecode <- runTestWithArgs rest tests case ecode of ExitFailure _ -> return () @@ -219,7 +225,8 @@ _ -> do withSystemTempFile "HTF-out" $ \outFile h -> do hClose h - ecode <- runTestWithArgs ["--json", "--output-file=" ++ outFile] tests + ecode <- runTestWithArgs ["-j4", "--deterministic", + "--json", "--output-file=" ++ outFile] tests case ecode of ExitFailure _ -> checkOutput outFile _ -> fail ("unexpected exit code: " ++ show ecode) diff --git a/tests/ThreadPoolTest.hs b/tests/ThreadPoolTest.hs new file mode 100644 --- /dev/null +++ b/tests/ThreadPoolTest.hs @@ -0,0 +1,39 @@ +-- +-- Copyright (c) 2013 Stefan Wehr - http://www.stefanwehr.de +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +import Test.Framework.ThreadPool +import System.Environment +import System.Exit +import Control.Monad + +main :: IO () +main = + do args <- getArgs + when ("-h" `elem` args || "--help" `elem` args) usage + (i, nEntries) <- case args of + [] -> return (200, 100) + [x] -> return (read x, 100) + [x, y] -> return (read x, read y) + _ -> usage + threadPoolTest (1, i) nEntries + return () + where + usage = + do putStrLn "USAGE: ThreadPoolTest [N_THREADS [N_ENTRIES]]" + exitWith (ExitFailure 1) diff --git a/tests/Tutorial.hs b/tests/Tutorial.hs --- a/tests/Tutorial.hs +++ b/tests/Tutorial.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} import System.Environment ( getArgs ) import System.Exit ( exitWith ) import Test.Framework diff --git a/tests/compile-errors/run-tests.sh b/tests/compile-errors/run-tests.sh --- a/tests/compile-errors/run-tests.sh +++ b/tests/compile-errors/run-tests.sh @@ -2,7 +2,7 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package HTF -package base --make" +FLAGS="-hide-all-packages -package base -package-conf ../../dist/package.conf.inplace -package HTF --make" lineno=7 function check() diff --git a/tests/test-HTF.cabal b/tests/test-HTF.cabal --- a/tests/test-HTF.cabal +++ b/tests/test-HTF.cabal @@ -6,7 +6,6 @@ Executable test Main-is: TestHTF.hs Build-depends: base >= 4, - HTF, bytestring >= 0.9, aeson >= 0.6, unordered-containers >= 0.2, @@ -17,6 +16,8 @@ process >= 1.0, regex-compat >= 0.92 Default-language: Haskell2010 + Ghc-options: -threaded + Hs-source-dirs: ., .. Test-Suite tutorial Type: exitcode-stdio-1.0