HTF 0.9.0.0 → 0.10.0.0

raw patch · 84 files changed

+2171/−549 lines, 84 filesdep +HTFdep +aesondep +filepathdep ~HUnitdep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HTF, aeson, filepath, lifted-base, monad-control, old-time, temporary, text, unordered-containers

Dependency ranges changed: HUnit, QuickCheck, base, bytestring, containers, directory, haskell-src-exts, pretty, process, random, regex-compat, unix

API changes (from Hackage documentation)

Files

• ChangeLog +20/−0
• HTF.cabal +111/−19
• HTFPP.hs +8/−0
• TODO.org +14/−3
• Test/Framework.hs +17/−9
• Test/Framework/CmdlineOptions.hs +231/−0
• Test/Framework/Colors.hs +15/−1
• Test/Framework/Diff.hs +1/−8
• Test/Framework/HUnitWrapper.hs +66/−30
• Test/Framework/HaskellParser.hs +30/−5
• Test/Framework/JsonOutput.hs +213/−0
• Test/Framework/Location.hs +1/−1
• Test/Framework/Preprocessor.hs +28/−13
• Test/Framework/Process.hs +13/−6
• Test/Framework/QuickCheckWrapper.hs +5/−9
• Test/Framework/TestConfig.hs +0/−64
• Test/Framework/TestManager.hs +131/−327
• Test/Framework/TestManagerInternal.hs +52/−30
• Test/Framework/TestManagerInternal.hs-boot +0/−8
• Test/Framework/TestReporter.hs +295/−0
• Test/Framework/TestTypes.hs +176/−0
• Test/Framework/Tutorial.hs +66/−16
• Test/Framework/Utils.hs +19/−0
• run-all-tests-for-all-compilers.sh +27/−0
• run-all-tests.sh +22/−0
• sample/LICENSE +30/−0
• sample/Main.hs +34/−0
• sample/MyPkg/A.hs +11/−0
• sample/MyPkg/B.hs +11/−0
• sample/README +12/−0
• sample/Setup.hs +2/−0
• sample/TestMain.hs +13/−0
• sample/bbt-dir/should-fail/BBTArgs +1/−0
• sample/bbt-dir/should-fail/z.err +1/−0
• sample/bbt-dir/should-fail/z.num +1/−0
• sample/bbt-dir/should-pass/x.num +1/−0
• sample/bbt-dir/should-pass/x.out +2/−0
• sample/sample-HTF.cabal +24/−0
• tests/Foo/A.hs +11/−0
• tests/Foo/B.hs +7/−0
• tests/Foo/test.h +6/−0
• tests/TestHTF.hs +229/−0
• tests/TestHTFHunitBackwardsCompatible.hs +10/−0
• tests/Tutorial.hs +28/−0
• tests/bbt/Skip/BBTArgs +1/−0
• tests/bbt/Skip/some_unknown_but_skipped_file.x +0/−0
• tests/bbt/Verbose/BBTArgs +1/−0
• tests/bbt/Verbose/not_ok_because_stdout1.out +1/−0
• tests/bbt/Verbose/not_ok_because_stdout1.x +0/−0
• tests/bbt/should_fail/BBTArgs +1/−0
• tests/bbt/should_fail/not_ok_because_stderr1.err +1/−0
• tests/bbt/should_fail/not_ok_because_stderr1.x +0/−0
• tests/bbt/should_fail/not_ok_because_stderr2.x +0/−0
• tests/bbt/should_fail/not_ok_because_stdout1.out +1/−0
• tests/bbt/should_fail/not_ok_because_stdout1.x +0/−0
• tests/bbt/should_fail/not_ok_because_stdout2.x +0/−0
• tests/bbt/should_fail/not_ok_because_succeeds.x +0/−0
• tests/bbt/should_fail/ok1.out +0/−0
• tests/bbt/should_fail/ok1.x +0/−0
• tests/bbt/should_fail/ok2.err +1/−0
• tests/bbt/should_fail/ok2.out +1/−0
• tests/bbt/should_fail/ok2.x +0/−0
• tests/bbt/should_pass/not_ok_because_fails.x +0/−0
• tests/bbt/should_pass/not_ok_because_stderr1.err +1/−0
• tests/bbt/should_pass/not_ok_because_stderr1.x +0/−0
• tests/bbt/should_pass/not_ok_because_stderr2.x +0/−0
• tests/bbt/should_pass/not_ok_because_stdout1.out +1/−0
• tests/bbt/should_pass/not_ok_because_stdout1.x +0/−0
• tests/bbt/should_pass/not_ok_because_stdout2.x +0/−0
• tests/bbt/should_pass/ok1.out +0/−0
• tests/bbt/should_pass/ok1.x +0/−0
• tests/bbt/should_pass/ok2.err +1/−0
• tests/bbt/should_pass/ok2.out +1/−0
• tests/bbt/should_pass/ok2.x +0/−0
• tests/bbt/should_pass/stdin_ok.in +5/−0
• tests/bbt/should_pass/stdin_ok.out +5/−0
• tests/bbt/should_pass/stdin_ok.x +0/−0
• tests/compile-errors/Foo.h +3/−0
• tests/compile-errors/Test1.hs +10/−0
• tests/compile-errors/Test2.hs +10/−0
• tests/compile-errors/run-tests.sh +25/−0
• tests/run-bbt.sh +66/−0
• tests/run-tests.sh +15/−0
• tests/test-HTF.cabal +25/−0

@@ -1,3 +1,23 @@+* 0.10.0.0 (2012-12-06)+  - machine-readable output: the --json option provides a way for getting+    machine-readable output in a simple JSON-based format+  - support for subAssert (allows abstraction over assertions but keeps error locations)+  - don't depend on unix under Windows+  - added timing information to the output+  - possibility to list all tests+  - several bugfixes, especially related to location information in presence+    of an extra cpp invocation+  - HTF itself now has a test suite+  - removed upper bounds from .cabal files+  - backwards incompatibilities:+    + Test.Framework now longer exports all of Test.Framework.TestManager and+      Test.Framework.BlackBoxTest. For modules that only define tests, no changes+      should be necessary. However, you likely need to adjust your test runner+      module by importing Test.Framework.TestManager and possibly Test.Framework.BlackBoxTest.+    + Some reorganization in Test.Framework.TestManager and related modules, introduction+      of Test.Framework.TestTypes. Usually, your code should not be affected+      by these changes.+ * 0.9.0.0 (2012-09-26)   NOTE: this version is NOT backwards compatible with 0.8.*. The documentation on   hackage describes what you need to do in order to upgrade.

@@ -1,5 +1,5 @@ Name:             HTF-Version:          0.9.0.0+Version:          0.10.0.0 License:          LGPL License-File:     LICENSE Copyright:        (c) 2005-2012 Stefan Wehr@@ -34,6 +34,23 @@     /HEADS UP, backwards incomatibility with prior versions:/      .++    In version 0.10.0.0, the following changes could break code compiled against version 0.9.*:++    .++    * "Test.Framework" now longer exports all of "Test.Framework.TestManager" and+      "Test.Framework.BlackBoxTest". For modules that only define tests, no changes+      should be necessary. However, you likely need to adjust your test runner+      module by importing "Test.Framework.TestManager" and possibly "Test.Framework.BlackBoxTest".++    .++    * Some reorganization in "Test.Framework.TestManager" and related modules, introduction+      of "Test.Framework.TestTypes". Usually, your code should not be affected+      by these changes.++    .     Starting with version 0.9.0.0, HTF uses a new strategy     for collecting the testcases defined in your project     (see "Test.Framework.Tutorial" for a description of this strategy).@@ -62,13 +79,55 @@       annotation, use the symbol @htf_importedTests@ for referencing       the imported tests. See "Test.Framework.Tutorial" for details. -Tested-With:      GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1+Tested-With:+                  GHC==7.0.4,+                  GHC==7.2.1,+                  GHC==7.4.2,+                  GHC==7.6.1 Build-Type:       Simple-Cabal-Version:    >= 1.6+Cabal-Version:    >= 1.10 Extra-Source-Files:   README.md   TODO.org   ChangeLog+  tests/bbt/should_fail/BBTArgs+  -- tests/bbt/should_fail/*.in+  tests/bbt/should_fail/*.err+  tests/bbt/should_fail/*.out+  tests/bbt/should_fail/*.x+  tests/bbt/should_pass/*.in+  tests/bbt/should_pass/*.err+  tests/bbt/should_pass/*.out+  tests/bbt/should_pass/*.x+  tests/bbt/Skip/BBTArgs+  tests/bbt/Skip/some_unknown_but_skipped_file.x+  tests/bbt/Verbose/BBTArgs+  tests/bbt/Verbose/not_ok_because_stdout1.out+  tests/bbt/Verbose/not_ok_because_stdout1.x+  tests/Foo/test.h+  tests/Tutorial.hs+  tests/run-bbt.sh+  tests/test-HTF.cabal+  tests/run-tests.sh+  tests/compile-errors/Foo.h+  tests/compile-errors/run-tests.sh+  tests/compile-errors/Test1.hs+  tests/compile-errors/Test2.hs+  sample/LICENSE+  sample/Main.hs+  sample/MyPkg/A.hs+  sample/MyPkg/B.hs+  sample/README+  sample/sample-HTF.cabal+  sample/Setup.hs+  sample/TestMain.hs+  sample/bbt-dir/should-fail/BBTArgs+  sample/bbt-dir/should-fail/z.err+  sample/bbt-dir/should-fail/z.num+  sample/bbt-dir/should-pass/x.num+  sample/bbt-dir/should-pass/x.out+  run-all-tests-for-all-compilers.sh+  run-all-tests.sh  Source-Repository head   Type:           git@@ -77,40 +136,73 @@ Executable htfpp   Main-Is:          HTFPP.hs   Build-Depends:    cpphs >= 1.12,-                    haskell-src-exts >= 1.11 && < 1.14,-                    base == 4.*+                    haskell-src-exts >= 1.11,+                    old-time >= 1.0,+                    directory >= 1.0,+                    base >= 4 && < 42   Other-Modules:     Test.Framework.Preprocessor     Test.Framework.HaskellParser+  Default-language:  Haskell2010  Library-  Build-Depends:    HUnit == 1.2.*,-                    QuickCheck >= 2.3 && < 2.6,-                    base == 4.*,-                    random == 1.0.*,-                    containers >= 0.3 && < 0.6,-                    process >= 1.0 && < 1.2,-                    directory >= 1.0 && < 1.3,+  Build-Depends:    HUnit >= 1.2.5,+                    QuickCheck >= 2.3,+                    base >= 4 && < 42,+                    random >= 1.0,+                    containers >= 0.3,+                    process >= 1.0,+                    directory >= 1.0,                     mtl >= 1.1 && < 2.2,-                    pretty >= 1.0 && < 1.2,-                    Diff >= 0.1.3 && < 0.2,-                    unix >= 2.4 && < 2.7,-                    bytestring >= 0.9 && < 0.11,-                    regex-compat >= 0.92 && < 0.96,-                    haskell-src-exts >= 1.11 && < 1.14+                    monad-control >= 0.3,+                    lifted-base >= 0.1,+                    pretty >= 1.0,+                    Diff >= 0.1.3,+                    bytestring >= 0.9,+                    regex-compat >= 0.92,+                    haskell-src-exts >= 1.11,+                    aeson >= 0.6,+                    text >= 0.11,+                    old-time >= 1.0+  if !os(windows)+    Build-Depends:   unix >= 2.4   Exposed-Modules:     Test.Framework     Test.Framework.HUnitWrapper     Test.Framework.TestManager+    Test.Framework.TestTypes+    Test.Framework.TestReporter+    Test.Framework.CmdlineOptions     Test.Framework.QuickCheckWrapper     Test.Framework.BlackBoxTest     Test.Framework.Location     Test.Framework.Tutorial     Test.Framework.Pretty+    Test.Framework.JsonOutput   Other-Modules:     Test.Framework.TestManagerInternal     Test.Framework.Utils     Test.Framework.Colors     Test.Framework.Diff     Test.Framework.Process-    Test.Framework.TestConfig+  Default-language:  Haskell2010+  -- Ghc-Options: -fwarn-unused-imports -fwarn-unused-binds++Test-Suite TestHTF+  Main-is:           TestHTF.hs+  Hs-Source-Dirs:    tests+  Type:              exitcode-stdio-1.0+  Build-depends:     base >= 4 && < 42,+                     bytestring >= 0.9,+                     aeson >= 0.6,+                     unordered-containers >= 0.2,+                     temporary >= 1.1,+                     text >= 0.11,+                     process >= 1.0,+                     filepath >= 1.1,+                     directory >= 1.0,+                     regex-compat >= 0.92,+                     HTF+  Default-language:  Haskell2010+  Other-Modules:+    Foo.A, Foo.B, TestHTFHunitBackwardsCompatible

@@ -26,8 +26,10 @@ import System.Exit import Control.Monad import Control.Exception+import Data.Version  import Test.Framework.Preprocessor+import qualified Paths_HTF  usage :: IO () usage =@@ -47,6 +49,9 @@        "that is backwards-compatible with the corresponding functions of the\n" ++        "HUnit library.") +outputVersion :: IO ()+outputVersion =+    hPutStrLn stderr (showVersion Paths_HTF.version) saveOpenFile :: FilePath -> IOMode -> IO Handle saveOpenFile path mode =     openFile path mode `catch` exHandler@@ -64,6 +69,9 @@              "--help" `elem` args) $            do usage               exitWith (ExitFailure 1)+       when ("--version" `elem` args) $+            do outputVersion+               exitWith ExitSuccess        let (restArgs, hunitBackwardsCompat) =                case reverse args of                  "--hunit":rrest -> (reverse rrest, True)

@@ -1,3 +1,14 @@-* Replace haskell-src-exts by the GHC parser-* diff if assertEqualsP fails-* LATER: Support for Smallcheck and/or Lazy Smallcheck+* Release 0.10+** Write changelog+* Relase 0.11+** Parallel test execution+*** Options --threads=[N] or -j [N]+*** Some test cannot be run in parallel++** Support for timeouts (--timeout=SECS)+** Proper test suite+* External interface for integrating other test frameworks+** Support for Smallcheck and/or Lazy Smallcheck+** Configuration file for htfpp+* Other ideas+** option --xml-result to output a junit-style XML document summarizing the test results

@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- --  -- Copyright (c) 2005,2009   Stefan Wehr - http://www.stefanwehr.de --@@ -18,19 +16,29 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++Top-level module that re-exports functionality from sub-modules.+Modules that only define unit tests and quickcheck properties typically+only need to import this module.+Your test driver should additionally import 'Test.Framework.TestManager' and,+if needed, 'Test.Framework.BlackBoxTest'.++-} module Test.Framework ( -  module Test.Framework.HUnitWrapper,-  module Test.Framework.QuickCheckWrapper,-  module Test.Framework.BlackBoxTest,-  module Test.Framework.TestManager,+  -- * Unit tests+  module Test.Framework.HUnitWrapper, TM.makeUnitTest, -  Loc.makeLoc+  -- * Quickcheck+  module Test.Framework.QuickCheckWrapper, TM.makeQuickCheckTest, +  -- * Organizing tests+  TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc+ ) where  import Test.Framework.HUnitWrapper import Test.Framework.QuickCheckWrapper-import Test.Framework.BlackBoxTest-import Test.Framework.TestManager+import qualified Test.Framework.TestManager as TM import qualified Test.Framework.Location as Loc

@@ -0,0 +1,231 @@+{-# LANGUAGE CPP #-}+--+-- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{- |++This module defines the commandline options of the test driver provided by HTF.++-}+module Test.Framework.CmdlineOptions (++    CmdlineOptions(..), defaultCmdlineOptions, parseTestArgs, helpString,+    testConfigFromCmdlineOptions++) where++import Test.Framework.TestReporter+import Test.Framework.TestTypes+import Test.Framework.Colors+import Test.Framework.Utils++import Data.Char (toLower)+import Data.Maybe++import System.IO++import System.Console.GetOpt+import qualified Text.Regex as R++#ifndef mingw32_HOST_OS+import System.Posix.Terminal+import System.Posix.IO (stdOutput)+import System.Posix.Env (getEnv)+#endif++#ifdef COMPILER_GHC+import GHC.Conc ( numCapabilities )+#endif++--+-- CmdlineOptions+--++-- | Commandline options for running tests.+data CmdlineOptions = CmdlineOptions {+      opts_quiet :: Bool                -- ^ Be quiet or not.+    , opts_filter :: TestFilter         -- ^ Run only tests matching this filter.+    , opts_help :: Bool                 -- ^ If 'True', display a help message and exit.+    , opts_negated :: [String]          -- ^ Regular expressions matching test names which should /not/ run.+--    , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution (currently unused).+    , opts_machineOutput :: Bool        -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format.+    , opts_useColors :: Maybe Bool      -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors.+    , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout+    , opts_listTests :: Bool            -- ^ If 'True', lists all tests available and exits.+    , opts_split :: Bool                -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile').+    }++{- |+The default 'CmdlineOptions'.+-}+defaultCmdlineOptions :: CmdlineOptions+defaultCmdlineOptions = CmdlineOptions {+      opts_quiet = False+    , opts_filter = const True+    , opts_help = False+    , opts_negated = []+--    , opts_threads = Nothing+    , opts_machineOutput = False+    , opts_useColors = Nothing+    , opts_outputFile = Nothing+    , opts_listTests = False+    , opts_split = False+    }++processorCount :: Int+#ifdef COMPILER_GHC+processorCount = numCapabilities+#else+processorCount = 1+#endif++optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+optionDescriptions =+    [ Option ['q']     ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"+    , Option ['n']     ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })+                                           "PATTERN") "tests to exclude"+    , Option ['l']     ["list"]   (NoArg (\o -> o { opts_listTests = True })) "list all matching tests"+--     , Option ['j']     ["threads"]   (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N")+--                                      ("run N tests in parallel, default N=" ++ show processorCount)+    , Option ['o']     ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s })+                                               "FILE") "name of output file"+    , Option []        ["json"] (NoArg (\o -> o { opts_machineOutput = True }))+                               "output results in machine-readable JSON format"+    , Option []        ["split"] (NoArg (\o -> o { opts_split = True }))+                               "splits results in separate files to avoid file locking (requires -o/--output-file)"+    , Option []        ["colors"]  (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) })+                                           "BOOL") "use colors or not"+    , Option ['h']     ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"+    ]+    where+      parseThreads Nothing = processorCount+      parseThreads (Just s) =+          case readM s of+            Just i -> i+            Nothing -> error ("invalid number of threads: " ++ s)+      parseBool s =+          if map toLower s `elem` ["1", "true", "yes", "on"] then True else False++{- |++Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis+of the format of the commandline arguments:++> USAGE: COMMAND [OPTION ...] PATTERN ...+>+>   where PATTERN is a posix regular expression matching+>   the names of the tests to run.+>+>   -q          --quiet             only display errors+>   -n PATTERN  --not=PATTERN       tests to exclude+>   -l          --list              list all matching tests+>   -o FILE     --output-file=FILE  name of output file+>               --json              output results in machine-readable JSON format+>               --split             splits results in separate files to avoid file locking (requires -o/--output-file)+>               --colors=BOOL       use colors or not+>   -h          --help              display this message+-}++parseTestArgs :: [String] -> Either String CmdlineOptions+parseTestArgs args =+    case getOpt Permute optionDescriptions args of+      (optTrans, tests, []  ) ->+          let posStrs = tests+              negStrs = opts_negated opts+              pos = map mkRegex posStrs+              neg = map mkRegex negStrs+              pred (FlatTest _ path _ _) =+                  let flat = flatName path+                  in if (any (\s -> s `matches` flat) neg)+                        then False+                        else null pos || any (\s -> s `matches` flat) pos+              opts = (foldr ($) defaultCmdlineOptions optTrans) { opts_filter = pred }+          in case (opts_outputFile opts, opts_split opts) of+               (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ +                                        usageInfo usageHeader optionDescriptions)+               _ -> Right opts+      (_,_,errs) ->+          Left (concat errs ++ usageInfo usageHeader optionDescriptions)+    where+      matches r s = isJust $ R.matchRegex r s+      mkRegex s = R.mkRegexWithOpts s True False++usageHeader :: String+usageHeader = ("USAGE: COMMAND [OPTION ...] PATTERN ...\n\n" +++               "  where PATTERN is a posix regular expression matching\n" +++               "  the names of the tests to run.\n")++-- | The string displayed for the @--help@ option.+helpString :: String+helpString = usageInfo usageHeader optionDescriptions++--+-- TestConfig+--++-- | Turn the 'CmdlineOptions' into a 'TestConfig'.+testConfigFromCmdlineOptions :: CmdlineOptions -> IO TestConfig+testConfigFromCmdlineOptions opts =+    do (output, colors) <-+           case (opts_outputFile opts, opts_split opts) of+             (Just fname, True) -> return (TestOutputSplitted fname, False)+             _ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile+                     colors <- checkColors mOutputFd+                     return (TestOutputHandle outputHandle closeOutput, colors)+       setUseColors colors+--       let threads = opts_threads opts+       let reporters = defaultTestReporters False {-(isJust threads)-} (opts_machineOutput opts)+       return $ TestConfig { tc_quiet = opts_quiet opts+--                           , tc_threads = threads+                           , tc_output = output+                           , tc_reporters = reporters+                           , tc_filter = opts_filter opts }+    where+#ifdef mingw32_HOST_OS+      openOutputFile =+          case opts_outputFile opts of+            Nothing -> return (stdout, False, Nothing)+            Just fname ->+                do f <- openFile fname WriteMode+                   return (f, True, Nothing)+      checkColors mOutputFd =+          case opts_useColors opts of+            Just b -> return b+            Nothing -> return False+#else+      openOutputFile =+          case opts_outputFile opts of+            Nothing -> return (stdout, False, Just stdOutput)+            Just fname ->+                do f <- openFile fname WriteMode+                   return (f, True, Nothing)+      checkColors mOutputFd =+          case opts_useColors opts of+            Just b -> return b+            Nothing ->+                do mterm <- getEnv "TERM"+                   case mterm of+                     Nothing -> return False+                     Just s | map toLower s == "dumb" -> return False+                     _ -> do mx <- getEnv "HTF_NO_COLORS"+                             case mx of+                               Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False+                               _ -> case mOutputFd of+                                      Just fd -> queryTerminal fd+                                      _ -> return False+#endif

@@ -23,9 +23,11 @@   , firstDiffColor, secondDiffColor, skipDiffColor, diffColor   , warningColor, testStartColor, testOkColor, pendingColor +  , setUseColors, useColors ) where -import Test.Framework.TestConfig+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef  -- REVERSE            = "\033[2m" @@ -78,3 +80,15 @@ colorize c s =     do b <- useColors        return $ if b then withColor c s else s++-- We store the info about the use of colors in a global variable instead of the TestConfigs because+-- hunit tests must known whether to colorize diffs.+_useColors :: IORef Bool+_useColors = unsafePerformIO (newIORef False)+{-# NOINLINE _useColors #-}++useColors :: IO Bool+useColors = readIORef _useColors++setUseColors :: Bool -> IO ()+setUseColors b = atomicModifyIORef _useColors (\_ -> (b, ()))

@@ -31,20 +31,13 @@  import Control.Exception (catch, finally, IOException) import qualified Data.List as List+import Data.Char import Data.Algorithm.Diff-import Data.Char (isDigit)-import Test.QuickCheck-import Text.PrettyPrint-import Debug.Trace (trace)- import Test.Framework.Colors-import Test.Framework.TestConfig  -- for testing import System.IO-import System.Environment import System.Directory-import System.IO.Unsafe (unsafePerformIO) import System.Exit import System.Process 

@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+ -- -- Copyright (c) 2005, 2009, 2012  Stefan Wehr - http://www.stefanwehr.de --@@ -70,33 +72,41 @@   assertNothingNoShow_, assertNothingNoShowVerbose_,    -- * General failure-  assertFailure, unitTestPending, unitTestPending'+  assertFailure_, +  -- * Pending unit tests+  unitTestPending, unitTestPending',++  -- * Sub assertions+  subAssert_, subAssertVerbose_ ) where -import System.IO ( stderr )-import Data.List ( (\\) ) import Control.Exception-import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Control import qualified Test.HUnit as HU hiding ( assertFailure )-import qualified Language.Haskell.Exts.Parser as HE import qualified Language.Haskell.Exts.Pretty as HE+import qualified Language.Haskell.Exts.Parser as HE -import Test.Framework.TestManager+import Data.List ( (\\) )+ import Test.Framework.TestManagerInternal import Test.Framework.Location-import Test.Framework.Utils import Test.Framework.Diff import Test.Framework.Colors import Test.Framework.Pretty  -- WARNING: do not forget to add a preprocessor macro for new assertions!! +assertFailure__ :: Location -> String -> IO a+assertFailure__ loc s = unitTestFail (Just loc) s+ {- |-Fail with the given reason.+Fail with the given reason, supplying the error location and the error message. -}-assertFailure :: String -> IO a-assertFailure s = unitTestFail s+assertFailure_ :: Location -> String -> IO a+assertFailure_ loc s =+    assertFailure__ loc (mkMsg "assertFailure" "" ("failed at " ++ showLoc loc) ++ ": " ++ s)  {- | Use @unitTestPending' msg test@ to mark the given test as pending@@ -145,7 +155,7 @@  _assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion _assertBool_ name loc s False =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))+    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertBool_ _ _ _   True = return ()  DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)@@ -202,7 +212,7 @@ _assertEqual_ name loc s expected actual =     if expected /= actual        then do x <- equalityFailedMessage (show expected) (show actual)-               assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()  DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.@@ -215,7 +225,7 @@ _assertNotEqual_ name loc s expected actual =     if expected == actual        then do x <- notEqualityFailedMessage (show expected)-               assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()  DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.@@ -228,7 +238,7 @@ _assertEqualPretty_ name loc s expected actual =     if expected /= actual        then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)-               assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()  DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.@@ -241,7 +251,7 @@ _assertNotEqualPretty_ name loc s expected actual =     if expected == actual        then do x <- notEqualityFailedMessage (showPretty expected)-               assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return () DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.              The first parameter denotes the expected value. Use these two functions@@ -252,7 +262,7 @@                     => String -> Location -> String -> a -> a -> HU.Assertion _assertEqualNoShow_ name loc s expected actual =     if expected /= actual-       then assertFailure (mkMsg name s ("failed at " ++ showLoc loc))+       then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))        else return () DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.              The first parameter denotes the expected value. Use these two functions@@ -264,7 +274,7 @@                     => String -> Location -> String -> a -> a -> HU.Assertion _assertNotEqualNoShow_ name loc s expected actual =     if expected == actual-       then assertFailure (mkMsg name s ("failed at " ++ showLoc loc))+       then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))        else return () DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.              The first parameter denotes the expected value. Use these two functions@@ -283,13 +293,13 @@         na = length actual         in case () of             _| ne /= na ->-                 assertFailure (mkMsg name s+                 assertFailure__ loc (mkMsg name s                                 ("failed at " ++ showLoc loc                                  ++ "\n expected length: " ++ show ne                                  ++ "\n actual length: " ++ show na))              | not (unorderedEq expected actual) ->                  do x <- equalityFailedMessage (show expected) (show actual)-                    assertFailure (mkMsg "assertSetEqual" s+                    assertFailure__ loc (mkMsg "assertSetEqual" s                                    ("failed at " ++ showLoc loc ++ x))              | otherwise -> return ()     where unorderedEq l1 l2 =@@ -301,14 +311,14 @@  _assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertNotEmpty_ name loc s [] =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))+    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertNotEmpty_ _ _ _ (_:_) = return () DocAssertion(assertNotEmpty, Fail if the given list is empty.) CreateAssertions(assertNotEmpty, [a])  _assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertEmpty_ name loc s (_:_) =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))+    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertEmpty_ _ _ _ [] = return () DocAssertion(assertEmpty, Fail if the given list is a non-empty list.) CreateAssertions(assertEmpty, [a])@@ -322,11 +332,11 @@ _assertThrowsIO_ name loc s x f =     do res <- try x        case res of-         Right _ -> assertFailure (mkMsg name s+         Right _ -> assertFailure__ loc (mkMsg name s                                    ("failed at " ++ showLoc loc ++                                     ": no exception was thrown"))          Left e -> if f e then return ()-                   else assertFailure (mkMsg name s+                   else assertFailure__ loc (mkMsg name s                                        ("failed at " ++                                         showLoc loc ++                                         ": wrong exception was thrown: " ++@@ -363,7 +373,7 @@              => String -> Location -> String -> Either a b -> IO a _assertLeft_ _ _ _ (Left x) = return x _assertLeft_ name loc s (Right x) =-    assertFailure (mkMsg name s+    assertFailure__ loc (mkMsg name s                    ("failed at " ++ showLoc loc ++                     ": expected a Left value, given " ++                     show (Right x :: Either b b)))@@ -374,7 +384,7 @@ _assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a _assertLeftNoShow_ _ _ _ (Left x) = return x _assertLeftNoShow_ name loc s (Right _) =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Left value, given a Right value")) DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.) CreateAssertionsRet(assertLeftNoShow, Either a b, IO a)@@ -383,7 +393,7 @@               => String -> Location -> String -> Either a b -> IO b _assertRight_ _ _ _ (Right x) = return x _assertRight_ name loc s (Left x) =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Right value, given " ++                                  show (Left x :: Either a a))) DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.@@ -393,7 +403,7 @@ _assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b _assertRightNoShow_ _ _ _ (Right x) = return x _assertRightNoShow_ name loc s (Left _) =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Right value, given a Left value")) DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.) CreateAssertionsRet(assertRightNoShow, Either a b, IO b)@@ -405,7 +415,7 @@ _assertJust_ :: String -> Location -> String -> Maybe a -> IO a _assertJust_ _ _ _ (Just x) = return x _assertJust_ name loc s Nothing =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Just value, given Nothing")) DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.) CreateAssertionsRet(assertJust, Maybe a, IO a)@@ -414,7 +424,7 @@                 => String -> Location -> String -> Maybe a -> HU.Assertion _assertNothing_ _ _ _ Nothing = return () _assertNothing_ name loc s jx =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected Nothing, given " ++ show jx)) DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.              Use this function if @a@ is an instance of 'Show'.)@@ -423,7 +433,33 @@ _assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion _assertNothingNoShow_ _ _ _ Nothing = return () _assertNothingNoShow_ name loc s _ =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc +++    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected Nothing, given a Just value")) DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.) CreateAssertions(assertNothingNoShow, Maybe a)++--+-- Sub assertions+--++-- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location+-- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write+--+-- > assertIsPositive :: Int -> Assertion+-- > assertIsPositive n = assertBool (n > 0)+--+-- You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly+-- you will lose location information: if @assertIsPositive i@ fails you will only get the location where+-- @assertIsPositive@ is defined but not from where it has been called.+--+-- To recover the location information you simply use @subAssert (assertIsPositive i)@.+-- In this case, if @i@ is not positive, you will get the location of the caller.+--+-- /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@.+subAssert_ :: MonadBaseControl IO m => Location -> m () -> m()+subAssert_ loc ass = unitTestSubAssert loc Nothing ass+++-- | Same as 'subAssert_' but with an additional error message.+subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m () -> m ()+subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass

@@ -18,7 +18,7 @@ module Test.Framework.HaskellParser where  import Data.Maybe-import Data.Char ( isSpace )+import Data.Char ( isSpace, isDigit ) import qualified Data.List as List import Control.Exception ( evaluate, catch, SomeException ) #if !MIN_VERSION_base(4,6,0)@@ -56,6 +56,25 @@                              , imp_alias :: Maybe Name                              , imp_loc :: Location } +-- Returns for lines of the form '# <number> "<filename>"'+-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)+-- the value 'Just <number> "<filename>"'+parseCppLineInfoOut :: String -> Maybe (String, String)+parseCppLineInfoOut line =+    case line of+      '#':' ':c:rest+        | isDigit c ->+            case List.span isDigit rest of+              (restDigits, ' ' : '"' : rest) ->+                  case dropWhile (/= '"') (reverse rest) of+                    '"' : fileNameRev ->+                        let line = (c:restDigits)+                            file = "\"" ++ reverse fileNameRev ++ "\""+                        in Just (line, file)+                    _ -> Nothing+              _ -> Nothing+      _ -> Nothing+ parse :: FilePath -> String -> IO (ParseResult Module) parse originalFileName input =     do r <- (evaluate $ Exts.parseFileContentsWithComments parseMode fixedInput)@@ -67,14 +86,20 @@     where       -- fixedInput serves two purposes:       -- 1. add a trailing \n-      -- 2. comment out lines starting with #+      -- 2. turn lines of the form '# <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'+      -- 2. turn lines of the form '#line <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'+      -- 3. comment out lines starting with #       fixedInput :: String       fixedInput = (unlines . map fixLine . lines) input           where             fixLine s =-                case dropWhile isSpace s of-                  '#':_ -> "-- " ++ s-                  _ -> s+                case parseCppLineInfoOut s of+                  Just (line, file) -> "{-# LINE " ++ line ++ " " ++ file ++ " #-}"+                  Nothing ->+                      case dropWhile isSpace s of+                        '#':'l':'i':'n':'e':rest -> "{-# LINE " ++ rest ++ " #-}"+                        '#':_ -> "-- " ++ s+                        _ -> s       {- FIXME: fixities needed for all operators. Heuristic:          all operators are considered to be any sequence          of the symbols _:"'>!#$%&*+./<=>?@\^|-~ with at most length 8 -}

@@ -0,0 +1,213 @@+{- |++HTF's machine-readable output is a sequence of JSON messages. Each message is terminated+by a newline followed by two semicolons followed again by a newline.++There are four types of JSON messages. Each JSON object has a "type" attribute denoting+this type. The types are: @test-start@, @test-end@, and @test-list@, @test-results@.+Their haskell representations are 'TestStartEventObj', 'TestEndEventObj', 'TestListObj', and+'TestResultsObj'. The corresponding JSON rendering is defined in this module.++  *  The @test-start@ message denotes the start of a single test case. Example (whitespace inserted for better readability):++> {"test": {"flatName": "Main:nonEmpty",+>           "location": {"file": "Tutorial.hs", "line": 17},+>           "path": ["Main","nonEmpty"],+>           "sort": "unit-test"},+>  "type":"test-start"}++  *  The @test-end@ message denotes the end of a single test case. It contains information about the outcome of the test. Example:++> {"result": "pass",+>  "message":"",+>  "test":{"flatName": "Main:nonEmpty",+>          "location": {"file": "Tutorial.hs", "line": 17},+>          "path": ["Main","nonEmpty"],+>          "sort": "unit-test"},+>  "wallTime": 0,  // in milliseconds+>  "type": "test-end",+>  "location":null}++  *  The @test-results@ message occurs after all tests have been run and summarizes their results. Example:++> {"failures": 0,+>  "passed": 4,+>  "pending": 0,+>  "wallTime": 39, // in milliseconds+>  "errors": 0,+>  "type":"test-results"}++  *  The @test-list@ message contains all tests defined. It is used for the --list commandline options. Example:++> {"tests": [{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},+>            {"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},+>            {"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},+>            {"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"}],+>  "type":"test-list"}++For an exact specification, please have a look at the code of this module.+-}++{-# LANGUAGE OverloadedStrings #-}+module Test.Framework.JsonOutput (++    TestStartEventObj, TestEndEventObj, TestListObj, TestObj, TestResultsObj,++    mkTestStartEventObj, mkTestEndEventObj, mkTestListObj, mkTestResultsObj,++    decodeObj, HTFJsonObj++) where++import Test.Framework.TestTypes+import Test.Framework.Location++import qualified Data.Aeson as J+import Data.Aeson ((.=))++import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC++class J.ToJSON a => HTFJsonObj a++-- "test-start" message+data TestStartEventObj+    = TestStartEventObj+      { ts_test :: TestObj }++instance J.ToJSON TestStartEventObj where+    toJSON ts =+        J.object ["type" .= J.String "test-start"+                 ,"test" .= J.toJSON (ts_test ts)]++instance HTFJsonObj TestStartEventObj++-- "test-end" message+data TestEndEventObj+    = TestEndEventObj+      { te_test :: TestObj+      , te_result :: TestResult+      , te_location :: Maybe Location+      , te_callers :: [(Maybe String, Location)]+      , te_message :: String+      , te_wallTimeMs :: Int+      }++instance J.ToJSON TestEndEventObj where+    toJSON te =+        J.object ["type" .= J.String "test-end"+                 ,"test" .= J.toJSON (te_test te)+                 ,"location" .= J.toJSON (te_location te)+                 ,"callers" .= J.toJSON (map (\(msg, loc) -> J.object ["message" .= J.toJSON msg+                                                                      ,"location" .= J.toJSON loc])+                                             (te_callers te))+                 ,"result" .= J.toJSON (te_result te)+                 ,"message" .= J.toJSON (te_message te)+                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)]++instance HTFJsonObj TestEndEventObj++instance J.ToJSON TestResult where+    toJSON r = J.String $+        case r of+          Pass -> "pass"+          Pending -> "pending"+          Fail -> "fail"+          Error -> "error"++-- "test-list" message+data TestListObj+    = TestListObj+      { tlm_tests :: [TestObj]+      }++instance J.ToJSON TestListObj where+    toJSON tl =+        J.object ["type" .= J.String "test-list"+                 ,"tests" .= J.toJSON (tlm_tests tl)]++instance HTFJsonObj TestListObj++-- "test-results"+data TestResultsObj+    = TestResultsObj+      { tr_wallTimeMs :: Int+      , tr_passed :: Int+      , tr_pending :: Int+      , tr_failed :: Int+      , tr_errors :: Int+      }++instance J.ToJSON TestResultsObj where+    toJSON r = J.object ["type" .= J.String "test-results"+                        ,"passed" .= J.toJSON (tr_passed r)+                        ,"pending" .= J.toJSON (tr_pending r)+                        ,"failures" .= J.toJSON (tr_failed r)+                        ,"errors" .= J.toJSON (tr_errors r)+                        ,"wallTime" .= J.toJSON (tr_wallTimeMs r)]++instance HTFJsonObj TestResultsObj++data TestObj+    = TestObj+      { to_flatName :: String+      , to_path :: TestPath+      , to_location :: Maybe Location+      , to_sort :: TestSort+      }++instance J.ToJSON TestObj where+    toJSON t = J.object (["flatName" .= J.toJSON (to_flatName t)+                         ,"path" .= J.toJSON (to_path t)+                         ,"sort" .= J.toJSON (to_sort t)] +++                         (case to_location t of+                            Just loc -> ["location" .= J.toJSON loc]+                            Nothing -> []))++instance J.ToJSON TestPath where+    toJSON p = J.toJSON (testPathToList p)++instance J.ToJSON TestSort where+    toJSON s =+        case s of+          UnitTest -> J.String "unit-test"+          QuickCheckTest -> J.String "quickcheck-property"+          BlackBoxTest -> J.String "blackbox-test"+++instance J.ToJSON Location where+    toJSON loc = J.object ["file" .= J.toJSON (fileName loc)+                          ,"line" .= J.toJSON (lineNumber loc)]+++mkTestObj :: GenFlatTest a -> String -> TestObj+mkTestObj ft flatName =+    TestObj flatName (ft_path ft) (ft_location ft) (ft_sort ft)++mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj+mkTestStartEventObj ft flatName =+    TestStartEventObj (mkTestObj ft flatName)++mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj+mkTestEndEventObj ftr flatName =+    let r = ft_payload ftr+    in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r)+                       (rr_message r) (rr_wallTimeMs r)++mkTestListObj :: [(FlatTest, String)] -> TestListObj+mkTestListObj l =+    TestListObj (map (\(ft, flatName) -> mkTestObj ft flatName) l)++mkTestResultsObj :: Milliseconds -> Int -> Int -> Int -> Int -> TestResultsObj+mkTestResultsObj time passed pending failed errors =+    TestResultsObj+    { tr_wallTimeMs = time+    , tr_passed = passed+    , tr_pending = pending+    , tr_failed = failed+    , tr_errors = errors+    }++decodeObj :: HTFJsonObj a => a -> BSL.ByteString+decodeObj x =+    J.encode x `BSL.append` (BSLC.pack "\n;;\n")

@@ -35,7 +35,7 @@  -- | An abstract type representing locations in a file. data Location = Location String Int-                deriving (Eq, Ord)+                deriving (Eq, Ord, Show, Read)  -- | Render a 'Location' as a 'String'. showLoc :: Location -> String

@@ -20,7 +20,7 @@  module Test.Framework.Preprocessor ( transform, progName ) where -import Data.Char ( toLower )+import Data.Char ( toLower, isSpace, isDigit ) import Data.Maybe ( mapMaybe ) import qualified Data.List as List import System.IO ( hPutStrLn, stderr )@@ -84,11 +84,12 @@              ,"assertJust"              ,"assertNothing"              ,"assertNothingNoShow"+             ,"subAssert"              ]  assertDefines :: Bool -> String -> [(String, String)] assertDefines hunitBackwardsCompat prefix =-    concatMap fun allAsserts+    concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")]     where       fun a =           if hunitBackwardsCompat@@ -170,15 +171,27 @@          ParseError loc err ->              do warn ("Parsing of " ++ originalFileName ++ " failed at line "                       ++ show (lineNumber loc) ++ ": " ++ err)-                preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE")+                preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE") input          ParseOK info ->-             preprocess info+             preprocess info input     where-      preprocess :: ModuleInfo -> IO String-      preprocess info =+      preprocess :: ModuleInfo -> String -> IO String+      preprocess info input =           do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName-                                           input+                                           fixedInput              return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+          where+              -- fixedInput serves two purposes:+              -- 1. add a trailing \n+              -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'+              -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output).+              fixedInput :: String+              fixedInput = (unlines . map fixLine . lines) input+                  where+                    fixLine s =+                        case parseCppLineInfoOut s of+                          Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName+                          _ -> s       cpphsOptions :: ModuleInfo -> CpphsOptions       cpphsOptions info =           defaultCpphsOptions { defines =@@ -210,12 +223,14 @@       importedTestListCode :: ModuleInfo -> String       importedTestListCode info =           let l = mi_htfImports info-          in importedTestListFullName (mi_moduleName info)-               ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++-             importedTestListFullName (mi_moduleName info)-               ++ " = [\n    " ++-             List.intercalate ",\n     " (map htfTestsInModule l) ++-             "\n  ]\n"+          in case l of+               [] -> ""+               _ -> (importedTestListFullName (mi_moduleName info)+                     ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" +++                     importedTestListFullName (mi_moduleName info)+                     ++ " = [\n    " +++                     List.intercalate ",\n     " (map htfTestsInModule l) +++                     "\n  ]\n")       htfTestsInModule :: ImportDecl -> String       htfTestsInModule imp = qualify imp (thisModulesTestsFullName (imp_moduleName imp))       qualify :: ImportDecl -> String -> String

@@ -31,18 +31,25 @@ import Control.Concurrent       (forkIO) import qualified Control.Exception -popenShell :: String -> Maybe String -> IO (String,String,ExitCode)+-- | Run a command using the shell.+popenShell :: String        -- ^ Command+           -> Maybe String  -- ^ Content of stdin+           -> IO (String,String,ExitCode)  -- ^ (stdout, stderr, exit code) popenShell cmd = popen' $ runInteractiveCommand cmd -popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ExitCode)-popen file args = +-- | Run a command.+popen :: FilePath         -- ^ Binary+      -> [String]         -- ^ Arguments+      -> Maybe String     -- ^ Content of stdin+      -> IO (String,String,ExitCode)  -- ^ (stdout, stderr, exit code)+popen file args =     popen' $ runInteractiveProcess file args Nothing Nothing -popen' :: IO (Handle, Handle, Handle, ProcessHandle) +popen' :: IO (Handle, Handle, Handle, ProcessHandle)        -> Maybe String        -> IO (String,String,ExitCode)-popen' run minput = -    Control.Exception.handle (\ (e :: Control.Exception.SomeException) -> +popen' run minput =+    Control.Exception.handle (\ (e :: Control.Exception.SomeException) ->                                 return ([],show e,error (show e))) $ do      (inp,out,err,pid) <- run

@@ -43,22 +43,18 @@  ) where -import qualified Data.Map as Map-import Control.Concurrent.MVar #if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..),                            throw, catch, catches, evaluate )-import System.IO-import System.IO.Unsafe-import System.Random-import Data.List( group, sort, intersperse, isPrefixOf )-import Data.Char import Data.Typeable (Typeable)+import Data.Char+import qualified Data.List as List+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent.MVar  import Test.QuickCheck-import Test.QuickCheck.Property hiding (reason)  import Test.Framework.TestManager import Test.Framework.TestManagerInternal@@ -119,7 +115,7 @@                       Right (Success { output=msg }) ->                           quickCheckTestPass (adjustOutput msg)                       Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->-                          if pendingPrefix `isPrefixOf` reason+                          if pendingPrefix `List.isPrefixOf` reason                              then let pendingMsg = let s = drop (length pendingPrefix) reason                                                    in take (length s - length pendingSuffix) s                                   in quickCheckTestPending pendingMsg

@@ -1,64 +0,0 @@------ Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.TestConfig (--    TestConfig(..), defaultTestConfig, ReportLevel(..), report-  , useColors--) where--import Data.Char (toLower)-import Control.Monad (unless)-import System.IO--import System.Posix.Terminal-import System.Posix.IO (stdOutput)-import System.Posix.Types (Fd)-import System.Posix.Env (getEnv)--data TestConfig = TestConfig { tc_quiet :: Bool }-                deriving (Read,Show,Eq)--defaultTestConfig :: TestConfig-defaultTestConfig = TestConfig { tc_quiet = False }--data ReportLevel = Debug | Info-                 deriving (Eq,Ord)--reportHandle :: Handle-reportHandle = stdout -- keep in sync with reportFd!--reportFd :: Fd-reportFd = stdOutput -- keep in sync with reportHandle!--report :: TestConfig -> ReportLevel -> String -> IO ()-report tc level msg =-    unless (tc_quiet tc && level < Info) $ do hPutStrLn reportHandle msg-                                              hFlush reportHandle--useColors :: IO Bool-useColors =-    do mterm <- getEnv "TERM"-       case mterm of-         Nothing -> return False-         Just s | map toLower s == "dump" -> return False-         _ -> do mx <- getEnv "HTF_NO_COLORS"-                 case mx of-                   Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False-                   _ -> queryTerminal reportFd

@@ -26,67 +26,49 @@  module Test.Framework.TestManager ( -  -- * Running tests-  htfMain, runTest, runTestWithArgs, runTestWithOptions,+  -- * Re-exports+  module Test.Framework.TestTypes, -  -- * Options for running tests-  TestOptions(..), defaultTestOptions, parseTestArgs,+  -- * Running tests+  htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',+  runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',    -- * Organzing tests-  TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),   TestableHTF,    makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,   makeAnonTestSuite,   addToTestSuite, testSuiteAsTest, - ) where -import Control.Monad import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs)-import Data.List ( isInfixOf, isPrefixOf, partition )-import Text.PrettyPrint-import qualified Data.List as List-import Data.Maybe (isJust)+import Control.Exception (finally) -import System.Directory (getTemporaryDirectory, removeFile) import System.IO-import System.Console.GetOpt-import GHC.IO.Handle-import qualified Data.ByteString.Lazy as BSL-import qualified Text.Regex as R  import qualified Test.HUnit.Lang as HU +import Test.Framework.Utils+import Test.Framework.TestManagerInternal+import Test.Framework.TestTypes+import Test.Framework.CmdlineOptions+import Test.Framework.TestReporter import Test.Framework.Location-import Test.Framework.Utils ( readM, ensureNewline )-import {-# SOURCE #-} Test.Framework.TestManagerInternal-import Test.Framework.TestConfig-import Test.Framework.Colors --- | An assertion is just an 'IO' action.-type Assertion = IO ()---- | Type for naming tests.-type TestID = String- -- | Construct a test where the given 'Assertion' checks a quick check property.--- See 'Test.Framework.QuickCheckWrapper'.--- Mainly used internally.+-- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass  -- | Construct a unit test from the given 'IO' action.--- See 'Test.Framework.HUnitWrapper'.--- Mainly used internally.+-- Mainly used internally by the htfpp preprocessor. makeUnitTest :: TestID -> Location -> IO a -> Test makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())  -- | Construct a black box test from the given 'Assertion'.--- See 'Test.Framework.BlackBoxTest'. -- Mainly used internally. makeBlackBoxTest :: TestID -> Assertion -> Test makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass@@ -108,31 +90,16 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') --- | Type for distinguishing different sorts of tests.-data TestSort = UnitTest | QuickCheckTest | BlackBoxTest-              deriving (Eq,Show,Read)---- | Abstract type for tests.-data Test = BaseTest TestSort TestID (Maybe Location) Assertion-          | CompoundTest TestSuite---- | Abstract type for test suites.-data TestSuite = TestSuite TestID [Test]-               | AnonTestSuite [Test]---- | Type for flattened tests.-data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion- -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where     flatten :: t -> [FlatTest]  instance TestableHTF Test where-    flatten = flattenTest Nothing+    flatten = flattenTest  instance TestableHTF TestSuite where-    flatten = flattenTestSuite Nothing+    flatten = flattenTestSuite  instance TestableHTF t => TestableHTF [t] where     flatten = concatMap flatten@@ -140,312 +107,149 @@ instance TestableHTF (IO a) where     flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action) -type Path = Maybe String--flattenTest :: Path -> Test -> [FlatTest]-flattenTest path (BaseTest sort id mloc ass) =-    [FlatTest sort (path `concatPath` id) mloc ass]-flattenTest path (CompoundTest ts) =-    flattenTestSuite path ts--flattenTestSuite :: Path -> TestSuite -> [FlatTest]-flattenTestSuite path (TestSuite id ts) =-    concatMap (flattenTest (Just (path `concatPath` id))) ts-flattenTestSuite path (AnonTestSuite ts) =-    concatMap (flattenTest path) ts--concatPath :: Path -> String -> String-concatPath Nothing s = s-concatPath (Just s1) s2 = s1 ++ pathSep ++ s2-    where pathSep = ":"--data TestState = TestState { ts_passed  :: [String]-                           , ts_failed  :: [String]-                           , ts_error   :: [String]-                           , ts_pending :: [String] }--initTestState :: TestState-initTestState = TestState [] [] [] []--type TR = RWST TestConfig () TestState IO--data HandleRedirection = HandleRedirection { hr_original :: Handle-                                           , hr_originalCopy :: Handle-                                           , hr_newHandle :: Handle-                                           , hr_newFilePath :: FilePath }--redirectHandle :: String -> Handle -> IO HandleRedirection-redirectHandle nameTmpl h =-    do tmpDir <- getTemporaryDirectory-       (path, new) <- openBinaryTempFile tmpDir nameTmpl-       copy <- hDuplicate h-       hDuplicateTo new h-       return $ HandleRedirection { hr_original = h-                                  , hr_originalCopy = copy-                                  , hr_newHandle = new-                                  , hr_newFilePath = path }--unredirectHandle :: HandleRedirection -> IO ()-unredirectHandle hr =-    do hClose (hr_newHandle hr)-       hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore+flattenTest :: Test -> [FlatTest]+flattenTest (BaseTest sort id mloc x) =+    [FlatTest sort (TestPathBase id) mloc x]+flattenTest (CompoundTest ts) =+    flattenTestSuite ts -cleanupRedirection :: Bool -> HandleRedirection -> IO ()-cleanupRedirection printOutput hr =-    do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr)-                               BSL.hPut (hr_original hr) x-                               hFlush (hr_original hr)-       removeFile (hr_newFilePath hr)+flattenTestSuite :: TestSuite -> [FlatTest]+flattenTestSuite (TestSuite id ts) =+    let fts = concatMap flattenTest ts+    in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts+flattenTestSuite (AnonTestSuite ts) =+    let fts = concatMap flattenTest ts+    in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -runFlatTest :: FlatTest -> TR ()-runFlatTest (FlatTest sort id mloc ass) =-    do let name = id ++ case mloc of-                          Nothing -> ""-                          Just loc -> " (" ++ showLoc loc ++ ")"-       x <- atStart name-       res <- liftIO $ HU.performTestCase ass-       let (testResult, msg) =+runFlatTest :: FlatTest -> TR FlatTestResult+runFlatTest ft =+    do reportTestStart ft+       (res, time) <- liftIO $ measure $ HU.performTestCase (ft_payload ft)+       let (testResult, (mLoc, callers, msg)) =              case res of-               Nothing -> (Pass, "")+               Nothing -> (Pass, (Nothing, [], ""))                Just (isFailure, msg') ->-                   if sort /= QuickCheckTest-                      then if isFailure-                              then case extractPendingMessage msg' of-                                     Nothing -> (Fail, msg')-                                     Just msg'' -> (Pending, msg'')-                              else (Error, msg')-                      else case readM msg' :: Maybe (TestResult, Maybe String) of-                             Nothing ->-                                 error ("ERROR: " ++-                                        "Cannot deserialize QuickCheck " ++-                                        "error message.\n[BEGIN]\n" ++-                                        show msg' ++ "\n[END]\n")-                             Just (r, ms) ->-                                 case ms of-                                   Nothing -> (r, "")-                                   Just s -> (r, s)-       afterRunning x name testResult-       case testResult of-         Pass -> reportSuccess name msg-         Pending ->-             do modify (\s -> s { ts_pending = name : (ts_pending s) })-                reportPending msg-         Fail ->-             do modify (\s -> s { ts_failed = name : (ts_failed s) })-                reportFailure msg-         Error ->-             do modify (\s -> s { ts_error = name : (ts_error s) })-                reportError msg-       atEnd testResult-    where-      testStartMessage name =-          do t <- colorize testStartColor "[TEST] "-             return $ t ++ name-      atStart name =-          do tc <- ask-             if tc_quiet tc-                then liftIO $-                     do stdoutRedir <- redirectHandle "HTF.out" stdout-                        stderrRedir <- redirectHandle "HTF.err" stderr-                        return $ Just (stdoutRedir, stderrRedir)-                else do msg <- liftIO $ testStartMessage name-                        reportTR Debug msg-                        return Nothing-      afterRunning x name testResult =-          do tc <- ask-             if tc_quiet tc-                then case x of-                       Just (stdoutRedir, stderrRedir) -> liftIO $-                          do unredirectHandle stderrRedir-                             unredirectHandle stdoutRedir-                             let printOutput = needsReport testResult-                             when printOutput $-                                  do msg <- testStartMessage name-                                     report tc Info msg-                             cleanupRedirection printOutput stderrRedir-                             cleanupRedirection printOutput stdoutRedir-                else return ()-      atEnd testResult =-          do tc <- ask-             if not (tc_quiet tc) || needsReport testResult-                then reportTR Info ""-                else return ()-      needsReport testResult = testResult `elem` [Fail, Error, Pending]-      reportSuccess name msg =-          do modify (\s -> s { ts_passed = name : (ts_passed s) })-             pref <- okPrefix-             reportTR Debug (ensureNewline msg ++ pref)-      reportPending msg =-          do pref <- pendingPrefix-             reportMessage Info msg  pref-      reportFailure msg =-          do pref <- failurePrefix-             reportMessage Info msg pref-      reportError msg =-          do pref <- errorPrefix-             reportMessage Info msg pref-      reportMessage isImportant msg prefix =-          reportTR isImportant (ensureNewline msg ++ prefix)-      failurePrefix = liftIO $ colorize warningColor "*** Failed! "-      errorPrefix = liftIO $ colorize warningColor "@@@ Error! "-      pendingPrefix = liftIO $ colorize pendingColor "^^^ Pending! "-      okPrefix = liftIO $ colorize testOkColor  "+++ OK"+                   if ft_sort ft /= QuickCheckTest+                      then let utr = deserializeHUnitMsg msg'+                               r = case () of+                                     _| utr_pending utr -> Pending+                                      | isFailure -> Fail+                                      | otherwise -> Error+                           in (r, (utr_location utr, utr_callingLocations utr, utr_message utr))+                      else let (r, s) = deserializeQuickCheckMsg msg'+                           in (r, (Nothing, [], s))+           rr = FlatTest+                  { ft_sort = ft_sort ft+                  , ft_path = ft_path ft+                  , ft_location = ft_location ft+                  , ft_payload = RunResult testResult mLoc callers msg time }+       return rr -runFlatTests :: [FlatTest] -> TR ()-runFlatTests = mapM_ runFlatTest+handleRunResult :: FlatTestResult -> TR ()+handleRunResult r =+    do modify (\s -> s { ts_results = r : ts_results s })+       reportTestResult r --- | Run something testable using the 'defaultTestOptions'.+runAllFlatTests :: [FlatTest] -> TR ()+runAllFlatTests tests =+    do reportGlobalStart tests+       mapM_ (\ft -> runFlatTest ft >>= handleRunResult) tests++-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t              -- ^ Testable thing-                         -> IO ExitCode    -- See 'runTestWithOptions' for a specification of the 'ExitCode' result-runTest = runTestWithOptions defaultTestOptions+                         -> IO ExitCode    -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result+runTest = runTestWithOptions defaultCmdlineOptions -optionDescriptions :: [OptDescr (TestOptions -> TestOptions)]-optionDescriptions =-    [ Option ['v']     ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output"-    , Option ['q']     ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"-    , Option ['n']     ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })-                                           "TEST_PATTERN") "tests to exclude"-    , Option ['h']     ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"-    ]+-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.+runTest' :: TestableHTF t => t              -- ^ Testable thing+                         -> IO (IO (), ExitCode)    -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result+runTest' = runTestWithOptions' defaultCmdlineOptions --- | Run something testable, parse the 'TestOptions' from the given commandline arguments.+-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.+-- Does not print the overall test results but returns an 'IO' action for doing so. runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments                                  -> t               -- ^ Testable thing-                                 -> IO ExitCode     -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result+                                 -> IO ExitCode     -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result. runTestWithArgs args t =+    do (printSummary, ecode) <- runTestWithArgs' args t+       printSummary+       return ecode+++-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.+runTestWithArgs' :: TestableHTF t => [String]        -- ^ Commandline arguments+                                 -> t               -- ^ Testable thing+                                 -> IO (IO (), ExitCode)  -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithArgs' args t =     case parseTestArgs args of       Left err ->           do hPutStrLn stderr err-             return $ ExitFailure 1+             return $ (return (), ExitFailure 1)       Right opts ->-          runTestWithOptions opts t--{- |--Parse commandline arguments into 'TestOptions'. Here's a synopsis-of the format of the commandline arguments:--> [OPTION ...] TEST_PATTERN ...->->   where TEST_PATTERN is a posix regular expression matching->   the names of the tests to run.->->   -v               --verbose           chatty output->   -q               --quiet             only display errors->   -n TEST_PATTERN  --not=TEST_PATTERN  tests to exclude->   -h               --help              display this message+          runTestWithOptions' opts t --}+-- | Runs something testable with the given 'CmdlineOptions'.+-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode+runTestWithOptions opts t =+    do (printSummary, ecode) <- runTestWithOptions' opts t+       printSummary+       return ecode -parseTestArgs :: [String] -> Either String TestOptions-parseTestArgs args =-    case getOpt Permute optionDescriptions args of-      (optTrans, tests, []  ) ->-          let posStrs = tests-              negStrs = opts_negated opts-              pos = map mkRegex posStrs-              neg = map mkRegex negStrs-              pred (FlatTest _ id _ _) =-                  if (any (\s -> s `matches` id) neg)-                     then False-                     else null pos || any (\s -> s `matches` id) pos-              opts = (foldr ($) defaultTestOptions optTrans) { opts_filter = pred }-          in Right opts-      (_,_,errs) ->-          Left (concat errs ++ usageInfo usageHeader optionDescriptions)+-- | Runs something testable with the given 'CmdlineOptions'. Does not+-- print the overall test results but returns an 'IO' action for doing so.+-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)+runTestWithOptions' opts t =+    if opts_help opts+       then do hPutStrLn stderr helpString+               return $ (return (), ExitFailure 1)+       else do tc <- testConfigFromCmdlineOptions opts+               (printSummary, ecode) <-+                   (if opts_listTests opts+                      then let fts = filter (opts_filter opts) (flatten t)+                           in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)+                      else runTestWithConfig' tc t)+               return (printSummary `finally` cleanup tc, ecode)     where-      matches r s = isJust $ R.matchRegex r s-      mkRegex s = R.mkRegexWithOpts s True False--usageHeader :: String-usageHeader = ("USAGE: COMMAND [OPTION ...] TEST_PATTERN ...\n\n" ++-               "  where TEST_PATTERN is a posix regular expression matching\n" ++-               "  the names of the tests to run.\n")---- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run.-type Filter = FlatTest -> Bool---- | Options for running tests.-data TestOptions = TestOptions {-      opts_quiet :: Bool          -- ^ Be quiet or not.-    , opts_filter :: Filter       -- ^ Run only tests matching this filter.-    , opts_help :: Bool           -- ^ If 'True', display a help message and exit.-    , opts_negated :: [String]    -- ^ Regular expressions matching test names which should /not/ run.-    }--defaultTestOptions :: TestOptions-{- | The default 'TestOptions':--> TestOptions {->       opts_quiet = False->     , opts_filter = const True->     , opts_help = False->     , opts_negated = []-> }---}-defaultTestOptions = TestOptions {-      opts_quiet = False-    , opts_filter = const True-    , opts_help = False-    , opts_negated = []-    }+      cleanup tc =+          case tc_output tc of+            TestOutputHandle h True -> hClose h+            _ -> return () --- | Runs something testable with the given 'TestOptions'.+-- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully, -- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates -- that failures but no errors occurred, otherwise the error code @2@ is used. -- -- A test is /successful/ if the test terminates and no assertion fails. -- A test is said to /fail/ if an assertion fails but no other error occur.-runTestWithOptions :: TestableHTF t => TestOptions -> t -> IO ExitCode-runTestWithOptions opts t =-    if opts_help opts-       then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions)-               return $ ExitFailure 1-       else-         do let pred = opts_filter opts-                tc = optsToConfig opts-            (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc initTestState-            let passed = length (ts_passed s)-                pending = length (ts_pending s)-                failed = length (ts_failed s)-                error = length (ts_error s)-                total = passed + failed + error + pending-            pendings <- colorize pendingColor "* Pending:"-            failures <- colorize warningColor "* Failures:"-            errors <- colorize warningColor "* Errors:"-            report tc Info ("* Tests:    " ++ show total ++ "\n" ++-                            "* Passed:   " ++ show passed ++ "\n" ++-                            pendings ++ "  " ++ show pending ++ "\n" ++-                            failures ++ " " ++ show failed ++ "\n" ++-                            errors ++ "   " ++ show error )-            when (pending > 0) $-               reportDoc tc Info-                   (text ('\n' : pendings) $$ renderTestNames (reverse (ts_pending s)))-            when (failed > 0) $-               reportDoc tc Info-                   (text ('\n' : failures) $$ renderTestNames (reverse (ts_failed s)))-            when (error > 0) $-               reportDoc tc Info-                   (text ('\n' : errors) $$ renderTestNames (reverse (ts_error s)))-            return $ case () of-                       _| failed == 0 && error == 0 -> ExitSuccess-                        | error == 0                -> ExitFailure 1-                        | otherwise                 -> ExitFailure 2-    where-      renderTestNames l =-          nest 2 (vcat (map (\name -> text "*" <+> text name) l))-      optsToConfig opts =-          TestConfig { tc_quiet = opts_quiet opts }--reportDoc :: TestConfig -> ReportLevel -> Doc -> IO ()-reportDoc tc level doc = report tc level (render doc)+runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode+runTestWithConfig tc t =+    do (printSummary, ecode) <- runTestWithConfig' tc t+       printSummary+       return ecode -reportTR :: ReportLevel -> String -> TR ()-reportTR level msg =-    do tc <- ask-       liftIO $ report tc level msg+-- | Runs something testable with the given 'TestConfig'. Does not+-- print the overall test results but returns an 'IO' action for doing so.+-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode)+runTestWithConfig' tc t =+     do ((_, s, _), time) <-+            measure $+            runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState+        let results = reverse (ts_results s)+            passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results+            pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results+            failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results+            error = filter (\ft -> (rr_result . ft_payload) ft == Error) results+        let printSummary =+                runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run+        return (printSummary >> return (),+                case () of+                   _| length failed == 0 && length error == 0 -> ExitSuccess+                    | length error == 0 -> ExitFailure 1+                    | otherwise -> ExitFailure 2)  -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- -- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de --@@ -18,36 +19,23 @@  module Test.Framework.TestManagerInternal ( -  extractPendingMessage,-  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,-  quickCheckTestPass,-  unitTestFail, unitTestPending, blackBoxTestFail,+  UnitTestResult(..), -  TestResult(..)+  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,+  quickCheckTestPass, deserializeQuickCheckMsg,+  unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert,+  blackBoxTestFail,  ) where -import Data.List ( isPrefixOf )-import qualified Test.HUnit.Lang as HU--import Test.Framework.TestManager--data TestResult = Error | Fail | Pending | Pass-                  deriving (Show, Read, Eq)---- A pending test case is treated as a failed testcase, but the error message--- starts with the given prefix.-pendingPrefix :: String-pendingPrefix = "__PENDING__"--makePendingMessage :: String -> String-makePendingMessage = (++) pendingPrefix+import Test.Framework.TestTypes+import Test.Framework.Utils+import Test.Framework.Location -extractPendingMessage :: String -> Maybe String-extractPendingMessage msg =-    if pendingPrefix `isPrefixOf` msg-       then Just $ drop (length pendingPrefix) msg-       else Nothing+import qualified Test.HUnit.Lang as HU+import Control.Monad.Trans+import Control.Monad.Trans.Control+import qualified Control.Exception.Lifted as Exc  assertFailureHTF :: String -> Assertion -- Important: force the string argument, otherwise an error embedded@@ -68,14 +56,48 @@ quickCheckTestPass :: String -> Assertion quickCheckTestPass m = assertFailureHTF (show (Pass, Just m)) -unitTestFail :: String -> IO a-unitTestFail s =-    do assertFailureHTF s+deserializeQuickCheckMsg :: String -> (TestResult, String)+deserializeQuickCheckMsg msg =+    case readM msg of+      Nothing ->+          (Error, msg)+      Just (r, ms) ->+          case ms of+            Nothing -> (r, "")+            Just s -> (r, s)++-- This is a HACK: we encode location and pending information as a datatype+-- that we show and parse later using read.+data UnitTestResult+    = UnitTestResult+      { utr_location :: Maybe Location+      , utr_callingLocations :: [(Maybe String, Location)]+      , utr_message :: String+      , utr_pending :: Bool+      } deriving (Eq, Show, Read)++unitTestFail :: Maybe Location -> String -> IO a+unitTestFail loc s =+    do assertFailureHTF (show (UnitTestResult loc [] s False))        error "unitTestFail: UNREACHABLE" --- |Mark a unit test as pending without removing it from the test suite.+unitTestSubAssert :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a+unitTestSubAssert loc mMsg action =+    action `Exc.catch` (\(HU.HUnitFailure s) -> let res = deserializeHUnitMsg s+                                                    newRes = res { utr_callingLocations = (mMsg, loc) : utr_callingLocations res }+                                                in Exc.throwIO (HU.HUnitFailure $ show newRes))++-- Mark a unit test as pending without removing it from the test suite. unitTestPending :: String -> IO a-unitTestPending s = unitTestFail (makePendingMessage s)+unitTestPending s =+    do assertFailureHTF (show (UnitTestResult Nothing [] s True))+       error "unitTestFail: UNREACHABLE"++deserializeHUnitMsg :: String -> UnitTestResult+deserializeHUnitMsg msg =+    case readM msg of+      Just r -> r+      _ -> UnitTestResult Nothing [] msg False  blackBoxTestFail :: String -> Assertion blackBoxTestFail = assertFailureHTF

@@ -1,8 +0,0 @@-module Test.Framework.TestManagerInternal where--data TestResult = Error | Fail | Pending | Pass-instance Read TestResult-instance Show TestResult-instance Eq TestResult--extractPendingMessage :: String -> Maybe String

@@ -0,0 +1,295 @@+{-|++This module defines functions for notifying all test reporters registered about+particular events in the lifecycle of a test run.++Further, it defines the standard test reporters for HTF's various output formats.++-}+module Test.Framework.TestReporter (++    reportAllTests, reportGlobalStart, reportTestStart, reportTestResult,+    reportGlobalResults, defaultTestReporters++) where++import Test.Framework.TestTypes+import Test.Framework.Location+import Test.Framework.Colors+import Test.Framework.Utils+import Test.Framework.JsonOutput++import System.IO+import Control.Monad.RWS+import Text.PrettyPrint++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++-- | Invokes 'tr_reportAllTests' on all test reporters registered.+reportAllTests :: ReportAllTests+reportAllTests tests =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportAllTests r tests) reps++-- | Invokes 'tr_reportGlobalStart' on all test reporters registered.+reportGlobalStart :: ReportGlobalStart+reportGlobalStart tests =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportGlobalStart r tests) reps++-- | Invokes 'tr_reportTestStart' on all test reporters registered.+reportTestStart :: ReportTestStart+reportTestStart t =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportTestStart r t) reps++-- | Invokes 'tr_reportTestResult' on all test reporters registered.+reportTestResult :: ReportTestResult+reportTestResult t =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportTestResult r t) reps++-- | Invokes 'tr_reportGlobalResults' on all test reporters registered.+reportGlobalResults :: ReportGlobalResults+reportGlobalResults t l1 l2 l3 l4 =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps++-- | The default test reporters for HTF.+defaultTestReporters :: Bool -- ^ 'True' if tests are run in parallel+                     -> Bool -- ^ 'True' if machine output should be produced+                     -> [TestReporter]+defaultTestReporters inParallel forMachine =+    case (inParallel, forMachine) of+      (False, False) ->+          [TestReporter+           { tr_id = "rep_seq_human"+           , tr_reportAllTests = reportAllTestsH+           , tr_reportGlobalStart = reportGlobalStartHS+           , tr_reportTestStart = reportTestStartHS+           , tr_reportTestResult = reportTestResultHS+           , tr_reportGlobalResults = reportGlobalResultsH+           }]+      (True, False) ->+          [TestReporter+           { tr_id = "rep_par_human"+           , tr_reportAllTests = reportAllTestsH+           , tr_reportGlobalStart = reportGlobalStartHP+           , tr_reportTestStart = reportTestStartHP+           , tr_reportTestResult = reportTestResultHP+           , tr_reportGlobalResults = reportGlobalResultsH+           }]+      (False, True) ->+          [TestReporter+           { tr_id = "rep_seq_machine"+           , tr_reportAllTests = reportAllTestsM+           , tr_reportGlobalStart = reportGlobalStartMS+           , tr_reportTestStart = reportTestStartMS+           , tr_reportTestResult = reportTestResultMS+           , tr_reportGlobalResults = reportGlobalResultsM+           }]+      (True, True) ->+          [TestReporter+           { tr_id = "rep_par_machine"+           , tr_reportAllTests = reportAllTestsM+           , tr_reportGlobalStart = reportGlobalStartMP+           , tr_reportTestStart = reportTestStartMP+           , tr_reportTestResult = reportTestResultMP+           , tr_reportGlobalResults = reportGlobalResultsM+           }]++--+-- output for humans+--++humanTestName :: GenFlatTest a -> String+humanTestName ft =+    flatName (ft_path ft) +++    case ft_location ft of+      Nothing -> ""+      Just loc -> " (" ++ showLoc loc ++ ")"++reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()+reportHumanTestStartMessage level ft =+    do t <- liftIO $ colorize testStartColor "[TEST] "+       reportTR level (t ++ (humanTestName ft))++-- sequential+reportGlobalStartHS :: ReportGlobalStart+reportGlobalStartHS _ = return ()++reportTestStartHS :: ReportTestStart+reportTestStartHS ft = reportHumanTestStartMessage Debug ft++reportTestResultHS :: ReportTestResult+reportTestResultHS ftr =+    let res = rr_result (ft_payload ftr)+        msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr))+    in case res of+         Pass ->+             do suf <- okSuffix+                reportMessage Debug msg suf+         Pending ->+             do reportHumanTestStartMessageIfNeeded+                suf <- pendingSuffix+                reportMessage Info msg suf+         Fail ->+             do reportHumanTestStartMessageIfNeeded+                suf <- failureSuffix+                reportMessage Info msg suf+         Error ->+             do reportHumanTestStartMessageIfNeeded+                suf <- errorSuffix+                reportMessage Info msg suf+   where+     attachCallStack msg callStack =+         case reverse callStack of+           [] -> msg+           l -> ensureNewline msg +++                unlines (map formatCallStackElem l)+     formatCallStackElem (mMsg, loc) =+         "  called from " ++ showLoc loc ++ (case mMsg of+                                               Nothing -> ""+                                               Just s -> " (" ++ s ++ ")")+     reportHumanTestStartMessageIfNeeded =+         do tc <- ask+            when (tc_quiet tc) (reportHumanTestStartMessage Info ftr)+     reportMessage level msg suffix =+         reportTR level (ensureNewline msg ++ suffix ++ timeStr)+     timeStr = " (" ++ show (rr_wallTimeMs (ft_payload ftr)) ++ "ms)\n"+     failureSuffix = liftIO $ colorize warningColor "*** Failed!"+     errorSuffix = liftIO $ colorize warningColor "@@@ Error!"+     pendingSuffix = liftIO $ colorize pendingColor "^^^ Pending!"+     okSuffix = liftIO $ colorize testOkColor  "+++ OK"++-- parallel+reportGlobalStartHP :: ReportGlobalStart+reportGlobalStartHP _ = return ()++reportTestStartHP :: ReportTestStart+reportTestStartHP ft =+     do reportTR Debug ("Starting " ++ (humanTestName ft))++reportTestResultHP :: ReportTestResult+reportTestResultHP ftr =+    do reportHumanTestStartMessage Debug ftr+       reportTestResultHS ftr++-- results and all tests+reportAllTestsH :: ReportAllTests+reportAllTestsH l =+    reportDoc Info (renderTestNames l)++reportGlobalResultsH :: ReportGlobalResults+reportGlobalResultsH t passedL pendingL failedL errorL =+    do let passed = length passedL+           pending = length pendingL+           failed = length failedL+           error = length errorL+           total = passed + failed + error + pending+       pendings <- liftIO $ colorize pendingColor "* Pending:"+       failures <- liftIO $ colorize warningColor "* Failures:"+       errors <- liftIO $ colorize warningColor "* Errors:"+       reportTR Info ("* Tests:    " ++ show total ++ "\n" +++                      "* Passed:   " ++ show passed ++ "\n" +++                      pendings ++ "  " ++ show pending ++ "\n" +++                      failures ++ " " ++ show failed ++ "\n" +++                      errors ++ "   " ++ show error)+       when (pending > 0) $+          reportDoc Info+              (text ('\n' : pendings) $$ renderTestNames' (reverse pendingL))+       when (failed > 0) $+          reportDoc Info+              (text ('\n' : failures) $$ renderTestNames' (reverse failedL))+       when (error > 0) $+          reportDoc Info+              (text ('\n' : errors) $$ renderTestNames' (reverse errorL))+       reportTR Info ("\nTotal execution time: " ++ show t ++ "ms")+    where+      renderTestNames' rrs =+          nest 2 $ renderTestNames rrs++renderTestNames :: [GenFlatTest a] -> Doc+renderTestNames l =+    vcat (map (\ft -> text "*" <+>+                      text (humanTestName ft)) l)++--+-- output for machines+--++-- sequential+reportGlobalStartMS :: ReportGlobalStart+reportGlobalStartMS _ = return ()++reportTestStartMS :: ReportTestStart+reportTestStartMS ft =+    let json = mkTestStartEventObj ft (flatName (ft_path ft))+    in reportJsonTR json++reportTestResultMS :: ReportTestResult+reportTestResultMS ftr =+    let json = mkTestEndEventObj ftr (flatName (ft_path ftr))+    in reportJsonTR json++-- parallel+reportGlobalStartMP :: ReportGlobalStart+reportGlobalStartMP _ = return ()++reportTestStartMP :: ReportTestStart+reportTestStartMP = reportTestStartMS++reportTestResultMP :: ReportTestResult+reportTestResultMP = reportTestResultMS++-- results and all tests+reportAllTestsM :: ReportAllTests+reportAllTestsM l =+    let json = mkTestListObj (map (\ft -> (ft, flatName (ft_path ft))) l)+    in reportJsonTR json++reportGlobalResultsM :: ReportGlobalResults+reportGlobalResultsM t pass pending failed errors =+    let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors)+    in reportJsonTR json++--+-- General reporting routines+--++reportDoc :: ReportLevel -> Doc -> TR ()+reportDoc level doc = reportTR level (render doc)++reportTR :: ReportLevel -> String -> TR ()+reportTR level msg =+    do tc <- ask+       reportGen tc level (\h -> hPutStrLn h msg)++reportBytesTR :: ReportLevel -> BS.ByteString -> TR ()+reportBytesTR level msg =+    do tc <- ask+       reportGen tc level (\h -> BS.hPut h msg)++reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR ()+reportLazyBytesTR level msg =+    do tc <- ask+       reportGen tc level (\h -> BSL.hPut h msg)++reportJsonTR :: HTFJsonObj a => a -> TR ()+reportJsonTR x = reportLazyBytesTR Info (decodeObj x)++data ReportLevel = Debug | Info+                 deriving (Eq,Ord)++reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()+reportGen tc level fun =+    unless (tc_quiet tc && level < Info) $+    case tc_output tc of+      TestOutputHandle h _ -> liftIO (fun h)+      TestOutputSplitted fp ->+          do -- split mode: one file for each result to avoid locking on windows+             ix <- gets ts_index+             let realFp = fp ++ (show ix) -- just append the index at the end of the file given as output parameter+             modify (\x -> x { ts_index = ts_index x + 1 })+             liftIO $ withFile realFp WriteMode fun

@@ -0,0 +1,176 @@+{-| ++This module defines types (and small auxiliary functions)+for organizing tests, for configuring the execution of+tests, and for representing and reporting their results.++-}+module Test.Framework.TestTypes (++  -- * Organizing tests+  TestID, Assertion, Test(..), TestSuite(..), TestSort(..),+  TestPath(..), GenFlatTest(..), FlatTest, TestFilter,+  testPathToList, flatName,++  -- * Executing tests+  TR, TestState(..), initTestState, TestConfig(..), TestOutput(..),++  -- * Reporting results+  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults,+  TestReporter(..),++  -- * Specifying results.+  TestResult(..), FlatTestResult, Milliseconds, RunResult(..)++) where++import Test.Framework.Location++import Control.Monad.RWS+import System.IO+import Data.Maybe+import qualified Data.List as List++-- | An assertion is just an 'IO' action.+type Assertion = IO ()++-- | Type for naming tests.+type TestID = String++-- | Type for distinguishing different sorts of tests.+data TestSort = UnitTest | QuickCheckTest | BlackBoxTest+              deriving (Eq,Show,Read)++-- | Abstract type for tests and their results.+data Test = BaseTest TestSort TestID (Maybe Location) Assertion+          | CompoundTest TestSuite++-- | Abstract type for test suites and their results.+data TestSuite = TestSuite TestID [Test]+               | AnonTestSuite [Test]++-- | A type denoting the hierarchical name of a test.+data TestPath = TestPathBase TestID+              | TestPathCompound (Maybe TestID) TestPath++-- | Splits a 'TestPath' into a list of test identifiers.+testPathToList :: TestPath -> [Maybe TestID]+testPathToList (TestPathBase i) = [Just i]+testPathToList (TestPathCompound mi p) =+    mi : testPathToList p++-- | Creates a string representation from a 'TestPath'.+flatName :: TestPath -> String+flatName p =+    List.intercalate ":" (map (fromMaybe "") (testPathToList p))++-- | Generic type for flattened tests and their results.+data GenFlatTest a+    = FlatTest+      { ft_sort :: TestSort           -- ^ The sort of the test.+      , ft_path :: TestPath           -- ^ Hierarchival path.+      , ft_location :: Maybe Location -- ^ Place of definition.+      , ft_payload :: a               -- ^ A generic payload.+      }++-- | Flattened representation of tests.+type FlatTest = GenFlatTest Assertion++-- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run.+type TestFilter = FlatTest -> Bool++-- | The summary result of a test.+data TestResult = Pass | Pending | Fail | Error+                deriving (Show, Read, Eq)++-- | A type synonym for time in milliseconds.+type Milliseconds = Int++-- | The result of a test run.+data RunResult+    = RunResult+      { rr_result :: TestResult       -- ^ The summary result of the test.+      , rr_location :: Maybe Location -- ^ The location where the test failed (if applicable).+      , rr_callers :: [(Maybe String, Location)] -- ^ Information about the callers of the location where the test failed+      , rr_message :: String          -- ^ A message describing the result.+      , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds.+      }++-- | The result of running a 'FlatTest'+type FlatTestResult = GenFlatTest RunResult++-- | The state type for the 'TR' monad.+data TestState = TestState { ts_results :: [FlatTestResult] -- ^ Results collected so far.+                           , ts_index :: Int                -- ^ Current index for splitted output.+                           }++-- | The initial test state.+initTestState :: TestState+initTestState = TestState [] 0++-- | The 'TR' (test runner) monad.+type TR = RWST TestConfig () TestState IO++-- | The destination of progress and result messages from HTF.+data TestOutput = TestOutputHandle Handle Bool -- ^ Output goes to 'Handle', boolean flag indicates whether the handle should be closed at the end.+                | TestOutputSplitted FilePath  -- ^ Output goes to files whose names are derived from 'FilePath' by appending a number to it. Numbering starts at zero.+                  deriving (Show, Eq)++-- | Configuration of test execution.+data TestConfig+    = TestConfig+      { tc_quiet :: Bool                -- ^ If set, displays messages only for failed tests.++--      , tc_threads :: Maybe Int       Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution (currently unused).+      , tc_output :: TestOutput         -- ^ Output destination of progress and result messages.+      , tc_filter :: TestFilter         -- ^ Filter for the tests to run.+      , tc_reporters :: [TestReporter]  -- ^ Test reporters to use.+      }++instance Show TestConfig where+    showsPrec prec tc =+        showParen (prec > 0) $+        showString "TestConfig { " .+        showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .+--        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_output=" . showsPrec 1 (tc_output tc) .+        showString ", tc_filter=<filter>" .+        showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) .+        showString " }"++-- | A 'TestReporter' provides hooks to customize the output of HTF.+data TestReporter+    = TestReporter+      { tr_id :: String+      , tr_reportAllTests :: ReportAllTests        -- ^ Called to report the IDs of all tests available.+      , tr_reportGlobalStart :: ReportGlobalStart  -- ^ Called to report the start of test execution.+      , tr_reportTestStart :: ReportTestStart      -- ^ Called to report the start of a single test.+      , tr_reportTestResult :: ReportTestResult    -- ^ Called to report the result of a single test.+      , tr_reportGlobalResults :: ReportGlobalResults  -- ^ Called to report the overall results of all tests.+      }++instance Show TestReporter where+    showsPrec _ x = showString (tr_id x)++instance Eq TestReporter where+    x == y = (tr_id x) == (tr_id y)++-- | Reports the IDs of all tests available.+type ReportAllTests = [FlatTest] -> TR ()++-- | Signals that test execution is about to start.+type ReportGlobalStart = [FlatTest] -> TR ()++-- | Reports the start of a single test.+type ReportTestStart = FlatTest -> TR ()++-- | Reports the result of a single test.+type ReportTestResult = FlatTestResult -> TR ()++-- | Reports the overall results of all tests.+type ReportGlobalResults = Milliseconds     -- ^ wall time in ms+                        -> [FlatTestResult] -- ^ passed tests+                        -> [FlatTestResult] -- ^ pending tests+                        -> [FlatTestResult] -- ^ failed tests+                        -> [FlatTestResult] -- ^ erroneous tests+                        -> TR ()

@@ -1,5 +1,3 @@-module Test.Framework.Tutorial (- {- | This module provides a short tutorial on how to use the HTF. It assumes that you are using GHC for compiling your Haskell code. (It is@@ -14,6 +12,8 @@  -} +module Test.Framework.Tutorial (+ -- * A simple example {- | @@ -92,39 +92,49 @@ Executable tutorial   Type:              exitcode-stdio-1.0   Main-is:           Tutorial.hs-  Build-depends:     base == 4.*, HTF == 0.9.*+  Build-depends:     base == 4.*, HTF == 0.10.*   Default-language:  Haskell2010 @  Compiling the program just shown (you must include the code for @myReverse@ as well), and then running the resulting program with no-further commandline arguments yields the following output:+further commandline arguments yields the following output (colors had to+be omitted, so the diff output does not look very useful):  > [TEST] Main:nonEmpty (Tutorial.hs:17) > assertEqual failed at Tutorial.hs:18 > * expected: [3, 2, 1] > * but got:  [3] > * diff:     [3, 2, 1]-> *** Failed!+> *** Failed! (0ms) > > [TEST] Main:empty (Tutorial.hs:19)-> +++ OK+> +++ OK (0ms) > > [TEST] Main:reverse (Tutorial.hs:22)-> Falsifiable (after 7 tests and 4 shrinks):+> Falsifiable (after 6 tests and 5 shrinks): > [0,0]-> Replay argument: "Just (1982441876 2147483392,6)"-> *** Failed!+> Replay argument: "Just (200055706 2147483393,5)"+> *** Failed! (0ms) >-> * Tests:    3+> [TEST] Main:reverseReplay (Tutorial.hs:24)+> Falsifiable (after 1 test and 2 shrinks):+> [0,0]+> Replay argument: "Just (1060394807 2147483396,2)"+> *** Failed! (0ms)+>+> * Tests:    4 > * Passed:   1 > * Pending:  0-> * Failures: 2+> * Failures: 3 > * Errors:   0 > > * Failures:->   * Main:nonEmpty (Tutorial.hs:17)+>   * Main:reverseReplay (Tutorial.hs:24) >   * Main:reverse (Tutorial.hs:22)+>   * Main:nonEmpty (Tutorial.hs:17)+>+> Total execution time: 4ms  (To check only specific tests, you can pass commandline arguments to the program: the HTF then runs only those tests whose name@@ -164,24 +174,26 @@ desired result:  > [TEST] Main:nonEmpty (Tutorial.hs:17)-> +++ OK+> +++ OK (0ms) > > [TEST] Main:empty (Tutorial.hs:19)-> +++ OK+> +++ OK (0ms) > > [TEST] Main:reverse (Tutorial.hs:22) > Passed 100 tests.-> +++ OK+> +++ OK (20ms) > > [TEST] Main:reverseReplay (Tutorial.hs:24) > Passed 100 tests.-> +++ OK+> +++ OK (4ms) > > * Tests:    4 > * Passed:   4 > * Pending:  0 > * Failures: 0 > * Errors:   0+>+> Total execution time: 28ms  The HTF also allows the definition of black box tests. Essentially, black box tests allow you to verify that the output of your program matches your expectations.@@ -253,11 +265,49 @@ module Main where  import Test.Framework+import Test.Framework.BlackBoxTest import {-@ HTF_TESTS @-} MyPkg.A import {-@ HTF_TESTS @-} MyPkg.B  main = htfMain htf_importedTests @++-}++-- * Machine-readable output++{- |++For better integration with your testing environment, HTF provides the ability to produce+machine-readable output in JSON format. Here is a short example how the JSON output looks like,+for details see "Test.Framework.JsonOutput":+++> {"test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"type":"test-start"}+> ;;+> {"result":"pass","message":"","test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"type":"test-start"}+> ;;+> {"result":"pass","message":"","test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"type":"test-start"}+> ;;+> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"wallTime":19,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"type":"test-start"}+> ;;+> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"wallTime":4,"type":"test-end","location":null}+> ;;+> {"failures":0,"passed":4,"pending":0,"wallTime":39,"errors":0,"type":"test-results"}+> ;;++Machine-readable ouput is requested by the @--json@ flag. You can specify a dedicated output file+using the @--output-file=@ option. On some platforms (e.g. Windows) it might not be possible to read+from the output file while the tests are running (due to file-locking). In this case, you might want+to use the @--split@ option. With this option, HTF writes each JSON message to a separate ouput file.+The name of the output file is derived from the name given with the @--output-file=@ flag by+appending an index (starting at 0) that is incremented for every message.  -} 

@@ -21,6 +21,7 @@  import System.Directory import Data.Char+import System.Time hiding (diffClockTimes)  infixr 6 </> @@ -130,3 +131,21 @@  strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- Measures execution time of the given IO action in milliseconds+measure :: IO a -> IO (a, Int)+measure ma =+    do t0 <- getClockTime+       a <- ma+       t1 <- a `seq` getClockTime+       let diffMicro = t1 `diffClockTimes` t0+       return (a, fromInteger (diffMicro `div` 1000))++diffClockTimes :: ClockTime -> ClockTime -> Integer+diffClockTimes (TOD s1 p1) (TOD s0 p0) =+    (picoseconds p1 + seconds s1) -+    (picoseconds p0 + seconds s0)+    where+      -- bring all into microseconds+      picoseconds i = i `div` (1000 * 1000)+      seconds i = i * 1000000

@@ -0,0 +1,27 @@+#!/bin/bash++compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal  | tr -d ,)++for x in $compilers+do+    switch-ghc $x > /dev/null+    ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g')+    if [ "$x" != "$ghc_version" ]+    then+        echo "Could not switch to GHC version $x as requested, version is now $ghc_version"+        exit 1+    fi+    echo "Running tests for GHC version $ghc_version"+    ./run-all-tests.sh+    ecode=$?+    if [ $ecode -eq 0 ]+    then+        result="ok"+    else+        result="FAIL"+    fi+    RESULT="$RESULT\nResult for GHC version $ghc_version: $result"+done++echo+echo -e $RESULT

@@ -0,0 +1,22 @@+#!/bin/bash++set -e++cabal configure --enable-tests+cabal build+cabal test+cabal install++cd tests+mkdir -p dist/build/htfpp+cp ../dist/build/htfpp/htfpp dist/build/htfpp+cabal configure --enable-tests+cabal build+cabal test++cd ../sample+mkdir -p dist/build/htfpp+cp ../dist/build/htfpp/htfpp dist/build/htfpp+cabal configure --enable-tests+cabal build+cabal test

@@ -0,0 +1,30 @@+Copyright (c) 2012, Stefan Wehr++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Stefan Wehr nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,34 @@+module Main where++-- A simple main program. The program reads the contents of the+-- given input file, checks whether the content is a number, and+-- then ouputs the results of apply funA and funB to this number.++import MyPkg.A+import MyPkg.B++import Test.Framework+import System.Environment (getArgs)+import System.Exit+import System.IO++main =+    do args <- getArgs+       case args of+         ["-h"] -> usage+         ["--help"] -> usage+         [file] -> doWork file+         _ -> usage+    where+      usage =+          do hPutStrLn stderr "Usage: sample [-h|--help] FILE"+             exitWith (ExitFailure 1)+      doWork file =+          do s <- readFile file+             case reads s of+               [(n, "")] ->+                   do putStrLn $ show (funA n)+                      putStrLn $ show (funB n)+                      exitWith ExitSuccess+               _ -> do hPutStrLn stderr "invalid input"+                       exitWith (ExitFailure 1)

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module MyPkg.A (funA, htf_thisModulesTests) where++import Test.Framework++funA :: Int -> Int+funA x = x + 1++test_funA1 = assertEqual (funA 41) 42++test_funA2 = assertEqual (funA 2) 3

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module MyPkg.B (funB, htf_thisModulesTests) where++import Test.Framework++funB :: Int -> Int+funB x = x * 2++test_funB1 = assertEqual (funB 21) 42++test_funB2 = assertEqual (funB 0) 0

@@ -0,0 +1,12 @@+A very simple and trivial sample project showing how to use HTF,+the Haskell Test Framework (https://github.com/skogsbaer/HTF/).++Usage:++$ cabal configure --enable-tests+$ cabal build+$ cabal test++To execute the tests directly, run++$ dist/build/sample-tests/sample-tests

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++-- The main test program.++import Test.Framework+import Test.Framework.BlackBoxTest+import {-@ HTF_TESTS @-} MyPkg.A+import {-@ HTF_TESTS @-} MyPkg.B++main =+    do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs+       htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts])

@@ -0,0 +1,1 @@+Fail

@@ -0,0 +1,1 @@+invalid input

@@ -0,0 +1,1 @@+hello world

@@ -0,0 +1,1 @@+42

@@ -0,0 +1,2 @@+43+84

@@ -0,0 +1,24 @@+name:                sample-HTF+version:             0.1.0.0+synopsis:            Sample project showing how to use HTF+homepage:            https://github.com/skogsbaer/HTF/+license:             BSD3+license-file:        LICENSE+author:              Stefan Wehr+maintainer:          mail@stefanwehr.de+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable sample+  main-is:           Main.hs+  other-modules:     MyPkg.A MyPkg.B+  build-depends:     base, HTF == 0.10.*+  default-language:  Haskell2010++test-suite sample-tests+  type:              exitcode-stdio-1.0+  main-is:           TestMain.hs+  other-modules:     MyPkg.A MyPkg.B+  build-depends:     base, HTF == 0.10.*+  default-language:  Haskell2010

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# LANGUAGE CPP #-}++module Foo.A where++import Test.Framework++#include "test.h"++test_a =+    assertEqual x y

@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}++module Foo.B (htf_thisModulesTests) where++import qualified Test.Framework as HTF++test_b = assertEqual 1 1

@@ -0,0 +1,6 @@++x :: Int+x = 1++y :: Int+y = 2

@@ -0,0 +1,229 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+--+-- Copyright (c) 2005,2010   Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++import Test.Framework+import Test.Framework.TestManager+import Test.Framework.BlackBoxTest++import System.Environment+import System.Directory+import System.FilePath+import System.Process+import System.Exit+import System.IO+import System.IO.Temp+import Control.Exception+import qualified Data.HashMap.Strict as M+import qualified Data.Aeson as J+import Data.Aeson ( (.=) )+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC+import Data.Maybe+import qualified Data.Text as T+import qualified Text.Regex as R+import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible+import {-@ HTF_TESTS @-} qualified Foo.A as A+import {-@ HTF_TESTS @-} Foo.B++data T = A | B+       deriving Eq++{-+stringGap = "hello \+            \world!"+-}+stringGap = "hello world!"++handleExc :: a -> SomeException -> a+handleExc x _ = x++test_assertFailure =+    assertFailure "I'm a failure"++test_stringGap = assertEqual stringGap "hello world!"++test_assertEqual = assertEqual 1 2++test_assertEqualV = assertEqualVerbose "blub" 1 2++test_assertEqualNoShow = assertEqualNoShow A B++test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2]++test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1]++test_assertNotEmpty = assertNotEmpty []++test_assertEmpty = assertEmpty [1]++test_assertThrows = assertThrows (return () :: IO ()) (handleExc True)++test_assertThrows' = assertThrows (error "ERROR") (handleExc False)++test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False)++test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True)++test_someError = error "Bart Simpson!!"++test_pendingTest = unitTestPending "This test is pending"++test_subAssert = subAssert anotherSub+    where+      anotherSub = subAssertVerbose "I'm another sub" (assertNegative 42)+      assertNegative n = assertBool (n < 0)++data Expr = PlusExpr Expr Expr+          | MultExpr Expr Expr+          | Literal Int+          | Variable String+            deriving (Eq, Show)++test_diff =+    assertEqual (mkExpr 1) (mkExpr 2)+    where+      mkExpr i =+          PlusExpr (PlusExpr (MultExpr (PlusExpr (Variable "foo")+                                                     (MultExpr (Literal 42) (Variable "bar")))+                                       (PlusExpr (Literal i) (Literal 2)))+                             (Literal 581))+                   (Variable "egg")++prop_ok :: [Int] -> Property+prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs))++prop_fail :: [Int] -> Bool+prop_fail xs = xs == (reverse xs)++prop_pendingProp :: Int -> Bool+prop_pendingProp x = qcPending "This property is pending" (x == 0)++prop_exhaust = False ==> True++prop_error :: Bool+prop_error = error "Lisa"++changeArgs args = args { maxSuccess = 1 }++prop_ok' = withQCArgs (\a -> a { maxSuccess = 1}) $+                     \xs -> classify (null xs) "trivial" $+                            (xs::[Int]) == (reverse (reverse xs))++prop_fail' =+    withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop+    where prop xs = xs == (reverse xs)+              where types = xs::[Int]++prop_error' :: TestableWithQCArgs+prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool)++checkOutput output =+    do bsl <- BSL.readFile output+       let jsons = map (fromJust . J.decode) (splitJson bsl)+       check jsons (J.object ["type" .= J.String "test-results"])+                   (J.object ["failures" .= J.toJSON (30::Int)+                             ,"passed" .= J.toJSON (12::Int)+                             ,"pending" .= J.toJSON (2::Int)+                             ,"errors" .= J.toJSON (1::Int)])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Main:diff"]])+                   (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs$"+                                                                         ,"line" .= J.toJSON (101::Int)]]+                             ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"+                                                     ,"line" .= J.toJSON (102::Int)]])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]])+                   (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs$"+                                                                         ,"line" .= J.toJSON (10::Int)]]+                             ,"location" .= J.object ["file" .= J.String "./Foo/A.hs"+                                                     ,"line" .= J.toJSON (11::Int)]])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Main:subAssert"]])+                   (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null+                                                              ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"+                                                                                      ,"line" .= J.toJSON (90::Int)]]+                                                    ,J.object ["message" .= J.String "I'm another sub"+                                                              ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"+                                                                                      ,"line" .= J.toJSON (92::Int)]]]])+    where+      check jsons pred assert =+          case filter (\j -> matches j pred) jsons of+            [json] ->+                if not (matches json assert)+                   then error ("Predicate " ++ show pred ++ " match JSON " ++ show json ++ ", but assertion " +++                               show assert ++ " not satisfied")+                   else return ()+            l -> error ("not exactly one JSON matches predicate " ++ show pred ++ " but " ++ show l)+      matches :: J.Value -> J.Value -> Bool+      matches json pred =+          case (json, pred) of+            (J.Object objJson, J.Object objPred) ->+                M.foldrWithKey (\k vPred b ->+                                    b && case M.lookup k objJson of+                                           Just vJson -> matches vJson vPred+                                           Nothing -> False)+                               True objPred+            (J.String strJson, J.String strPred) ->+                regexMatches (mkRegex strPred) strJson+            (arrJson@(J.Array _), arrPred@(J.Array _)) ->+                let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson+                    J.Success (listPred :: [J.Value]) = J.fromJSON arrPred+                in length listJson == length listPred &&+                   all (\(x, y) -> matches x y) (zip listJson listPred)+            _ -> json == pred+      regexMatches r s = isJust $ R.matchRegex r (T.unpack s)+      mkRegex s = R.mkRegexWithOpts (T.unpack s) True False+      splitJson bsl =+          if BSL.null bsl+             then []+             else case BSL.span (/= 10) bsl of+                    (start, rest) ->+                        if BSLC.pack "\n;;\n" `BSL.isPrefixOf` rest+                           then start : splitJson (BSL.drop 4 rest)+                           else case splitJson rest of+                                  [] -> error "invalid json output from HTF"+                                  (x:xs) -> (start `BSL.append` x : xs)++main =+    do args <- getArgs+       b <- doesDirectoryExist "tests/bbt"+       let dirPrefix = if b then "tests" else ""+       bbts <- blackBoxTests (dirPrefix </> "bbt") (dirPrefix </> "./run-bbt.sh") ".x"+                 (defaultBBTArgs { bbtArgs_verbose = False })+       let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests+       case args of+         "--interactive":rest ->+             do ecode <- runTestWithArgs rest tests+                case ecode of+                  ExitFailure _ -> return ()+                  _ -> fail ("unexpected exit code: " ++ show ecode)+         _ ->+             do withSystemTempFile "HTF-out" $ \outFile h ->+                  do hClose h+                     ecode <- runTestWithArgs ["--json", "--output-file=" ++ outFile] tests+                     case ecode of+                       ExitFailure _ -> checkOutput outFile+                       _ -> fail ("unexpected exit code: " ++ show ecode)+                     `onException` (do s <- readFile outFile+                                       hPutStrLn stderr s)+                ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")+                exitWith ecode

@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp -optF --hunit #-}+module TestHTFHunitBackwardsCompatible where++import Test.Framework++test_1 = do assertEqual "1 == 2" 1 2+            assertEqualHTF 1 1++test_2 = do assertJust "foo" (Just 1)+            assertJustHTF (Just 1)

@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+import System.Environment ( getArgs )+import System.Exit ( exitWith )+import Test.Framework++{-+myReverse :: [a] -> [a]+myReverse [] = []+myReverse [x] = [x]+myReverse (x:xs) = myReverse xs+-}++myReverse :: [a] -> [a]+myReverse [] = []+myReverse (x:xs) = myReverse xs ++ [x]++test_nonEmpty = do assertEqual [1] (myReverse [1])+                   assertEqual [3,2,1] (myReverse [1,2,3])+test_empty = assertEqual ([] :: [Int]) (myReverse [])++prop_reverse :: [Int] -> Bool+prop_reverse xs = xs == (myReverse (myReverse xs))++prop_reverseReplay =+  withQCArgs (\a -> a { replay = read "Just (1060394807 2147483396,2)" })+  prop_reverse++main = htfMain htf_thisModulesTests

@@ -0,0 +1,1 @@+Skip

@@ -0,0 +1,1 @@+Verbose

@@ -0,0 +1,1 @@+x

@@ -0,0 +1,1 @@+Fail

@@ -0,0 +1,1 @@+x

@@ -0,0 +1,1 @@+x

@@ -0,0 +1,1 @@+y

@@ -0,0 +1,1 @@+x

@@ -0,0 +1,1 @@+1

@@ -0,0 +1,1 @@+1

@@ -0,0 +1,1 @@+y

@@ -0,0 +1,1 @@+x

@@ -0,0 +1,5 @@+1+2+3+4+5

@@ -0,0 +1,5 @@+1+2+3+4+5

@@ -0,0 +1,3 @@+-- 1+-- 2+-- 3

@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}++import Test.Framework+#include "Foo.h"++foo :: Int -> Int+foo i = i + "Stefan"++main :: IO ()+main = return ()

@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}++import Test.Framework+#include "Foo.h"+foo :: Int -> Int+foo i = i + "Stefan"++main :: IO ()+main = return ()

@@ -0,0 +1,25 @@+#!/bin/bash++cd "$(dirname $0)"++FLAGS="-hide-all-packages -package HTF -package base --make"+lineno=7++function check()+{+    grep_ecode="$1"+    test="$2"+    if [ "$grep_ecode" != "0" ]+    then+        echo "Compile error for test $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"+        exit 1+    fi+}++ghc $FLAGS Test1.hs 2>&1 | grep Test1.hs:$lineno+grep_ecode=${PIPESTATUS[1]}+check $grep_ecode 1++ghc $FLAGS Test2.hs 2>&1 | grep Test2.hs:$lineno+grep_ecode=${PIPESTATUS[1]}+check $grep_ecode 2

@@ -0,0 +1,66 @@+#!/bin/sh++case "$1" in+  *bbt/should_fail/ok1.x)+    exit 1+  ;;+  *bbt/should_fail/ok2.x)+    echo x +    echo y 1>&2+    exit 2+  ;;+  *bbt/should_fail/not_ok_because_succeeds.x)+    exit 0+  ;;+  *bbt/should_fail/not_ok_because_stdout1.x)+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stdout2.x)+    echo x+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stderr1.x)+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stderr2.x)+    echo x 1>&2+    exit 1+  ;;++  *bbt/should_pass/ok1.x)+    exit 0+  ;;+  *bbt/should_pass/ok2.x)+    echo x +    echo y 1>&2+    exit 0+  ;;+  *bbt/should_pass/stdin_ok.x)+    cat+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_fails.x)+    exit 6+  ;;+  *bbt/should_pass/not_ok_because_stdout1.x)+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stdout2.x)+    echo x+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stderr1.x)+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stderr2.x)+    echo x 1>&2+    exit 0+  ;;+  *bbt/Verbose/not_ok_because_stdout1.x)+    exit 0+  ;;+  *)+    echo "$0: Illegal failname: <$1>"+    exit 127+  ;;+esac

@@ -0,0 +1,15 @@+#!/bin/bash++if [ "$1" != "--no-clean" ]+then+    cabal clean || exit 1+fi+mkdir -p dist/build/htfpp || exit 1+cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1+cabal configure || exit 1+cabal build || exit 1+dist/build/test/test || exit 1+echo "Tests ok"++./compile-errors/run-tests.sh || exit 1+echo "Line numbers in compile errors ok"

@@ -0,0 +1,25 @@+Name:          test-HTF+Version:       0.1+Cabal-Version: >= 1.10+Build-type:    Simple++Executable test+  Main-is: TestHTF.hs+  Build-depends:     base >= 4,+                     HTF,+                     bytestring >= 0.9,+                     aeson >= 0.6,+                     unordered-containers >= 0.2,+                     temporary >= 1.1,+                     text >= 0.11,+                     directory >= 1.0,+                     filepath >= 1.1,+                     process >= 1.0,+                     regex-compat >= 0.92+  Default-language:  Haskell2010++Test-Suite tutorial+  Type:              exitcode-stdio-1.0+  Main-is:           Tutorial.hs+  Build-depends:     base >= 4, HTF == 0.10.*+  Default-language:  Haskell2010