HTF 0.10.0.7 → 0.11.0.0

raw patch · 29 files changed

+1123/−524 lines, 29 filesdep +arraydep +xmlgendep ~Diffdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: array, xmlgen

Dependency ranges changed: Diff, base, containers, haskell-src-exts, mtl, random

API changes (from Hackage documentation)

Files

• ChangeLog +11/−0
• HTF.cabal +32/−10
• TODO.org +7/−7
• Test/Framework/BlackBoxTest.hs +14/−14
• Test/Framework/CmdlineOptions.hs +29/−15
• Test/Framework/Colors.hs +115/−26
• Test/Framework/Diff.hs +66/−259
• Test/Framework/HUnitWrapper.hs +63/−29
• Test/Framework/HaskellParser.hs +42/−6
• Test/Framework/JsonOutput.hs +5/−2
• Test/Framework/Preprocessor.hs +2/−0
• Test/Framework/Process.hs +2/−2
• Test/Framework/QuickCheckWrapper.hs +2/−2
• Test/Framework/TestManager.hs +57/−35
• Test/Framework/TestManagerInternal.hs +5/−5
• Test/Framework/TestReporter.hs +76/−63
• Test/Framework/TestTypes.hs +96/−11
• Test/Framework/ThreadPool.hs +215/−0
• Test/Framework/Tutorial.hs +2/−7
• Test/Framework/Utils.hs +20/−1
• Test/Framework/XmlOutput.hs +189/−0
• run-all-tests-for-all-compilers.sh +4/−0
• run-all-tests.sh +9/−17
• sample/sample-HTF.cabal +2/−2
• tests/TestHTF.hs +15/−8
• tests/ThreadPoolTest.hs +39/−0
• tests/Tutorial.hs +1/−1
• tests/compile-errors/run-tests.sh +1/−1
• tests/test-HTF.cabal +2/−1

@@ -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. 

@@ -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

@@ -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)

@@ -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. 

@@ -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 =

@@ -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]

@@ -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--}

@@ -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)

@@ -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)

@@ -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 =

@@ -77,6 +77,8 @@              ,"assertThrowsSome"              ,"assertThrowsIO"              ,"assertThrowsSomeIO"+             ,"assertThrowsM"+             ,"assertThrowsSomeM"              ,"assertLeft"              ,"assertLeftNoShow"              ,"assertRight"

@@ -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.

@@ -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)))

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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))

@@ -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

@@ -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

@@ -0,0 +1,189 @@+{- |++See <http://pzolee.blogs.balabit.com/2012/11/jenkins-vs-junit-xml-format/>+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)

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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()

@@ -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