packages feed

HTF 0.10.0.7 → 0.15.0.2

raw patch · 77 files changed

Files

ChangeLog view
@@ -1,3 +1,131 @@+* 0.15.0.1+  - Fix build for mtl-2.3 #118++* 0.15.0.0+  - Remove macros for assertions, location information is now provided+    via HasCallStack. For most users, this change should be backwards compatible.+    However, if you imported Test.Framework qualified, then all assert macros+    where previously in scope unqualified, through macros. In this case, you need to+    import Test.Framework unqualified or qualify all uses of assert macros.+  - The modules Test.Framework.CmdlineOptions, Test.Framework.Colors,+    and Test.Framework.TestReporter are no longer exposed. I don't think that+    anyone depends on these internal modules. Let me know I am wrong.++* 0.14.0.7 (2022-03-03)+  - several upper bounds for packages+  - minor improvements++* 0.14.0.5 (2021-01-26)+  - make sure htfpp is available before running the tests++* 0.14.0.4 (2021-01-26)+  - fix #99+  - hopefully fix #97++* 0.14.0.2 (2019-11-27)+  - use haskell-src from hackage++* 0.14.0.1 (2019-11-27)+  - find cpphs++* 0.14.0.0 (2019-11-26)+  - support for GHC 8.8+  - fix for performance problem with long strings+    https://github.com/skogsbaer/HTF/issues/85++* 0.13.2.5 (2018-11-06)+  - fix build problem with quickcheck:+        https://github.com/skogsbaer/HTF/issues/70+  - fix some compiler warnings+  - support for GHC 8.6++* 0.13.2.4 (2018-03-31)+  - fix build for ghc 8.4++* 0.13.2.{0,1,2} (2017-08-06)+  - various build and documentation fixes and improvements++* 0.13.1.0 (2015-08-21)+  - resolved compile error with HUnit == 1.3.0.0++* 0.13.0.0 (2015-08-21)+  - use cpphs for lexing (fixes many bugs related to lexing)++* 0.12.2.4 (2015-03-22)+  - fixed bug that caused double quoted strings to appear in the output+    of error messages produced by assertEqual and co.++* 0.12.2.3 (2014-10-27)+  - fixed another lexing bug (issue #45)++* 0.12.2.2 (2014-10-22)+  - fixed lexing bug (some source files were not parsed properly)+  - fixed bug where wrong module name was generated+  - fixed source distribution (not all files were included)++* 0.12.2.1 (2014-10-19)+  - fixed compile error with QuickCheck == 2.6++* 0.12.2.0 (2014-10-18)+  - drop dependency on haskell-src-exts (took too long to compile)+  - only color error counts if they are > 0 (thanks to Matthias Fischmann)++* 0.12.1.0 (2014-09-16)+  - support for haskell-src-exts version 1.16+  - Functor and Applicative instances for AssertBool++* 0.12.0.0 (2014-07-14)+  - support for several new commandline options:+      --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+      --fail-fast                 Fail and abort test run as soon as the first test fails.+      --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+      --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+      --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+      --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+      --timeout-is-success        Do not regard a test timeout as an error.+  - potential backward incompatibility: JSON output format changed,+    several new keys were introduced.++* 0.11.3.4 (2014-04-10)+  - completed changelog++* 0.11.3.2 (2014-04-10)+  - fix compile error (issue #34)++* 0.11.3.1 (2014-04-09)+  - fix compile error under GHC 7.4 (fixes #33)++* 0.11.3.0 (2014-04-08)+  - support for generic assertions+  - fixed setDefaultArgs und withQCArgs for quickcheck tests (fixes #30)+  - added assertElem assertion (fixes #27)+  - don't output warning if fallback parsers kick (fixes #32)++* 0.11.2.1 (2014-02-10)+  - fixed compile error under ghc 7.4++* 0.11.2 (2014-02-07)+  - fall-back to poor men's parser if parsing with haskell-src-exts fails++* 0.11.1.0 (2014-01-22)+  - htfpp now lexes input files as text, not as haskell src. This allows+    proper treatment of TH single quotes (fix for #26)+  - more general type for subAssert++* 0.11.0.1 (2013-09-03)+  - support for containers-0.4.* (thanks to M. Snoyman)++* 0.11.0.0 (2013-08-31)+  - fallback to pure Haskell diff if no diff binary found (thanks JP Moresmau)+  - use cabal test feature (thanks Tom Brow)+  - parallel execution of tests+  - bugfix: enable DoAndIfThenElse+  - bugfix: use default fixities for all operators+  - two new assertions for dealing with exceptions: assertThrowsM and assertThrowsSomeM++* 0.10.0.7 (2012-12-07)+  - fixed problem building against Diff 0.1.3+ * 0.10.0.6 (2012-12-06)   - support for Diff 0.2.
HTF.cabal view
@@ -1,10 +1,11 @@+Cabal-Version:    2.0 Name:             HTF-Version:          0.10.0.7-License:          LGPL+Version:          0.15.0.2+License:          LGPL-2.1 License-File:     LICENSE-Copyright:        (c) 2005-2012 Stefan Wehr-Author:           Stefan Wehr <wehr@factisresearch.com>-Maintainer:       Stefan Wehr <wehr@factisresearch.com>+Copyright:        (c) 2005-2024 Stefan Wehr+Author:           Stefan Wehr+Maintainer:       Stefan Wehr Stability:        Beta Category:         Testing Synopsis:         The Haskell Test Framework@@ -12,87 +13,42 @@ Bug-Reports:      https://github.com/skogsbaer/HTF/issues Description: -    The Haskell Test Framework (/HTF/ for short) lets you define unit-    tests (<http://hunit.sourceforge.net>), QuickCheck properties-    (<http://www.cs.chalmers.se/~rjmh/QuickCheck/>), and black box-    tests in an easy and convenient way. HTF uses a custom-    preprocessor that collects test definitions automatically.-    Furthermore, the preprocessor allows HTF to report failing-    test cases with exact file name and line number information.-    Additionally, HTF tries to produce highly readable output-    for failing tests: for example, it colors and pretty prints expected and-    actual results and provides a diff between the two values.--    .--    The documentation of the "Test.Framework.Tutorial" module-    provides a tutorial for HTF. There is also a slightly out-dated-    blog article (<http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html>)-    demonstrating HTF's coloring, pretty-printing and diff functionality.--    .--    /HEADS UP, backwards incomatibility with prior versions:/--    .--    In version 0.10.0.0, the following changes could break code compiled against version 0.9.*:--    .--    * "Test.Framework" now longer exports all of "Test.Framework.TestManager" and-      "Test.Framework.BlackBoxTest". For modules that only define tests, no changes-      should be necessary. However, you likely need to adjust your test runner-      module by importing "Test.Framework.TestManager" and possibly "Test.Framework.BlackBoxTest".--    .--    * Some reorganization in "Test.Framework.TestManager" and related modules, introduction-      of "Test.Framework.TestTypes". Usually, your code should not be affected-      by these changes.--    .-    Starting with version 0.9.0.0, HTF uses a new strategy-    for collecting the testcases defined in your project-    (see "Test.Framework.Tutorial" for a description of this strategy).-    If you used version 0.8.* or earlier of HTF, this /will break your build!/-    However, it's rather easy to bring you project in line with the new HTF-    version. Here are the steps that will most likely resolve-    your backwards incompatibility problems:--    .--    * If a module exports the @allHTFTests@ symbol, this export must-      be changed to @htf_thisModulesTests@.+    The Haskell Test Framework (/HTF/ for short) lets you define and organize unit tests,+    QuickCheck properties,+    and black box tests in an+    easy and convenient way. HTF uses a custom preprocessor that collects+    test definitions automatically.      . -    * If an import declaration of some module hides the @allHTFTests@-      symbol, you can simply remove the hiding clause for @allHTFTests@.+    HTF produces highly readable output+    for failing test cases: it provides exact file name and line number+    information,+    it colors and pretty prints expected and+    actual results, and it displays a diff highlighting the mismatching parts.      . -    * If a module collects and executes tests from several other modules,-      the collecting module has to be changed as follows: add-      @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ to the top-      of the collecting module, import-      the other modules with the @&#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d;@-      annotation, use the symbol @htf_importedTests@ for referencing-      the imported tests. See "Test.Framework.Tutorial" for details.+    The documentation of the "Test.Framework.Tutorial" module+    provides a tutorial for HTF. The /sample/ directory in+    the HTF repo provides a good starting point for+    a project using HTF. -Tested-With:-                  GHC==7.0.4,-                  GHC==7.2.1,-                  GHC==7.4.2,-                  GHC==7.6.1 Build-Type:       Simple-Cabal-Version:    >= 1.10+ Extra-Source-Files:   README.md-  TODO.org   ChangeLog+  stack.yaml+  stack-ghc-8.2.yaml+  stack-ghc-8.4.yaml+  stack-ghc-8.6.yaml+  stack-ghc-8.8.yaml+  stack-ghc-8.10.yaml+  stack-ghc-9.0.yaml+  stack-ghc-9.2.yaml+  stack-ghc-9.4.yaml   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@@ -108,8 +64,6 @@   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@@ -129,82 +83,152 @@   sample/bbt-dir/should-fail/z.num   sample/bbt-dir/should-pass/x.num   sample/bbt-dir/should-pass/x.out-  run-all-tests-for-all-compilers.sh-  run-all-tests.sh+  scripts/local-htfpp+  scripts/dist.sh+  scripts/check.sh+  scripts/run-sample+  scripts/prepare++tested-with:+  GHC == 9.4.4+  GHC == 9.2.6+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+ Source-Repository head   Type:           git   Location:       http://github.com/skogsbaer/HTF.git  Executable htfpp   Main-Is:          HTFPP.hs-  Build-Depends:    cpphs >= 1.12,-                    haskell-src-exts >= 1.11,-                    old-time >= 1.0,+  Build-Depends:    HUnit,+                    array,+                    base >= 4.10 && < 5,+                    cpphs >= 1.19,                     directory >= 1.0,-                    base == 4.*+                    mtl >= 1.1,+                    old-time >= 1.0,+                    random >= 1.0,+                    text >= 0.11,+                    HTF+  Build-tool-depends: cpphs:cpphs >= 1.19   Other-Modules:+    Paths_HTF+    Test.Framework.Location     Test.Framework.Preprocessor-    Test.Framework.HaskellParser+  Autogen-modules:+    Paths_HTF   Default-language:  Haskell2010  Library-  Build-Depends:    HUnit >= 1.2.5,+  Build-Depends:    Diff >= 0.3,+                    HUnit >= 1.2.5,                     QuickCheck >= 2.3,-                    base == 4.*,-                    random >= 1.0,-                    containers >= 0.3,-                    process >= 1.0,+                    aeson >= 0.11,+                    array,+                    base >= 4.10 && < 5,+                    base64-bytestring,+                    bytestring >= 0.9,+                    containers >= 0.5,+                    cpphs >= 1.19,+                    haskell-src,                     directory >= 1.0,-                    mtl >= 1.1 && < 2.2,-                    monad-control >= 0.3,                     lifted-base >= 0.1,+                    monad-control >= 0.3,+                    mtl >= 1.1,+                    old-time >= 1.0,                     pretty >= 1.0,-                    Diff >= 0.1.3,-                    bytestring >= 0.9,+                    process >= 1.0,+                    random >= 1.0,                     regex-compat >= 0.92,-                    haskell-src-exts >= 1.11,-                    aeson >= 0.6,                     text >= 0.11,-                    old-time >= 1.0+                    time,+                    vector,+                    xmlgen >= 0.6   if !os(windows)     Build-Depends:   unix >= 2.4   Exposed-Modules:     Test.Framework+    Test.Framework.AssertM+    Test.Framework.BlackBoxTest     Test.Framework.HUnitWrapper+    Test.Framework.History+    Test.Framework.JsonOutput+    Test.Framework.Location+    Test.Framework.Preprocessor+    Test.Framework.Pretty+    Test.Framework.PrettyHaskell+    Test.Framework.QuickCheckWrapper+    Test.Framework.TestInterface     Test.Framework.TestManager     Test.Framework.TestTypes-    Test.Framework.TestReporter-    Test.Framework.CmdlineOptions-    Test.Framework.QuickCheckWrapper-    Test.Framework.BlackBoxTest-    Test.Framework.Location+    Test.Framework.ThreadPool     Test.Framework.Tutorial-    Test.Framework.Pretty-    Test.Framework.JsonOutput+    Test.Framework.XmlOutput   Other-Modules:-    Test.Framework.TestManagerInternal-    Test.Framework.Utils+    Paths_HTF+    Test.Framework.CmdlineOptions     Test.Framework.Colors     Test.Framework.Diff     Test.Framework.Process+    Test.Framework.TestReporter+    Test.Framework.Utils+  Autogen-modules:+    Paths_HTF+  Build-tool-depends: cpphs:cpphs >= 1.19   Default-language:  Haskell2010-  -- Ghc-Options: -fwarn-unused-imports -fwarn-unused-binds+  Ghc-Options:+    -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+    -Wcompat +Test-Suite MiscTests+  Main-is:           MiscTest.hs+  Type:              exitcode-stdio-1.0+  Hs-Source-Dirs:    tests+  Build-depends:     HTF,+                     HUnit,+                     base >= 4.10 && < 5,+                     mtl,+                     random+  Build-tool-depends: HTF:htfpp+  Default-language:  Haskell2010+ Test-Suite TestHTF   Main-is:           TestHTF.hs-  Hs-Source-Dirs:    tests+  Hs-Source-Dirs:    tests, tests/real-bbt   Type:              exitcode-stdio-1.0-  Build-depends:     base == 4.*,+  Build-depends:     HTF,+                     aeson >= 0.11,+                     aeson-pretty,+                     base >= 4.10 && < 5,                      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,+                     filepath >= 1.1,+                     process >= 1.0,+                     random,                      regex-compat >= 0.92,-                     HTF+                     template-haskell,+                     temporary >= 1.1,+                     text >= 0.11,+                     unordered-containers >= 0.2+  Build-tool-depends: HTF:htfpp   Default-language:  Haskell2010   Other-Modules:-    Foo.A, Foo.B, TestHTFHunitBackwardsCompatible+    Foo.A, Foo.B, FailFast, MaxCurTime,+    MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi,+    Tutorial, Repeat++Test-Suite TestThreadPools+  Main-is:           ThreadPoolTest.hs+  Type:              exitcode-stdio-1.0+  Hs-Source-Dirs:    tests+  Build-depends:     HTF,+                     base >= 4.10 && < 5,+                     mtl,+                     random+  Build-tool-depends: HTF:htfpp+  Default-language:  Haskell2010
HTFPP.hs view
@@ -35,7 +35,7 @@ usage =     hPutStrLn stderr       ("Preprocessor for the Haskell Test Framework\n\n" ++-       "Usage: " ++ progName ++ " [--hunit] [FILE1 [FILE2 [FILE3]]]\n\n" +++       "Usage: " ++ progName ++ " [--debug|--version|--literate-tex] [FILE1 [FILE2 [FILE3]]]\n\n" ++        "* If no argument is given, input is read from stdin and\n" ++        "  output is written to stdout.\n" ++        "* If only FILE1 is given, input is read from this file\n" ++@@ -45,13 +45,14 @@        "* If FILE1, FILE2, and FILE3 are given, input is read\n" ++        "  from FILE2, output is written to FILE3, and\n" ++        "  FILE1 serves as the original input filename.\n\n" ++-       "The `--hunit' flag causes assert-like macros to be expanded in a way\n" ++-       "that is backwards-compatible with the corresponding functions of the\n" ++-       "HUnit library.")+       "The `--hunit' flag has been deprecated starting with version 0.15." +++       "The `--literate-tex` flag causes the additional generated code to be wrapped\n" +++       "in TeX-style literate code blocks.")  outputVersion :: IO () outputVersion =     hPutStrLn stderr (showVersion Paths_HTF.version)+ saveOpenFile :: FilePath -> IOMode -> IO Handle saveOpenFile path mode =     openFile path mode `catch` exHandler@@ -72,10 +73,9 @@        when ("--version" `elem` args) $             do outputVersion                exitWith ExitSuccess-       let (restArgs, hunitBackwardsCompat) =-               case reverse args of-                 "--hunit":rrest -> (reverse rrest, True)-                 rrest -> (reverse rrest, False)+       let transformOpts = TransformOptions { debug = "--debug" `elem` args+                                            , literateTex = "--literate-tex" `elem` args }+           restArgs = flip filter args $ \x -> not $ x `elem` ["--hunit", "--debug", "--literate-tex"]        (origInputFilename, hIn, hOut) <-            case restArgs of              [] ->@@ -92,10 +92,11 @@                     h2 <- saveOpenFile file3 WriteMode                     return (file1, h1, h2)              _ ->-                 do usage+                 do hPutStrLn stderr ("Too many arguments: " ++ show restArgs)+                    usage                     exitWith (ExitFailure 1)        input <- hGetContents hIn-       output <- transform hunitBackwardsCompat origInputFilename input `catch`+       output <- transform transformOpts origInputFilename input `catch`                    (\ (e::SomeException) ->                         do hPutStrLn stderr (progName ++                                              ": unexpected exception: " ++
README.md view
@@ -1,36 +1,27 @@ # HTF - The Haskell Test Framework +[![Build Status](https://github.com/skogsbaer/HTF/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/skogsbaer/HTF/actions/workflows/haskell-ci.yml)+[![Hackage](https://img.shields.io/hackage/v/HTF.svg)](http://hackage.haskell.org/package/HTF)+ * Documentation:     http://hackage.haskell.org/package/HTF * Source Repository: https://github.com/skogsbaer/HTF/ * Issue tracker:     https://github.com/skogsbaer/HTF/issues?state=open * Author:            Stefan Wehr (http://www.stefanwehr.de)-* License: LGPL+* License:           LGPL  ## Summary -The Haskell Test Framework (HTF for short) lets you define unit tests-(http://hunit.sourceforge.net), QuickCheck properties-(http://www.cs.chalmers.se/~rjmh/QuickCheck/), and black box tests in an+The Haskell Test Framework (HTF for short) lets you define and organize unit tests+(http://hackage.haskell.org/package/HUnit), QuickCheck properties+(https://hackage.haskell.org/package/QuickCheck), and black box tests in an easy and convenient way. HTF uses a custom preprocessor that collects-test definitions automatically. Furthermore, the preprocessor allows-HTF to report failing test cases with exact file name and line number-information. Additionally, HTF tries to produce highly readable output-for failing tests: for example, it colors and pretty prints expected and-actual results and provides a diff between the two values.--Look [here](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html)-for a short tutorial on HTF. The following slightly out-dated-[blog article](http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html)-demonstrates HTF's coloring, pretty-printing and diff functionality.--## Installation instructions--* Install from http://hackage.haskell.org/ using `cabal install HTF`-* Install from source:+test definitions automatically. -        $ git clone git@github.com:skogsbaer/HTF.git-        $ cd HTF-        $ cabal install+HTF produces highly readable output+for failing test cases: it provides exact file name and line number+information,+it colors and pretty prints expected and+actual results, and it displays a diff highlighting the mismatching parts.  ## Getting started
− Setup.hs 
@@ -1,5 +0,0 @@-#!/usr/bin/runhaskell--import Distribution.Simple--main = defaultMain
− TODO.org 
@@ -1,11 +0,0 @@-* Relase 0.11-** Fallback parser-*** Use the lexer of haskell-src-exts-** Parallel test execution-*** Options --threads=[N] or -j [N]-*** Some test cannot be run in parallel--** Support for timeouts (--timeout=SECS)-** External interface for integrating other test frameworks-*** Support for Smallcheck and/or Lazy Smallcheck-*** Configuration file for htfpp
Test/Framework.hs view
@@ -1,11 +1,11 @@--- +-- -- Copyright (c) 2005,2009   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@@ -21,9 +21,11 @@ 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,+Test drivers should additionally import 'Test.Framework.TestManager' and, if needed, 'Test.Framework.BlackBoxTest'. +See "Test.Framework.Tutorial" for a description how to use HTF.+ -} module Test.Framework ( @@ -33,12 +35,17 @@   -- * Quickcheck   module Test.Framework.QuickCheckWrapper, TM.makeQuickCheckTest, +  -- * Generic assertions+  module Test.Framework.AssertM,+   -- * Organizing tests-  TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc+  TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest,+  TM.WrappableHTF(..)  ) where  import Test.Framework.HUnitWrapper import Test.Framework.QuickCheckWrapper+import Test.Framework.AssertM import qualified Test.Framework.TestManager as TM import qualified Test.Framework.Location as Loc
+ Test/Framework/AssertM.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}+--+-- Copyright (c) 2005-2022   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 'AssertM' monad, which allows you either to run assertions+as ordinary unit tests or to evaluate them as pure functions.++-}+module Test.Framework.AssertM (++    AssertM(..), AssertBool(..), boolValue, eitherValue++) where++import Control.Monad       (liftM, ap)+import GHC.Stack+import qualified Data.Text as T++import Test.Framework.TestInterface+import Test.Framework.Colors++-- | A typeclass for generic assertions.+class Monad m => AssertM m where+    genericAssertFailure :: HasCallStack => ColorString -> m a+    genericSubAssert :: HasCallStack => Maybe String -> m a -> m a++instance AssertM IO where+    genericAssertFailure s =+        failHTF (FullTestResult (mkHtfStack callStack) (Just s) (Just Fail))+    genericSubAssert mMsg action = subAssertHTF mMsg action++-- | Type for evaluating a generic assertion as a pure function.+data AssertBool a+    -- | Assertion passes successfully and yields the given value.+    = AssertOk a+    -- | Assertion fails with the given stack trace. In the stack trace, the outermost stackframe comes first.+    | AssertFailed HtfStack String+      deriving (Eq, Ord, Show, Read)++instance Functor AssertBool where+    fmap = liftM++instance Applicative AssertBool where+    pure  = AssertOk+    (<*>) = ap++instance Monad AssertBool where+    return = AssertOk+    AssertFailed stack msg >>= _ = AssertFailed stack msg+    AssertOk x >>= k = k x+#if !(MIN_VERSION_base(4,13,0))+    fail msg = AssertFailed emptyHtfStack msg+#endif++instance AssertM AssertBool where+    genericAssertFailure s =+        AssertFailed (mkHtfStack callStack) (T.unpack $ renderColorString s False)+    genericSubAssert subMsg action =+        case action of+          AssertOk x -> AssertOk x+          AssertFailed stack msg ->+              let ghcStack = callStack+              in AssertFailed (addCallerToSubAssertStack ghcStack stack subMsg) msg++-- | Evaluates a generic assertion to a 'Bool' value.+boolValue :: AssertBool a -> Bool+boolValue x =+    case x of+      AssertOk _ -> True+      AssertFailed _ _ -> False++-- | Evaluates a generic assertion to an 'Either' value. The result+--   is @Right x@ if the assertion passes and yields value @x@, otherwise+--   the result is @Left err@, where @err@ is an error message.+eitherValue :: AssertBool a -> Either String a+eitherValue x =+    case x of+      AssertOk z -> Right z+      AssertFailed stack msg -> Left (msg ++ "\n" ++ formatHtfStack stack)
Test/Framework/BlackBoxTest.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009,2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022   Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -45,28 +45,24 @@ import Prelude hiding ( catch ) #endif -import System.IO import System.Exit-import Control.Exception import System.Directory-import Data.List ( mapAccumL ) import qualified Data.Map as Map-import Control.Monad  import Test.Framework.Process+import Test.Framework.TestInterface import Test.Framework.TestManager-import Test.Framework.TestManagerInternal import Test.Framework.Utils  {- | The type of a function comparing the content of a file against a string, similar to the unix tool @diff@. The first parameter is the name of the file containing the-expected output. If this parameter is 'Nothing', then no output-is expected. The second parameter is the actual output produced.+expected output. If this parameter is 'Nothing', then output+should not be checked. The second parameter is the actual output produced. If the result is 'Nothing' then no difference was found. Otherwise, a 'Just' value contains a string explaining the-different.+difference. -} type Diff = Maybe FilePath -> String -> IO (Maybe String) @@ -74,8 +70,8 @@                        { bbtCfg_shouldFail  :: Bool                        , bbtCfg_cmd         :: String                        , bbtCfg_stdinFile   :: Maybe FilePath-                       , bbtCfg_stdoutFile  :: Maybe FilePath-                       , bbtCfg_stderrFile  :: Maybe FilePath+                       , bbtCfg_stdoutFile  :: Maybe FilePath -- ^ path to file holding expected output on stdout+                       , bbtCfg_stderrFile  :: Maybe FilePath -- ^ path to file holding expected output on stderr                        , bbtCfg_verbose     :: Bool                        -- functions for comparing output on stdout and stderr.                        , bbtCfg_stdoutCmp   :: Diff@@ -125,6 +121,9 @@ endOfOutput :: String -> String endOfOutput s = "[end of " ++ s ++ "]" +blackBoxTestFail :: String -> Assertion+blackBoxTestFail s = failHTF $ mkFullTestResult Fail (Just s)+ {- | Use a value of this datatype to customize various aspects of your black box tests.@@ -132,8 +131,8 @@ data BBTArgs = BBTArgs { bbtArgs_stdinSuffix    :: String -- ^ File extension for the file used as stdin.                        , bbtArgs_stdoutSuffix   :: String -- ^ File extension for the file specifying expected output on stdout.                        , bbtArgs_stderrSuffix   :: String -- ^ File extension for the file specifying expected output on stderr.-                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format.-                       , bbtArgs_verbose        :: Bool   -- ^ Ge verbose or not.+                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. Default: BBTArgs+                       , bbtArgs_verbose        :: Bool   -- ^ Be verbose or not.                        , bbtArgs_stdoutDiff     :: Diff   -- ^ Diff program for comparing output on stdout with the expected value.                        , bbtArgs_stderrDiff     :: Diff   -- ^ Diff program for comparing output on stderr with the expected value.                        }@@ -145,7 +144,7 @@ defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = \".in\"                          , bbtArgs_stdoutSuffix   = \".out\"                          , bbtArgs_stderrSuffix   = \".err\"-                         , bbtArgs_dynArgsName    = "BBTArgs"+                         , bbtArgs_dynArgsName    = \"BBTArgs\"                          , bbtArgs_stdoutDiff     = defaultDiff                          , bbtArgs_stderrDiff     = defaultDiff                          , bbtArgs_verbose        = False }@@ -166,24 +165,21 @@ -} defaultDiff :: Diff defaultDiff expectFile real =-    do mexe <- findExecutable "diff"-       let exe = case mexe of-                   Just p -> p-                   Nothing -> error ("diff command not in path")-       case expectFile of-         Nothing | null real -> return Nothing-                 | otherwise -> return $ Just ("no output expected, but " ++-                                               "given:\n" ++ real ++-                                               (endOfOutput "given output"))-         Just expect ->-             do (out, err, exitCode) <- popen exe ["-u", expect, "-"]-                                          (Just real)-                case exitCode of-                  ExitSuccess -> return Nothing       -- no difference-                  ExitFailure 1 ->                    -- files differ-                      return $ Just (out ++ (endOfOutput "diff output"))-                  ExitFailure i -> error ("diff command failed with exit " ++-                                          "code " ++ show i ++ ": " ++ err)+    case expectFile of+      Nothing -> return Nothing+      Just expect ->+          do mexe <- findExecutable "diff"+             let exe = case mexe of+                         Just p -> p+                         Nothing -> error ("diff command not in path")+             (out, err, exitCode) <- popen exe ["-u", expect, "-"]+                                        (Just real)+             case exitCode of+               ExitSuccess -> return Nothing       -- no difference+               ExitFailure 1 ->                    -- files differ+                   return $ Just (out ++ (endOfOutput "diff output"))+               ExitFailure i -> error ("diff command failed with exit " +++                                       "code " ++ show i ++ ": " ++ err)  {- | Collects all black box tests with the given file extension stored in a specific directory.@@ -198,17 +194,23 @@  Suppose that one of the @.num@ files is @bbt-dir\/should-pass\/x.num@. Running the corresponding 'Test' invokes-@dist\/build\/sample\/sample@ (the program under test) with @bbt-dir\/should-pass\/x.num@-as input file. If @bbt-dir\/should-pass\/x.num@ existed, its content+@dist\/build\/sample\/sample@ (the program under test)+with @bbt-dir\/should-pass\/x.num@ as the last commandline argument.+The other commandline arguments are taken from the flags specification given in the+file whose name is stored in the 'bbtArgs_dynArgsName' field of the 'BBTArgs' record+(see below, default is BBTArgs).++If @bbt-dir\/should-pass\/x.in@ existed, its content would be used as stdin. The tests succeeds if the exit code of the program is zero and the output on stdout and stderr matches the contents of @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively.+If @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@ do+not exist, then output is not checked. -The directory @bbt-dir\/should-fail@ contains the file @BBTArgs@. If this file-exists, then its content specifies various-arguments for the test run. The file defines the arguments separated by newlines.-Supported arguments:+The 'bbtArgs_dynArgsName' field of the 'BBTArgs' record specifies a filename+that contains some more configuration flags for the tests. The following+flags (separated by newlines) are supported:   [@Skip@] Skips all tests in the same directory as the argument file.
Test/Framework/CmdlineOptions.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} ----- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022   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@@ -31,27 +33,39 @@  import Test.Framework.TestReporter import Test.Framework.TestTypes-import Test.Framework.Colors+import Test.Framework.History import Test.Framework.Utils +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(a,b,c) 1+#endif+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding ( catch )+#endif+import Control.Exception+ import Data.Char (toLower) import Data.Maybe  import System.IO-+import System.Environment hiding (getEnv)+import System.Directory 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)+import System.Posix.Env #endif -#ifdef COMPILER_GHC+#ifdef __GLASGOW_HASKELL__ import GHC.Conc ( numCapabilities ) #endif +import qualified Data.ByteString as BS+import Control.Monad+ -- -- CmdlineOptions --@@ -62,12 +76,22 @@     , opts_filter :: TestFilter         -- ^ Run only tests matching this filter.     , opts_help :: Bool                 -- ^ If 'True', display a help message and exit.     , opts_negated :: [String]          -- ^ Regular expressions matching test names which should /not/ run.---    , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution (currently unused).+    , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.+    , opts_shuffle :: Bool              -- ^ If 'True', shuffle tests when running them in parallel. Default: 'False'     , opts_machineOutput :: Bool        -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format.+    , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format.     , opts_useColors :: Maybe Bool      -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors.     , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout     , opts_listTests :: Bool            -- ^ If 'True', lists all tests available and exits.     , opts_split :: Bool                -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile').+    , opts_historyFile :: Maybe FilePath -- ^ History file, default: @./.HTF/<ProgramName>.history@+    , opts_failFast :: Bool             -- ^ Fail and terminate test run as soon as the first test fails. Default: 'False'+    , opts_sortByPrevTime :: Bool       -- ^ Sort tests by their previous run times (ascending). Default: 'False'+    , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run.+    , opts_maxCurTimeMs :: Maybe Milliseconds  -- ^ Abort tests that run more than the given milliseconds.+    , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run.+    , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error.+    , opts_repeat :: Int                 -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.     }  {- |@@ -79,51 +103,111 @@     , opts_filter = const True     , opts_help = False     , opts_negated = []---    , opts_threads = Nothing+    , opts_threads = Nothing+    , opts_shuffle = False     , opts_machineOutput = False+    , opts_machineOutputXml = Nothing     , opts_useColors = Nothing     , opts_outputFile = Nothing     , opts_listTests = False     , opts_split = False+    , opts_historyFile = Nothing+    , opts_failFast = False+    , opts_sortByPrevTime = False+    , opts_maxPrevTimeMs = Nothing+    , opts_maxCurTimeMs = Nothing+    , opts_prevFactor = Nothing+    , opts_timeoutIsSuccess = False+    , opts_repeat = 1     }  processorCount :: Int-#ifdef COMPILER_GHC+#ifdef __GLASGOW_HASKELL__ processorCount = numCapabilities #else processorCount = 1 #endif -optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+optionDescriptions :: [OptDescr (CmdlineOptions -> Either String 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"+    [ Option ['q']     ["quiet"]+             (NoArg (\o -> Right $ o { opts_quiet = True }))+             "Only display errors."+    , Option ['n']     ["not"]+             (ReqArg (\s o -> Right $ o { opts_negated = s : (opts_negated o) }) "PATTERN")+             "Tests to exclude."+    , Option ['l']     ["list"]+             (NoArg (\o -> Right $ o { opts_listTests = True }))+             "List all matching tests."+    , Option ['j']     ["threads"]+             (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N")+             ("Run N tests in parallel, default N=" ++ show processorCount ++ ".")+    , Option []        ["shuffle"]+             (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL")+             "Shuffle test order. Default: false"+    , Option ['o']     ["output-file"]+             (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE")+             "Name of output file."+    , Option []        ["json"]+             (NoArg (\o -> Right $ o { opts_machineOutput = True }))+             "Output results in machine-readable JSON format (incremental)."+    , Option []        ["xml"]+             (ReqArg (\s o -> Right $ o { opts_machineOutputXml = Just s }) "FILE")+             "Output results in junit-style XML format."+    , Option []        ["split"]+             (NoArg (\o -> Right $ o { opts_split = True }))+             "Splits results in separate files to avoid file locking (requires -o/--output-file)."+    , Option []        ["colors"]+             (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_useColors = Just b }) "BOOL")+             "Use colors or not."+    , Option []        ["history"]+             (ReqArg (\s o -> Right $ o { opts_historyFile = Just s }) "FILE")+             "Path to the history file. Default: ./.HTF/<ProgramName>.history"+    , Option []        ["fail-fast"]+             (NoArg (\o -> Right $ o { opts_failFast = True }))+             "Fail and abort test run as soon as the first test fails."+    , Option []        ["sort-by-prev-time"]+             (NoArg (\o -> Right $ o { opts_sortByPrevTime = True }))+             "Sort tests ascending by their execution of the previous test run (if available). Default: false"+    , Option []        ["max-prev-ms"]+             (ReqArg (\s o -> parseRead "--max-prev-ms" s >>= \(ms::Int) -> Right $ o { opts_maxPrevTimeMs = Just ms }) "MILLISECONDS")+             "Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run."+    , Option []        ["max-cur-ms"]+             (ReqArg (\s o -> parseRead "--max-cur-ms" s >>= \(ms::Int) ->+                              Right $ o { opts_maxCurTimeMs = Just ms }) "MILLISECONDS")+             "Abort a test that runs more than MILLISECONDS."+    , Option []        ["prev-factor"]+             (ReqArg (\s o -> parseRead "--prev-factor" s >>= \(ms::Double) ->+                              Right $ o { opts_prevFactor = Just ms }) "DOUBLE")+             "Abort a test that runs more than DOUBLE times slower than in a previous run."+    , Option []        ["timeout-is-success"]+             (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True }))+             "Do not regard a test timeout as an error."+    , Option []        ["repeat"]+             (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) ->+                              Right $ o { opts_repeat = i}) "NUMBER")+             "Execute the tests selected on the command line NUMBER times."+    , Option ['h']     ["help"]+             (NoArg (\o -> Right $ o { opts_help = True }))+             "Display this message."     ]     where-      parseThreads Nothing = processorCount+      parseThreads Nothing = Right processorCount       parseThreads (Just s) =           case readM s of-            Just i -> i-            Nothing -> error ("invalid number of threads: " ++ s)+            Just i -> Right i+            Nothing -> Left ("invalid number of threads: " ++ s)       parseBool s =+          Right $           if map toLower s `elem` ["1", "true", "yes", "on"] then True else False+      parseRead opt s =+          case readM s of+            Just i -> Right i+            Nothing -> Left ("invalid value for option " ++ opt ++ ": " ++ s)  {- | -Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis+Parse commandline arguments into 'CmdlineOptions'. Here is a synopsis of the format of the commandline arguments:  > USAGE: COMMAND [OPTION ...] PATTERN ...@@ -131,34 +215,49 @@ >   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+>   -q          --quiet                     Only display errors.+>   -n PATTERN  --not=PATTERN               Tests to exclude.+>   -l          --list                      List all matching tests.+>   -j[N]       --threads[=N]               Run N tests in parallel, default N=1.+>               --shuffle=BOOL              Shuffle test order. Default: false+>   -o FILE     --output-file=FILE          Name of output file.+>               --json                      Output results in machine-readable JSON format (incremental).+>               --xml=FILE                  Output results in junit-style XML format.+>               --split                     Splits results in separate files to avoid file locking (requires -o/--output-file).+>               --colors=BOOL               Use colors or not.+>               --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+>               --fail-fast                 Fail and abort test run as soon as the first test fails.+>               --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+>               --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+>               --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+>               --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+>               --timeout-is-success        Do not regard a test timeout as an error.+>   -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" ++ +      (optTrans, tests, []) ->+          do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans+             when (opts_shuffle opts && opts_sortByPrevTime opts) $+                 Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " +++                       "Can only use one of both.\n\n" +++                       usageInfo usageHeader optionDescriptions)+             case (opts_outputFile opts, opts_split opts) of+               (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++                                         usageInfo usageHeader optionDescriptions)-               _ -> Right opts+               _ -> 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+                    in Right (opts { opts_filter = pred })       (_,_,errs) ->           Left (concat errs ++ usageInfo usageHeader optionDescriptions)     where@@ -187,14 +286,29 @@              _ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile                      colors <- checkColors mOutputFd                      return (TestOutputHandle outputHandle closeOutput, colors)-       setUseColors colors---       let threads = opts_threads opts-       let reporters = defaultTestReporters False {-(isJust threads)-} (opts_machineOutput opts)+       let threads = opts_threads opts+           reporters = defaultTestReporters (isParallelFromBool $ isJust threads)+                                            (if opts_machineOutput opts then JsonOutput else NoJsonOutput)+                                            (if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput)+       historyFile <- getHistoryFile+       history <- getHistory historyFile        return $ TestConfig { tc_quiet = opts_quiet opts---                           , tc_threads = threads+                           , tc_threads = threads+                           , tc_shuffle = opts_shuffle opts                            , tc_output = output+                           , tc_outputXml = opts_machineOutputXml opts                            , tc_reporters = reporters-                           , tc_filter = opts_filter opts }+                           , tc_filter = opts_filter opts `mergeFilters` (historicFilter history)+                           , tc_useColors = colors+                           , tc_historyFile = historyFile+                           , tc_history = history+                           , tc_sortByPrevTime = opts_sortByPrevTime opts+                           , tc_failFast = opts_failFast opts+                           , tc_maxSingleTestTime = opts_maxCurTimeMs opts+                           , tc_prevFactor = opts_prevFactor opts+                           , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts+                           , tc_repeat = opts_repeat opts+                           }     where #ifdef mingw32_HOST_OS       openOutputFile =@@ -229,3 +343,37 @@                                       Just fd -> queryTerminal fd                                       _ -> return False #endif+      getHistoryFile =+          case opts_historyFile opts of+            Just fp -> return fp+            Nothing ->+                do progName <- getProgName+                   let x = if progName == "<interactive>" then "interactive" else progName+                   curDir <- getCurrentDirectory+                   let dir = curDir </> ".HTF"+                   createDirectoryIfMissing False dir+                   return $ dir </> (x ++ ".history")+      getHistory fp =+          do b <- doesFileExist fp+             if not b+             then return emptyTestHistory+             else do bs <- BS.readFile fp+                     case deserializeTestHistory bs of+                       Right history -> return history+                       Left err ->+                           do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err)+                              return emptyTestHistory+                  `catch` (\(e::IOException) ->+                               do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e)+                                  return emptyTestHistory)+      mergeFilters f1 f2 t =+          f1 t && f2 t+      historicFilter history t =+          case opts_maxPrevTimeMs opts of+            Nothing -> True+            Just ms ->+                case max (fmap htr_timeMs (findHistoricTestResult (historyKey t) history))+                         (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey t) history))+                of+                  Nothing -> True+                  Just t -> t <= ms
Test/Framework/Colors.hs view
@@ -1,5 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{- |+Utility module dealing with ANSI colors.+-} ----- Copyright (c) 2011, 2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011-2022   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@@ -18,18 +23,20 @@  module Test.Framework.Colors ( -    Color(..), PrimColor(..), startColor, withColor, colorize-  , reset+    Color(..), PrimColor(..), ColorString(..), PrimColorString(..)   , firstDiffColor, secondDiffColor, skipDiffColor, diffColor   , warningColor, testStartColor, testOkColor, pendingColor+  , emptyColorString, (+++), unlinesColorString, colorStringFind, ensureNewlineColorString+  , colorize, colorizeText, colorize', colorizeText'+  , noColor, noColorText, noColor', noColorText'+  , renderColorString, maxLength -  , setUseColors, useColors ) where -import System.IO.Unsafe (unsafePerformIO)-import Data.IORef---- REVERSE            = "\033[2m"+import qualified Data.Text as T+import Data.String+import Data.Maybe+import Control.Monad  firstDiffColor = Color Magenta False secondDiffColor = Color Blue False@@ -41,14 +48,15 @@ pendingColor = Color Cyan True  data Color = Color PrimColor Bool+           deriving (Eq, Show, Read)  data PrimColor = Black | Blue | Green | Cyan | Red | Magenta                | Brown | Gray | DarkGray | LightBlue                | LightGreen | LightCyan | LightRed | LightMagenta                | Yellow | White | NoColor-             deriving (Eq, Show)+             deriving (Eq, Show, Read) -startColor :: Color -> String+startColor :: Color -> T.Text startColor (Color c isBold) =     (case c of        Black -> "\ESC[0;30m"@@ -67,28 +75,119 @@        LightMagenta -> "\ESC[1;35m"        Yellow -> "\ESC[1;33m"        White -> "\ESC[1;37m"-       NoColor -> "") +++       NoColor -> "") `T.append`     (if isBold then "\ESC[1m" else "") -reset :: String+reset :: T.Text reset = "\ESC[0;0m" -withColor :: Color -> String -> String-withColor c s = startColor c ++ s ++ reset+data PrimColorString = PrimColorString Color T.Text (Maybe T.Text) {- no-color fallback -}+                    deriving (Eq, Show, Read) -colorize :: Color -> String -> IO String-colorize c s =-    do b <- useColors-       return $ if b then withColor c s else s+newtype ColorString = ColorString { unColorString :: [PrimColorString] }+                    deriving (Eq, Show, Read) --- We store the info about the use of colors in a global variable instead of the TestConfigs because--- hunit tests must known whether to colorize diffs.-_useColors :: IORef Bool-_useColors = unsafePerformIO (newIORef False)-{-# NOINLINE _useColors #-}+instance IsString ColorString where+    fromString = noColor -useColors :: IO Bool-useColors = readIORef _useColors+emptyColorString :: ColorString+emptyColorString = noColor "" -setUseColors :: Bool -> IO ()-setUseColors b = atomicModifyIORef _useColors (\_ -> (b, ()))+maxLength :: ColorString -> Int+maxLength (ColorString prims) =+    let ml (PrimColorString _ t mt) =+            max (T.length t) (fromMaybe 0 (fmap T.length mt))+    in sum $ map ml prims++unlinesColorString :: [ColorString] -> ColorString+unlinesColorString l =+    concatColorString $+    map (\x -> appendPrimColorString x (PrimColorString (Color NoColor False) (T.pack "\n") Nothing)) l+    where+      appendPrimColorString (ColorString l) x =+          ColorString (l ++ [x])++concatColorString :: [ColorString] -> ColorString+concatColorString l =+    ColorString $ concatMap (\(ColorString l) -> l) l++colorStringFind :: (Char -> Bool) -> ColorString -> Bool -> Maybe Char+colorStringFind pred (ColorString l) c =+    let f = if c then pcolorStringFindColor else pcolorStringFindNoColor+    in msum (map f l)+    where+      pcolorStringFindColor (PrimColorString _ t _) = tfind t+      pcolorStringFindNoColor (PrimColorString _ t Nothing) = tfind t+      pcolorStringFindNoColor (PrimColorString _ _ (Just t)) = tfind t+      tfind t = T.find pred t++ensureNewlineColorString :: ColorString -> ColorString+ensureNewlineColorString cs@(ColorString l) =+    let (colors, noColors) = unzip $ map colorsAndNoColors (reverse l)+        nlColor = needsNl colors+        nlNoColor = needsNl noColors+    in if not nlColor && not nlNoColor+       then cs+       else ColorString (l +++                         [PrimColorString (Color NoColor False) (mkNl nlColor)+                                              (Just (mkNl nlNoColor))])+    where+      mkNl True = "\n"+      mkNl False = ""+      colorsAndNoColors (PrimColorString _ t1 (Just t2)) = (t1, t2)+      colorsAndNoColors (PrimColorString _ t1 Nothing) = (t1, t1)+      needsNl [] = False+      needsNl (t:ts) =+          let t' = T.dropWhileEnd (\c -> c == ' ') t+          in if T.null t'+             then needsNl ts+             else T.last t' /= '\n'++colorize :: Color -> String -> ColorString+colorize c s = colorizeText c (T.pack s)++colorizeText :: Color -> T.Text -> ColorString+colorizeText !c !t = ColorString [PrimColorString c t Nothing]++colorize' :: Color -> String -> String -> ColorString+colorize' c s x = colorizeText' c (T.pack s) (T.pack x)++colorizeText' :: Color -> T.Text -> T.Text -> ColorString+colorizeText' !c !t !x = ColorString [PrimColorString c t (Just x)]++noColor :: String -> ColorString+noColor = colorize (Color NoColor False)++noColorText :: T.Text -> ColorString+noColorText = colorizeText (Color NoColor False)++noColor' :: String -> String -> ColorString+noColor' s1 s2 = colorize' (Color NoColor False) s1 s2++noColorText' :: T.Text -> T.Text -> ColorString+noColorText' t1 t2 = colorizeText' (Color NoColor False) t1 t2++infixr 5  +++++(+++) :: ColorString -> ColorString -> ColorString+cs1 +++ cs2 =+    case (cs1, cs2) of+      (ColorString [PrimColorString c1 t1 m1], ColorString (PrimColorString c2 t2 m2 : rest))+          | c1 == c2 ->+              let m3 = case (m1, m2) of+                         (Nothing, Nothing) -> Nothing+                         (Just x1, Just x2) -> Just (x1 `T.append` x2)+                         (Just x1, Nothing) -> Just (x1 `T.append` t2)+                         (Nothing, Just x2) -> Just (t1 `T.append` x2)+              in ColorString (PrimColorString c1 (t1 `T.append` t2) m3 : rest)+      (ColorString ps1, ColorString ps2) -> ColorString (ps1 ++ ps2)++renderColorString :: ColorString -> Bool -> T.Text+renderColorString (ColorString l) useColor =+    T.concat (map render l)+    where+      render = if useColor then renderColors else renderNoColors+      renderNoColors (PrimColorString _ _ (Just t)) = t+      renderNoColors (PrimColorString _ t Nothing) = t+      renderColors (PrimColorString c t _) =+          T.concat [startColor c, t, reset]
Test/Framework/Diff.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----- Copyright (c) 2011, 2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011-2022   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@@ -19,12 +19,14 @@  module Test.Framework.Diff ( -    DiffConfig(..), noColorsDiffConfig, coloredDiffConfig-  , defaultTerminalDiffConfig, defaultNoColorsDiffConfig-  , diffWithSensibleConfig, diff+    DiffConfig(..), diffWithSensibleConfig, diff, main  ) where +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(a,b,c) 1+#endif+ #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif@@ -33,6 +35,7 @@ import qualified Data.List as List import Data.Char import qualified Data.Algorithm.Diff as D+import Data.Algorithm.DiffOutput import Test.Framework.Colors  -- for testing@@ -40,6 +43,8 @@ import System.Directory import System.Exit import System.Process+import System.Environment (getArgs)+import qualified Data.Text as T  data Pos = First | Middle | Last | FirstLast          deriving (Eq)@@ -54,91 +59,87 @@ isFirst FirstLast = True isFirst _ = False -isMiddle :: Pos -> Bool-isMiddle Middle = True-isMiddle _ = False- data DiffConfig = DiffConfig {     -- for single line diffs-      dc_fromFirstPrefix :: String-    , dc_fromFirstSuffix :: String-    , dc_fromSecondPrefix :: String-    , dc_fromSecondSuffix :: String-    , dc_fromBothPrefix :: String-    , dc_fromBothSuffix :: String-    , dc_sep :: String-    , dc_skipPrefix :: String-    , dc_skipSuffix :: String+      dc_fromFirst :: String -> ColorString+    , dc_fromSecond :: String -> ColorString+    , dc_fromBoth :: String -> ColorString+    , dc_sep :: ColorString+    , dc_skip :: String -> ColorString     -- for multi-line diffs-    , dc_lineFromFirstPrefix :: String-    , dc_lineFromSecondPrefix :: String-    , dc_lineFromFirstSuffix :: String-    , dc_lineFromSecondSuffix :: String-    }--noColorsDiffConfig :: Char -> Char -> DiffConfig-noColorsDiffConfig f s = DiffConfig {-      dc_fromFirstPrefix = f : " "-    , dc_fromFirstSuffix = ""-    , dc_fromSecondPrefix = s : " "-    , dc_fromSecondSuffix = ""-    , dc_fromBothPrefix = "C "-    , dc_fromBothSuffix = ""-    , dc_skipPrefix = "<..."-    , dc_skipSuffix = "...>"-    , dc_sep = "\n"-    , dc_lineFromFirstPrefix = ""-    , dc_lineFromSecondPrefix = ""-    , dc_lineFromFirstSuffix = ""-    , dc_lineFromSecondSuffix = ""+    , dc_lineFromFirst :: String -> ColorString+    , dc_lineFromSecond :: String -> ColorString     } -coloredDiffConfig :: Color -> Color -> Color -> DiffConfig-coloredDiffConfig c1 c2 c3 = DiffConfig {-      dc_fromFirstPrefix = startColor c1-    , dc_fromFirstSuffix = reset-    , dc_fromSecondPrefix = startColor c2-    , dc_fromSecondSuffix = reset-    , dc_fromBothPrefix = ""-    , dc_fromBothSuffix = ""-    , dc_skipPrefix = startColor c3 ++ "..."-    , dc_skipSuffix = "..." ++ reset-    , dc_sep = ""-    , dc_lineFromFirstPrefix = startColor c1-    , dc_lineFromSecondPrefix = startColor c2-    , dc_lineFromFirstSuffix = reset-    , dc_lineFromSecondSuffix = reset+mkDefaultDiffConfig :: Color -> Color -> Color -> Char -> Char -> DiffConfig+mkDefaultDiffConfig c1 c2 c3 f s = DiffConfig {+      dc_fromFirst = \x -> colorize' c1 x (f : " " ++ x)+    , dc_fromSecond = \x -> colorize' c2 x (s : " " ++ x)+    , dc_fromBoth = \x -> noColor' x ("C " ++ x)+    , dc_skip = \x -> colorize' c3 ("..." ++ x ++ "...") ("<..." ++ x ++ "...>")+    , dc_sep = noColor' "" "\n"+    , dc_lineFromFirst = colorize c1+    , dc_lineFromSecond = colorize c2     } -defaultTerminalDiffConfig :: DiffConfig-defaultTerminalDiffConfig = coloredDiffConfig firstDiffColor secondDiffColor skipDiffColor--defaultNoColorsDiffConfig :: DiffConfig-defaultNoColorsDiffConfig = noColorsDiffConfig 'F' 'S'+defaultDiffConfig :: DiffConfig+defaultDiffConfig = mkDefaultDiffConfig firstDiffColor secondDiffColor skipDiffColor 'F' 'S'  contextSize :: Int contextSize = 10 -singleLineDiff :: DiffConfig -> String -> String -> String-singleLineDiff dc s1 s2-    | s1 == s2 = ""+prepareStringsForDiff :: String -> String -> (String, String, Maybe (String, String))+prepareStringsForDiff s1 s2 =+    case (List.splitAt 1024 s1, List.splitAt 1024 s2) of+      ((start1, rest1@(_:_)), (start2, rest2@(_:_))) -> (start1, start2, Just (rest1, rest2))+      ((start1, []), (start2, _)) -> (start1, start2, Nothing)+      ((start1, _), (start2, [])) -> (start1, start2, Nothing)++singleLineDiff :: DiffConfig -> String -> String -> ColorString+singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2)+    where+      loop :: (Int, Int) -> (String, String) -> ColorString+      loop (skipped1, skipped2) (s1, s2) =+          let (start1, start2, cont) = prepareStringsForDiff s1 s2+          in case singleLineDiff' dc start1 start2 of+               Just cs ->+                   let prefix =+                           if skipped1 == 0 && skipped1 == 0+                           then emptyColorString+                           else dc_skip dc+                                    ("skipped " ++ show skipped1 +++                                     " chars from first string, "+                                    ++ show skipped2 ++ " chars from second string")+                       suffix =+                           case cont of+                             Nothing -> emptyColorString+                             Just (r1, r2) ->+                                 dc_skip dc+                                     ("skipped " ++ show (length r1) +++                                      " chars from first string, " +++                                      show (length r2) ++ " chars from second string")+                   in prefix +++ cs +++ suffix+               Nothing ->+                   case cont of+                     Just (r1, r2) ->+                         loop (skipped1 + length start1, skipped2 + length start2) (r1, r2)+                     Nothing -> emptyColorString++singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString+singleLineDiff' dc s1 s2+    | s1 == s2 = Nothing     | otherwise =         let groups = D.getGroupedDiff s1 s2-        in foldr (\(group, pos) string ->-                      (showDiffGroup pos group) ++-                      (if not (isLast pos) then dc_sep dc else "") +++        in Just $+           foldr (\(group, pos) string ->+                      (showDiffGroup pos group) ++++                      (if not (isLast pos) then dc_sep dc else emptyColorString) +++                       string)-                 "" (addPositions groups)+                 emptyColorString (addPositions groups)     where-#if MIN_VERSION_Diff(0,2,0)-      showDiffGroup _ (D.First s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc-      showDiffGroup _ (D.Second s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc+      showDiffGroup _ (D.First s) = dc_fromFirst dc s+      showDiffGroup _ (D.Second s) = dc_fromSecond dc s       showDiffGroup pos (D.Both inBoth _) =-#else-      showDiffGroup _ (D.F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc-      showDiffGroup _ (D.S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc-      showDiffGroup pos (D.B, inBoth) =-#endif           let showStart = not $ isFirst pos               showEnd = not $ isLast pos               (contextStart, ignored, contextEnd) =@@ -150,11 +151,11 @@                             (if showEnd then "" else e)                   in (start, ign, end)               middle = let n = length ignored-                           replText = dc_skipPrefix dc ++ "skipped " ++ show n ++ " chars" ++-                                      dc_skipSuffix dc-                       in if n <= length replText then ignored else replText-          in dc_fromBothPrefix dc ++ contextStart ++ middle ++ contextEnd ++-             dc_fromBothSuffix dc+                           replText = "skipped " ++ show n ++ " chars"+                       in if n <= length replText+                          then dc_skip dc ignored+                          else dc_skip dc replText+          in dc_fromBoth dc contextStart +++ middle +++ dc_fromBoth dc contextEnd       addPositions [] = []       addPositions (x:[]) = (x, FirstLast) : []       addPositions (x:xs) = (x, First) : addPositions' xs@@ -162,226 +163,83 @@       addPositions' (x:[]) = (x, Last) : []       addPositions' (x:xs) = (x, Middle) : addPositions' xs -multiLineDiff :: DiffConfig -> String -> String -> IO String+multiLineDiff :: DiffConfig -> String -> String -> IO ColorString multiLineDiff cfg left right =     withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) ->-        do write hLeft left-           write hRight right+        do write hLeft leftForFile+           write hRight rightForFile            doDiff fpLeft fpRight     where+      (leftForFile, rightForFile) =+        if lastChar left /= Just '\n' && lastChar right /= Just '\n'+        then (left ++ "\n", right ++ "\n") -- avoid "No newline at end of file" error messages+        else (left, right)+      lastChar s =+        case reverse s of+          [] -> Nothing+          (c:_) -> Just c       doDiff leftFile rightFile =-          do (ecode, out, err) <- readProcessWithExitCode "diff" [leftFile, rightFile] ""-             case ecode of-               ExitSuccess -> return (format out)-               ExitFailure 1 -> return (format out)-               ExitFailure i ->-                   return ("'diff " ++ leftFile ++ " " ++ rightFile ++-                           "' failed with exit code " ++ show i ++-                           ": " ++ show err)+          (do (ecode, out, _err) <- readProcessWithExitCode "diff" ["-u", leftFile, rightFile] ""+              case ecode of+                ExitSuccess -> return (format out)+                ExitFailure 1 -> return (format out)+                ExitFailure _i -> return $ multiLineDiffHaskell left right)+             -- if we can't launch diff, use the Haskell code.+             -- We don't write the exception anywhere to not pollute test results.+            `catch` (\(_::IOException) -> return $ multiLineDiffHaskell left right)       saveRemove fp =           removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException)))       withTempFiles action =           do dir <- getTemporaryDirectory-             left@(fpLeft, _) <- openTempFile dir "HTF-diff-left.txt"-             (do right@(fpRight, _) <- openTempFile dir "HTF-diff-right.txt"+             left@(fpLeft, _) <- openTempFile dir "HTF-diff-EXPECTED_.txt"+             (do right@(fpRight, _) <- openTempFile dir "HTF-diff-ACTUAL_.txt"                  action left right `finally` saveRemove fpRight               `finally` saveRemove fpLeft)       write h s =           do hPutStr h s              hClose h-      format out = unlines $ map formatLine (lines out)+      format out = unlinesColorString $ map formatLine (lines out)       formatLine l =           case l of             ('<' : _) -> fromFirst l             ('>' : _) -> fromSecond l             (c : _)                  | isDigit c -> case List.span (\c -> c /= 'a' && c /= 'c' && c /= 'd') l of-                                  (left, c:right) -> fromFirst left ++ [c] ++ fromSecond right-                                  (left, []) -> left-                 | otherwise -> l+                                  (left, c:right) -> fromFirst left ++++                                                     noColor [c] ++++                                                     fromSecond right+                                  (left, []) -> noColor left+                 | otherwise -> noColor l+            [] -> noColor l           where-            fromFirst s = dc_fromFirstPrefix cfg ++ s ++ dc_fromFirstSuffix cfg-            fromSecond s = dc_fromSecondPrefix cfg ++ s ++ dc_fromSecondSuffix cfg+            fromFirst s = dc_fromFirst cfg s+            fromSecond s = dc_fromSecond cfg s -diff :: DiffConfig -> String -> String -> IO String-diff cfg left right =+diff :: DiffConfig -> String -> String -> IO ColorString+diff cfg left right = do     case (lines left, lines right) of-      ([], []) -> return ""-      ([], [_]) -> return $ singleLineDiff cfg left right-      ([_], []) -> return $ singleLineDiff cfg left right-      ([_], [_]) -> return $ singleLineDiff cfg left right+      ([], []) -> return emptyColorString+      ([], [_]) -> return (singleLineDiff cfg left right)+      ([_], []) -> return (singleLineDiff cfg left right)+      ([_], [_]) -> return (singleLineDiff cfg left right)       _ -> multiLineDiff cfg left right -diffWithSensibleConfig :: String -> String -> IO String+diffWithSensibleConfig :: String -> String -> IO ColorString diffWithSensibleConfig s1 s2 =-    do b <- useColors-       let dc = if b then defaultTerminalDiffConfig else defaultNoColorsDiffConfig-       diff dc s1 s2+    diff defaultDiffConfig s1 s2  {--NOTE: This is *nearly* working. Originally, I wanted to implemented a pure Haskell-diff solution. At some point, however, I decided that it would be better to implement-a solution based on the diff tool. For now, I leave the code as it is.--type PrimDiff = [(DI, Char)]-type LineNo = Int--data Line = Line { line_number :: LineNo-                 , line_content :: String {- without trailing \n -}-                 }-            deriving (Show)--data LineRange = LineRange { lr_numbers :: (LineNo, LineNo)-                           , lr_contents :: [String] {- without trailing \n -}-                           }-            deriving (Show)--data Diff a = OnlyInLeft a LineNo-            | OnlyInRight a LineNo-            | InBoth a a-            deriving (Show)--instance Functor Diff where-    fmap f d = case d of-                 OnlyInLeft x n -> OnlyInLeft (f x) n-                 OnlyInRight x n -> OnlyInRight (f x) n-                 InBoth x y -> InBoth (f x) (f y)--multiLineDiff :: DiffConfig -> String -> String -> String-multiLineDiff cfg left right =-    let diff = getDiff left right :: PrimDiff-        diffByLine = List.unfoldr nextLine diff-        diffLines = let (_, _, l) = foldl diffLine (1, 1, []) diffByLine-                    in reverse l-        diffLineRanges = maximize diffLines-    in debug ("diff: " ++ show diff ++-              "\ndiffByLine: " ++ show diffByLine ++-              "\ndiffLines: " ++ show diffLines ++-              "\ndiffLineRanges: " ++ show diffLineRanges) $-       render $ prettyDiffs diffLineRanges-    where-      nextLine :: PrimDiff -> Maybe (PrimDiff, PrimDiff)-      nextLine [] = Nothing-      nextLine diff =-          -- FIXME: add support for \r\n-          case List.span (\d -> d /= (B, '\n')) diff of-            ([], _ : rest) -> nextLine rest-            (l, _ : rest) -> Just (l, rest)-            (l, []) -> Just (l, [])-      diffLine :: (Int, Int, [Diff Line]) -> PrimDiff -> (Int, Int, [Diff Line])-      diffLine (leftLineNo, rightLineNo, l) diff =-          case (\(x, y) -> (reverse x, reverse y)) $-               foldl (\(l, r) d -> case d of-                                     (F, c) -> (c : l, r)-                                     (S, c) -> (l, c : r)-                                     (B, c) -> (c : l, c : r))-                     ([], []) diff-          of ([], rightLine) -> (leftLineNo, rightLineNo + 1,-                                 OnlyInRight (Line rightLineNo rightLine) leftLineNo : l)-             (leftLine, []) -> (leftLineNo + 1, rightLineNo,-                                OnlyInLeft (Line leftLineNo leftLine) rightLineNo : l)-             (leftLine, rightLine)-                 | leftLine /= rightLine ->-                     (leftLineNo + 1, rightLineNo + 1,-                      InBoth (Line leftLineNo leftLine) (Line rightLineNo rightLine) : l)-                 | otherwise ->-                     (leftLineNo + 1, rightLineNo + 1, l)-      maximize :: [Diff Line] -> [Diff LineRange]-      maximize [] = []-      maximize (x : l) = maximize' (fmap (\a -> [a]) x) l-          where-            maximize' (OnlyInLeft xs rightLineNo) (OnlyInLeft y _ : rest) =-                maximize' (OnlyInLeft (y : xs) rightLineNo) rest-            maximize' (OnlyInRight xs leftLineNo) (OnlyInRight y _ : rest) =-                maximize' (OnlyInRight (y : xs) leftLineNo) rest-            maximize' (InBoth xs ys) (InBoth x y : rest) =-                maximize' (InBoth (x:xs) (y:ys)) rest-            maximize' acc rest = fmap mkLineRange acc : maximize rest-            mkLineRange :: [Line] -> LineRange-            mkLineRange [] = error ("multilineDiff: cannot convert an empty list of lines " ++-                                    "into a LineRange")-            mkLineRange r@(Line lastLineNo _ : _) =-                case reverse r of-                  l@(Line firstLineNo _ : _) -> LineRange (firstLineNo, lastLineNo)-                                                          (map line_content l)--prettyDiffs :: [Diff LineRange] -> Doc-prettyDiffs [] = empty-prettyDiffs (d : rest) = prettyDiff d $$ prettyDiffs rest-    where-      prettyDiff (OnlyInLeft inLeft lineNoRight) =-          prettyRange (lr_numbers inLeft) <> char 'd' <> int lineNoRight $$-          prettyLines '<' (lr_contents inLeft)-      prettyDiff (OnlyInRight inRight lineNoLeft) =-          int lineNoLeft <> char 'a' <> prettyRange (lr_numbers inRight) $$-          prettyLines '>' (lr_contents inRight)-      prettyDiff (InBoth inLeft inRight) =-          prettyRange (lr_numbers inLeft) <> char 'c' <> prettyRange (lr_numbers inRight) $$-          prettyLines '<' (lr_contents inLeft) $$-          text "---" $$-          prettyLines '>' (lr_contents inRight)-      prettyRange (start, end) =-          if start == end then int start else int start <> comma <> int end-      prettyLines start lines =-          vcat (map (\l -> char start <+> text l) lines)------- Tests for diff-----prop_diffOk :: DiffInput -> Bool-prop_diffOk inp =-    multiLineDiff cfg (di_left inp) (di_right inp) ==-    unsafePerformIO (runDiff (di_left inp) (di_right inp))+Haskell diff, in case the diff tool is not present+-}+multiLineDiffHaskell :: String -> String -> ColorString+multiLineDiffHaskell left right =+    if length left > maxLen || length right > maxLen+    then noColor+             ("Refusing to compute a multiline diff for strings with more than " ++ show maxLen +++              " chars. Please install the 'diff' tool to get a diff ouput.")+    else noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right)     where-      cfg = noColorsDiffConfig 'l' 'r'-      runDiff left right =-          do leftFile <- writeTemp left-             rightFile <- writeTemp right-             (ecode, out, err) <--                 readProcessWithExitCode "diff" [leftFile, rightFile] ""-             -- putStrLn ("OUT:\n" ++ out)-             -- putStrLn ("ERR:\n" ++ err)-             -- putStrLn ("ECODE:\n" ++ show ecode)-             case ecode of-               ExitSuccess -> return out-               ExitFailure 1 -> return out-               ExitFailure i -> error ("'diff " ++ leftFile ++ " " ++ rightFile ++-                                       "' failed with exit code " ++ show i ++-                                       ": " ++ show err)-      writeTemp s =-          do dir <- getTemporaryDirectory-             (fp, h) <- openTempFile dir "HTF-diff.txt"-             hPutStr h s-             hClose h-             return fp--data DiffInput = DiffInput { di_left :: String, di_right :: String }-               deriving (Show)--leftDiffInput = unlines ["1", "2", "3", "4", "", "5", "6", "7"]--instance Arbitrary DiffInput where-    arbitrary =-        do let leftLines = lines leftDiffInput-           rightLinesLines <- mapM modifyLine (leftLines ++ [""])-           return $ DiffInput (unlines leftLines)-                              (unlines (concat rightLinesLines))-      where-        randomString =-            do c <- (elements (['a'..'z']))-               return [c]-        modifyLine :: String -> Gen [String]-        modifyLine str =-            do prefixLen <- frequency [(20-i, return i) | i <- [0..5]]-               prefix <- mapM (\_ -> randomString) [1..prefixLen]-               frequency [ (5, return (prefix ++ [str]))-                         , (3, return (prefix ++ ["XXX" ++ str]))-                         , (2, return prefix)-                         , (2, return [str])]--debug = trace--- debug _ x = x+      maxLen = 10000  main =     do args <- getArgs@@ -392,8 +250,8 @@              _ -> fail ("USAGE: diff FILE1 FILE2")        left <- readFile leftFp        right <- readFile rightFp-       diff <- return $ multiLineDiff defaultTerminalDiffConfig left right-       putStr diff+       diff <- return $ multiLineDiffHaskell left right+       putStr $ T.unpack $ renderColorString diff True  -- Testcases: --@@ -401,4 +259,3 @@ -- vs. -- > 1 -- > 2--}
Test/Framework/HUnitWrapper.hs view
@@ -1,465 +1,932 @@-{-# 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------ 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 provides assert-like functions for writing unit tests.--/Hint:/ Do not use the @assertXXX_@ functions-directly. Instead, for each function @assertXXX_@,-there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically. Use these macros, which-are available automatically if you add--@&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@--at the top of your source file (see the 'Test.Framework.Tutorial').---}--module Test.Framework.HUnitWrapper (--  -- * Assertions on Bool values-  assertBool_, assertBoolVerbose_,--  -- * Equality assertions-  assertEqual_, assertEqualVerbose_,-  assertEqualPretty_, assertEqualPrettyVerbose_,-  assertEqualNoShow_, assertEqualNoShowVerbose_,-  assertNotEqual_, assertNotEqualVerbose_,-  assertNotEqualPretty_, assertNotEqualPrettyVerbose_,-  assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,--  -- * Assertions on lists-  assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,-  assertNotEmpty_, assertNotEmptyVerbose_,-  assertEmpty_, assertEmptyVerbose_,--  -- * Assertions for exceptions-  assertThrows_, assertThrowsVerbose_,-  assertThrowsSome_, assertThrowsSomeVerbose_,-  assertThrowsIO_, assertThrowsIOVerbose_,-  assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,--  -- * Assertions on Either values-  assertLeft_, assertLeftVerbose_,-  assertLeftNoShow_, assertLeftNoShowVerbose_,-  assertRight_, assertRightVerbose_,-  assertRightNoShow_, assertRightNoShowVerbose_,--  -- * Assertions on Just values-  assertJust_, assertJustVerbose_,-  assertNothing_, assertNothingVerbose_,-  assertNothingNoShow_, assertNothingNoShowVerbose_,--  -- * General failure-  assertFailure_,--  -- * Pending unit tests-  unitTestPending, unitTestPending',--  -- * Sub assertions-  subAssert_, subAssertVerbose_-) where--import Control.Exception-import Control.Monad.Trans-import Control.Monad.Trans.Control-import qualified Test.HUnit as HU hiding ( assertFailure )-import qualified Language.Haskell.Exts.Pretty as HE-import qualified Language.Haskell.Exts.Parser as HE--import Data.List ( (\\) )--import Test.Framework.TestManagerInternal-import Test.Framework.Location-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, supplying the error location and the error message.--}-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-without removing it from the test suite and without deleting or commenting out the test code.--}-unitTestPending' :: String -> IO a -> IO a-unitTestPending' msg _ = unitTestPending msg--mkMsg :: String -> String -> String -> String-mkMsg fun extraInfo s =-    if null extraInfo-       then fun ++ (' ':s)-       else fun ++ " (" ++ extraInfo ++ ") " ++ s------- Dirty macro hackery (I'm too lazy ...)----#define CreateAssertionsGeneric(__name__, __ctx__, __type__, __ret__) \-__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \-__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \-__name__##_ loc = _##__name__##_ #__name__ loc ""--#define CreateAssertionsCtx(__name__, __ctx__, __type__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, HU.Assertion)--#define CreateAssertions(__name__, __type__) \-CreateAssertionsGeneric(__name__, , __type__, HU.Assertion)--#define CreateAssertionsCtxRet(__name__, __ctx__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, __ret__)--#define CreateAssertionsRet(__name__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, , __type__, __ret__)--#define DocAssertion(__name__, __text__) \-  {- | __text__ The 'String' parameter in the @Verbose@ \-      variant can be used to provide extra information about the error. Do not use \-      @__name__##_@ and @__name__##Verbose_@ directly, use the macros @__name__@ \-      and @__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \-      insert the 'Location' parameter automatically. -}------- Boolean Assertions-----_assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion-_assertBool_ name loc s False =-    assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertBool_ _ _ _   True = return ()--DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)-CreateAssertions(assertBool, Bool)------- Equality Assertions-----equalityFailedMessage :: String -> String -> IO String-equalityFailedMessage exp act =-    do d <- diffWithSensibleConfig expP actP-       expected_ <- colorize firstDiffColor "* expected:"-       but_got_ <- colorize secondDiffColor "* but got:"-       diff_ <- colorize diffColor "* diff:"-       return ("\n" ++ expected_ ++ " " ++ withNewline expP ++-               "\n" ++ but_got_ ++ "  " ++ withNewline actP ++-               "\n" ++ diff_ ++ "     " ++ withNewline d ++-               (if stringEq-                   then "\nWARNING: strings are equal but actual values differ!"-                   else ""))-    where-      withNewline s =-          case lines s of-            [] -> s-            [_] -> s-            _ -> '\n':s-      (expP, actP, stringEq) =-          case (pp exp, pp act) of-            (Nothing, _) -> (exp, act, exp == act)-            (_, Nothing) -> (exp, act, exp == act)-            (Just expP, Just actP)-                | expP == actP ->-                    if exp /= act-                       then (exp, act, exp == act)-                       else (expP, actP, True)-                | otherwise -> (expP, actP, False)-      pp s =-          case HE.parseExp s of-            HE.ParseOk x -> Just $ HE.prettyPrint x-            HE.ParseFailed{} -> Nothing--notEqualityFailedMessage :: String -> IO String-notEqualityFailedMessage exp =-    do return (": Objects are equal\n" ++ pp exp)-    where-      pp s =-          case HE.parseExp s of-            HE.ParseOk x -> HE.prettyPrint x-            HE.ParseFailed{} -> s--_assertEqual_ :: (Eq a, Show a)-                 => String -> Location -> String -> a -> a -> HU.Assertion-_assertEqual_ name loc s expected actual =-    if expected /= actual-       then do x <- equalityFailedMessage (show expected) (show actual)-               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()--DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.-             The first parameter denotes the expected value. Use these two functions-             of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a)--_assertNotEqual_ :: (Eq a, Show a)-                 => String -> Location -> String -> a -> a -> HU.Assertion-_assertNotEqual_ name loc s expected actual =-    if expected == actual-       then do x <- notEqualityFailedMessage (show expected)-               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()--DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.-             The first parameter denotes the expected value. Use these two functions-             of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), a -> a)--_assertEqualPretty_ :: (Eq a, Pretty a)-                       => String -> Location -> String -> a -> a -> HU.Assertion-_assertEqualPretty_ name loc s expected actual =-    if expected /= actual-       then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)-               assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()--DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.-             The first parameter denotes the expected value. Use these two functions-             of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a)--_assertNotEqualPretty_ :: (Eq a, Pretty a)-                       => String -> Location -> String -> a -> a -> HU.Assertion-_assertNotEqualPretty_ name loc s expected actual =-    if expected == actual-       then do x <- notEqualityFailedMessage (showPretty expected)-               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-             of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), a -> a)--_assertEqualNoShow_ :: Eq a-                    => String -> Location -> String -> a -> a -> HU.Assertion-_assertEqualNoShow_ name loc s expected actual =-    if expected /= actual-       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-             of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this-             case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a)--_assertNotEqualNoShow_ :: Eq a-                    => String -> Location -> String -> a -> a -> HU.Assertion-_assertNotEqualNoShow_ name loc s expected actual =-    if expected == actual-       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-             of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this-             case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertNotEqualNoShow, Eq a, a -> a)------- Assertions on Lists-----_assertListsEqualAsSets_ :: (Eq a, Show a)-                   => String -> Location -> String -> [a] -> [a] -> HU.Assertion-_assertListsEqualAsSets_ name loc s expected actual =-    let ne = length expected-        na = length actual-        in case () of-            _| ne /= na ->-                 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__ loc (mkMsg "assertSetEqual" s-                                   ("failed at " ++ showLoc loc ++ x))-             | otherwise -> return ()-    where unorderedEq l1 l2 =-              null (l1 \\ l2) && null (l2 \\ l1)-DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal-                                     when considered as sets. The first list parameter-                                     denotes the expected value.)-CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a])--_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion-_assertNotEmpty_ name loc s [] =-    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__ 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])------- Assertions for Exceptions-----_assertThrowsIO_ :: Exception e-                 => String -> Location -> String -> IO a -> (e -> Bool) -> HU.Assertion-_assertThrowsIO_ name loc s x f =-    do res <- try x-       case res of-         Right _ -> assertFailure__ loc (mkMsg name s-                                   ("failed at " ++ showLoc loc ++-                                    ": no exception was thrown"))-         Left e -> if f e then return ()-                   else assertFailure__ loc (mkMsg name s-                                       ("failed at " ++-                                        showLoc loc ++-                                        ": wrong exception was thrown: " ++-                                        show e))-DocAssertion(assertThrowsIO, Fail if executing the 'IO' action does not-             throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtx(assertThrowsIO, Exception e, IO a -> (e -> Bool))--_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion-_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (e::SomeException) -> True)-DocAssertion(assertThrowsSomeIO, Fail if executing the 'IO' action does not-             throw an exception.)-CreateAssertions(assertThrowsSomeIO, IO a)--_assertThrows_ :: Exception e-               => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion-_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f-DocAssertion(assertThrows, Fail if evaluating the expression of type @a@ does not-             throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtx(assertThrows, Exception e, a -> (e -> Bool))--_assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion-_assertThrowsSome_ name loc s x =-    _assertThrows_ name loc s x (\ (e::SomeException) -> True)-DocAssertion(assertThrowsSome, Fail if evaluating the expression of type @a@ does not-             throw an exception.)-CreateAssertions(assertThrowsSome, a)------- Assertions on Either-----_assertLeft_ :: forall a b . Show b-             => String -> Location -> String -> Either a b -> IO a-_assertLeft_ _ _ _ (Left x) = return x-_assertLeft_ name loc s (Right x) =-    assertFailure__ loc (mkMsg name s-                   ("failed at " ++ showLoc loc ++-                    ": expected a Left value, given " ++-                    show (Right x :: Either b b)))-DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.-             Use this function if @b@ is an instance of 'Show')-CreateAssertionsCtxRet(assertLeft, Show b, Either a b, IO a)--_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a-_assertLeftNoShow_ _ _ _ (Left x) = return x-_assertLeftNoShow_ name loc s (Right _) =-    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)--_assertRight_ :: forall a b . Show a-              => String -> Location -> String -> Either a b -> IO b-_assertRight_ _ _ _ (Right x) = return x-_assertRight_ name loc s (Left x) =-    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'.-             Use this function if @a@ is an instance of 'Show')-CreateAssertionsCtxRet(assertRight, Show a, Either a b, IO b)--_assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b-_assertRightNoShow_ _ _ _ (Right x) = return x-_assertRightNoShow_ name loc s (Left _) =-    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)------- Assertions on Maybe-----_assertJust_ :: String -> Location -> String -> Maybe a -> IO a-_assertJust_ _ _ _ (Just x) = return x-_assertJust_ name loc s Nothing =-    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)--_assertNothing_ :: Show a-                => String -> Location -> String -> Maybe a -> HU.Assertion-_assertNothing_ _ _ _ Nothing = return ()-_assertNothing_ name loc s jx =-    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'.)-CreateAssertionsCtx(assertNothing, Show a, Maybe a)--_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion-_assertNothingNoShow_ _ _ _ Nothing = return ()-_assertNothingNoShow_ name loc s _ =-    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+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++--+-- Copyright (c) 2005-2022  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 provides assert-like functions for writing unit tests.++-}++module Test.Framework.HUnitWrapper (++  -- * Assertions on Bool values+  assertBool, assertBoolVerbose,++  -- * Equality assertions+  assertEqual, assertEqualVerbose,+  assertEqualPretty, assertEqualPrettyVerbose,+  assertEqualNoShow, assertEqualNoShowVerbose,++  -- * Inequality assertions+  assertNotEqual, assertNotEqualVerbose,+  assertNotEqualPretty, assertNotEqualPrettyVerbose,+  assertNotEqualNoShow, assertNotEqualNoShowVerbose,++  -- * Assertions on lists+  assertListsEqualAsSets, assertListsEqualAsSetsVerbose,+  assertNotEmpty, assertNotEmptyVerbose,+  assertEmpty, assertEmptyVerbose,+  assertElem, assertElemVerbose,++  -- * Assertions for exceptions+  assertThrows, assertThrowsVerbose,+  assertThrowsSome, assertThrowsSomeVerbose,+  assertThrowsIO, assertThrowsIOVerbose,+  assertThrowsSomeIO, assertThrowsSomeIOVerbose,+  assertThrowsM, assertThrowsMVerbose,+  assertThrowsSomeM, assertThrowsSomeMVerbose,++  -- * Assertions on Either values+  assertLeft, assertLeftVerbose,+  assertLeftNoShow, assertLeftNoShowVerbose,+  assertRight, assertRightVerbose,+  assertRightNoShow, assertRightNoShowVerbose,++  -- * Assertions on Just values+  assertJust, assertJustVerbose,+  assertNothing, assertNothingVerbose,+  assertNothingNoShow, assertNothingNoShowVerbose,++  -- * General failure+  assertFailure,++  -- * Pending unit tests+  unitTestPending, unitTestPending',++  -- * Sub assertions+  subAssert, subAssertVerbose,++  -- * Generalized assertions and failures in AssertM+  {- |+       The following definitions generalize the the monad in which assertions are executed.+       Usually, assertions are executed in the @IO@ monad. The @AssertM@ monad+       (see "Test.Framework.AssertM") allows you to evaluate assertions also as pure functions.+   -}+  -- ** Assertions on Bool values+  gassertBool, gassertBoolVerbose,++  -- ** Equality assertions+  gassertEqual, gassertEqualVerbose,+  gassertEqualPretty, gassertEqualPrettyVerbose,+  gassertEqualNoShow, gassertEqualNoShowVerbose,++  -- ** Inequality assertions+  gassertNotEqual, gassertNotEqualVerbose,+  gassertNotEqualPretty, gassertNotEqualPrettyVerbose,+  gassertNotEqualNoShow, gassertNotEqualNoShowVerbose,++  -- ** Assertions on lists+  gassertListsEqualAsSets, gassertListsEqualAsSetsVerbose,+  gassertNotEmpty, gassertNotEmptyVerbose,+  gassertEmpty, gassertEmptyVerbose,+  gassertElem, gassertElemVerbose,++  -- ** Assertions on Either values+  gassertLeft, gassertLeftVerbose,+  gassertLeftNoShow, gassertLeftNoShowVerbose,+  gassertRight, gassertRightVerbose,+  gassertRightNoShow, gassertRightNoShowVerbose,++  -- ** Assertions on Just values+  gassertJust, gassertJustVerbose,+  gassertNothing, gassertNothingVerbose,+  gassertNothingNoShow, gassertNothingNoShowVerbose,++  -- ** General failure+  gassertFailure,++  -- ** Sub assertions+  gsubAssert, gsubAssertVerbose,++  -- * HUnit re-exports+  HU.HUnitFailure,++  -- * Tests (for internal use)+  hunitWrapperTests++) where++import Control.Exception+import qualified Control.Exception.Lifted as ExL+import Control.Monad.Trans.Control+import Control.Monad.Trans+import qualified Test.HUnit.Lang as HU+#if !MIN_VERSION_HUnit(1,4,0)+import qualified Test.HUnit.Base as HU+#endif++import GHC.Stack++import Data.List ( (\\) )+import System.IO.Unsafe (unsafePerformIO)++import Test.Framework.TestInterface+import Test.Framework.Location+import Test.Framework.Diff+import Test.Framework.Colors+import Test.Framework.Pretty+import Test.Framework.AssertM+import Test.Framework.PrettyHaskell+import Test.Framework.Utils++import qualified Data.Text as T+import qualified Data.List as List++-- WARNING: do not forget to add a preprocessor macro for new assertions!!++{- |+Fail with the given reason in some 'AssertM' monad.+-}+gassertFailure :: (HasCallStack, AssertM m) => String -> m a+gassertFailure s =+    genericAssertFailure (mkMsg "assertFailure" "" s)++-- | Specialization of 'gassertFailure' to @IO@.+assertFailure :: HasCallStack => String -> IO a+assertFailure = gassertFailure++{- |+Signals that the current unit test is pending.+-}+unitTestPending :: String -> IO a+unitTestPending s =+    failHTF (FullTestResult emptyHtfStack (Just $ noColor s) (Just Pending))++{- |+Use @unitTestPending' msg test@ to mark the given test as pending+without removing it from the test suite and without deleting or commenting out the test code.+-}+unitTestPending' :: String -> IO a -> IO a+unitTestPending' msg _ = unitTestPending msg++mkMsg :: String -> String -> String -> ColorString+mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)++mkColorMsg :: String -> String -> ColorString -> ColorString+mkColorMsg fun extraInfo s =+    let pref = if null extraInfo+               then fun ++ " "+               else fun ++ " (" ++ extraInfo ++ ") "+    in noColor pref +++ s++--+-- Boolean Assertions+--++assertBool_ :: (HasCallStack, AssertM m) => String -> String -> Bool -> m ()+assertBool_ name s False = genericAssertFailure (mkMsg name s "failed")+assertBool_ _ _ True = return ()++-- | Fail if the 'Bool' value is 'False'.+assertBool :: HasCallStack => Bool -> IO ()+assertBool = assertBool_ "assertBool" ""++assertBoolVerbose :: HasCallStack => String -> Bool -> IO ()+assertBoolVerbose = assertBool_ "assertBoolVerbose"++gassertBool :: (HasCallStack, AssertM m) => Bool -> m ()+gassertBool = assertBool_ "gassertBool" ""++gassertBoolVerbose :: (HasCallStack, AssertM m) => String -> Bool -> m ()+gassertBoolVerbose = assertBool_ "gassertBoolVerbose"++--+-- Equality Assertions+--++equalityFailedMessage' :: String -> String -> ColorString+equalityFailedMessage' exp act =+    let !diff = unsafePerformIO (diffWithSensibleConfig exp act)+        expected_ = colorize firstDiffColor "* expected:"+        but_got_ = colorize secondDiffColor "* but got:"+        diff_ = colorize diffColor "* diff:"+    in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) ++++        "\n" +++ but_got_ +++ "  " +++ noColor (withNewline (trim act)) ++++        "\n" +++ diff_ +++ "     " +++ newlineBeforeDiff diff +++ diff ++++        (if (exp == act)+         then "\nWARNING: strings are equal but actual values differ!"+         else ""))+    where+      withNewline s =+          case lines s of+            [] -> s+            [_] -> s+            _ -> '\n':s+      newlineBeforeDiff d =+          let f b = case colorStringFind (\c -> c == '\n') d b of+                      Just _ -> "\n"+                      Nothing -> ""+          in noColor' (f True) (f False)+      trim s =+          case List.splitAt maxLen s of+            (_, []) -> s+            (prefix, rest) ->+                prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)"+      maxLen = 10000++asString :: Show a => a -> Maybe String+asString x = readM (show x)++equalityFailedMessage :: (Show a) => a -> a -> ColorString+equalityFailedMessage exp act =+    equalityFailedMessage' expP actP+    where+      (expP, actP) =+        case (asString exp, asString act) of+          (Just expS, Just actS)+            | expS /= actS -> (expS, actS)+          _ ->+            case (prettyHaskell' exp, prettyHaskell' act) of+              (Nothing, _) -> (show exp, show act)+              (_, Nothing) -> (show exp, show act)+              (Just expP, Just actP)+                  | expP == actP ->+                      (show exp, show act)+                  | otherwise -> (expP, actP)++notEqualityFailedMessage :: Show a => a -> String+notEqualityFailedMessage exp =+    notEqualityFailedMessage' (prettyHaskell exp)++notEqualityFailedMessage' :: String -> String+notEqualityFailedMessage' exp =+    (": Objects are equal\n" ++ exp)++failedAt :: HasCallStack => String+failedAt =+  case failureLocation of+    Nothing -> "failed"+    Just loc -> "failed at " ++ showLoc loc++assertEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+                 => String -> String -> a -> a -> m ()+assertEqual_ name s expected actual =+    if expected /= actual+       then do let x = equalityFailedMessage expected actual+               genericAssertFailure (mkColorMsg name s $+                                      noColor failedAt +++ x)+       else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualVerbose = assertEqual_ "gassertEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqual = assertEqual_ "gassertEqual" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertEqualVerbose = assertEqual_ "assertEqualVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertEqual = assertEqual_ "assertEqual" ""++assertNotEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+                => String -> String -> a -> a -> m ()+assertNotEqual_ name s expected actual =+    if expected == actual+       then do let x = notEqualityFailedMessage expected+               genericAssertFailure (mkMsg name s $ failedAt ++ x)+       else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualVerbose = assertNotEqual_ "gassertNotEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqual = assertNotEqual_ "gassertNotEqual" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualVerbose = assertNotEqual_ "assertNotEqualVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertNotEqual = assertNotEqual_ "assertNotEqual" ""++assertEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+                   => String -> String -> a -> a -> m ()+assertEqualPretty_ name s expected actual =+    if expected /= actual+       then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)+               genericAssertFailure (mkColorMsg name s+                                      (noColor failedAt +++ x))+       else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualPrettyVerbose = assertEqualPretty_ "gassertEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualPretty = assertEqualPretty_ "gassertEqualPretty" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertEqualPrettyVerbose = assertEqualPretty_ "assertEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertEqualPretty = assertEqualPretty_ "assertEqualPretty" ""++assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+                       => String -> String -> a -> a -> m ()+assertNotEqualPretty_ name s expected actual =+    if expected == actual+       then do let x = notEqualityFailedMessage' (showPretty expected)+               genericAssertFailure (mkMsg name s $ failedAt ++ x)+       else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualPrettyVerbose = assertNotEqualPretty_ "gassertNotEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualPretty = assertNotEqualPretty_ "gassertNotEqualPretty" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualPrettyVerbose = assertNotEqualPretty_ "assertNotEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertNotEqualPretty = assertNotEqualPretty_ "assertNotEqualPretty" ""++assertEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+                    => String -> String -> a -> a -> m ()+assertEqualNoShow_ name s expected actual =+    if expected /= actual+    then genericAssertFailure (mkMsg name s failedAt)+    else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualNoShowVerbose = assertEqualNoShow_ "gassertEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualNoShow = assertEqualNoShow_ "gassertEqualNoShow" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertEqualNoShowVerbose = assertEqualNoShow_ "assertEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertEqualNoShow = assertEqualNoShow_ "assertEqualNoShow" ""++assertNotEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+                      => String -> String -> a -> a -> m ()+assertNotEqualNoShow_ name s expected actual =+    if expected == actual+       then genericAssertFailure (mkMsg name s failedAt)+       else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualNoShowVerbose = assertNotEqualNoShow_ "gassertNotEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualNoShow = assertNotEqualNoShow_ "gassertNotEqualNoShow" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualNoShowVerbose = assertNotEqualNoShow_ "assertNotEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertNotEqualNoShow = assertNotEqualNoShow_ "assertNotEqualNoShow" ""++--+-- Assertions on Lists+--++assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m, HasCallStack)+                   => String -> String -> [a] -> [a] -> m ()+assertListsEqualAsSets_ name s expected actual =+    let ne = length expected+        na = length actual+        in case () of+            _| ne /= na ->+                 do let x = equalityFailedMessage expected actual+                    genericAssertFailure (mkColorMsg name s+                                           (noColor+                                             (failedAt+                                               ++ "\n expected length: " ++ show ne+                                               ++ "\n actual length: " ++ show na) ++++                                             (if maxLength x < 5000+                                               then x else emptyColorString)))+             | not (unorderedEq expected actual) ->+                 do let x = equalityFailedMessage expected actual+                    genericAssertFailure (mkColorMsg "assertSetEqual" s+                                           (noColor failedAt +++ x))+             | otherwise -> return ()+    where unorderedEq l1 l2 =+              null (l1 \\ l2) && null (l2 \\ l1)++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+gassertListsEqualAsSetsVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> [a] -> [a] -> m ()+gassertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "gassertListsEqualAsSetsVerbose"++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets.+gassertListsEqualAsSets :: (Eq a, Show a, AssertM m, HasCallStack) => [a] -> [a] -> m ()+gassertListsEqualAsSets= assertListsEqualAsSets_ "gassertListsEqualAsSets" ""++-- | Fail if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+assertListsEqualAsSetsVerbose :: (Eq a, Show a, HasCallStack) => String -> [a] -> [a] -> IO ()+assertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "assertListsEqualAsSetsVerbose"++-- | Fail if the two given lists are not equal when considered as sets.+assertListsEqualAsSets :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> IO ()+assertListsEqualAsSets = assertListsEqualAsSets_ "assertListsEqualAsSets" ""++assertNotEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertNotEmpty_ name s [] =+    genericAssertFailure (mkMsg name s failedAt)+assertNotEmpty_ _ _ (_:_) = return ()++-- | Fail in some 'AssertM' monad if the given list is empty, supplying an+-- additional error message.+gassertNotEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertNotEmptyVerbose = assertNotEmpty_ "gassertNotEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is empty.+gassertNotEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertNotEmpty = assertNotEmpty_ "gassertNotEmpty" ""++-- | Fail if the given list is empty, supplying an+-- additional error message.+assertNotEmptyVerbose ::  HasCallStack => String -> [a] -> IO ()+assertNotEmptyVerbose = assertNotEmpty_ "assertNotEmptyVerbose"++-- | Fail if the given list is empty.+assertNotEmpty ::  HasCallStack => [a] -> IO ()+assertNotEmpty = assertNotEmpty_ "assertNotEmpty" ""++assertEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertEmpty_ name s (_:_) =+    genericAssertFailure (mkMsg name s failedAt)+assertEmpty_ _ _ [] = return ()++-- | Fail in some 'AssertM' monad if the given list is not empty, supplying an+-- additional error message.+gassertEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertEmptyVerbose = assertEmpty_ "gassertEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is not empty.+gassertEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertEmpty = assertEmpty_ "gassertEmpty" ""++-- | Fail if the given list is not empty, supplying an+-- additional error message.+assertEmptyVerbose ::  HasCallStack => String -> [a] -> IO ()+assertEmptyVerbose = assertEmpty_ "assertEmptyVerbose"++-- | Fail if the given list is not empty.+assertEmpty ::  HasCallStack => [a] -> IO ()+assertEmpty = assertEmpty_ "assertEmpty" ""++assertElem_ :: (Eq a, Show a, AssertM m, HasCallStack) => String -> String -> a -> [a] -> m ()+assertElem_ name s x l =+    if x `elem` l+    then return ()+    else genericAssertFailure (mkMsg name s+                                (failedAt +++                                  "\n element: " ++ show x +++                                  "\n list:   " ++ show l))++-- | Fail in some 'AssertM' monad if the element given is not contained in the list, supplying+-- an additional error message.+gassertElemVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> [a] -> m ()+gassertElemVerbose = assertElem_ "gassertElemVerbose"++-- | Fail in some 'AssertM' monad if the element given is not contained in the list.+gassertElem :: (Eq a, Show a, AssertM m, HasCallStack) => a -> [a] -> m ()+gassertElem = assertElem_ "gassertElem" ""++-- | Fail if the element given is not contained in the list, supplying+-- an additional error message.+assertElemVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> [a] -> IO ()+assertElemVerbose = assertElem_ "assertElemVerbose"++-- | Fail if the element given is not contained in the list.+assertElem :: (Eq a, Show a, HasCallStack) => a -> [a] -> IO ()+assertElem = assertElem_ "assertElem" ""++--+-- Assertions for Exceptions+--++assertThrowsIO_ :: (HasCallStack, Exception e)+                 => String -> String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIO_ name s x f =+    assertThrowsM_ name s x f++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsIOVerbose :: (HasCallStack, Exception e) => String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIOVerbose = assertThrowsIO_ "assertThrowsIOVerbose"++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsIO :: (HasCallStack, Exception e) => IO a -> (e -> Bool) -> IO ()+assertThrowsIO = assertThrowsIO_ "assertThrowsIO" ""++assertThrowsSomeIO_ :: HasCallStack => String -> String -> IO a -> IO ()+assertThrowsSomeIO_ name s x = assertThrowsIO_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the 'IO' action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeIOVerbose ::  HasCallStack => String -> IO a -> IO ()+assertThrowsSomeIOVerbose = assertThrowsSomeIO_ "assertThrowsSomeIOVerbose"++-- | Fail if executing the 'IO' action does not throw any exception.+assertThrowsSomeIO :: HasCallStack => IO a -> IO ()+assertThrowsSomeIO = assertThrowsSomeIO_ "assertThrowsSomeIO" ""++assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+                => String -> String -> m a -> (e -> Bool) -> m ()+assertThrowsM_ name s x f =+    do res <- ExL.try x+       case res of+         Right _ -> liftIO $+                    genericAssertFailure (mkMsg name s+                                           (failedAt +++                                             ": no exception was thrown"))+         Left e -> if f e then return ()+                   else liftIO $+                        genericAssertFailure (mkMsg name s+                                               (failedAt +++                                                 ": wrong exception was thrown: " +++                                                 show e))+-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsMVerbose ::+  (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+  => String -> m a -> (e -> Bool) -> m ()+assertThrowsMVerbose = assertThrowsM_ "assertThrowsMVerbose"++-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsM ::+  (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+  => m a -> (e -> Bool) -> m ()+assertThrowsM = assertThrowsM_ "assertThrowsM" ""++assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m, HasCallStack)+                    => String -> String -> m a -> m ()+assertThrowsSomeM_ name s x = assertThrowsM_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the @m@ action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeMVerbose ::+  (MonadBaseControl IO m, MonadIO m, HasCallStack)+  => String -> m a -> m ()+assertThrowsSomeMVerbose = assertThrowsSomeM_ "assertThrowsSomeMVerbose"++-- | Fail if executing the @m@ action does not throw any exception.+assertThrowsSomeM :: (MonadBaseControl IO m, MonadIO m, HasCallStack) => m a -> m ()+assertThrowsSomeM = assertThrowsSomeM_ "assertThrowsSomeM" ""++assertThrows_ :: (HasCallStack, Exception e)+               => String -> String -> a -> (e -> Bool) -> IO ()+assertThrows_ name s x f = assertThrowsIO_ name s (evaluate x) f++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@,+-- supplying an additional error message.+assertThrowsVerbose :: (HasCallStack, Exception e) => String -> a -> (e -> Bool) -> IO ()+assertThrowsVerbose = assertThrows_ "assertThrowsVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@.+assertThrows :: (HasCallStack, Exception e) => a -> (e -> Bool) -> IO ()+assertThrows = assertThrows_ "assertThrows" ""++assertThrowsSome_ :: HasCallStack => String -> String -> a -> IO ()+assertThrowsSome_ name s x =+    assertThrows_ name s x (\ (_e::SomeException) -> True)++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception, supplying an additional error message.+assertThrowsSomeVerbose :: HasCallStack => String -> a -> IO ()+assertThrowsSomeVerbose = assertThrowsSome_ "assertThrowsSomeVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception.+assertThrowsSome ::  HasCallStack => a -> IO ()+assertThrowsSome = assertThrowsSome_ "assertThrowsSome" ""++--+-- Assertions on Either+--++assertLeft_ :: forall a b m . (AssertM m, Show b, HasCallStack)+             => String -> String -> Either a b -> m a+assertLeft_ _ _ (Left x) = return x+assertLeft_ name s (Right x) =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected a Left value, given " +++                             show (Right x :: Either b b)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeftVerbose :: (Show b, AssertM m, HasCallStack) => String -> Either a b -> m a+gassertLeftVerbose = assertLeft_ "gassertLeftVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeft :: (Show b, AssertM m, HasCallStack) => Either a b -> m a+gassertLeft = assertLeft_ "gassertLeft" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+assertLeftVerbose :: (Show b, HasCallStack) => String -> Either a b -> IO a+assertLeftVerbose = assertLeft_ "assertLeftVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+assertLeft :: (HasCallStack, Show b) => Either a b -> IO a+assertLeft = assertLeft_ "assertLeft" ""++assertLeftNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m a+assertLeftNoShow_ _ _ (Left x) = return x+assertLeftNoShow_ name s (Right _) =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected a Left value, given a Right value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m a+gassertLeftNoShowVerbose = assertLeftNoShow_ "gassertLeftNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShow :: (HasCallStack, AssertM m) => Either a b -> m a+gassertLeftNoShow = assertLeftNoShow_ "gassertLeftNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShowVerbose ::  HasCallStack => String -> Either a b -> IO a+assertLeftNoShowVerbose = assertLeftNoShow_ "assertLeftNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShow :: HasCallStack => Either a b -> IO a+assertLeftNoShow = assertLeftNoShow_ "assertLeftNoShow" ""++assertRight_ :: forall a b m . (AssertM m, Show a, HasCallStack)+             => String -> String -> Either a b -> m b+assertRight_ _ _ (Right x) = return x+assertRight_ name s (Left x) =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected a Right value, given " +++                             show (Left x :: Either a a)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertRightVerbose :: (Show a, AssertM m, HasCallStack) => String -> Either a b -> m b+gassertRightVerbose = assertRight_ "gassertRightVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+gassertRight :: (Show a, AssertM m, HasCallStack) => Either a b -> m b+gassertRight = assertRight_ "gassertRight" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+assertRightVerbose :: (Show a, HasCallStack) => String -> Either a b -> IO b+assertRightVerbose = assertRight_ "assertRightVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+assertRight :: (HasCallStack, Show a) => Either a b -> IO b+assertRight = assertRight_ "assertRight" ""++assertRightNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m b+assertRightNoShow_ _ _ (Right x) = return x+assertRightNoShow_ name s (Left _) =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected a Right value, given a Left value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m b+gassertRightNoShowVerbose = assertRightNoShow_ "gassertRightNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShow :: (HasCallStack, AssertM m) => Either a b -> m b+gassertRightNoShow = assertRightNoShow_ "gassertRightNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShowVerbose ::  HasCallStack => String -> Either a b -> IO b+assertRightNoShowVerbose = assertRightNoShow_ "assertRightNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShow :: HasCallStack => Either a b -> IO b+assertRightNoShow = assertRightNoShow_ "assertRightNoShow" ""++--+-- Assertions on Maybe+--++assertJust_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m a+assertJust_ _ _ (Just x) = return x+assertJust_ name s Nothing =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected a Just value, given Nothing"))++-- | Fail in some 'AssertM' monad if the given value is a Nothing, supplying an additional+-- error message.+gassertJustVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m a+gassertJustVerbose = assertJust_ "gassertJustVerbose"++-- | Fail in some 'AssertM' monad if the given value is a Nothing.+gassertJust :: (HasCallStack, AssertM m) => Maybe a -> m a+gassertJust = assertJust_ "gassertJust" ""++-- | Fail if the given value is a Nothing, supplying an additional+-- error message.+assertJustVerbose :: HasCallStack => String -> Maybe a -> IO a+assertJustVerbose = assertJust_ "assertJustVerbose"++-- | Fail if the given value is a Nothing.+assertJust :: HasCallStack => Maybe a -> IO a+assertJust = assertJust_ "assertJust" ""++assertNothing_ :: (Show a, AssertM m, HasCallStack)+                => String -> String -> Maybe a -> m ()+assertNothing_ _ _ Nothing = return ()+assertNothing_ name s jx =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected Nothing, given " ++ show jx))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothingVerbose :: (Show a, AssertM m, HasCallStack) => String -> Maybe a -> m ()+gassertNothingVerbose = assertNothing_ "gassertNothingVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothing :: (Show a, AssertM m, HasCallStack) => Maybe a -> m ()+gassertNothing = assertNothing_ "gassertNothing" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+assertNothingVerbose :: (Show a, HasCallStack) => String -> Maybe a -> IO ()+assertNothingVerbose = assertNothing_ "assertNothingVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+assertNothing :: (HasCallStack, Show a) => Maybe a -> IO ()+assertNothing = assertNothing_ "assertNothing" ""++assertNothingNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m ()+assertNothingNoShow_ _ _ Nothing = return ()+assertNothingNoShow_ name s _ =+    genericAssertFailure (mkMsg name s+                           (failedAt +++                             ": expected Nothing, given a Just value"))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShowVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m ()+gassertNothingNoShowVerbose = assertNothingNoShow_ "gassertNothingNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShow :: (HasCallStack, AssertM m) => Maybe a -> m ()+gassertNothingNoShow = assertNothingNoShow_ "gassertNothingNoShow" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShowVerbose :: HasCallStack => String -> Maybe a -> IO ()+assertNothingNoShowVerbose = assertNothingNoShow_ "assertNothingNoShowVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShow :: HasCallStack => Maybe a -> IO ()+assertNothingNoShow = assertNothingNoShow_ "assertNothingNoShow" ""++--+-- Sub assertions+--++-- | Use 'subAssert' if you want location information for the call site but the function+--   being called does not carry a 'HasCallStack' constraint.+subAssert :: (HasCallStack, MonadBaseControl IO m) => m a -> m a+subAssert = subAssertHTF Nothing++gsubAssert :: (HasCallStack, AssertM m) => m a -> m a+gsubAssert = genericSubAssert Nothing++subAssertVerbose :: (HasCallStack, MonadBaseControl IO m) => String -> m a -> m a+subAssertVerbose msg = subAssertHTF (Just msg)++gsubAssertVerbose :: (HasCallStack, AssertM m) => String -> m a -> m a+gsubAssertVerbose msg = genericSubAssert (Just msg)++testEqualityFailedMessage1 :: IO ()+testEqualityFailedMessage1 =+    let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3,4]) False+    in HU.assertEqual "error" msg exp+    where+      exp = "\n* expected: [1, 2, 3]\n* but got:  [1, 2, 3, 4]\n* " +++            "diff:     \nC <...[1, 2, 3...>C \nS , 4\nC ]<......>C "++testEqualityFailedMessage2 :: IO ()+testEqualityFailedMessage2 =+    let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3]) False+    in HU.assertEqual "error" msg exp+    where+      exp = "\n* expected: [1,2,3]\n* but got:  [1,2,3]\n* " +++            "diff:     \nWARNING: strings are equal but actual values differ!"++hunitWrapperTests =+    [("testEqualityFailedMessage1", testEqualityFailedMessage1)+    ,("testEqualityFailedMessage2", testEqualityFailedMessage2)]
− Test/Framework/HaskellParser.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE ScopedTypeVariables,CPP #-}---- 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.HaskellParser where--import Data.Maybe-import Data.Char ( isSpace, isDigit )-import qualified Data.List as List-import Control.Exception ( evaluate, catch, SomeException )-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding ( catch )-#endif--import qualified Language.Haskell.Exts as Exts-import qualified Language.Haskell.Exts.Parser as Parser-import qualified Language.Haskell.Exts.Syntax as Syn-import qualified Language.Haskell.Exts.Extension as Ext-import qualified Language.Haskell.Exts.Fixity as Fix-import qualified Language.Haskell.Exts.SrcLoc as Src--import Test.Framework.Location-import Test.Framework.Utils--type Name = String--data Decl = Decl { decl_loc :: Location-                 , decl_name :: Name }--data Pragma = Pragma { pr_name :: String-                     , pr_args :: String-                     , pr_loc :: Location }--data ParseResult a = ParseOK a | ParseError Location String--data Module = Module { mod_name :: Name-                     , mod_imports :: [ImportDecl]-                     , mod_decls :: [Decl]-                     , mod_htfPragmas :: [Pragma] }--data ImportDecl = ImportDecl { imp_moduleName :: Name-                             , imp_qualified :: Bool-                             , 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)-            `catch` (\(e::SomeException) ->-                         return $ Parser.ParseFailed unknownLoc (show e))-       case r of-         Parser.ParseFailed loc err -> return (ParseError (transformLoc loc) err)-         Parser.ParseOk (m, comments) -> return $ ParseOK (transformModule m comments)-    where-      -- fixedInput serves two purposes:-      -- 1. add a trailing \n-      -- 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 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 -}-      parseMode :: Parser.ParseMode-      parseMode = Parser.ParseMode { Parser.parseFilename = originalFileName-                                   , Parser.ignoreLanguagePragmas = False-                                   , Parser.ignoreLinePragmas = False-                                   , Parser.extensions =-                                       Ext.glasgowExts ++-                                       [Ext.BangPatterns, Ext.TemplateHaskell]-                                   , Parser.fixities =-                                       Just (Fix.baseFixities ++-                                             Fix.infixr_ 0 ["==>"])-                                   }-      unknownLoc :: Syn.SrcLoc-      unknownLoc = Syn.SrcLoc originalFileName 0 0-      transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls)-                      comments =-          Module moduleName (map transformImport imports)-                            (mapMaybe transformDecl decls)-                            (mapMaybe transformComment comments)-      transformImport (Syn.ImportDecl loc (Syn.ModuleName s)-                                      qualified _ _ alias _) =-          let alias' = case alias of-                         Nothing -> Nothing-                         Just (Syn.ModuleName s) -> Just s-          in ImportDecl s qualified alias' (transformLoc loc)-      transformDecl (Syn.PatBind loc (Syn.PVar name) _ _ _) =-          Just $ Decl (transformLoc loc) (transformName name)-      transformDecl (Syn.FunBind (Syn.Match loc name _ _ _ _ : _)) =-          Just $ Decl (transformLoc loc) (transformName name)-      transformDecl _ = Nothing-      transformSpan span = makeLoc (Src.srcSpanFilename span) (Src.srcSpanStartLine span)-      transformLoc (Syn.SrcLoc f n _) = makeLoc f n-      transformName :: Syn.Name -> String-      transformName (Syn.Ident s) = s-      transformName (Syn.Symbol s) = s-      transformComment (Exts.Comment True span ('@':s)) =-          case reverse s of-            '@':r ->-                let stripped = strip (reverse r)-                in if "HTF_" `List.isPrefixOf` stripped-                      then let (name, args) = List.span (not . isSpace) stripped-                               argsStripped = dropWhile isSpace args-                               loc = transformSpan span-                           in Just $ Pragma name argsStripped loc-                      else Nothing-            _ -> Nothing-      transformComment _ = Nothing
+ Test/Framework/History.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+--+-- Copyright (c) 2005-2022   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+--+{- |+Internal module for retaining a history of test runs.+-}+module Test.Framework.History (++    TestHistory, HistoricTestResult(..), emptyTestHistory, Milliseconds, TestResult(..)+  , serializeTestHistory, deserializeTestHistory+  , findHistoricTestResult, findHistoricSuccessfulTestResult+  , updateTestHistory, mkTestRunHistory+  , historyTests++) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.List as L+import qualified Data.Vector as V+import Data.Time.Clock+import Test.HUnit+import Data.Aeson hiding (Error)+import Data.Aeson.TH+import Test.Framework.TestInterface++-- | A type synonym for time in milliseconds.+type Milliseconds = Int++data TestHistory+    = TestHistory+      { th_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+      , th_index :: !(Map T.Text (HistoricTestResult))+      , th_successfulIndex :: !(Map T.Text (HistoricTestResult))+      }+    deriving (Eq)++instance Show (TestHistory) where+    showsPrec _ _ = showString "<TestHistory>"++emptyTestHistory :: TestHistory+emptyTestHistory =+    TestHistory V.empty Map.empty Map.empty++data TestRunHistory+    = TestRunHistory+      { trh_startTime :: !UTCTime+      , trh_tests :: !(V.Vector (HistoricTestResult))+      }+    deriving (Eq)++instance Show TestRunHistory where+    showsPrec d trh =+        showParen (d > 10) $+        showString "TestRunHistory <hidden time> " .+        showsPrec 11 (trh_tests trh)++data HistoricTestResult+    = HistoricTestResult+      { htr_testId :: !T.Text+      , htr_result :: !TestResult+      , htr_timedOut :: !Bool+      , htr_timeMs :: !Milliseconds+      }+    deriving (Show, Eq)++mkTestRunHistory :: UTCTime -> [HistoricTestResult] -> TestRunHistory+mkTestRunHistory time results = TestRunHistory {+                                  trh_startTime = time+                                , trh_tests = V.fromList results+                                }++isSuccess :: HistoricTestResult -> Bool+isSuccess r = htr_result r == Pass && not (htr_timedOut r)++updateTestHistory :: TestRunHistory -> TestHistory -> TestHistory+updateTestHistory runHistory history =+    let runs = runHistory : V.toList (th_runs history)+    in TestHistory (V.fromList runs) (createIndex runs (const True)) (createIndex runs isSuccess)++-- The [TestRunHistory] list is sorted reverse chronologically+createIndex :: [TestRunHistory] -> (HistoricTestResult -> Bool) -> Map T.Text (HistoricTestResult)+createIndex list pred =+    L.foldl' updateMap Map.empty flatRunHistory+    where+      updateMap m res =+          Map.insertWith (\_new old -> old) (htr_testId res) res m+      flatRunHistory =+          filter pred $ concatMap (\trh -> V.toList (trh_tests trh)) list++findHistoricTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricTestResult id hist = Map.lookup id (th_index hist)++findHistoricSuccessfulTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricSuccessfulTestResult id hist = Map.lookup id (th_successfulIndex hist)++data SerializableTestHistory+    = SerializableTestHistory+      { sth_version :: Int+      , sth_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+      }++_CURRENT_VERSION_ :: Int+_CURRENT_VERSION_ = 0++instance ToJSON TestResult where+    toJSON r = String $+        case L.lookup r testResultStringMapping of+          Just s -> s+          Nothing -> error ("TestResult " ++ show r ++ " not defined in testResultStringMapping")++instance FromJSON TestResult where+    parseJSON v =+        case v of+          String s+              | Just r <- L.lookup s (map (\(x, y) -> (y, x)) testResultStringMapping)+                       -> return r+          _ -> fail ("could not parse JSON value as a test result: " ++ show v)++testResultStringMapping :: [(TestResult, T.Text)]+testResultStringMapping =+    [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")]++deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory++serializeTestHistory :: TestHistory -> BS.ByteString+serializeTestHistory hist =+    let serHist = SerializableTestHistory {+                    sth_version = _CURRENT_VERSION_+                  , sth_runs = th_runs hist+                  }+    in BSL.toStrict $ encode serHist++deserializeTestHistory :: BS.ByteString -> Either String (TestHistory)+deserializeTestHistory bs =+    -- assume version 0 for now. Later we have to look into the json, find the version and then decide which parser to user+    case decodeStrict bs of+      Nothing -> Left ("could not decode JSON: " ++ show bs)+      Just !serHist ->+          let list = V.toList (sth_runs serHist)+          in Right (TestHistory (sth_runs serHist) (createIndex list (const True)) (createIndex list isSuccess))++testCreateIndex =+    do time <- getCurrentTime+       let index = createIndex (historyList time) (const True)+       if index == expectedIndex+       then return ()+       else assertFailure ("== Expected index:\n" ++ show expectedIndex +++                           "\n== Given index:\n" ++ show index)+    where+      historyList time =+          [mkHist time [mkRes "foo" 1]+          ,mkHist time [mkRes "foo" 2, mkRes "bar" 10]+          ,mkHist time [mkRes "bar" 20, mkRes "egg" 3]]+      expectedIndex = Map.fromList [("foo", mkRes "foo" 1)+                                   ,("bar", mkRes "bar" 10)+                                   ,("egg", mkRes "egg" 3)]+      mkHist time l = TestRunHistory time (V.fromList l)+      mkRes id ms = HistoricTestResult id Pass False ms++historyTests = [("testCreateIndex", testCreateIndex)]
Test/Framework/JsonOutput.hs view
@@ -1,3 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+--+-- Copyright (c) 2005-2022   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+-- {- |  HTF's machine-readable output is a sequence of JSON messages. Each message is terminated@@ -47,8 +65,6 @@  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,@@ -61,12 +77,15 @@  import Test.Framework.TestTypes import Test.Framework.Location+import Test.Framework.Colors+import Test.Framework.TestInterface  import qualified Data.Aeson as J import Data.Aeson ((.=))  import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.Text as T  class J.ToJSON a => HTFJsonObj a @@ -87,34 +106,28 @@     = TestEndEventObj       { te_test :: TestObj       , te_result :: TestResult-      , te_location :: Maybe Location-      , te_callers :: [(Maybe String, Location)]-      , te_message :: String+      , te_stack :: HtfStack+      , te_message :: T.Text       , te_wallTimeMs :: Int+      , te_timedOut :: Bool       }  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))+                 ,"location" .= J.toJSON (failureLocationFromStack (te_stack te))+                 ,"callers" .=+                    J.toJSON (map (\entry -> J.object ["location" .= J.toJSON (hse_location entry)+                                                      ,"message" .= J.toJSON (hse_message entry)])+                              (restCallStack (te_stack te)))                  ,"result" .= J.toJSON (te_result te)                  ,"message" .= J.toJSON (te_message te)-                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)]+                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)+                 ,"timedOut" .= J.toJSON (te_timedOut 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@@ -136,6 +149,8 @@       , tr_pending :: Int       , tr_failed :: Int       , tr_errors :: Int+      , tr_timedOut :: Int+      , tr_filtered :: Int       }  instance J.ToJSON TestResultsObj where@@ -144,6 +159,8 @@                         ,"pending" .= J.toJSON (tr_pending r)                         ,"failures" .= J.toJSON (tr_failed r)                         ,"errors" .= J.toJSON (tr_errors r)+                        ,"timedOut" .= J.toJSON (tr_timedOut r)+                        ,"filtered" .= J.toJSON (tr_filtered r)                         ,"wallTime" .= J.toJSON (tr_wallTimeMs r)]  instance HTFJsonObj TestResultsObj@@ -191,21 +208,24 @@ 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)+        msg = renderColorString (rr_message r) False+    in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_stack r)+                       msg (rr_wallTimeMs r) (rr_timeout 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 =+mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj+mkTestResultsObj arg =     TestResultsObj-    { tr_wallTimeMs = time-    , tr_passed = passed-    , tr_pending = pending-    , tr_failed = failed-    , tr_errors = errors+    { tr_wallTimeMs = rgra_timeMs arg+    , tr_passed = length (rgra_passed arg)+    , tr_pending = length (rgra_pending arg)+    , tr_failed = length (rgra_failed arg)+    , tr_errors = length (rgra_errors arg)+    , tr_timedOut = length (rgra_timedOut arg)+    , tr_filtered = length (rgra_filtered arg)     }  decodeObj :: HTFJsonObj a => a -> BSL.ByteString
Test/Framework/Location.hs view
@@ -1,5 +1,5 @@ ----- Copyright (c) 2005, 2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022   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@@ -18,7 +18,7 @@  {- | -This module defines types and functions dealing with source code locations.+Internal module for types and functions dealing with source code locations.  -}
Test/Framework/Preprocessor.hs view
@@ -1,7 +1,13 @@+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PackageImports #-}+{- |+Internal module providing access to some functionality of cpphs.+-} ----- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022 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@@ -18,19 +24,42 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Preprocessor ( transform, progName ) where+module Test.Framework.Preprocessor ( -import Data.Char ( toLower, isSpace, isDigit )-import Data.Maybe ( mapMaybe )-import qualified Data.List as List-import System.IO ( hPutStrLn, stderr )-import Language.Preprocessor.Cpphs ( runCpphs,+    transform, progName, preprocessorTests, TransformOptions(..)++) where++-- import Debug.Trace+import Control.Monad+import Data.Char+import Language.Preprocessor.Cpphs ( runCpphsPass1,+                                     runCpphsPass2,                                      CpphsOptions(..),-                                     defaultCpphsOptions)+                                     BoolOptions(..),+                                     defaultCpphsOptions,+                                     WordStyle(..),+                                     Posn,+                                     filename,+                                     lineno,+                                     newfile,+                                     tokenise+                                   )+import System.IO ( hPutStrLn, stderr )+#if MIN_VERSION_HUnit(1,4,0)+import Test.HUnit hiding (State)+#else+import Test.HUnit hiding (State, Location)+#endif+import Control.Monad.State.Strict+import qualified Data.List as List+import Data.Maybe -import Test.Framework.HaskellParser import Test.Framework.Location +_DEBUG_ :: Bool+_DEBUG_ = False+ progName :: String progName = "htfpp" @@ -59,153 +88,316 @@  nameDefines :: ModuleInfo -> [(String, String)] nameDefines info =-    [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleName info)),-     (importedTestListName, importedTestListFullName (mi_moduleName info))]--allAsserts :: [String]-allAsserts = ["assertBool"-             ,"assertEqual"-             ,"assertEqualPretty"-             ,"assertEqualNoShow"-             ,"assertNotEqual"-             ,"assertNotEqualPretty"-             ,"assertNotEqualNoShow"-             ,"assertListsEqualAsSets"-             ,"assertEmpty"-             ,"assertNotEmpty"-             ,"assertThrows"-             ,"assertThrowsSome"-             ,"assertThrowsIO"-             ,"assertThrowsSomeIO"-             ,"assertLeft"-             ,"assertLeftNoShow"-             ,"assertRight"-             ,"assertRightNoShow"-             ,"assertJust"-             ,"assertNothing"-             ,"assertNothingNoShow"-             ,"subAssert"-             ]--assertDefines :: Bool -> String -> [(String, String)]-assertDefines hunitBackwardsCompat prefix =-    concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")]-    where-      fun a =-          if hunitBackwardsCompat-             then [(a, expansion a "Verbose_"), (a ++ "HTF", expansion a "_")]-             else [(a, expansion a "_"), (a ++ "Verbose", expansion a "Verbose_")]-      expansion a suffix = "(" ++ prefix ++ a ++ suffix ++ " (" ++-                           prefix ++ "makeLoc __FILE__ __LINE__))"--warn :: String -> IO ()-warn s =-    hPutStrLn stderr $ progName ++ " warning: " ++ s+    [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)),+     (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault info))]  data ModuleInfo = ModuleInfo { mi_htfPrefix  :: String                              , mi_htfImports :: [ImportDecl]                              , mi_defs       :: [Definition]-                             , mi_moduleName :: String }+                             , mi_moduleName :: Maybe String }+                  deriving (Show, Eq) +mi_moduleNameWithDefault :: ModuleInfo -> String+mi_moduleNameWithDefault = fromMaybe "Main" . mi_moduleName++data ImportDecl = ImportDecl { imp_moduleName :: Name+                             , imp_qualified :: Bool+                             , imp_alias :: Maybe Name+                             , imp_loc :: Location }+                  deriving (Show, Eq)+ data Definition = TestDef String Location String                 | PropDef String Location String+                  deriving (Eq, Show) -data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma+type Name = String -analyse :: FilePath -> String-        -> IO (ParseResult ModuleInfo)-analyse originalFileName inputString =-    do parseResult <- parse originalFileName inputString-       case parseResult of-         ParseOK (Module moduleName imports decls pragmas) ->-             do -- putStrLn $ show decls-                let defs = mapMaybe defFromDecl decls-                    htfImports = findHtfImports imports pragmas-                htfPrefix <--                  case mapMaybe prefixFromImport imports of-                    (s:_) -> return s-                    [] -> do warn ("No import found for " ++ htfModule ++-                                   " in " ++ originalFileName)-                             return (htfModule ++ ".")-                return $ ParseOK (ModuleInfo htfPrefix htfImports defs moduleName)-         ParseError loc err -> return (ParseError loc err)+type PMA a = State ModuleInfo a++setModName :: String -> PMA ()+setModName name =+    do oldName <- gets mi_moduleName+       when (isNothing oldName) $ modify $ \mi -> mi { mi_moduleName = Just name }++addTestDef :: String -> String -> Location -> PMA ()+addTestDef name fullName loc =+    modify $ \mi -> mi { mi_defs = (TestDef name loc fullName) : mi_defs mi }++addPropDef :: String -> String -> Location -> PMA ()+addPropDef name fullName loc =+    modify $ \mi -> mi { mi_defs = (PropDef name loc fullName) : mi_defs mi }++addHtfImport :: ImportDecl -> PMA ()+addHtfImport decl =+    modify $ \mi -> mi { mi_htfImports = decl : mi_htfImports mi }++setTestFrameworkImport :: String -> PMA ()+setTestFrameworkImport name =+    modify $ \mi -> mi { mi_htfPrefix = name }++data Tok+    = TokModule+    | TokQname Location String+    | TokName Location Bool String+    | TokHtfImport Location+    | TokImport Location++transWordStyles :: [WordStyle] -> [Tok]+transWordStyles styles = loop styles True     where-      prefixFromImport :: ImportDecl -> Maybe String-      prefixFromImport (ImportDecl s qualified alias _)-          | s == htfModule =-              if qualified-                  then case alias of-                         Just s' -> Just $ s' ++ "."-                         Nothing -> Just $ s ++ "."-                  else Just ""-      prefixFromImport _ = Nothing-      defFromDecl :: Decl -> Maybe Definition-      defFromDecl (Decl loc name) = defFromNameAndLoc name loc-      defFromNameAndLoc :: Name -> Location -> Maybe Definition-      defFromNameAndLoc name loc =-          case name of-            ('t':'e':'s':'t':'_':rest) | not (null rest) ->-                Just (TestDef rest loc name)-            ('p':'r':'o':'p':'_':rest) | not (null rest) ->-                Just (PropDef rest loc name)-            _ -> Nothing-      findHtfImports allImports allPragmas =-          let importPragmas = filter (\p -> pr_name p == "HTF_TESTS") allPragmas-              importsAndPragmas = List.sortBy cmpByLine (map IsImport allImports ++-                                                         map IsPragma importPragmas)-              loop (IsImport imp : IsPragma prag : rest) =-                  if lineNumber (imp_loc imp) == lineNumber (pr_loc prag)-                     then imp : loop rest-                     else loop rest-              loop (_ : rest) = loop rest-              loop [] = []-          in loop importsAndPragmas-      cmpByLine x y = getLine x `compare` getLine y-      getLine (IsImport imp) = (lineNumber (imp_loc imp))-      getLine (IsPragma prag) = (lineNumber (pr_loc prag))+      loop styles startOfLine =+        case styles of+          [] -> []+          Ident pos name : rest ->+              case name of+                "module" -> TokModule : loop rest False+                "import" ->+                    case dropWhite rest of+                      Other "{-@ HTF_TESTS @-}" : rest2 ->+                          TokHtfImport (posToLocation pos) : loop rest2 False+                      _ ->+                          TokImport (posToLocation pos) : loop rest False+                _ ->+                    case parseQname rest of+                      ([], rest2) ->+                          TokName (posToLocation pos) startOfLine name : loop rest2 False+                      (nameParts, rest2) ->+                          TokQname (posToLocation pos) (List.intercalate "." (name:nameParts)) : loop rest2 False+          Other str : rest ->+              let startOfLine =+                      case reverse str of+                        '\n':_ -> True+                        _ -> False+              in loop rest startOfLine+          Cmd _ : rest -> loop rest False+      dropWhite styles =+          case styles of+            Other str : rest ->+                case dropWhile isSpace str of+                  [] -> dropWhite rest+                  str' -> Other str' : rest+            _ -> styles+      parseQname styles =+          case styles of+            Other "." : Ident _ name : rest ->+                let (restParts, rest2) = parseQname rest+                in (name:restParts, rest2)+            _ -> ([], styles)+      posToLocation pos = makeLoc (filename pos) (lineno pos) -transform :: Bool -> FilePath -> String -> IO String-transform hunitBackwardsCompat originalFileName input =-    do analyseResult <- analyse originalFileName input-       case analyseResult of-         ParseError loc err ->-             do warn ("Parsing of " ++ originalFileName ++ " failed at line "-                      ++ show (lineNumber loc) ++ ": " ++ err)-                preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE") input-         ParseOK info ->-             preprocess info input+poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo+poorManAnalyzeTokens styles =+    let toks = transWordStyles styles+        revRes =+            execState (loop toks) $+                      ModuleInfo { mi_htfPrefix = htfModule ++ "."+                                 , mi_htfImports = []+                                 , mi_defs = []+                                 , mi_moduleName = Nothing }+    in ModuleInfo { mi_htfPrefix = mi_htfPrefix revRes+                  , mi_htfImports = reverse (mi_htfImports revRes)+                  , mi_defs = reverse $ List.nubBy defEqByName (mi_defs revRes)+                  , mi_moduleName = mi_moduleName revRes+                  }     where-      preprocess :: ModuleInfo -> String -> IO String-      preprocess info input =-          do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName-                                           fixedInput-             return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+      defEqByName (TestDef n1 _ _) (TestDef n2 _ _) = n1 == n2+      defEqByName (PropDef n1 _ _) (PropDef n2 _ _) = n1 == n2+      defEqByName _ _ = False+      loop toks =+        case toks of+          TokModule : TokQname _ name : rest ->+              do setModName name+                 loop rest+          TokModule : TokName _ _ name : rest ->+              do setModName name+                 loop rest+          TokName loc startOfLine name : rest+              | startOfLine ->+                  case name of+                    't':'e':'s':'t':'_':shortName ->+                        do addTestDef shortName name loc+                           loop rest+                    'p':'r':'o':'p':'_':shortName ->+                        do addPropDef shortName name loc+                           loop rest+                    _ -> loop rest+              | otherwise -> loop rest+          TokHtfImport loc : rest ->+              case parseImport loc rest of+                Just (imp, rest2) ->+                    do addHtfImport imp+                       loop rest2+                Nothing -> loop rest+          TokImport loc : rest ->+              do case parseImport loc rest of+                   Nothing -> loop rest+                   Just (imp, rest2) ->+                       do when (imp_moduleName imp == htfModule) $+                            let prefix = case (imp_alias imp, imp_qualified imp) of+                                           (Just alias, True) -> alias+                                           (Nothing, True) -> imp_moduleName imp+                                           _ -> ""+                            in setTestFrameworkImport+                                   (if null prefix then prefix else prefix ++ ".")+                          loop rest2+          _ : rest -> loop rest+          [] -> return ()+      parseImport loc toks =+          do let (qualified, toks2) =+                  case toks of+                    TokName _ _ "qualified" : rest -> (True, rest)+                    _ -> (False, toks)+             (name, toks3) <-+                  case toks2 of+                    TokName _ _ name : rest -> return (name, rest)+                    TokQname _ name : rest -> return (name, rest)+                    _ -> fail "no import"+             let (mAlias, toks4) =+                   case toks3 of+                     TokName _ _ "as" : TokName _ _ alias : rest -> (Just alias, rest)+                     _ -> (Nothing, toks3)+                 decl = ImportDecl { imp_moduleName = name+                                   , imp_qualified = qualified+                                   , imp_alias = mAlias+                                   , imp_loc = loc }+             return (decl, toks4)++analyze :: FilePath -> String -> IO (ModuleInfo, [WordStyle], [(Posn,String)])+analyze originalFileName input =+    do xs <- runCpphsPass1 cpphsOptions originalFileName input+       let bopts = boolopts cpphsOptions+           toks = tokenise (stripEol bopts) (stripC89 bopts) (ansi bopts) (lang bopts) ((newfile "preDefined",""):xs)+           mi = poorManAnalyzeTokens toks+       return (mi, toks, xs)++analyzeTests =+    [(unlines ["module FOO where"+              ,"import Test.Framework"+              ,"import {-@ HTF_TESTS @-} qualified Foo as Bar"+              ,"import {-@ HTF_TESTS @-} qualified Foo.X as Egg"+              ,"import {-@ HTF_TESTS @-} Foo.Y as Spam"+              ,"import {-@ HTF_TESTS @-} Foo.Z"+              ,"import {-@ HTF_TESTS @-} Baz"+              ,"deriveSafeCopy 1 'base ''T"+              ,"$(deriveSafeCopy 2 'extension ''T)"+              ,"test_blub test_foo = 1"+              ,"test_blah test_foo = '\''"+              ,"prop_abc prop_foo = 2"+              ,"prop_xyz = True"]+     ,ModuleInfo { mi_htfPrefix = ""+                 , mi_htfImports =+                     [ImportDecl { imp_moduleName = "Foo"+                                 , imp_qualified = True+                                 , imp_alias = Just "Bar"+                                 , imp_loc = makeLoc "<input>" 3}+                     ,ImportDecl { imp_moduleName = "Foo.X"+                                 , imp_qualified = True+                                 , imp_alias = Just "Egg"+                                 , imp_loc = makeLoc "<input>" 4}+                     ,ImportDecl { imp_moduleName = "Foo.Y"+                                 , imp_qualified = False+                                 , imp_alias = Just "Spam"+                                 , imp_loc = makeLoc "<input>" 5}+                     ,ImportDecl { imp_moduleName = "Foo.Z"+                                 , imp_qualified = False+                                 , imp_alias = Nothing+                                 , imp_loc = makeLoc "<input>" 6}+                     ,ImportDecl { imp_moduleName = "Baz"+                                 , imp_qualified = False+                                 , imp_alias = Nothing+                                 , imp_loc = makeLoc "<input>" 7}]+                 , mi_moduleName = Just "FOO"+                 , mi_defs = [TestDef "blub" (makeLoc "<input>" 10) "test_blub"+                             ,TestDef "blah" (makeLoc "<input>" 11) "test_blah"+                             ,PropDef "abc" (makeLoc "<input>" 12) "prop_abc"+                             ,PropDef "xyz" (makeLoc "<input>" 13) "prop_xyz"]+                 })+    ,(unlines ["module Foo.Bar where"+              ,"import Test.Framework as Blub"+              ,"prop_xyz = True"]+     ,ModuleInfo { mi_htfPrefix = ""+                 , mi_htfImports = []+                 , mi_moduleName = Just "Foo.Bar"+                 , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"]+                 })+    ,(unlines ["module Foo.Bar where"+              ,"import qualified Test.Framework as Blub"+              ,"prop_xyz = True"]+     ,ModuleInfo { mi_htfPrefix = "Blub."+                 , mi_htfImports = []+                 , mi_moduleName = Just "Foo.Bar"+                 , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"]+                 })+    ,(unlines ["module Foo.Bar where"+              ,"import qualified Test.Framework"+              ,"prop_xyz = True"]+     ,ModuleInfo { mi_htfPrefix = "Test.Framework."+                 , mi_htfImports = []+                 , mi_moduleName = Just "Foo.Bar"+                 , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"]+                 })]++testAnalyze =+    do mapM_ runTest (zip [1..] analyzeTests)+    where+      runTest (i, (src, mi)) =+          do (givenMi, _, _) <- analyze "<input>" src+             if givenMi == mi+             then return ()+             else assertFailure ("Error in test " ++ show i +++                                 ", expected:\n" ++ show mi +++                                 "\nGiven:\n" ++ show givenMi +++                                 "\nSrc:\n" ++ src)++cpphsOptions :: CpphsOptions+cpphsOptions =+    defaultCpphsOptions {+      boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell+    }++data TransformOptions = TransformOptions { debug :: Bool+                                         , literateTex :: Bool }++transform :: TransformOptions -> FilePath -> String -> IO String+transform (TransformOptions debug literateTex) originalFileName input =+    do (info, toks, pass1) <- analyze originalFileName fixedInput+       preprocess info toks pass1+    where+      preprocess info toks pass1 =+          do when debug $+                  do hPutStrLn stderr ("Tokens: " ++ show toks)+                     hPutStrLn stderr ("Module info:\n" ++ show info)+             let opts = mkOptionsForModule info+             preProcessedInput <-+                 runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1+             return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n"+      -- 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-              -- 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 =+            fixLine s =+                case parseCppLineInfoOut s of+                  Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName+                  _ -> s+      mkOptionsForModule :: ModuleInfo -> CpphsOptions+      mkOptionsForModule info =           defaultCpphsOptions { defines =                                     defines defaultCpphsOptions ++-                                    assertDefines hunitBackwardsCompat (mi_htfPrefix info) ++                                     nameDefines info+                              , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell                               }+      possiblyWrap :: Bool -> String -> String+      possiblyWrap b s = if b then "\\begin{code}\n" ++ s ++ "\\end{code}" else s       additionalCode :: ModuleInfo -> String       additionalCode info =-          thisModulesTestsFullName (mi_moduleName info) ++ " :: " +++          thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++             mi_htfPrefix info ++ "TestSuite\n" ++-          thisModulesTestsFullName (mi_moduleName info) ++ " = " +++          thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " = " ++             mi_htfPrefix info ++ "makeTestSuite" ++-          " " ++ show (mi_moduleName info) +++          " " ++ show (mi_moduleNameWithDefault info) ++           " [\n" ++ List.intercalate ",\n"                           (map (codeForDef (mi_htfPrefix info)) (mi_defs info))           ++ "\n  ]\n" ++ importedTestListCode info@@ -215,8 +407,7 @@           " " ++ name       codeForDef pref (PropDef s loc name) =           locPragma loc ++ pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++-          codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++-          pref ++ "asTestableWithQCArgs " ++ name ++ "))"+          codeForLoc pref loc ++ " (" ++ pref ++ "qcAssertion " ++ name ++ ")"       locPragma :: Location -> String       locPragma loc =           "{-# LINE " ++ show (lineNumber loc) ++ " " ++ show (fileName loc) ++ " #-}\n    "@@ -228,9 +419,9 @@           let l = mi_htfImports info           in case l of                [] -> ""-               _ -> (importedTestListFullName (mi_moduleName info)+               _ -> (importedTestListFullName (mi_moduleNameWithDefault info)                      ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++-                     importedTestListFullName (mi_moduleName info)+                     importedTestListFullName (mi_moduleNameWithDefault info)                      ++ " = [\n    " ++                      List.intercalate ",\n     " (map htfTestsInModule l) ++                      "\n  ]\n")@@ -242,3 +433,25 @@             (False, _) -> name             (True, Just alias) -> alias ++ "." ++ name             (True, _) -> imp_moduleName imp ++ "." ++ name++-- 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++preprocessorTests =+    [("testAnalyze", testAnalyze)]
Test/Framework/Pretty.hs view
@@ -1,4 +1,21 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}+--+-- Copyright (c) 2005-2022   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+--  {- | @@ -19,7 +36,12 @@  where +#if MIN_VERSION_base(4,11,0)+-- Text.PrettyPrint exports (<>) conflicting with newer Prelude.+import Text.PrettyPrint hiding ((<>))+#else import Text.PrettyPrint+#endif  -- | A type class for pretty-printable things. -- Minimal complete definition: @pretty@.
+ Test/Framework/PrettyHaskell.hs view
@@ -0,0 +1,103 @@+{- |+Internal module for pretty-printing showable Haskell values.+-}+--+-- Copyright (c) 2009-2022 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.PrettyHaskell (++    prettyHaskell, prettyHaskell', prettyHaskellTests++) where++import qualified Data.List as List+import Language.Haskell.Parser+import Language.Haskell.Pretty+import Test.HUnit+import Test.Framework.Utils++prettyHaskell :: Show a => a -> String+prettyHaskell x =+    case prettyHaskell' x of+      Just s -> s+      Nothing -> "FALLBACK: " ++ show x++prettyHaskell' :: Show a => a -> Maybe String+prettyHaskell' x =+    fmap (postProcess (show x)) (prettyHaskell'' x )++prettyHaskell'' :: Show a => a -> Maybe String+prettyHaskell'' x =+    let str = show x+        code = "module M where TOP = " ++ str+    in case parseModule code of+         ParseOk x -> Just (prettyPrint x)+         ParseFailed _ _ -> Nothing++postProcess :: String -> String -> String+postProcess fallback s =+    case dropWhile (\l -> not ('=' `elem` l)) (lines s) of+      [] -> fallback+      (l:ls) ->+          case List.span (/= '=') l of+            (prefix, '=':' ':suffix) ->+                let indentLen = length prefix + 2+                in strip $ unlines (suffix : (map (drop indentLen) ls))+            _ -> fallback++prettyHaskellTests =+    [("testPrettyHaskell", testPrettyHaskell)]++data MySuperHero+    = MySuperHero+      { msh_age :: Int+      , msh_name :: String+      , msh_address :: String+      , msh_fun :: Int+      }+    deriving (Show)++data MySuperSuperHero+    = MySuperSuperHero+      { mssh_isHere :: Bool+      , mssh_hero :: MySuperHero+      }+    deriving (Show)++testPrettyHaskell =+    do assertPretty "Just 1" (Just 1)+       let hero =+               MySuperHero+               { msh_age = 35+               , msh_name = "FOO"+               , msh_address = "address"+               , msh_fun = 1+               }+       assertPretty+         ("MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" +++          "            msh_address = \"address\", msh_fun = 1}")+         hero+       assertPretty+          ("MySuperSuperHero{mssh_isHere = True,\n" +++           "                 mssh_hero =\n" +++           "                   MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" +++           "                               msh_address = \"address\", msh_fun = 1}}")+          (MySuperSuperHero { mssh_isHere = True, mssh_hero = hero })+    where+      assertPretty s x =+          assertEqual (s ++ " /=\n" ++ prettyHaskell x)+                      s (prettyHaskell x)
Test/Framework/Process.hs view
@@ -67,8 +67,8 @@     --  data gets pulled as it becomes available. you have to force the     --  output strings before waiting for the process to terminate.     ---    forkIO (Control.Exception.evaluate (length output) >> return ())-    forkIO (Control.Exception.evaluate (length errput) >> return ())+    _ <- forkIO (Control.Exception.evaluate (length output) >> return ())+    _ <- forkIO (Control.Exception.evaluate (length errput) >> return ())      -- And now we wait. We must wait after we read, unsurprisingly.     ecode <- waitForProcess pid -- blocks without -threaded, you're warned.
Test/Framework/QuickCheckWrapper.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification,-             DeriveDataTypeable,ScopedTypeVariables,CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  ----- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 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@@ -32,14 +36,20 @@    -- * Arguments for evaluating properties   defaultArgs, getCurrentArgs, setDefaultArgs,-  withQCArgs,+  withQCArgs, WithQCArgs, setReplayFromString,+  QCAssertion,    -- * Pending properties   qcPending, +  -- * Auxiliary functions+#if !MIN_VERSION_QuickCheck(2,7,0)+  ioProperty,+#endif+  assertionAsProperty,+   -- * Internal functions-  testableAsAssertion, asTestableWithQCArgs,-  TestableWithQCArgs, WithQCArgs+  qcAssertion  ) where @@ -52,17 +62,25 @@ import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO)-import Control.Concurrent.MVar+import Data.IORef  import Test.QuickCheck+#if !MIN_VERSION_QuickCheck(2,7,0)+import Test.QuickCheck.Property (morallyDubiousIOProperty)+#endif+import Test.Framework.TestInterface+import Test.Framework.Utils -import Test.Framework.TestManager-import Test.Framework.TestManagerInternal+_DEBUG_ :: Bool+_DEBUG_ = False -data QCState = QCState { qc_args :: Args }+debug :: String -> IO ()+debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return () -qcState :: MVar QCState-qcState = unsafePerformIO (newMVar (QCState defaultArgs))+data QCState = QCState { qc_args :: !Args }++qcState :: IORef QCState+qcState = unsafePerformIO (newIORef (QCState defaultArgs)) {-# NOINLINE qcState #-}  -- | The 'Args' used if not explicitly changed.@@ -72,63 +90,91 @@ -- | Change the default 'Args' used to evaluate quick check properties. setDefaultArgs :: Args -> IO () setDefaultArgs args =-    do withMVar qcState $ \state -> return (state { qc_args = args })-       return ()+    do force <- atomicModifyIORef qcState $ \state ->+                  let newState = state { qc_args = args }+                  in (newState, newState)+       force `seq` return ()  -- | Retrieve the 'Args' currently used per default when evaluating quick check properties. getCurrentArgs :: IO Args getCurrentArgs =-    withMVar qcState $ \state -> return (qc_args state)+    do state <- readIORef qcState+       return (qc_args state)  data QCPendingException = QCPendingException String                         deriving (Show,Read,Eq,Typeable)  instance Exception QCPendingException +quickCheckTestError :: Maybe String -> Assertion+quickCheckTestError m = failHTF $ mkFullTestResult Error m++quickCheckTestFail :: Maybe String -> Assertion+quickCheckTestFail m = failHTF $ mkFullTestResult Fail m++quickCheckTestPending :: String -> Assertion+quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m)++quickCheckTestPass :: String -> Assertion+quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m)+ -- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function -- is used internally in the code generated by @htfpp@, do not use it directly.-testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion-testableAsAssertion t =-    withMVar qcState $ \state ->-        do eitherArgs <--               (let a = (argsModifier t) (qc_args state)-                in do evaluate (length (show a))-                      return (Right a))-               `catch`-               (\e -> return $ Left (show (e :: SomeException)))-           case eitherArgs of-             Left err -> quickCheckTestError-                            (Just ("Cannot evaluate custom arguments: "-                                   ++ err))-             Right args ->-                 do res <- do t' <- evaluate t-                              x <- quickCheckWithResult args t'-                              return (Right x)-                          `catches`-                           [Handler $ \(QCPendingException msg) -> return $ Left (True, msg)-                           ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]-                    case res of-                      Left (isPending, err) ->-                          if isPending-                             then quickCheckTestPending err-                             else quickCheckTestError (Just err)-                      Right (Success { output=msg }) ->-                          quickCheckTestPass (adjustOutput msg)-                      Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=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-                             else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))-                                     quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))-                      Right (GaveUp { output=msg }) ->-                          quickCheckTestFail (Just (adjustOutput msg))-                      Right (NoExpectedFailure { output=msg }) ->-                          quickCheckTestFail (Just (adjustOutput msg))-                    return ()+qcAssertion :: (QCAssertion t) => t -> Assertion+qcAssertion qc =+    do origArgs <- getCurrentArgs+       eitherArgs <-+           (let a = (argsModifier qc) origArgs+            in do _ <- evaluate (length (show a))+                  return (Right a))+           `catch`+           (\e -> return $ Left (show (e :: SomeException)))+       case eitherArgs of+         Left err -> quickCheckTestError+                        (Just ("Cannot evaluate custom arguments: "+                               ++ err))+         Right args ->+             do res <- do anyTestable <- evaluate (testable qc)+                          x <- case anyTestable of+                                 AnyTestable t' -> quickCheckWithResult args t'+                          return (Right x)+                      `catches`+                       [Handler $ \(QCPendingException msg) -> return $ Left msg]+                debug ("QuickCheck result: " ++ show res)+                case res of+                  Left err ->+                      quickCheckTestPending err+                  Right (Success { output=msg }) ->+                      quickCheckTestPass (adjustOutput msg)+                  Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->+                      case () of+                        _| pendingPrefix `List.isPrefixOf` reason ->+                             let pendingMsg = getPayload pendingPrefix pendingSuffix reason+                             in quickCheckTestPending pendingMsg+                         | failurePrefix `List.isPrefixOf` reason+                         , Just result <- readM (getPayload failurePrefix failureSuffix reason)+                            -> failHTF result+                         | otherwise ->+                             let replay = "Replay argument: " ++ (show (show (Just (gen, size))))+                                 out = adjustOutput msg+                             in quickCheckTestFail (Just (out ++ "\n" ++ replay))+                  Right (GaveUp { output=msg }) ->+                      quickCheckTestFail (Just (adjustOutput msg))+                  Right (NoExpectedFailure { output=msg }) ->+                      quickCheckTestFail (Just (adjustOutput msg))+#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)+                  Right (InsufficientCoverage { output=msg }) ->+                      quickCheckTestFail (Just (adjustOutput msg))+#endif+                return ()     where       pendingPrefix = "Exception: 'QCPendingException \""       pendingSuffix = "\"'"+      failurePrefix = "Exception: 'HTFFailure "+      failureSuffix = "'"+      getPayload pref suf reason =+          let s = drop (length pref) reason+          in take (length s - length suf) s       adjustOutput s = trimTrailing $           case s of             '+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest@@ -139,41 +185,58 @@  -- | Abstract type for representing quick check properties with custom 'Args'. --   Used only internally.-data TestableWithQCArgs = forall a . Testable a =>-                          TestableWithQCArgs (Args -> Args) a+data WithQCArgs a = WithQCArgs (Args -> Args) a -instance Testable TestableWithQCArgs where-    property (TestableWithQCArgs _ t) = property t+-- | Existential holding a 'Testable' value.+--   Used only internally.+data AnyTestable = forall a . Testable a => AnyTestable a  -- | Type class providing access to the custom 'Args' of a quick check property. --   Used only internally.-class WithQCArgs a where+class QCAssertion a where     argsModifier :: a -> (Args -> Args)-    original :: a -> Maybe TestableWithQCArgs+    testable :: a -> AnyTestable -instance WithQCArgs a where+instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where     argsModifier _ = id-    original _ = Nothing+    testable = AnyTestable -instance WithQCArgs TestableWithQCArgs where-    argsModifier (TestableWithQCArgs f _) = f-    original a = Just a+instance {-# OVERLAPPING  #-} Testable a => QCAssertion (WithQCArgs a) where+    argsModifier (WithQCArgs f _) = f+    testable (WithQCArgs _ x) = AnyTestable x  -- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.-withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'-           -> a                                            -- ^ Property-           -> TestableWithQCArgs-withQCArgs = TestableWithQCArgs---- | Turns a 'Test.QuickCheck' property with custom 'Args' into an 'Assertion'. This function--- is used internally in the code generated by @htfpp@, do not use it directly.-asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs-asTestableWithQCArgs a =-    case original a of-      Just a' -> a'-      Nothing -> TestableWithQCArgs id a+withQCArgs :: (Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'+           -> a                              -- ^ Property+           -> WithQCArgs a+withQCArgs = WithQCArgs  -- | Use @qcPending msg prop@ to mark the given quick check property as pending -- without removing it from the test suite and without deleting or commenting out the property code. qcPending :: Testable t => String -> t -> t qcPending msg _ = throw (QCPendingException msg)++#if !MIN_VERSION_QuickCheck(2,7,0)+ioProperty :: Testable prop => IO prop -> Property+ioProperty = morallyDubiousIOProperty+#endif++assertionAsProperty :: IO () -> Property+assertionAsProperty action =+    ioProperty $ action >> return True++-- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string.+setReplayFromString :: Args -> String -> Args+setReplayFromString args str =+#if !MIN_VERSION_QuickCheck(2,7,0)+    case readM str of+      Just x -> args { replay = x }+      Nothing -> error ("Could not parse replay parameter from string " ++ show str)+#else+    -- Starting with QC 2.7 the type of the replay field changed from+    -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)'+    case readM str of+      Just x -> args { replay = x }+      Nothing ->+          error ("Could not parse replay parameter from string " ++ show str)+#endif
+ Test/Framework/TestInterface.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+--+-- Copyright (c) 2009-2022   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 API for HTF tests, i.e. unit tests and quickcheck properties.++This functionality is mainly used internally in the code+generated by the @hftpp@ pre-processor.+-}++module Test.Framework.TestInterface (++    Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..)+  , HtfStackEntry(..), HtfStack, emptyHtfStack, mkHtfStack, formatHtfStack+  , failureLocationFromStack, failureLocation+  , restCallStack, htfStackToList+  , failHTF, subAssertHTF, addCallerToSubAssertStack+  , mkFullTestResult++) where++import Test.Framework.Location+import Test.Framework.Colors++import Control.Monad.Trans.Control+import Data.Typeable+import GHC.Stack+import qualified Data.List as L+import qualified Control.Exception as Exc+import qualified Control.Exception.Lifted as ExcLifted++{- | An assertion is just an 'IO' action. Internally, the body of any test+in HTF is of type 'Assertion'. If a test specification of a certain plugin+has a type different from 'Assertion', the plugin's preprocessor pass must+inject wrapper code to convert the test specification into an assertion.++Assertions may use 'failHTF' to signal a 'TestResult' different from+'Pass'. If the assertion finishes successfully, the tests passes+implicitly.++Please note: the assertion must not swallow any exceptions! Otherwise,+timeouts and other things might not work as expected.+-}+type Assertion = IO ()++-- | The summary result of a test.+data TestResult = Pass | Pending | Fail | Error+                deriving (Show, Read, Eq)++data HtfStackEntry+    = HtfStackEntry+    { hse_location :: Location+    , hse_calledFunction :: String+    , hse_message :: Maybe String+    } deriving (Eq, Ord, Show, Read)++-- The first entry in the list is the location of the assertion failure+data HtfStack+    = HtfStack+      { hs_assertStack :: [HtfStackEntry]+      , hs_subAssertStack :: [HtfStackEntry]+      }+    deriving (Eq, Ord, Show, Read)++mkHtfStack :: CallStack -> HtfStack+mkHtfStack cs = HtfStack (map mkHtfStackEntry (removeHtfPrefix (getCallStack cs))) []++removeHtfPrefix :: [(String, SrcLoc)] -> [(String, SrcLoc)]+removeHtfPrefix [] = []+removeHtfPrefix all@((_, srcLoc) : rest) =+    if "Test.Framework" `L.isPrefixOf` srcLocModule srcLoc+    then removeHtfPrefix rest+    else all++mkHtfStackEntry :: (String, SrcLoc) -> HtfStackEntry+mkHtfStackEntry x = mkHtfStackEntry' x Nothing++mkHtfStackEntry' :: (String, SrcLoc) -> Maybe String -> HtfStackEntry+mkHtfStackEntry' (funName, srcLoc) mMsg =+    HtfStackEntry+    { hse_location = makeLoc (srcLocFile srcLoc) (srcLocStartLine srcLoc)+    , hse_calledFunction = funName+    , hse_message = mMsg+    }++htfStackToList :: HtfStack -> [HtfStackEntry]+htfStackToList s = hs_assertStack s ++ reverse (hs_subAssertStack s)++emptyHtfStack :: HtfStack+emptyHtfStack = HtfStack [] []++failureLocation :: HasCallStack => Maybe Location+failureLocation = failureLocationFromStack (mkHtfStack callStack)++failureLocationFromStack :: HtfStack -> Maybe Location+failureLocationFromStack stack =+    case htfStackToList stack of+      [] -> Nothing+      e:_ -> Just (hse_location e)++restCallStack :: HtfStack -> [HtfStackEntry]+restCallStack stack =+    case htfStackToList stack of+      [] -> []+      _:rest -> rest++-- | Formats a stack trace.+formatHtfStack :: HtfStack -> String+formatHtfStack stack =+    unlines $ map formatStackElem $ zip [0..] $ htfStackToList stack+    where+      formatStackElem (pos, HtfStackEntry loc _ mMsg) =+          let pref = if pos > 0 then "  called from " else "  at "+          in pref ++ showLoc loc ++ showMsg mMsg+      showMsg Nothing = ""+      showMsg (Just m) = " (" ++ m ++ ")"++-- | The full result of a test, as used by HTF plugins.+data FullTestResult+    = FullTestResult+      { ftr_stack :: HtfStack                  -- ^ The stack to the location of a possible failure+      , ftr_message :: Maybe ColorString       -- ^ An error message+      , ftr_result :: Maybe TestResult         -- ^ The outcome of the test, 'Nothing' means timeout+      } deriving (Eq, Show, Read)++-- | Auxiliary function for contructing a 'FullTestResult'.+mkFullTestResult :: TestResult -> Maybe String -> FullTestResult+mkFullTestResult r msg =+    FullTestResult+    { ftr_stack = emptyHtfStack+    , ftr_message = fmap noColor msg+    , ftr_result = Just r+    }++-- Internal exception type for propagating exceptions.+data HTFFailureException+    = HTFFailure FullTestResult+      deriving (Show, Typeable)++instance Exc.Exception HTFFailureException++{- |+Terminate a HTF test, usually to signal a failure. The result of the test+is given in the 'FullTestResult' argument.+-}+failHTF :: MonadBaseControl IO m => FullTestResult -> m a+-- Important: force the string argument, otherwise an error embedded+-- lazily inside the string might escape.+failHTF r = length (show r) `seq` ExcLifted.throwIO (HTFFailure r)++addCallerToSubAssertStack :: CallStack -> HtfStack -> Maybe String -> HtfStack+addCallerToSubAssertStack ghcStack stack@(HtfStack s1 s2) mMsg =+    case removeHtfPrefix (getCallStack ghcStack) of+      [] -> stack+      (entry : _) -> HtfStack s1 ((mkHtfStackEntry' entry mMsg) : s2)++{- |+Opens a new assertion stack frame to allow for sensible location information.+This function should be used if the function being called does not carry+a 'HasCallStack' annotation.+-}+subAssertHTF :: (HasCallStack, MonadBaseControl IO m) => Maybe String -> m a -> m a+subAssertHTF mMsg action =+    let stack = callStack+    in action `ExcLifted.catch`+                  (\(HTFFailure res) ->+                       let newRes =+                               res { ftr_stack =+                                         addCallerToSubAssertStack stack (ftr_stack res) mMsg }+                       in failHTF newRes)
Test/Framework/TestManager.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} ----- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022   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@@ -20,7 +22,9 @@  This module defines function for running a set of tests. Furthermore, it provides functionality for organzing tests into a hierarchical-structure. This functionality is mainly used internally in the code+structure.++This functionality is mainly used internally in the code generated by the @hftpp@ pre-processor. -} @@ -30,48 +34,62 @@   module Test.Framework.TestTypes,    -- * Running tests-  htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',+  htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs',   runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',    -- * Organzing tests   TestableHTF,+  WrappableHTF(..),    makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,   makeAnonTestSuite,   addToTestSuite, testSuiteAsTest, +  flattenTest,++  -- * Tests (for internal use)+  wrappableTests ) where  import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs)-import Control.Exception (finally)+import qualified Control.Exception as Exc+import Data.Maybe+import Data.Time+import qualified Data.List as List+import qualified Data.ByteString as BS+import Data.IORef+import Control.Concurrent  import System.IO -import qualified Test.HUnit.Lang as HU- import Test.Framework.Utils-import Test.Framework.TestManagerInternal+import Test.Framework.TestInterface import Test.Framework.TestTypes import Test.Framework.CmdlineOptions import Test.Framework.TestReporter import Test.Framework.Location+import Test.Framework.Colors+import Test.Framework.ThreadPool+import Test.Framework.History +import qualified Test.HUnit as HU -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test-makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass+makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass  -- | Construct a unit test from the given 'IO' action. -- Mainly used internally by the htfpp preprocessor.-makeUnitTest :: TestID -> Location -> IO a -> Test-makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())+makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test+makeUnitTest id loc ass =+    BaseTest UnitTest id (Just loc) (testOptions ass) (assertion ass)  -- | Construct a black box test from the given 'Assertion'. -- Mainly used internally. makeBlackBoxTest :: TestID -> Assertion -> Test-makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass+makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass  -- | Create a named 'TestSuite' from a list of 'Test' values. makeTestSuite :: TestID -> [Test] -> TestSuite@@ -90,6 +108,26 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') +-- | Kind of specialised 'Functor' type class for tests, which allows you to+-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any+-- test code.+--+-- E.g. if you want to add timeouts to all tests of a module, you could write:+--+-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded"+-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests+class WrappableHTF t where+    wrap :: (Assertion -> Assertion) -> t -> t++instance WrappableHTF TestSuite where+    wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests+    wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests++instance WrappableHTF Test where+    wrap wrapper (BaseTest ts tid loc topt assertion) =+        BaseTest ts tid loc topt (wrapper assertion)+    wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite+ -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where@@ -108,8 +146,8 @@     flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)  flattenTest :: Test -> [FlatTest]-flattenTest (BaseTest sort id mloc x) =-    [FlatTest sort (TestPathBase id) mloc x]+flattenTest (BaseTest sort id mloc opts x) =+    [FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)] flattenTest (CompoundTest ts) =     flattenTestSuite ts @@ -121,39 +159,198 @@     let fts = concatMap flattenTest ts     in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -runFlatTest :: FlatTest -> TR FlatTestResult-runFlatTest ft =-    do reportTestStart ft-       (res, time) <- liftIO $ measure $ HU.performTestCase (ft_payload ft)-       let (testResult, (mLoc, callers, msg)) =-             case res of-               Nothing -> (Pass, (Nothing, [], ""))-               Just (isFailure, msg') ->-                   if ft_sort ft /= QuickCheckTest-                      then let utr = deserializeHUnitMsg msg'-                               r = case () of-                                     _| utr_pending utr -> Pending-                                      | isFailure -> Fail-                                      | otherwise -> Error-                           in (r, (utr_location utr, utr_callingLocations utr, utr_message utr))-                      else let (r, s) = deserializeQuickCheckMsg msg'-                           in (r, (Nothing, [], s))-           rr = FlatTest-                  { ft_sort = ft_sort ft-                  , ft_path = ft_path ft-                  , ft_location = ft_location ft-                  , ft_payload = RunResult testResult mLoc callers msg time }-       return rr+maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds+maxRunTime tc ft =+    let mt1 = tc_maxSingleTestTime tc+        mt2 =+            case tc_prevFactor tc of+              Nothing -> Nothing+              Just d ->+                  case max (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey ft) (tc_history tc)))+                           (fmap htr_timeMs (findHistoricTestResult (historyKey ft) (tc_history tc)))+                  of+                    Nothing -> Nothing+                    Just t -> Just $ ceiling (fromInteger (toInteger t) * d)+    in case (mt1, mt2) of+         (Just t1, Just t2) -> Just (min t1 t2)+         (_, Nothing) -> mt1+         (Nothing, _) -> mt2 -handleRunResult :: FlatTestResult -> TR ()-handleRunResult r =-    do modify (\s -> s { ts_results = r : ts_results s })-       reportTestResult r+-- | HTF uses this function to execute the given assertion as a HTF test.+performTestHTF :: Assertion -> IO FullTestResult+performTestHTF action =+    do action+       return (mkFullTestResult Pass Nothing)+     `Exc.catches`+      [Exc.Handler (\(HTFFailure res) -> return res)+      ,Exc.Handler handleUnexpectedException]+    where+      handleUnexpectedException exc =+          case Exc.fromException exc of+            Just (async :: Exc.AsyncException) ->+                case async of+                  Exc.StackOverflow -> exceptionAsError exc+                  _ -> Exc.throwIO exc+            _ -> exceptionAsError exc+      exceptionAsError exc =+          return (mkFullTestResult Error (Just $ show (exc :: Exc.SomeException))) +data TimeoutResult a+    = TimeoutResultOk a+    | TimeoutResultException Exc.SomeException+    | TimeoutResultTimeout++timeout :: Int -> IO a -> IO (Maybe a)+timeout microSecs action+    | microSecs < 0 = fmap Just action+    | microSecs == 0 = return Nothing+    | otherwise =+        do resultChan <- newChan+           finishedVar <- newIORef False+           workerTid <- forkIO (wrappedAction resultChan finishedVar)+           _ <- forkIO (threadDelay microSecs >> writeChan resultChan TimeoutResultTimeout)+           res <- readChan resultChan+           case res of+             TimeoutResultTimeout ->+                 do atomicModifyIORef finishedVar (\_ -> (True, ()))+                    killThread workerTid+                    return Nothing+             TimeoutResultOk x ->+                 return (Just x)+             TimeoutResultException exc ->+                 Exc.throwIO exc+    where+      wrappedAction resultChan finishedVar =+          Exc.mask $ \restore ->+                   (do x <- restore action+                       writeChan resultChan (TimeoutResultOk x))+                   `Exc.catch`+                   (\(exc::Exc.SomeException) ->+                        do b <- shouldReraiseException exc finishedVar+                           if b then Exc.throwIO exc else writeChan resultChan (TimeoutResultException exc))+      shouldReraiseException exc finishedVar =+          case Exc.fromException exc of+            Just (async :: Exc.AsyncException) ->+                case async of+                  Exc.ThreadKilled -> atomicModifyIORef finishedVar (\old -> (old, old))+                  _ -> return False+            _ -> return False++data PrimTestResult+    = PrimTestResultNoTimeout FullTestResult+    | PrimTestResultTimeout++mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)+mkFlatTestRunner tc ft = (pre, action, post)+    where+      pre = reportTestStart ft+      action _ =+          let run = performTestHTF (wto_payload (ft_payload ft))+              runWithTimeout =+                  case maxRunTime tc ft of+                    Nothing ->+                        do (res, time) <- measure run+                           return (PrimTestResultNoTimeout res, time)+                    Just maxMs ->+                         do mx <- timeout (1000 * maxMs) $ measure run+                            case mx of+                              Nothing -> return (PrimTestResultTimeout, maxMs)+                              Just (res, time) ->+                                  return (PrimTestResultNoTimeout res, time)+              isPass primTestRes =+                  case primTestRes of+                    PrimTestResultNoTimeout fullTestRes ->+                        ftr_result fullTestRes == Just Pass+                    PrimTestResultTimeout -> False+              iterRunWithTimeout i =+                  do (primTestRes, time) <- runWithTimeout+                     if isPass primTestRes && i >= 2+                       then iterRunWithTimeout (i-1)+                       else return (primTestRes, time)+          in iterRunWithTimeout (tc_repeat tc)+      post excOrResult =+          let (testResult, time) =+                 case excOrResult of+                   Left exc ->+                       (FullTestResult+                        { ftr_stack = emptyHtfStack+                        , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc)+                        , ftr_result = Just Error+                        }+                       ,(-1))+                   Right (res, time) ->+                       case res of+                         PrimTestResultTimeout ->+                             (FullTestResult+                              { ftr_stack = emptyHtfStack+                              , ftr_message = Just $ colorize warningColor "timeout"+                              , ftr_result = Nothing+                              }+                             ,time)+                         PrimTestResultNoTimeout res ->+                             let res' =+                                     if isNothing (ftr_message res) && isNothing (ftr_result res)+                                     then res { ftr_message = Just (colorize warningColor "timeout") }+                                     else res+                             in (res', time)+              (sumRes, isTimeout) =+                  case ftr_result testResult of+                    Just x -> (x, False)+                    Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True)+              rr = FlatTest+                     { ft_sort = ft_sort ft+                     , ft_path = ft_path ft+                     , ft_location = ft_location ft+                     , ft_payload = RunResult sumRes (ftr_stack testResult)+                                              (fromMaybe emptyColorString (ftr_message testResult))+                                              time isTimeout+                     }+          in do modify (\s -> s { ts_results = rr : ts_results s })+                reportTestResult rr+                return (stopFlag sumRes)+      stopFlag result =+          if not (tc_failFast tc)+          then DoNotStop+          else case result of+                 Pass -> DoNotStop+                 Pending -> DoNotStop+                 Fail -> DoStop+                 Error -> DoStop+ runAllFlatTests :: [FlatTest] -> TR ()-runAllFlatTests tests =-    do reportGlobalStart tests-       mapM_ (\ft -> runFlatTest ft >>= handleRunResult) tests+runAllFlatTests tests' =+    do tc <- ask+       tests <- orderTests tc tests'+       reportGlobalStart tests+       case tc_threads tc of+         Nothing ->+             let entries = map (mkFlatTestRunner tc) tests+             in tp_run sequentialThreadPool entries+         Just i ->+             let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests+                 pentries = map (mkFlatTestRunner tc) ptests+                 sentries = map (mkFlatTestRunner tc) stests+             in do tp <- parallelThreadPool i+                   tp_run tp pentries+                   tp_run sequentialThreadPool sentries+    where+      orderTests tc ts+          | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts+          | tc_shuffle tc = shuffleTests ts+          | otherwise = return ts+      shuffleTests = liftIO . shuffleIO+      sortByPrevTime tc ts =+              map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts)+      compareTests tc (t1, _) (t2, _) =+          case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc)))+                    (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc)))+               ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc)))+                    (fmap htr_timeMs (findHistoricTestResult t2 (tc_history tc))))+          of+            (Just t1, Just t2) -> compare t1 t2+            (Just _, Nothing) -> GT+            (Nothing, Just _) -> LT+            (Nothing, Nothing) -> EQ  -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t              -- ^ Testable thing@@ -209,13 +406,19 @@                    (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)+                      else do (printSummary, ecode, history) <- runTestWithConfig' tc t+                              storeHistory (tc_historyFile tc) history+                              return (printSummary, ecode))+               return (printSummary `Exc.finally` cleanup tc, ecode)     where       cleanup tc =           case tc_output tc of             TestOutputHandle h True -> hClose h             _ -> return ()+      storeHistory file history =+          BS.writeFile file (serializeTestHistory history)+          `Exc.catch` (\(e::Exc.IOException) ->+                          hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e))  -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,@@ -224,32 +427,59 @@ -- -- 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.-runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode+runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory) runTestWithConfig tc t =-    do (printSummary, ecode) <- runTestWithConfig' tc t+    do (printSummary, ecode, history) <- runTestWithConfig' tc t        printSummary-       return ecode+       return (ecode, history)  -- | 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' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory) runTestWithConfig' tc t =-     do ((_, s, _), time) <-+     do let allTests = flatten t+            activeTests = filter (tc_filter tc) allTests+            filteredTests = filter (not . tc_filter tc) allTests+        startTime <- getCurrentTime+        ((_, s, _), time) <-             measure $-            runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState+            runRWST (runAllFlatTests activeTests) tc initTestState         let results = reverse (ts_results s)             passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results             pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results             failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results             error = filter (\ft -> (rr_result . ft_payload) ft == Error) results+            timedOut = filter (\ft -> (rr_timeout . ft_payload) ft) results+            arg = ReportGlobalResultsArg+                  { rgra_timeMs = time+                  , rgra_passed = passed+                  , rgra_pending = pending+                  , rgra_failed = failed+                  , rgra_errors = error+                  , rgra_timedOut = timedOut+                  , rgra_filtered = filteredTests+    }         let printSummary =-                runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run+                runRWST (reportGlobalResults arg) tc (TestState [] (ts_index s)) -- keep index from run+            !newHistory = updateHistory startTime results (tc_history tc)         return (printSummary >> return (),                 case () of                    _| length failed == 0 && length error == 0 -> ExitSuccess                     | length error == 0 -> ExitFailure 1-                    | otherwise -> ExitFailure 2)+                    | otherwise -> ExitFailure 2+               ,newHistory)+    where+      updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory+      updateHistory time results history =+          let runHistory = mkTestRunHistory time (map (\res -> HistoricTestResult {+                                                                 htr_testId = historyKey res+                                                               , htr_result = rr_result (ft_payload res)+                                                               , htr_timedOut = rr_timeout (ft_payload res)+                                                               , htr_timeMs = rr_wallTimeMs (ft_payload res)+                                                               })+                                                      results)+          in updateTestHistory runHistory history  -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.@@ -257,5 +487,22 @@ htfMain :: TestableHTF t => t -> IO () htfMain tests =     do args <- getArgs-       ecode <- runTestWithArgs args tests+       htfMainWithArgs args tests++-- | Runs something testable by parsing the commandline arguments as test options+-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.+htfMainWithArgs :: TestableHTF t => [String] -> t -> IO ()+htfMainWithArgs args tests =+    do ecode <- runTestWithArgs args tests        exitWith ecode++testWrapCanCauseFailure :: IO ()+testWrapCanCauseFailure =+    do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest+       HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest+    where+      unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ())+      wrappedUnitTest = wrap wrapper unitTest+      wrapper test = HU.assertFailure "Fail" >> test++wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)]
− Test/Framework/TestManagerInternal.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}------ 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.TestManagerInternal (--  UnitTestResult(..),--  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,-  quickCheckTestPass, deserializeQuickCheckMsg,-  unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert,-  blackBoxTestFail,--) where--import Test.Framework.TestTypes-import Test.Framework.Utils-import Test.Framework.Location--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--- lazily inside the string might escape.-assertFailureHTF s = length s `seq` HU.assertFailure s---- This is a HACK: we encode a custom error message for QuickCheck--- failures and errors in a string, which is later parsed using read!-quickCheckTestError :: Maybe String -> Assertion-quickCheckTestError m = assertFailureHTF (show (Error, m))--quickCheckTestFail :: Maybe String -> Assertion-quickCheckTestFail m = assertFailureHTF (show (Fail, m))--quickCheckTestPending :: String -> Assertion-quickCheckTestPending m = assertFailureHTF (show (Pending, Just m))--quickCheckTestPass :: String -> Assertion-quickCheckTestPass m = assertFailureHTF (show (Pass, Just m))--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"--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 =-    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
Test/Framework/TestReporter.hs view
@@ -1,3 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+--+-- Copyright (c) 2005-2022   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 functions for notifying all test reporters registered about@@ -8,6 +26,7 @@ -} module Test.Framework.TestReporter ( +    IsParallel(..), isParallelFromBool, IsJsonOutput(..), IsXmlOutput(..),     reportAllTests, reportGlobalStart, reportTestStart, reportTestResult,     reportGlobalResults, defaultTestReporters @@ -16,14 +35,15 @@ import Test.Framework.TestTypes import Test.Framework.Location import Test.Framework.Colors-import Test.Framework.Utils import Test.Framework.JsonOutput+import Test.Framework.XmlOutput  import System.IO+import Control.Monad import Control.Monad.RWS import Text.PrettyPrint -import qualified Data.ByteString as BS+import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy as BSL  -- | Invokes 'tr_reportAllTests' on all test reporters registered.@@ -52,17 +72,27 @@  -- | Invokes 'tr_reportGlobalResults' on all test reporters registered. reportGlobalResults :: ReportGlobalResults-reportGlobalResults t l1 l2 l3 l4 =+reportGlobalResults arg =     do reps <- asks tc_reporters-       mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps+       mapM_ (\r -> tr_reportGlobalResults r arg) reps +data IsParallel = Parallel | NonParallel++isParallelFromBool :: Bool -> IsParallel+isParallelFromBool True = Parallel+isParallelFromBool False = NonParallel++data IsJsonOutput = JsonOutput | NoJsonOutput+data IsXmlOutput = XmlOutput | NoXmlOutput+ -- | The default test reporters for HTF.-defaultTestReporters :: Bool -- ^ 'True' if tests are run in parallel-                     -> Bool -- ^ 'True' if machine output should be produced+defaultTestReporters :: IsParallel+                     -> IsJsonOutput+                     -> IsXmlOutput                      -> [TestReporter]-defaultTestReporters inParallel forMachine =+defaultTestReporters inParallel forMachine doXml =     case (inParallel, forMachine) of-      (False, False) ->+      (NonParallel, NoJsonOutput) ->           [TestReporter            { tr_id = "rep_seq_human"            , tr_reportAllTests = reportAllTestsH@@ -70,8 +100,8 @@            , tr_reportTestStart = reportTestStartHS            , tr_reportTestResult = reportTestResultHS            , tr_reportGlobalResults = reportGlobalResultsH-           }]-      (True, False) ->+           }] ++ xmlReporters+      (Parallel, NoJsonOutput) ->           [TestReporter            { tr_id = "rep_par_human"            , tr_reportAllTests = reportAllTestsH@@ -79,8 +109,8 @@            , tr_reportTestStart = reportTestStartHP            , tr_reportTestResult = reportTestResultHP            , tr_reportGlobalResults = reportGlobalResultsH-           }]-      (False, True) ->+           }] ++ xmlReporters+      (NonParallel, JsonOutput) ->           [TestReporter            { tr_id = "rep_seq_machine"            , tr_reportAllTests = reportAllTestsM@@ -88,8 +118,8 @@            , tr_reportTestStart = reportTestStartMS            , tr_reportTestResult = reportTestResultMS            , tr_reportGlobalResults = reportGlobalResultsM-           }]-      (True, True) ->+           }] ++ xmlReporters+      (Parallel, JsonOutput) ->           [TestReporter            { tr_id = "rep_par_machine"            , tr_reportAllTests = reportAllTestsM@@ -97,7 +127,14 @@            , tr_reportTestStart = reportTestStartMP            , tr_reportTestResult = reportTestResultMP            , tr_reportGlobalResults = reportGlobalResultsM-           }]+           }] ++ xmlReporters+    where+      xmlReporters =+          case doXml of+            NoXmlOutput -> []+            XmlOutput -> [(emptyTestReporter "rep_xml") {+                            tr_reportGlobalResults = reportGlobalResultsXml+                          }]  -- -- output for humans@@ -112,8 +149,8 @@  reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR () reportHumanTestStartMessage level ft =-    do t <- liftIO $ colorize testStartColor "[TEST] "-       reportTR level (t ++ (humanTestName ft))+    do let t = colorize testStartColor "[TEST] "+       reportTR level (t +++ noColor (humanTestName ft))  -- sequential reportGlobalStartHS :: ReportGlobalStart@@ -125,43 +162,30 @@ reportTestResultHS :: ReportTestResult reportTestResultHS ftr =     let res = rr_result (ft_payload ftr)-        msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr))+        msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr))     in case res of          Pass ->-             do suf <- okSuffix-                reportMessage Debug msg suf+             reportMessage Debug msg okSuffix          Pending ->              do reportHumanTestStartMessageIfNeeded-                suf <- pendingSuffix-                reportMessage Info msg suf+                reportMessage Info msg pendingSuffix          Fail ->              do reportHumanTestStartMessageIfNeeded-                suf <- failureSuffix-                reportMessage Info msg suf+                reportMessage Info msg failureSuffix          Error ->              do reportHumanTestStartMessageIfNeeded-                suf <- errorSuffix-                reportMessage Info msg suf+                reportMessage Info msg errorSuffix    where-     attachCallStack msg callStack =-         case reverse callStack of-           [] -> msg-           l -> ensureNewline msg ++-                unlines (map formatCallStackElem l)-     formatCallStackElem (mMsg, loc) =-         "  called from " ++ showLoc loc ++ (case mMsg of-                                               Nothing -> ""-                                               Just s -> " (" ++ s ++ ")")      reportHumanTestStartMessageIfNeeded =          do tc <- ask             when (tc_quiet tc) (reportHumanTestStartMessage Info ftr)      reportMessage level msg suffix =-         reportTR level (ensureNewline msg ++ suffix ++ timeStr)+         reportTR level (ensureNewlineColorString msg +++ suffix +++ noColor timeStr)      timeStr = " (" ++ show (rr_wallTimeMs (ft_payload ftr)) ++ "ms)\n"-     failureSuffix = liftIO $ colorize warningColor "*** Failed!"-     errorSuffix = liftIO $ colorize warningColor "@@@ Error!"-     pendingSuffix = liftIO $ colorize pendingColor "^^^ Pending!"-     okSuffix = liftIO $ colorize testOkColor  "+++ OK"+     failureSuffix = colorize warningColor "*** Failed!"+     errorSuffix = colorize warningColor "@@@ Error!"+     pendingSuffix = colorize pendingColor "^^^ Pending!"+     okSuffix = colorize testOkColor  "+++ OK"  -- parallel reportGlobalStartHP :: ReportGlobalStart@@ -169,7 +193,7 @@  reportTestStartHP :: ReportTestStart reportTestStartHP ft =-     do reportTR Debug ("Starting " ++ (humanTestName ft))+     do reportStringTR Debug ("Starting " ++ (humanTestName ft))  reportTestResultHP :: ReportTestResult reportTestResultHP ftr =@@ -179,36 +203,57 @@ -- results and all tests reportAllTestsH :: ReportAllTests reportAllTestsH l =-    reportDoc Info (renderTestNames l)+    reportStringTR Info (render (renderTestNames l))  reportGlobalResultsH :: ReportGlobalResults-reportGlobalResultsH t passedL pendingL failedL errorL =-    do let passed = length passedL-           pending = length pendingL-           failed = length failedL-           error = length errorL+reportGlobalResultsH arg =+    do let passed = length (rgra_passed arg)+           pending = length (rgra_pending arg)+           failed = length (rgra_failed arg)+           error = length (rgra_errors arg)+           timedOut = length (rgra_timedOut arg)+           filtered = length (rgra_filtered arg)            total = passed + failed + error + pending-       pendings <- liftIO $ colorize pendingColor "* Pending:"-       failures <- liftIO $ colorize warningColor "* Failures:"-       errors <- liftIO $ colorize warningColor "* Errors:"-       reportTR Info ("* Tests:    " ++ show total ++ "\n" ++-                      "* Passed:   " ++ show passed ++ "\n" ++-                      pendings ++ "  " ++ show pending ++ "\n" ++-                      failures ++ " " ++ show failed ++ "\n" ++-                      errors ++ "   " ++ show error)+       let pendings = (if pending > 0 then colorize pendingColor else noColor) "* Pending:"+           failures = (if failed > 0 then colorize warningColor else noColor) "* Failures:"+           errors = (if error > 0 then colorize warningColor else noColor) "* Errors:"+       reportTR Info ("* Tests:     " +++ showC total +++ "\n" ++++                      "* Passed:    " +++ showC passed +++ "\n" ++++                      pendings +++ "   " +++ showC pending +++ "\n" ++++                      failures +++ "  " +++ showC failed +++ "\n" ++++                      errors +++ "    " +++ showC error +++ "\n" ++++                      "* Timed out: " +++ showC timedOut +++ "\n" ++++                      "* Filtered:  " +++ showC filtered)+       when (timedOut > 0) $+            if timedOut < 10+            then+                reportTR Info+                    ("\n" +++ noColor "* Timed out:" +++ "\n" +++ renderTestNames' (reverse (rgra_timedOut arg)))+            else+                reportTR Info+                  ("\n" +++ noColor "* Timed out: (" +++ showC timedOut +++ noColor ", too many to list)")+       when (filtered > 0) $+            if filtered < 10+            then+                reportTR Info+                  ("\n" +++ noColor "* Filtered:" +++ "\n" +++ renderTestNames' (reverse (rgra_filtered arg)))+            else+                reportTR Info+                  ("\n" +++ noColor "* Filtered: (" +++ showC filtered +++ noColor ", too many to list)")        when (pending > 0) $-          reportDoc Info-              (text ('\n' : pendings) $$ renderTestNames' (reverse pendingL))+          reportTR Info+              ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg)))        when (failed > 0) $-          reportDoc Info-              (text ('\n' : failures) $$ renderTestNames' (reverse failedL))+          reportTR Info+              ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg)))        when (error > 0) $-          reportDoc Info-              (text ('\n' : errors) $$ renderTestNames' (reverse errorL))-       reportTR Info ("\nTotal execution time: " ++ show t ++ "ms")+          reportTR Info+              ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse (rgra_errors arg)))+       reportStringTR Info ("\nTotal execution time: " ++ show (rgra_timeMs arg) ++ "ms")     where+      showC x = noColor (show x)       renderTestNames' rrs =-          nest 2 $ renderTestNames rrs+          noColor $ render $ nest 2 $ renderTestNames rrs  renderTestNames :: [GenFlatTest a] -> Doc renderTestNames l =@@ -250,26 +295,32 @@     in reportJsonTR json  reportGlobalResultsM :: ReportGlobalResults-reportGlobalResultsM t pass pending failed errors =-    let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors)+reportGlobalResultsM arg =+    let json = mkTestResultsObj arg     in reportJsonTR json +reportGlobalResultsXml :: ReportGlobalResults+reportGlobalResultsXml arg =+    do let xml = mkGlobalResultsXml arg+       tc <- ask+       case tc_outputXml tc of+         Just fname -> liftIO $ withFile fname WriteMode $ \h -> BSL.hPut h xml+         Nothing -> liftIO $ BSL.putStr xml+ -- -- General reporting routines -- -reportDoc :: ReportLevel -> Doc -> TR ()-reportDoc level doc = reportTR level (render doc)--reportTR :: ReportLevel -> String -> TR ()+reportTR :: ReportLevel -> ColorString -> TR () reportTR level msg =     do tc <- ask-       reportGen tc level (\h -> hPutStrLn h msg)+       let s = renderColorString msg (tc_useColors tc)+       reportGen tc level (\h -> T.hPutStrLn h s) -reportBytesTR :: ReportLevel -> BS.ByteString -> TR ()-reportBytesTR level msg =+reportStringTR :: ReportLevel -> String -> TR ()+reportStringTR level msg =     do tc <- ask-       reportGen tc level (\h -> BS.hPut h msg)+       reportGen tc level (\h -> hPutStrLn h msg)  reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR () reportLazyBytesTR level msg =
Test/Framework/TestTypes.hs view
@@ -1,23 +1,44 @@-{-| +{-# LANGUAGE FlexibleInstances #-}+--+-- Copyright (c) 2005-2022   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 types (and small auxiliary functions) for organizing tests, for configuring the execution of tests, and for representing and reporting their results. +This functionality is mainly used internally in the code+generated by the @hftpp@ pre-processor. -} module Test.Framework.TestTypes (    -- * Organizing tests-  TestID, Assertion, Test(..), TestSuite(..), TestSort(..),+  TestID, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),+  TestSuite(..), TestSort(..),   TestPath(..), GenFlatTest(..), FlatTest, TestFilter,-  testPathToList, flatName,+  testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey,    -- * Executing tests   TR, TestState(..), initTestState, TestConfig(..), TestOutput(..),    -- * Reporting results-  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults,-  TestReporter(..),+  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..),+  TestReporter(..), emptyTestReporter, attachCallStack, CallStack,    -- * Specifying results.   TestResult(..), FlatTestResult, Milliseconds, RunResult(..)@@ -25,14 +46,15 @@ ) where  import Test.Framework.Location+import Test.Framework.Colors+import Test.Framework.History+import Test.Framework.TestInterface  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 ()+import qualified Data.Text as T  -- | Type for naming tests. type TestID = String@@ -41,8 +63,44 @@ data TestSort = UnitTest | QuickCheckTest | BlackBoxTest               deriving (Eq,Show,Read) +-- | General options for tests+data TestOptions = TestOptions {+      to_parallel :: Bool+    }+    deriving (Eq,Show,Read)++-- | The default 'TestOptions'+defaultTestOptions :: TestOptions+defaultTestOptions = TestOptions {+                       to_parallel = True+                     }++-- | Something with 'TestOptions'+data WithTestOptions a = WithTestOptions {+      wto_options :: TestOptions+    , wto_payload :: a+    }+    deriving (Eq,Show,Read)++-- | Shortcut for constructing a 'WithTestOptions' value.+withOptions :: (TestOptions -> TestOptions) -> a -> WithTestOptions a+withOptions f x = WithTestOptions (f defaultTestOptions) x++-- | A type class for an assertion with 'TestOptions'.+class AssertionWithTestOptions a where+    testOptions :: a -> TestOptions+    assertion :: a -> Assertion++instance AssertionWithTestOptions (IO a) where+    testOptions _ = defaultTestOptions+    assertion io = io >> return ()++instance AssertionWithTestOptions (WithTestOptions (IO a)) where+    testOptions (WithTestOptions opts _) = opts+    assertion (WithTestOptions _ io) = io >> return ()+ -- | Abstract type for tests and their results.-data Test = BaseTest TestSort TestID (Maybe Location) Assertion+data Test = BaseTest TestSort TestID (Maybe Location) TestOptions Assertion           | CompoundTest TestSuite  -- | Abstract type for test suites and their results.@@ -52,6 +110,7 @@ -- | A type denoting the hierarchical name of a test. data TestPath = TestPathBase TestID               | TestPathCompound (Maybe TestID) TestPath+                deriving (Show)  -- | Splits a 'TestPath' into a list of test identifiers. testPathToList :: TestPath -> [Maybe TestID]@@ -62,8 +121,26 @@ -- | Creates a string representation from a 'TestPath'. flatName :: TestPath -> String flatName p =-    List.intercalate ":" (map (fromMaybe "") (testPathToList p))+    flatNameFromList (testPathToList p) +flatNameFromList :: [Maybe TestID] -> String+flatNameFromList l =+    List.intercalate ":" (map (fromMaybe "") l)++-- | Returns the final name of a 'TestPath'+finalName :: TestPath -> String+finalName (TestPathBase i) = i+finalName (TestPathCompound _ p) = finalName p++-- | Returns the name of the prefix of a test path. The prefix is everything except the+--   last element.+prefixName :: TestPath -> String+prefixName path =+    let l = case reverse (testPathToList path) of+              [] -> []+              (_:xs) -> reverse xs+    in flatNameFromList l+ -- | Generic type for flattened tests and their results. data GenFlatTest a     = FlatTest@@ -73,29 +150,36 @@       , ft_payload :: a               -- ^ A generic payload.       } +-- | Key of a flat test for the history database.+historyKey :: GenFlatTest a -> T.Text+historyKey ft = T.pack (flatName (ft_path ft))+ -- | Flattened representation of tests.-type FlatTest = GenFlatTest Assertion+type FlatTest = GenFlatTest (WithTestOptions Assertion)  -- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. type TestFilter = FlatTest -> Bool --- | 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+-- | A type for call-stacks+type CallStack = [(Maybe String, Location)]  -- | The result of a test run. data RunResult     = RunResult       { rr_result :: TestResult       -- ^ The summary result of the test.-      , rr_location :: Maybe Location -- ^ The location where the test failed (if applicable).-      , rr_callers :: [(Maybe String, Location)] -- ^ Information about the callers of the location where the test failed-      , rr_message :: String          -- ^ A message describing the result.+      , rr_stack :: HtfStack          -- ^ The stack leading to the test failure+      , rr_message :: ColorString     -- ^ A message describing the result.       , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds.+      , rr_timeout :: Bool            -- ^ 'True' if the execution took too long       } +attachCallStack :: ColorString -> HtfStack -> ColorString+attachCallStack msg stack =+    let fstack = formatHtfStack stack+    in if fstack == ""+       then msg+       else ensureNewlineColorString msg +++ noColor fstack+ -- | The result of running a 'FlatTest' type FlatTestResult = GenFlatTest RunResult @@ -120,11 +204,21 @@ data TestConfig     = TestConfig       { tc_quiet :: Bool                -- ^ If set, displays messages only for failed tests.----      , tc_threads :: Maybe Int       Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution (currently unused).+      , tc_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.+      , tc_shuffle :: Bool              -- ^ Shuffle tests before parallel execution       , tc_output :: TestOutput         -- ^ Output destination of progress and result messages.+      , tc_outputXml :: Maybe FilePath  -- ^ Output destination of XML result summary       , tc_filter :: TestFilter         -- ^ Filter for the tests to run.       , tc_reporters :: [TestReporter]  -- ^ Test reporters to use.+      , tc_useColors :: Bool            -- ^ Whether to use colored output+      , tc_historyFile :: FilePath      -- ^ Path to history file+      , tc_history :: TestHistory       -- ^ History of previous test runs+      , tc_sortByPrevTime :: Bool       -- ^ Sort ascending by previous execution times+      , tc_failFast :: Bool             -- ^ Stop test run as soon as one test fails+      , tc_timeoutIsSuccess :: Bool     -- ^ Do not regard timeout as an error+      , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run+      , tc_prevFactor :: Maybe Double   -- ^ Maximum factor a single test is allowed to run slower than its previous execution+      , tc_repeat :: Int                -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.       }  instance Show TestConfig where@@ -132,10 +226,21 @@         showParen (prec > 0) $         showString "TestConfig { " .         showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .---        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_shuffle=" . showsPrec 1 (tc_shuffle tc) .         showString ", tc_output=" . showsPrec 1 (tc_output tc) .+        showString ", tc_outputXml=" . showsPrec 1 (tc_outputXml tc) .         showString ", tc_filter=<filter>" .         showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) .+        showString ", tc_useColors=" . showsPrec 1 (tc_useColors tc) .+        showString ", tc_historyFile=" . showsPrec 1 (tc_historyFile tc) .+        showString ", tc_history=" . showsPrec 1 (tc_history tc) .+        showString ", tc_sortByPrevTime=" . showsPrec 1 (tc_sortByPrevTime tc) .+        showString ", tc_failFast=" . showsPrec 1 (tc_failFast tc) .+        showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) .+        showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) .+        showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) .+        showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) .         showString " }"  -- | A 'TestReporter' provides hooks to customize the output of HTF.@@ -149,6 +254,17 @@       , tr_reportGlobalResults :: ReportGlobalResults  -- ^ Called to report the overall results of all tests.       } +emptyTestReporter :: String -> TestReporter+emptyTestReporter id =+    TestReporter+      { tr_id = id+      , tr_reportAllTests = \_ -> return ()+      , tr_reportGlobalStart = \_ -> return ()+      , tr_reportTestStart = \_ -> return ()+      , tr_reportTestResult = \_ -> return ()+      , tr_reportGlobalResults = \_ -> return ()+      }+ instance Show TestReporter where     showsPrec _ x = showString (tr_id x) @@ -167,10 +283,16 @@ -- | Reports the result of a single test. type ReportTestResult = FlatTestResult -> TR () +data ReportGlobalResultsArg+    = ReportGlobalResultsArg+    { rgra_timeMs :: Milliseconds+    , rgra_passed :: [FlatTestResult]+    , rgra_pending :: [FlatTestResult]+    , rgra_failed :: [FlatTestResult]+    , rgra_errors :: [FlatTestResult]+    , rgra_timedOut :: [FlatTestResult]+    , rgra_filtered :: [FlatTest]+    }+ -- | 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 ()+type ReportGlobalResults = ReportGlobalResultsArg -> TR ()
+ Test/Framework/ThreadPool.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE ScopedTypeVariables #-}+{- |+Internal module providing a pool of threads.+-}+--+-- Copyright (c) 2009-2022   Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++module Test.Framework.ThreadPool (++    ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool+  , threadPoolTest++) where++import qualified Control.Exception as Ex+import Control.Monad+import Control.Monad.Trans+import Control.Concurrent++-- for tests+import System.Random++data StopFlag+    = DoStop+    | DoNotStop+      deriving (Eq, Show, Read)++type ThreadPoolEntry m a b = ( m a        -- pre-action, must not throw exceptions+                             , a -> IO b  -- action+                             , Either Ex.SomeException b -> m StopFlag+                               -- post-action, must not throw exceptions. If the result is+                               -- DoStop, the thread pool is terminated asap.+                             )++data ThreadPool m a b+    = ThreadPool+      { tp_run :: [ThreadPoolEntry m a b] -> m () }++sequentialThreadPool :: MonadIO m => ThreadPool m a b+sequentialThreadPool = ThreadPool runSequentially++parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b)+parallelThreadPool n =+    do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n))+       return (ThreadPool (runParallel n))++runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m ()+runSequentially entries =+    loop entries+    where+      loop [] = return ()+      loop (e:es) =+          do b <- run e+             if b == DoStop then return () else loop es+      run (pre, action, post) =+          do a <- pre+             b <- liftIO $ Ex.try (action a)+             post b++data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m StopFlag) | Done++instance Show (WorkItem m b) where+    show (Work _ _) = "Work"+    show Done = "Done"++type NamedMVar a = (String, MVar a)+type NamedChan a = (String, Chan a)++type ToWorker m b = NamedMVar (WorkItem m b)++data WorkResult m b = WorkResult (m StopFlag) (ToWorker m b)++instance Show (WorkResult m b) where+    show _ = "WorkResult"++type FromWorker m b = NamedChan (WorkResult m b)++runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m ()+runParallel _ [] = return ()+runParallel n entries =+    do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n))+       fromWorker <- liftIO $ newNamedChan "fromWorker"+       let nWorkers = min n (length entries)+       toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers]+       let (initEntries, restEntries) = splitAt nWorkers entries+       mapM_ (\(mvar, entry) -> runEntry entry mvar) (zip toWorkers initEntries)+       loop fromWorker nWorkers restEntries+    where+      loop :: FromWorker m b -> Int -> [ThreadPoolEntry m a b] -> m ()+      loop fromWorker nWorkers [] =+          cleanup fromWorker nWorkers+      loop fromWorker nWorkers (x:xs) =+          do (toWorker, stop) <- waitForWorkerResult fromWorker+             if stop == DoStop+             then return ()+             else do runEntry x toWorker+                     loop fromWorker nWorkers xs+      cleanup :: FromWorker m b -> Int -> m ()+      -- n is the number of workers that will still write to fromWorker+      cleanup fromWorker n =+          do debug ("cleanup, n=" ++ show n)+             (toWorker, _) <- waitForWorkerResult fromWorker+             liftIO $ putNamedMVar toWorker Done+             when (n > 1) $ cleanup fromWorker (n - 1)+      waitForWorkerResult :: FromWorker m b -> m (ToWorker m b, StopFlag)+      waitForWorkerResult fromWorker =+          do WorkResult postAction toWorker <- liftIO $ readNamedChan fromWorker+             b <- postAction+             return (toWorker, b)+      runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m ()+      runEntry (pre, action, post) toWorker =+          do a <- pre+             liftIO $ putNamedMVar toWorker (Work (action a) post)+      mkWorker :: Int -> FromWorker m b -> IO (ToWorker m b)+      mkWorker i fromWorker =+          do toWorker <- newEmptyNamedMVar ("worker" ++ show i)+             let loop = do workItem <- takeNamedMVar toWorker+                           case workItem of+                             Done ->+                                 do debug ("worker" ++ show i ++ " exiting!")+                                    return ()+                             Work action post ->+                                 do res <- Ex.try action+                                    _ <- Ex.evaluate res+                                    writeNamedChan fromWorker (WorkResult (post res) toWorker)+                                    loop+             _ <- forkIO (loop `Ex.catch` (\(e::Ex.BlockedIndefinitelyOnMVar) ->+                                          fail ("worker " ++ show i ++ ": " ++ show e)))+             return toWorker++--+-- Debugging and testing+--++_DEBUG_ = False++newNamedChan :: String -> IO (NamedChan a)+newNamedChan name =+    do chan <- newChan+       return (name, chan)++readNamedChan :: Show a => NamedChan a -> IO a+readNamedChan (name, chan) =+    do debug ("readChan[" ++ name ++ "]...")+       x <- readChan chan+       debug ("DONE readChan[" ++ name ++"]=" ++ show x)+       return x++writeNamedChan :: Show a => NamedChan a -> a -> IO ()+writeNamedChan (name, chan) x =+    do debug ("writeChan[" ++ name ++ "]=" ++ show x)+       writeChan chan x++newEmptyNamedMVar :: String -> IO (NamedMVar a)+newEmptyNamedMVar name =+    do mvar <- newEmptyMVar+       return (name, mvar)++putNamedMVar :: Show a => NamedMVar a -> a -> IO ()+putNamedMVar (name, mvar) x =+    do debug ("putMVar[" ++ name ++ "]=" ++ show x ++ "...")+       putMVar mvar x+       debug ("DONE putMVar[" ++ name ++ "]=" ++ show x)++takeNamedMVar :: Show a => NamedMVar a -> IO a+takeNamedMVar (name, mvar) =+    do debug ("takeMVar[" ++ name ++ "]...")+       x <- takeMVar mvar+       debug ("DONE takeMVar[" ++ name ++ "]=" ++ show x)+       return x++debug :: MonadIO m => String -> m ()+debug s = if _DEBUG_ then liftIO $ putStrLn s else return ()++runTestParallel :: Int -> Int -> IO ()+runTestParallel nEntries n =+    do debug ("Running test " ++ show n)+       boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i)+                               return (mvar, i))+                      [1..nEntries]+       let entries = map mkEntry boxes+       runParallel n entries+       debug ("Checking boxes in test " ++ show n)+       --runSequentially entries+       mapM_ assertBox boxes+       debug ("Test " ++ show n ++ " successful")+    where+      mkEntry (mvar, i) =+          let pre = myThreadId+              post x = case x of+                         Left err -> fail ("Exception in worker thread: " ++ show err)+                         Right y -> do tid <- myThreadId+                                       putNamedMVar mvar (y, tid)+                                       return DoNotStop+              action x = do tid <- myThreadId+                            j <- randomIO+                            let micros = (j `mod` 50)+                            threadDelay micros+                            return (x, tid, i)+          in (pre, action, post)+      assertBox (mvar, i) =+         do ((preTid, actionTid, i'), postTid) <- takeNamedMVar mvar+            tid <- myThreadId+            assertEq "pre-tid" tid preTid+            assertEq "post-tid" tid postTid+            assertNeq "action-tid" tid actionTid+            assertEq "i" i i'+      assertEq what exp act =+          when (exp /= act) $ fail (what ++ " wrong, expected=" ++ show exp ++ ", actual=" +++                                    show act)+      assertNeq what exp act =+          when (exp == act) $ fail (what ++ " wrong, did not expected " ++ show exp)++threadPoolTest (i, j) nEntries =+    mapM (runTestParallel nEntries) [i..j] `Ex.catch`+             (\(e::Ex.BlockedIndefinitelyOnMVar) ->+                  fail ("main-thread blocked " ++ show e))
Test/Framework/Tutorial.hs view
@@ -1,3 +1,20 @@+--+-- Copyright (c) 2005-2022   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 provides a short tutorial on how to use the HTF. It assumes that you are using GHC for compiling your Haskell code. (It is@@ -5,18 +22,90 @@ taken to invoke the custom preprocessor of the HTF may differ in this case.) -We start with a simple example. Then we show how to use HTF to easily-collect test definitions from multiple modules and discuss-backwards-compatibility for projects already using `HUnit`. Finally,-we give a brief cookbook-like summary on how to setup your tests with HTF.- -}  module Test.Framework.Tutorial ( +-- * Quickstart++{- |++For the impatient, we start with a brief cookbook-like summary and then go into details.+You should also have a look at the sample project at+<https://github.com/skogsbaer/HTF/tree/master/sample>.++-}++-- ** Writing tests++{- |++You should use the following skeleton for each module defining test cases:++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module MyModule (+    -- some more exports here++    htf_thisModulesTests -- all test cases are automatically collected in htf_thisModulesTests++) where++import Test.Framework++-- Each top-level definition whose name starts with 'test_' defines a unit test.+test_nonEmpty :: Assertion+test_nonEmpty = do+  assertEqual [1] (reverse [1])+  assertEqual [3,2,1] (reverse [1,2,3])+++-- Each top-level definition whose name starts with 'prop_' defines a quickcheck property.+prop_reverse :: [Int] -> Bool+prop_reverse xs = xs == (reverse (reverse xs))+@++For unit tests, see "Test.Framework.HUnitWrapper" for the assertions provided.++-}++-- ** Collecting and executing tests++{- |++Your main module collecting all tests should look like this:++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module Main ( main ) where++-- Import modules defining HTF tests like this:+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyModule++main :: IO ()+main = htfMain htf_importedTests -- all tests in modules imported via &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; are available in htf_importedTests+@++Tests are then executed via @cabal test@ or @stack test@. You only need to add+the following snippet to your @.cabal@ file:++@+Test-Suite example+  Type:               exitcode-stdio-1.0+  Main-is:            Main.hs+  Build-depends:      base, HTF+  Build-tool-depends: HTF:htfpp+  Default-language:   Haskell2010+@++Several commandline options are available for HTF tests. Use+@stack test --ta --help@ or @cabal test --test-options --help@ to see the list of options.+-}+ -- * A simple example {- | +We now explain everything in more detail. Suppose you are trying to write a function for reversing lists :  @@@ -36,11 +125,9 @@ This pragma instructs GHC to run the source file through @htfpp@, the custom preprocessor of the HTF. -The following @import@ statements are also needed:+The following @import@ statement is also needed:  @-import System.Environment ( getArgs )-import System.Exit ( exitWith ) import Test.Framework @ @@ -56,13 +143,8 @@ prop_reverse xs = xs == (myReverse (myReverse xs)) @ -When @htfpp@ consumes the source file, it replaces the @assertEqual@-tokens (and other @assert@-like tokens, see-"Test.Framework.HUnitWrapper") with calls to-'assertEqual_', passing-the current location in the file as the first argument.-Moreover, the-preprocessor collects all top-level definitions starting with @test_@+When @htfpp@ consumes the source file, it+collects all top-level definitions starting with @test_@ or @prop_@ in a test suite of type 'TestSuite' and name @htf_@/M/@_thisModulesTests@, where /M/ is the name of the current module with dots @.@ replaced by underscores @_@. For your convenience, the preprocessor also defines the token @htf_thisModulesTests@@@ -89,11 +171,12 @@ Cabal-Version: >= 1.10 Build-type:    Simple -Executable tutorial-  Type:              exitcode-stdio-1.0-  Main-is:           Tutorial.hs-  Build-depends:     base == 4.*, HTF == 0.10.*-  Default-language:  Haskell2010+Test-Suite tutorial+  Type:               exitcode-stdio-1.0+  Main-is:            Tutorial.hs+  Build-depends:      base, HTF+  Build-tool-depends: HTF:htfpp+  Default-language:   Haskell2010 @  Compiling the program just shown (you must include the code for@@ -209,7 +292,7 @@ split the tests into several modules. For example, suppose your library contains of two modules @MyPkg.A@ and @MyPkg.B@, each containing test functions. You can find a slightly extended of this scenario in the samples directory-of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>.)+of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>.  File @MyPkg/A.hs@ @@ -245,9 +328,9 @@  For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules' testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a-preprocessor token @thisModulesTests@ as a shorthand for this variable.+preprocessor token @htf_thisModulesTests@ as a shorthand for this variable. Thus, to expose all HTF tests defined in @MyPkg.A@, we only-need to put @thisModulesTests@ into the export list. The same holds+need to put @htf_thisModulesTests@ into the export list. The same holds analogously for module @MyPkg.B@.  To execute all tests defined in these two modules, you would create@@ -265,7 +348,6 @@ module Main where  import Test.Framework-import Test.Framework.BlackBoxTest import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.B @@ -276,10 +358,14 @@  -- * Machine-readable output +-- ** JSON+ {- |  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,+machine-readable output in JSON format. The output is produced incrementally, line by line.++Here is a short example how the JSON output looks like, for details see "Test.Framework.JsonOutput":  @@ -311,65 +397,44 @@  -} --- * Backwards-compatibility with HUnit--{- |-The types of the various @assert@-like macros of the HTF are not backwards-compatible-with the corresponding functions of HUnit. This incompatibility is intentional, of course:-with HUnit, the programmer has to provide suitable location information by explicitly-passing a string argument to the @assert@-like functions, whereas HTF provides-location information implicitly through its pre-processor @htfpp@.--To simplify transition from HUnit to HTF, @htfpp@ provides a commandline flag-@--hunit@. This flag causes @htfpp@ to exand the assertion macros in a way compatible-with the types of the corresponding HUnit functions. For example, with the @--hunit@-flag being present, @assertEqual@ is exanded to-@'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type-@(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with-the type of HUnit's 'Test.HUnit.Base.assertEqual' function.---}---- * Summary--{- |+-- ** XML -Here is a quick summary of how to write, collect, and execute your tests.-You should also have a look at the sample project at-<https://github.com/skogsbaer/HTF/tree/master/sample>.+{- | Machine-readable output is also available as XML, following the specification of the JUnit+output format. XML-output is requested by the @--xml=OUTPUT_FILE@ flag.+See "Test.Framework.XmlOutput" for details.  -}---- ** Writing tests+-- * Commandline options  {- | -* Place @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ at the top of your module.--* Put @htf_thisModulesTests@ into the export list of your module.--* Import @Test.Framework@.--* Prefix your unit tests with @test_@, see "Test.Framework.HUnitWrapper" for the assertions provided.--* Prefix your QuickCheck properties with @prop_@.---}---- ** Collecting and executing tests--{- |-* Place @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ at the top of your module.--* Import @Test.Framework@.+Here is the list of commandline options for programs using @htfMain@: -* Import modules defining HTF tests with @import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A@.+@+USAGE: COMMAND [OPTION ...] PATTERN ... -* Use @main = htfMain htf_importedTests@ to run all imported tests.+  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.+  -j[N]       --threads[=N]               Run N tests in parallel, default N=1.+              --shuffle=BOOL              Shuffle test order. Default: false+  -o FILE     --output-file=FILE          Name of output file.+              --json                      Output results in machine-readable JSON format (incremental).+              --xml=FILE                  Output results in junit-style XML format.+              --split                     Splits results in separate files to avoid file locking (requires -o/--output-file).+              --colors=BOOL               Use colors or not.+              --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+              --fail-fast                 Fail and abort test run as soon as the first test fails.+              --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+              --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+              --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+              --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+              --timeout-is-success        Do not regard a test timeout as an error.+              --repeat=NUMBER             Execute the tests selected on the command line NUMBER times.+  -h          --help                      Display this message.+@ -}- ) where--import Test.Framework-import qualified Test.HUnit.Base
Test/Framework/Utils.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----- Copyright (c) 2005, 2012   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022   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@@ -22,6 +23,9 @@ import System.Directory import Data.Char import System.Time hiding (diffClockTimes)+import System.Random+import Data.Array.IO+import Control.Monad  infixr 6 </> @@ -116,11 +120,15 @@                               (s'',ys) <- mapAccumLM f s' xs                               return (s'',y:ys) +#if !(MIN_VERSION_base(4,13,0)) readM :: (Monad m, Read a) => String -> m a+#else+readM :: (MonadFail m, Read a) => String -> m a+#endif readM s | [x] <- parse = return x         | otherwise    = fail $ "Failed parse: " ++ show s     where-      parse = [x | (x,t) <- reads s]+      parse = [x | (x, []) <- reads s]  ensureNewline :: String -> String ensureNewline s =@@ -149,3 +157,19 @@       -- bring all into microseconds       picoseconds i = i `div` (1000 * 1000)       seconds i = i * 1000000++-- | Randomly shuffle a list+--   /O(N)/+shuffleIO :: [a] -> IO [a]+shuffleIO xs = do+        ar <- newArray n xs+        forM [1..n] $ \i -> do+            j <- randomRIO (i,n)+            vi <- readArray ar i+            vj <- readArray ar j+            writeArray ar j vi+            return vj+  where+    n = length xs+    newArray :: Int -> [a] -> IO (IOArray Int a)+    newArray n xs =  newListArray (1,n) xs
+ Test/Framework/XmlOutput.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE CPP #-}+--+-- Copyright (c) 2005-2022   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+--+{- |++XML-output following the JUnit output format.++The data types exposed by this module give a rough specification of+the output format.++Here is a sample ouput:++@+\<?xml version="1.0" encoding="UTF-8" standalone="yes"?\>+\<testsuites tests="6" failures="2" errors="0" time="0.705"\>+  \<testsuite id="0" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.A" package="MyPkg.A"\>+    \<testcase classname="MyPkg.A" name="test_funA2" time="0.000"/\>+    \<testcase classname="MyPkg.A" name="test_funA1" time="0.000"/\>+  \</testsuite\>+  \<testsuite id="1" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.B" package="MyPkg.B"\>+    \<testcase classname="MyPkg.B" name="test_funB2" time="0.000"/\>+    \<testcase classname="MyPkg.B" name="test_funB1" time="0.000"/\>+  \</testsuite\>+  \<testsuite id="2" tests="2" failures="2" errors="0" time="0.703" name="bbts" package="bbts"\>+    \<testcase classname="bbts" name="bbt_bbt-dir/should-pass/x.num" time="0.230"\>+      \<failure type="failure" message="test is supposed to succeed but failed with exit code 255"\>test is supposed to succeed but failed with exit code 255\</failure\>+    \</testcase\>+    \<testcase classname="bbts" name="bbt_bbt-dir/should-fail/z.num" time="0.473"\>+      \<failure type="failure" message="Mismatch on stderr:"\>Mismatch on stderr:+--- bbt-dir/should-fail/z.err	2015-09-05 18:37:30.000000000 +0200++++ -	2022-03-06 09:49:55.480265000 +0100+\@\@ -1 +1 \@\@+-invalid input++sample[88331]: [fatal] unable to read input graph: The data couldn’t be read because it isn’t in the correct format.+[end of diff output]+\</failure\>+    \</testcase\>+  \</testsuite\>+\</testsuites\>+@++-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Framework.XmlOutput (++  JunitXmlOutput(..), Testsuites(..), Testsuite(..), Testcase(..), Result(..)+  , mkGlobalResultsXml++) where++import qualified Data.ByteString.Lazy as BSL+import qualified Data.List as List++#ifndef MIN_VERSION_containers+#define MIN_VERSION_containers(a,b,c) 1+#endif+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+#else+import qualified Data.Map as Map+#endif++import qualified Data.Text as T+import Text.Printf++import Text.XML.Generator++import Test.Framework.TestTypes+import Test.Framework.Colors++-- | A "specification" of the output format in terms of haskell data types:+-- The name of each data type corresponds to the name of an XML element+-- (lowercase first letter).+-- The name of a field with a primitive corresponds to an attribute with+-- then same name as the field (without the prefix up to the first @_@).+--+-- The root element is @testsuites@+data JunitXmlOutput = JunitXmlOutput Testsuites++type Seconds = Double++data Testsuites+    = Testsuites+      { tss_tests :: Int+      , tss_failures :: Int+      , tss_errors :: Int+      , tss_time :: Seconds+      , tss_suites :: [Testsuite] }++data Testsuite+    = Testsuite+      { ts_tests :: Int+      , ts_failures :: Int+      , ts_errors :: Int+      , ts_time :: Seconds+      , ts_id :: Int+      , ts_name :: String+      , ts_package :: String+      , ts_testcases :: [Testcase] }++data Testcase+    = Testcase+      { tc_classname :: String+      , tc_name :: String+      , tc_time :: Seconds+      , tc_result :: Maybe Result }++-- For this datatype, the elemName field specifies the name of the element+data Result+    = Result+      { r_elemName :: String+      , r_message :: T.Text+      , r_type :: String+      , r_textContent :: T.Text }++renderAsXml :: JunitXmlOutput -> BSL.ByteString+renderAsXml (JunitXmlOutput suites) =+    xrender $+    doc defaultDocInfo $+        xelem "testsuites" $+              xattr "tests" (showT (tss_tests suites)) <>+              xattr "failures" (showT (tss_failures suites)) <>+              xattr "errors" (showT (tss_errors suites)) <>+              xattr "time" (showTime (tss_time suites)) <#>+              (map testsuiteXml (tss_suites suites))+    where+      testsuiteXml suite =+          xelem "testsuite" $+                xattr "id" (showT (ts_id suite)) <>+                xattr "tests" (showT (ts_tests suite)) <>+                xattr "failures" (showT (ts_failures suite)) <>+                xattr "errors" (showT (ts_errors suite)) <>+                xattr "time" (showTime (ts_time suite)) <>+                xattr "name" (T.pack (ts_name suite)) <>+                xattr "package" (T.pack (ts_package suite)) <#>+                (map testcaseXml (ts_testcases suite))+      testcaseXml tc =+          xelem "testcase" $+                xattr "classname" (T.pack (tc_classname tc)) <>+                xattr "name" (T.pack (tc_name tc)) <>+                xattr "time" (showTime (tc_time tc)) <#>+                resultXml (tc_result tc)+      resultXml Nothing = xempty+      resultXml (Just res) =+          xelem (T.pack (r_elemName res)) $+                xattr "type" (T.pack (r_type res)) <>+                xattr "message" (r_message res) <#>+                xtext (r_textContent res)+      showT = T.pack . show+      showTime = T.pack . printf "%.3f"++groupByModule :: [FlatTestResult] -> [(String, [FlatTestResult])]+groupByModule l =+    let m = List.foldl' (\m r -> Map.insertWith (++) (prefixName (ft_path r)) [r] m) Map.empty l+    in Map.toList m++mkTestSuite :: (Int, (String, [FlatTestResult])) -> Testsuite+mkTestSuite (id, (modName, results)) =+    Testsuite+    { ts_tests = nTests+    , ts_failures = nFailures+    , ts_errors = nErrors+    , ts_time = millisToSeconds millis+    , ts_id = id+    , ts_name = modName+    , ts_package = modName+    , ts_testcases = map mkTestCase results }+    where+      (nTests, nFailures, nErrors, millis) =+          List.foldl' (\(t, f, e, m) r -> (t + 1, f + failureInc r, e + errorInc r,+                                           m + (rr_wallTimeMs . ft_payload) r))+                      (0, 0, 0, 0) results+      failureInc r = if isFailure r then 1 else 0+      errorInc r = if isError r then 1 else 0++isFailure :: FlatTestResult -> Bool+isFailure r = Fail == (rr_result . ft_payload) r++isError :: FlatTestResult -> Bool+isError r = Error == (rr_result . ft_payload) r++mkTestCase :: FlatTestResult -> Testcase+mkTestCase r =+    Testcase+    { tc_classname = modName+    , tc_name = simpleName+    , tc_time = millisToSeconds (rr_wallTimeMs payload)+    , tc_result = result }+    where+      payload = ft_payload r+      simpleName = prefix ++ finalName (ft_path r)+      modName = prefixName (ft_path r)+      prefix = case ft_sort r of+                 UnitTest -> "test_"+                 QuickCheckTest -> "prop_"+                 BlackBoxTest -> "bbt_"+      result =+          if isFailure r+          then Just (mkResult "failure")+          else if isError r+               then Just (mkResult "error")+               else Nothing+      mkResult elemName =+          Result+          { r_elemName = elemName+          , r_message = T.takeWhile (/= '\n') msg+          , r_type = elemName+          , r_textContent = msg }+      msg = renderColorString (attachCallStack (rr_message payload) (rr_stack payload)) False++millisToSeconds :: Milliseconds -> Seconds+millisToSeconds millis =+    fromInteger (toInteger millis) / 1000.0++mkGlobalResultsXml :: ReportGlobalResultsArg -> BSL.ByteString+mkGlobalResultsXml arg =+    let nPassed = length (rgra_passed arg)+        nPending = length (rgra_pending arg)+        nFailed = length (rgra_failed arg)+        nErrors = length (rgra_errors arg)+        byModules = groupByModule (rgra_passed arg ++ rgra_pending arg +++                                   rgra_failed arg ++ rgra_errors arg)+        suites = map mkTestSuite (zip [0..] byModules)+        root = Testsuites+               { tss_tests = nPassed + nPending + nFailed + nErrors+               , tss_failures = nFailed+               , tss_errors = nErrors+               , tss_time = millisToSeconds (rgra_timeMs arg)+               , tss_suites = suites }+    in renderAsXml (JunitXmlOutput root)
− run-all-tests-for-all-compilers.sh 
@@ -1,36 +0,0 @@-#!/bin/bash--compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal  | tr -d ,)--for x in $compilers-do-    switch-ghc $x > /dev/null-    ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g')-    if [ "$x" != "$ghc_version" ]-    then-        echo "Could not switch to GHC version $x as requested, version is now $ghc_version"-        exit 1-    fi-    echo-    echo-    echo "============================================================"-    echo "============================================================"-    echo "==> Running tests for GHC version $ghc_version <=="-    echo "==> Running tests for GHC version $ghc_version <=="-    echo "==> Running tests for GHC version $ghc_version <=="-    echo "============================================================"-    echo "============================================================"-    echo-    ./run-all-tests.sh-    ecode=$?-    if [ $ecode -eq 0 ]-    then-        result="ok"-    else-        result="FAIL"-    fi-    RESULT="$RESULT\nResult for GHC version $ghc_version: $result"-done--echo-echo -e $RESULT
− run-all-tests.sh 
@@ -1,22 +0,0 @@-#!/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
sample/TestMain.hs view
@@ -9,5 +9,5 @@ import {-@ HTF_TESTS @-} MyPkg.B  main =-    do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs+    do bbts <- blackBoxTests "bbt-dir" "../scripts/run-sample" ".num" defaultBBTArgs        htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts])
sample/sample-HTF.cabal view
@@ -1,6 +1,7 @@ name:                sample-HTF version:             0.1.0.0 synopsis:            Sample project showing how to use HTF+description:         Sample project showing how to use HTF homepage:            https://github.com/skogsbaer/HTF/ license:             BSD3 license-file:        LICENSE@@ -13,12 +14,14 @@ executable sample   main-is:           Main.hs   other-modules:     MyPkg.A MyPkg.B-  build-depends:     base, HTF == 0.10.*+  build-depends:     base, HTF   default-language:  Haskell2010+  build-tool-depends: HTF:htfpp  test-suite sample-tests   type:              exitcode-stdio-1.0   main-is:           TestMain.hs   other-modules:     MyPkg.A MyPkg.B-  build-depends:     base, HTF == 0.10.*+  build-depends:     base, HTF   default-language:  Haskell2010+  build-tool-depends: HTF:htfpp
+ scripts/check.sh view
@@ -0,0 +1,40 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+    echo "Checks that HTF compiles against all resolvers mentioned in .travis.yml"+    exit 1+fi++set -e++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+TRAVIS="$TOP/.travis.yml"+if [ ! -e "$TRAVIS" ]; then+    echo "$TRAVIS does not exist!"+    exit 1+fi++YAMLS=$(grep '^- HTF_TEST_STACK_ARGS' "$TRAVIS" | sed 's/^.*="--stack-yaml //g; s/"$//g')++if [ -z "$TRAVIS_BUILD_DIR" ]; then+    export TRAVIS_BUILD_DIR="$TOP"+fi++for yaml in $YAMLS; do+    echo >&2+    eval yaml="$yaml" # evaluate variables contained in $yaml+    echo >&2 "Checking with $yaml ..."+    export HTF_TEST_STACK_ARGS="--stack-yaml $yaml"+    stack $HTF_TEST_STACK_ARGS build+    ecode=$?+    if [ $ecode -ne 0 ]; then+        echo >&2 "Build for $yaml failed!"+        exit 1+    fi+    stack $HTF_TEST_STACK_ARGS test+    ecode=$?+    if [ $ecode -ne 0 ]; then+        echo >&2 "Test for $yaml failed!"+        exit 1+    fi+done
+ scripts/dist.sh view
@@ -0,0 +1,50 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+    echo "USAGE: $0 [--no-check]"+    echo "Creates an dist tarball and checks that it builds."+    exit 1+fi++no_check=no+if [ "$1" == "--no-check" ]; then+    no_check=yes+fi++version=$(gawk -F: '/^Version:/ { print $2 }' HTF.cabal | sed 's/ //g')++echo "Building version $version"++# Somehow, --test-tarball always because of a strange permission error. That's why+# we do the checks here by hand.++stack sdist . --no-test-tarball || exit 1+tarball=$(find $(pwd)/.stack-work/dist -name "*${version}.tar.gz" | xargs ls -t | head -1)++echo "Distribution tarball is $tarball"++tmp=$(mktemp -d)+tar -C "$tmp" -x -z -f "$tarball" || exit 1++if [ "$no_check" == "yes" ]; then+    echo "Skipping tests as requested"+else+    pushd "${tmp}/HTF-${version}" > /dev/null+    echo "Running checks in directory $(pwd)"+    scripts/check.sh || exit 1+    popd > /dev/null+fi++git_tag="release/${version}"+if ! git tag --points-at HEAD | grep -E "^$git_tag$" > /dev/null; then+    git tag "$git_tag" || exit 1+    echo "Tagged HEAD with $git_tag"+fi++echo+echo+echo 'All checks succeeded, now upload to archive using the following command:'+echo '$ stack upload . --no-test-tarball'+echo+echo 'And do not forget to push all tags:'+echo '$ git push --tags'
+ scripts/local-htfpp view
@@ -0,0 +1,36 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)++if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_TEST_STACK_YAML" ]; then+    HTF_TEST_STACK_ARGS="--stack-yaml $HTF_TEST_STACK_YAML"+fi+if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_STACK_YAML" ]; then+    HTF_TEST_STACK_ARGS="--stack-yaml $HTF_STACK_YAML"+fi++dist=$(stack $HTF_TEST_STACK_ARGS path --dist-dir 2> /dev/null)+find=find+if [ "$(uname)" == "Darwin" ]; then+    find=gfind+fi++function find_bin()+{+    local d="$TOP/$dist"+    if [ ! -d "$d" ]; then+        d="$(dirname $d)"+    fi+    bin=$($find "$d" -name htfpp -type f -executable -printf "%T+\t%p\n" | sort -r | head -1 | cut -f 2)+}++find_bin++if [ -z "$bin" ]; then+    echo "TOP=$TOP" >&2+    echo "dist=$dist" >&2+    echo "bin=$bin" >&2+    echo "No executable named htfpp found in $TOP/$dist. Aborting!" >&2+    exit 1+fi+"$bin" "$@"
+ scripts/prepare view
@@ -0,0 +1,6 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+echo "Preparing everything for building ..."+chmod 755 "$TOP/scripts/local-htfpp"+echo "Done with preparing!"
+ scripts/run-sample view
@@ -0,0 +1,3 @@+#!/bin/bash++stack exec sample -- "$@"
+ stack-ghc-8.10.yaml view
@@ -0,0 +1,4 @@+resolver: lts-18.28+flags: {}+packages:+- '.'
+ stack-ghc-8.2.yaml view
@@ -0,0 +1,5 @@+resolver: lts-11.22+flags: {}+packages:+- '.'+extra-deps: []
+ stack-ghc-8.4.yaml view
@@ -0,0 +1,6 @@+resolver: lts-12.26+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ stack-ghc-8.6.yaml view
@@ -0,0 +1,6 @@+resolver: lts-14.27+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ stack-ghc-8.8.yaml view
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
+ stack-ghc-9.0.yaml view
@@ -0,0 +1,4 @@+resolver: lts-19.33+flags: {}+packages:+- '.'
+ stack-ghc-9.2.yaml view
@@ -0,0 +1,4 @@+resolver: lts-20.12+flags: {}+packages:+- '.'
+ stack-ghc-9.4.yaml view
@@ -0,0 +1,4 @@+resolver: lts-21.25+flags: {}+packages:+- '.'
+ stack.yaml view
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
tests/Foo/A.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} {-# LANGUAGE CPP #-}  module Foo.A where@@ -7,5 +7,5 @@  #include "test.h" -test_a =+test_a_FAIL =     assertEqual x y
tests/Foo/B.hs view
@@ -1,7 +1,7 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}  module Foo.B (htf_thisModulesTests) where  import qualified Test.Framework as HTF -test_b = assertEqual 1 1+test_b_OK = HTF.assertEqual 1 1
tests/Foo/test.h view
@@ -4,3 +4,6 @@  y :: Int y = 2++test_h_FAIL =+    assertEqual 4 5
+ tests/MiscTest.hs view
@@ -0,0 +1,38 @@+--+-- Copyright (c) 2013   Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++import Test.Framework.History+import Test.Framework.Preprocessor+import Test.Framework.PrettyHaskell+import Test.Framework.HUnitWrapper+import Test.Framework.TestManager+import System.Exit+import Test.HUnit++allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests ++ wrappableTests++main :: IO ()+main =+    do counts <- runTestTT hunitTests+       if errors counts /= 0 || failures counts /= 0+       then exitWith (ExitFailure 1)+       else exitWith ExitSuccess+    where+      hunitTests =+          TestList (map (\(name, code) -> TestLabel name (TestCase code)) allTests)
+ tests/Quasi.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+module Quasi where++import Language.Haskell.TH.Quote+import GHC.Exts (IsString(..))++q :: QuasiQuoter+q = QuasiQuoter exprQ undefined undefined undefined+    where+      exprQ =+          (\a -> [|fromString a|]) . filter (/= '\r')
tests/TestHTF.hs view
@@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} -- -- Copyright (c) 2005,2010   Stefan Wehr - http://www.stefanwehr.de --@@ -19,10 +25,11 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. --- import Test.Framework+import Test.Framework.Location import Test.Framework.TestManager import Test.Framework.BlackBoxTest+import Test.Framework.TestInterface  import System.Environment import System.Directory@@ -32,21 +39,44 @@ import System.IO import System.IO.Temp import Control.Exception-import qualified Data.HashMap.Strict as M+import Control.Monad++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif+import qualified Data.HashSet as Set import qualified Data.Aeson as J+import qualified Data.Aeson.Encode.Pretty 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 Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.List as List import qualified Text.Regex as R-import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible+import GHC.Stack+ import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B +import FailFast+import MaxCurTime+import MaxPrevTime+import UniqTests1+import UniqTests2+import PrevFactor+import Repeat+import SortByPrevTime+import Quasi++import Tutorial hiding (main)+ data T = A | B        deriving Eq- {- stringGap = "hello \             \world!"@@ -56,38 +86,53 @@ handleExc :: a -> SomeException -> a handleExc x _ = x -test_assertFailure =-    assertFailure "I'm a failure"+-- 世界不是英文的 Test for #47 -test_stringGap = assertEqual stringGap "hello world!"+-- Test for #48+data HVect (ts :: [*]) where+  HNil :: HVect '[]+  HCons :: t -> HVect ts -> HVect (t ': ts) -test_assertEqual = assertEqual 1 2+fun :: HVect '[Int, Int] -> String+fun = undefined -test_assertEqualV = assertEqualVerbose "blub" 1 2+-- Test for #45+foobar = [q|INSERT INTO a (name) VALUES ('')|] -test_assertEqualNoShow = assertEqualNoShow A B+test_assertFailure_FAIL = assertFailure "I'm a failure" -test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2]+test_stringGap_OK = assertEqual stringGap "hello world!" -test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1]+test_assertEqual_FAIL = assertEqual 1 2 -test_assertNotEmpty = assertNotEmpty []+test_assertEqualV_FAIL = assertEqualVerbose "blub" 1 2 -test_assertEmpty = assertEmpty [1]+test_assertEqualNoShow_FAIL = withOptions (\opts -> opts { to_parallel = False }) $+                              assertEqualNoShow A B -test_assertThrows = assertThrows (return () :: IO ()) (handleExc True)+test_assertListsEqualAsSets_FAIL = assertListsEqualAsSets [1,2] [2] -test_assertThrows' = assertThrows (error "ERROR") (handleExc False)+test_assertSetEqualSuccess_OK = assertListsEqualAsSets [1,2] [2,1] -test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False)+test_assertNotEmpty_FAIL = assertNotEmpty [] -test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True)+test_assertEmpty_FAIL = assertEmpty [1] -test_someError = error "Bart Simpson!!"+test_assertElem_FAIL = assertElem 1 [0,2,3] -test_pendingTest = unitTestPending "This test is pending"+test_assertThrows_FAIL = assertThrows (return () :: IO ()) (handleExc True) -test_subAssert = subAssert anotherSub+test_assertThrows'_FAIL = assertThrows (error "ERROR") (handleExc False)++test_assertThrowsIO1_FAIL = assertThrows (fail "ERROR" :: IO ()) (handleExc False)++test_assertThrowsIO2_OK = assertThrowsIO (fail "ERROR") (handleExc True)++test_someError_ERROR = error "Bart Simpson!!" :: IO ()++test_pendingTest_PENDING = unitTestPending "This test is pending"++test_subAssert_FAIL = subAssert anotherSub     where       anotherSub = subAssertVerbose "I'm another sub" (assertNegative 42)       assertNegative n = assertBool (n < 0)@@ -98,7 +143,7 @@           | Variable String             deriving (Eq, Show) -test_diff =+test_diff_FAIL =     assertEqual (mkExpr 1) (mkExpr 2)     where       mkExpr i =@@ -108,89 +153,269 @@                              (Literal 581))                    (Variable "egg") -prop_ok :: [Int] -> Property-prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs))+test_diff2_FAIL =+  assertEqual s1 s2+  where+    n = 100000+    s1 = mk [0..n]+    s2 = mk ([0..4999] ++ [5001..n])+    mk :: [Int] -> String+    mk [] = ""+    mk (x:[]) = "line " ++ show x+    mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_fail :: [Int] -> Bool-prop_fail xs = xs == (reverse xs)+test_diff3_FAIL =+  assertEqual s1 s2+  where+    n = 100000+    s1 = mk [0..n]+    s2 = mk [0..(n+1)]+    mk :: [Int] -> String+    mk [] = ""+    mk (x:[]) = "line " ++ show x+    mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_pendingProp :: Int -> Bool-prop_pendingProp x = qcPending "This property is pending" (x == 0)+prop_ok_OK :: [Int] -> Property+prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) -prop_exhaust = False ==> True+prop_fail_FAIL :: [Int] -> Bool+prop_fail_FAIL xs = xs == (reverse xs) -prop_error :: Bool-prop_error = error "Lisa"+prop_pendingProp_PENDING :: Int -> Bool+prop_pendingProp_PENDING x = qcPending "This property is pending" (x == 0) +prop_exhaust_FAIL = False ==> True++prop_implies :: Int -> Property+prop_implies n = n <= 10 ==> (\i -> i + n <= i + 10)++prop_forAll = forAll (choose (0::Int, 10::Int)) (\i -> i < 11)++prop_error_FAIL :: Bool+prop_error_FAIL = 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_ok'_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+prop_fail'_FAIL =+    prop     where prop xs = xs == (reverse xs)               where types = xs::[Int] -prop_error' :: TestableWithQCArgs-prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool)+prop_error'_FAIL :: WithQCArgs Bool+prop_error'_FAIL = withQCArgs changeArgs $ (error "Lisa" :: Bool) +test_genericAssertions_OK =+    case test1 of+      AssertOk _ -> fail "did not expect AssertOk"+      AssertFailed stack msg ->+          do assertEqualVerbose ("stack=" ++ show stack) 2 (length (htfStackToList stack))+             let [se1, se2] = htfStackToList stack+                 loc1 = hse_location se1+                 loc2 = hse_location se2+             assertEqual (fileName loc1) (fileName loc2)+             assertEqual (lineNumber loc1) (line - 1)+             assertEqual (lineNumber loc2) (line - 3)+             assertNotEqual msg ""+    where+      test1 = test2+      test2 :: (HasCallStack) => AssertBool ()+      test2 = gassertBool False+      line = __LINE__++-- find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_PENDING" | sed 's/test_//g; s/prop_//g' | sort -u+pendingTests :: [T.Text]+pendingTests =+    ["pendingProp_PENDING"+    ,"pendingTest_PENDING"]++failedTests :: [T.Text]+failedTests =+-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_FAIL" | sed 's/test_//g; s/prop_//g' | sort -u+    ["a_FAIL"+    ,"h_FAIL"+    ,"assertElem_FAIL"+    ,"assertEmpty_FAIL"+    ,"assertEqualNoShow_FAIL"+    ,"assertEqualV_FAIL"+    ,"assertEqual_FAIL"+    ,"assertFailure_FAIL"+    ,"assertListsEqualAsSets_FAIL"+    ,"assertNotEmpty_FAIL"+    ,"assertThrows'_FAIL"+    ,"assertThrowsIO1_FAIL"+    ,"assertThrows_FAIL"+    ,"diff_FAIL"+    ,"diff2_FAIL"+    ,"diff3_FAIL"+    ,"error'_FAIL"+    ,"error_FAIL"+    ,"exhaust_FAIL"+    ,"fail'_FAIL"+    ,"fail_FAIL"+    ,"subAssert_FAIL"+-- $ find bbt -name '*not_ok*.x'+    ,"bbt/should_fail/not_ok_because_stderr1.x"+    ,"bbt/should_fail/not_ok_because_stderr2.x"+    ,"bbt/should_fail/not_ok_because_stdout1.x"+    ,"bbt/should_fail/not_ok_because_stdout2.x"+    ,"bbt/should_fail/not_ok_because_succeeds.x"+    ,"bbt/should_pass/not_ok_because_fails.x"+    ,"bbt/should_pass/not_ok_because_stderr1.x"+    ,"bbt/should_pass/not_ok_because_stderr2.x"+    ,"bbt/should_pass/not_ok_because_stdout1.x"+    ,"bbt/should_pass/not_ok_because_stdout2.x"+    ,"bbt/Verbose/not_ok_because_stdout1.x"]++-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_ERROR" | sed 's/test_//g; s/prop_//g' | sort -u+errorTests :: [T.Text]+errorTests = ["someError_ERROR"]++passedTests :: [T.Text]+passedTests =+    -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_OK" | sed 's/test_//g; s/prop_//g' | sort -u+    ["assertSetEqualSuccess_OK"+    ,"assertThrowsIO2_OK"+    ,"b_OK"+    ,"genericAssertions_OK"+    ,"ok'_OK"+    ,"ok_OK"+    ,"stringGap_OK"+    ,"implies"+    ,"forAll"+-- $ find bbt -name '*ok*.x' | grep -v not_ok+    ,"bbt/should_fail/ok1.x"+    ,"bbt/should_fail/ok2.x"+    ,"bbt/should_pass/ok1.x"+    ,"bbt/should_pass/ok2.x"+    ,"bbt/should_pass/stdin_ok.x"]++timedOutTests = []+ checkOutput output =     do bsl <- BSL.readFile output        let jsons = map (fromJust . J.decode) (splitJson bsl)+       let (pass, fail, error, pending, timedOut) = foldl checkStatus ([], [], [], [], []) jsons+       checkAsSet "passed" passedTests pass+       checkAsSet "failed" failedTests fail+       checkAsSet "errors" errorTests error+       checkAsSet "pending" pendingTests pending+       checkAsSet "timed-out" timedOutTests timedOut        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)])+                   (J.object ["failures" .= J.toJSON (length failedTests)+                             ,"passed" .= J.toJSON (length passedTests)+                             ,"pending" .= J.toJSON (length pendingTests)+                             ,"errors" .= J.toJSON (length errorTests)+                             ,"timedOut" .= J.toJSON (length timedOutTests)])        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)]])+                             ,"test" .= J.object ["flatName" .= J.String "Main:diff_FAIL"]])+                   (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs"+                                                                         ,"line" .= J.toJSON (106+lineOffset)]]+                             ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+                                                     ,"line" .= J.toJSON (107+lineOffset)]])        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$"+                             ,"test" .= J.object ["flatName" .= J.String "Main:diff2_FAIL"]])+                   (J.object ["message" .= J.String "NOT:No newline at end of file"])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Main:diff3_FAIL"]])+                   (J.object ["message" .= J.String "NOT:No newline at end of file"])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]])+                   (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)]]]])+                             ,"test" .= J.object ["flatName" .= J.String "Foo.A:h_FAIL"]])+                   (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/test.h"+                                                                         ,"line" .= J.toJSON (8::Int)]]+                             ,"location" .= J.object ["file" .= J.String "./Foo/test.h"+                                                     ,"line" .= J.toJSON (9::Int)]])+       check jsons (J.object ["type" .= J.String "test-end"+                             ,"test" .= J.object ["flatName" .= J.String "Main:subAssert_FAIL"]])+                   (J.object ["callers" .= J.toJSON [J.object ["message" .= J.String "I'm another sub"+                                                              ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+                                                                                      ,"line" .= J.toJSON (97+lineOffset)]]+                                                    ,J.object ["message" .= J.Null+                                                              ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+                                                                                      ,"line" .= J.toJSON (95+lineOffset)]]]])     where+      lineOffset :: Int+      lineOffset = 40+      checkStatus tuple@(pass, fail, error, pending, timedOut) json =+          {-+            {"location":null+            ,"test":{"path":["Main","tests/bbt/should_pass/stdin_ok.x"],"sort":"blackbox-test","flatName":"Main:tests/bbt/should_pass/stdin_ok.x"}+            ,"callers":[]+            ,"result":"pass"+            ,"timedOut":false+            ,"type":"test-end"+            ,"message":""+            ,"wallTime":11}+           -}+          case json of+            J.Object objJson | Just (J.Object testObj) <- KM.lookup "test" objJson+                             , Just (J.String flatName) <- KM.lookup "flatName" testObj+                             , Just (J.String "test-end") <- KM.lookup "type" objJson+                             , Just (J.String result) <- KM.lookup "result" objJson+                             , Just (J.Bool to) <- KM.lookup "timedOut" objJson ->+                let shortName =+                        let t = T.tail (T.dropWhile (/= ':') flatName)+                        in if "tests/" `T.isPrefixOf` t+                           then T.drop (T.length "tests/") t+                           else t+                    newTimedOut = if to then shortName : timedOut else timedOut+                in case () of+                     _| result == "pass" -> (shortName : pass, fail, error, pending, newTimedOut)+                     _| result == "fail" -> (pass, shortName : fail, error, pending, newTimedOut)+                     _| result == "error" -> (pass, fail, shortName : error, pending, newTimedOut)+                     _| result == "pending" -> (pass, fail, error, shortName : pending, newTimedOut)+            _ -> tuple+      checkAsSet what expList givenList =+          let expSet = Set.fromList expList+              givenSet = Set.fromList givenList+          in if expSet == givenSet+             then return ()+             else do let unexpected = givenSet `Set.difference` expSet+                         notGiven = expSet `Set.difference` givenSet+                     fail ("Mismatch for " ++ what ++ ":" +++                           "\nExpected: " ++ show expList +++                           "\nGiven: " ++ show givenList +++                           "\nUnexpected elements: " ++ show unexpected +++                           "\nElements expected but not present: " ++ show notGiven)       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")+                   then error ("Predicate\n" ++ ppJ pred ++ " match JSON\n" ++ ppJ json ++ ", but assertion\n" +++                               ppJ 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+                KM.foldrWithKey (\k vPred b ->+                                    b && case KM.lookup k objJson of                                            Just vJson -> matches vJson vPred                                            Nothing -> False)                                True objPred             (J.String strJson, J.String strPred) ->-                regexMatches (mkRegex strPred) strJson+                regexMatches 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)+      regexMatches pred t =+        let s = T.unpack t+        in case T.unpack pred of+             'N':'O':'T':':':rest -> isNothing $ R.matchRegex (mkRegex (T.pack rest)) s+             _ -> isJust $ R.matchRegex (mkRegex pred) s       mkRegex s = R.mkRegexWithOpts (T.unpack s) True False       splitJson bsl =           if BSL.null bsl@@ -202,7 +427,22 @@                            else case splitJson rest of                                   [] -> error "invalid json output from HTF"                                   (x:xs) -> (start `BSL.append` x : xs)+      ppJ json =+          T.unpack $+          T.decodeUtf8With T.lenientDecode $+          BSL.toStrict $+          J.encodePretty' J.defConfig json +runRealBlackBoxTests =+    do b <- doesDirectoryExist "tests/bbt"+       let dirPrefix = if b then "tests" else ""+       bbts <- blackBoxTests (dirPrefix </> "real-bbt") ("/bin/bash") ".sh"+                 (defaultBBTArgs { bbtArgs_verbose = True })+       ecode <- runTest bbts+       case ecode of+         ExitFailure _ -> fail ("real blackbox tests failed!")+         _ -> return ()+ main =     do args <- getArgs        b <- doesDirectoryExist "tests/bbt"@@ -210,8 +450,21 @@        bbts <- blackBoxTests (dirPrefix </> "bbt") (dirPrefix </> "./run-bbt.sh") ".x"                  (defaultBBTArgs { bbtArgs_verbose = False })        let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests+       when ("--help" `elem` args || "-h" `elem` args) $+            do hPutStrLn stderr ("USAGE: PROG [--direct]")+               ecode <- runTestWithArgs ["--help"] ([] :: [Test])+               exitWith ecode        case args of-         "--interactive":rest ->+         "FailFast.hs":rest -> failFastMain rest+         "MaxCurTime.hs":rest -> maxCurTimeMain rest+         "MaxPrevTime.hs":rest -> maxPrevTimeMain rest+         "PrevFactor.hs":rest -> prevFactorMain rest+         "Repeat.hs":rest -> repeatMain rest+         "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest+         "UniqTests1.hs":rest -> uniqTests1Main rest+         "UniqTests2.hs":rest -> uniqTests2Main rest+         x:_ | ".hs" `List.isSuffixOf` x -> fail ("Unkown real-bbt test: " ++ x)+         "--direct":rest ->              do ecode <- runTestWithArgs rest tests                 case ecode of                   ExitFailure _ -> return ()@@ -219,11 +472,11 @@          _ ->              do withSystemTempFile "HTF-out" $ \outFile h ->                   do hClose h-                     ecode <- runTestWithArgs ["--json", "--output-file=" ++ outFile] tests+                     ecode <- runTestWithArgs ["-j4", "--shuffle=false",+                                               "--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+                runRealBlackBoxTests
− tests/TestHTFHunitBackwardsCompatible.hs 
@@ -1,10 +0,0 @@-{-# 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)
+ tests/ThreadPoolTest.hs view
@@ -0,0 +1,39 @@+--+-- Copyright (c) 2013   Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++import Test.Framework.ThreadPool+import System.Environment+import System.Exit+import Control.Monad++main :: IO ()+main =+    do args <- getArgs+       when ("-h" `elem` args || "--help" `elem` args) usage+       (i, nEntries) <- case args of+                          [] -> return (200, 100)+                          [x] -> return (read x, 100)+                          [x, y] -> return (read x, read y)+                          _ -> usage+       threadPoolTest (1, i) nEntries+       return ()+    where+      usage =+          do putStrLn "USAGE: ThreadPoolTest [N_THREADS [N_ENTRIES]]"+             exitWith (ExitFailure 1)
tests/Tutorial.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module Tutorial where+ import System.Environment ( getArgs ) import System.Exit ( exitWith ) import Test.Framework
+ tests/bbt/should_fail/not_ok_because_stderr2.err view
+ tests/bbt/should_fail/not_ok_because_stdout2.out view
+ tests/bbt/should_pass/not_ok_because_stderr2.err view
+ tests/bbt/should_pass/not_ok_because_stdout2.out view
tests/compile-errors/Test1.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h"  foo :: Int -> Int
tests/compile-errors/Test2.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int foo i = i + "Stefan"
tests/compile-errors/Test3.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework  -- error must be in line 7 test_foo :: Int
tests/compile-errors/Test4.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework data D = D -- error must be in line 7 prop_foo :: D -> Bool
tests/compile-errors/run-tests.sh view
@@ -2,20 +2,27 @@  cd "$(dirname $0)" -FLAGS="-hide-all-packages -package HTF -package base --make" lineno=7- function check() {     test="$1"-    ghc $FLAGS "$test" 2>&1 | grep "$test":$lineno+    echo "Running test $test ..."+    command -v grep >/dev/null 2>&1 || \+        { echo >&2 "Test $0 requires ``grep'' but it's not installed.  Aborting."; exit 1; }+    compile_cmd="stack $HTF_TEST_STACK_ARGS ghc --package HTF -- -XPackageImports $test"+    $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null     grep_ecode=${PIPESTATUS[1]}     if [ "$grep_ecode" != "0" ]     then         echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"-        ghc $FLAGS "$test"+        echo "Compile command: $compile_cmd"+        echo "Stack version: $(stack --version)"+        echo "GHC version: $(stack $HTF_TEST_STACK_ARGS ghc -- --version)"+        echo "Here is the output of the compiler:"+        $compile_cmd         exit 1     fi+    echo "Done with test $test" }  check Test1.hs
+ tests/real-bbt/FailFast.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module FailFast (failFastMain) where++import Test.Framework++test_1 = assertEqual 1 2+test_2 = assertEqual 1 2++failFastMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxCurTime.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module MaxCurTime (maxCurTimeMain) where++import Test.Framework+import Control.Concurrent+import System.IO.Unsafe++test_slow :: IO ()+test_slow = threadDelay 20000++prop_verySlow :: Int -> Bool+prop_verySlow _i = unsafePerformIO test_slow `seq` True++maxCurTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module MaxPrevTime (maxPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 20000++test_fast :: IO ()+test_fast = return ()++maxPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/PrevFactor.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module PrevFactor (prevFactorMain) where++import Test.Framework+import Test.Framework.TestManager+import System.Environment+import System.Exit+import Control.Concurrent++doTest :: Bool -> IO ()+doTest slow =+    if slow then threadDelay 100000 else threadDelay 1000++prevFactorMain args =+    do ecode <-+           case args of+             "SLOW":rest -> runTestWithArgs rest [doTest True]+             _ -> runTestWithArgs args [doTest False]+       exitWith ecode
+ tests/real-bbt/Repeat.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module Repeat (repeatMain) where++import Test.Framework++import Data.IORef+import System.IO.Unsafe++globalBool :: IORef Bool+globalBool = unsafePerformIO (newIORef True)+{-# NOINLINE globalBool #-}++readGlobalBool ::  IO Bool+readGlobalBool =+    do b <- readIORef globalBool+       writeIORef globalBool False+       return b++test_globalMVarIsTrue =+    do b <- readGlobalBool+       assertEqual b True++repeatMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/SortByPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module SortByPrevTime (sortByPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 300000++test_fast :: IO ()+test_fast = return ()++sortByPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests1.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module UniqTests1 (uniqTests1Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast = return ()++uniqTests1Main args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests2.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module UniqTests2 (uniqTests2Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast =+    let l =+            flip map [True, False] $ \case+                                        True -> 1+                                        False -> 2+    in putStrLn (show l)++uniqTests2Main args = htfMainWithArgs args htf_thisModulesTests
− tests/run-tests.sh 
@@ -1,15 +0,0 @@-#!/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"
− tests/test-HTF.cabal 
@@ -1,25 +0,0 @@-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