packages feed

HTF 0.8.2.2 → 0.15.0.2

raw patch · 122 files changed

Files

ChangeLog view
@@ -1,3 +1,163 @@+* 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.++* 0.10.0.0 (2012-12-06)+  - machine-readable output: the --json option provides a way for getting+    machine-readable output in a simple JSON-based format+  - support for subAssert (allows abstraction over assertions but keeps error locations)+  - don't depend on unix under Windows+  - added timing information to the output+  - possibility to list all tests+  - several bugfixes, especially related to location information in presence+    of an extra cpp invocation+  - HTF itself now has a test suite+  - removed upper bounds from .cabal files+  - backwards incompatibilities:+    + Test.Framework now longer exports all of Test.Framework.TestManager and+      Test.Framework.BlackBoxTest. For modules that only define tests, no changes+      should be necessary. However, you likely need to adjust your test runner+      module by importing Test.Framework.TestManager and possibly Test.Framework.BlackBoxTest.+    + Some reorganization in Test.Framework.TestManager and related modules, introduction+      of Test.Framework.TestTypes. Usually, your code should not be affected+      by these changes.++* 0.9.0.0 (2012-09-26)+  NOTE: this version is NOT backwards compatible with 0.8.*. The documentation on+  hackage describes what you need to do in order to upgrade.++  - Totally reworked how tests are collected+  - Greatly improved documentation (fixes issue #2)+  - Added assertThrowsIO and similar functions (fixes issue #6)+  - Added htfMain function+ * 0.8.2.0 (2012-01-30)   - Assertions can be run via runTest   - Support for assertNotEqual
HTF.cabal view
@@ -1,80 +1,234 @@+Cabal-Version:    2.0 Name:             HTF-Version:          0.8.2.2-License:          LGPL+Version:          0.15.0.2+License:          LGPL-2.1 License-File:     LICENSE-Copyright:        (c) 2005-2011 Stefan Wehr-Author:           Stefan Wehr <mail@stefanwehr.de>-Maintainer:       Stefan Wehr <mail@stefanwehr.de>-Bug-Reports:      mailto:mail@stefanwehr.de+Copyright:        (c) 2005-2024 Stefan Wehr+Author:           Stefan Wehr+Maintainer:       Stefan Wehr Stability:        Beta Category:         Testing Synopsis:         The Haskell Test Framework+Homepage:         https://github.com/skogsbaer/HTF/+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. The HTF uses a custom-    preprocessor that collects test definitions automatically.-    Furthermore, the preprocessor allows the HTF to report failing-    test cases with exact file name and line number information.+    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.      . +    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.++    .+     The documentation of the "Test.Framework.Tutorial" module-    provides a tutorial for the HTF.+    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==6.10.4, GHC==6.12, GHC==7.0 Build-Type:       Simple-Cabal-Version:    >= 1.6+ Extra-Source-Files:-  README-  TODO+  README.md   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/*.err+  tests/bbt/should_fail/*.out+  tests/bbt/should_fail/*.x+  tests/bbt/should_pass/*.in+  tests/bbt/should_pass/*.err+  tests/bbt/should_pass/*.out+  tests/bbt/should_pass/*.x+  tests/bbt/Skip/BBTArgs+  tests/bbt/Skip/some_unknown_but_skipped_file.x+  tests/bbt/Verbose/BBTArgs+  tests/bbt/Verbose/not_ok_because_stdout1.out+  tests/bbt/Verbose/not_ok_because_stdout1.x+  tests/Foo/test.h+  tests/Tutorial.hs+  tests/run-bbt.sh+  tests/compile-errors/Foo.h+  tests/compile-errors/run-tests.sh+  tests/compile-errors/Test1.hs+  tests/compile-errors/Test2.hs+  tests/compile-errors/Test3.hs+  tests/compile-errors/Test4.hs+  sample/LICENSE+  sample/Main.hs+  sample/MyPkg/A.hs+  sample/MyPkg/B.hs+  sample/README+  sample/sample-HTF.cabal+  sample/Setup.hs+  sample/TestMain.hs+  sample/bbt-dir/should-fail/BBTArgs+  sample/bbt-dir/should-fail/z.err+  sample/bbt-dir/should-fail/z.num+  sample/bbt-dir/should-pass/x.num+  sample/bbt-dir/should-pass/x.out+  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:           darcs-  Location:       http://www.stefanwehr.de/darcs/HTF+  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 && < 1.14,-                    base == 4.*+  Build-Depends:    HUnit,+                    array,+                    base >= 4.10 && < 5,+                    cpphs >= 1.19,+                    directory >= 1.0,+                    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.*,-                    QuickCheck >= 2.3 && < 2.6,-                    base == 4.*,-                    random == 1.0.*,-                    containers >= 0.3 && < 0.6,-                    process >= 1.0 && < 1.2,-                    directory >= 1.0 && < 1.3,-                    mtl >= 1.1 && < 2.2,-                    pretty >= 1.0 && < 1.2,-                    Diff >= 0.1.3 && < 0.2,-                    unix >= 2.4 && < 2.7,-                    bytestring >= 0.9 && < 0.11,-                    regex-compat >= 0.92 && < 0.96,-                    haskell-src-exts >= 1.11 && < 1.14,-                    criterion >= 0.5 && < 0.7+  Build-Depends:    Diff >= 0.3,+                    HUnit >= 1.2.5,+                    QuickCheck >= 2.3,+                    aeson >= 0.11,+                    array,+                    base >= 4.10 && < 5,+                    base64-bytestring,+                    bytestring >= 0.9,+                    containers >= 0.5,+                    cpphs >= 1.19,+                    haskell-src,+                    directory >= 1.0,+                    lifted-base >= 0.1,+                    monad-control >= 0.3,+                    mtl >= 1.1,+                    old-time >= 1.0,+                    pretty >= 1.0,+                    process >= 1.0,+                    random >= 1.0,+                    regex-compat >= 0.92,+                    text >= 0.11,+                    time,+                    vector,+                    xmlgen >= 0.6+  if !os(windows)+    Build-Depends:   unix >= 2.4   Exposed-Modules:     Test.Framework-    Test.Framework.HUnitWrapper-    Test.Framework.CriterionWrapper-    Test.Framework.TestManager-    Test.Framework.TestConfig-    Test.Framework.QuickCheckWrapper+    Test.Framework.AssertM     Test.Framework.BlackBoxTest+    Test.Framework.HUnitWrapper+    Test.Framework.History+    Test.Framework.JsonOutput     Test.Framework.Location-    Test.Framework.Tutorial+    Test.Framework.Preprocessor     Test.Framework.Pretty+    Test.Framework.PrettyHaskell+    Test.Framework.QuickCheckWrapper+    Test.Framework.TestInterface+    Test.Framework.TestManager+    Test.Framework.TestTypes+    Test.Framework.ThreadPool+    Test.Framework.Tutorial+    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:+    -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, tests/real-bbt+  Type:              exitcode-stdio-1.0+  Build-depends:     HTF,+                     aeson >= 0.11,+                     aeson-pretty,+                     base >= 4.10 && < 5,+                     bytestring >= 0.9,+                     directory >= 1.0,+                     filepath >= 1.1,+                     process >= 1.0,+                     random,+                     regex-compat >= 0.92,+                     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, 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
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables,CPP #-}  -- -- Copyright (c) 2009   Stefan Wehr - http://www.stefanwehr.de@@ -18,20 +18,24 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif import System.IO import System.Environment import System.Exit import Control.Monad import Control.Exception+import Data.Version  import Test.Framework.Preprocessor+import qualified Paths_HTF  usage :: IO () 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" ++@@ -41,10 +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@@ -62,10 +70,12 @@              "--help" `elem` args) $            do usage               exitWith (ExitFailure 1)-       let (restArgs, hunitBackwardsCompat) =-               case reverse args of-                 "--hunit":rrest -> (reverse rrest, True)-                 rrest -> (reverse rrest, False)+       when ("--version" `elem` args) $+            do outputVersion+               exitWith ExitSuccess+       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              [] ->@@ -82,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 
@@ -1,33 +0,0 @@-                    HTF - The Haskell Test Framework-                  ====================================--Author:  Stefan Wehr <mail AT stefanwehr DOT de>-License: LGPL--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. The HTF uses a custom preprocessor that collects-test definitions automatically. Furthermore, the preprocessor allows the-HTF to report failing test cases with exact file name and line number-information.--The documentation of the Test.Framework.Tutorial module provides a-tutorial for the HTF.--NOTE: If you use black box tests, you have to compile your program-with the `-threaded' option. Otherwise, your program just blocks-indefinitely!---Requirements:----------------- GHC (tested with 6.10.4 and 6.12.3)-- Some haskell libraries, see HTF.cabal---Installation instructions:-----------------------------Execute the command `cabal install' inside the HTF root directory.
+ README.md view
@@ -0,0 +1,29 @@+# 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++## Summary++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.++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++* Read the [tutorial](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html).+* Experiment with the sample project located in the `sample` directory of HTF's source tree.
− Setup.hs 
@@ -1,5 +0,0 @@-#!/usr/bin/runhaskell--import Distribution.Simple--main = defaultMain
− TODO 
@@ -1,4 +0,0 @@-* Replace haskell-src-exts by the GHC parser-* Write proper documentation-* diff if assertEqualsP fails-* LATER: Support for Smallcheck and/or Lazy Smallcheck
Test/Framework.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- -- Copyright (c) 2005,2009   Stefan Wehr - http://www.stefanwehr.de --@@ -18,21 +16,36 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++Top-level module that re-exports functionality from sub-modules.+Modules that only define unit tests and quickcheck properties typically+only need to import this module.+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 ( -  module Test.Framework.HUnitWrapper,-  module Test.Framework.QuickCheckWrapper,-  module Test.Framework.CriterionWrapper,-  module Test.Framework.BlackBoxTest,-  module Test.Framework.TestManager,+  -- * Unit tests+  module Test.Framework.HUnitWrapper, TM.makeUnitTest, -  Loc.makeLoc+  -- * Quickcheck+  module Test.Framework.QuickCheckWrapper, TM.makeQuickCheckTest, +  -- * Generic assertions+  module Test.Framework.AssertM,++  -- * Organizing tests+  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.CriterionWrapper-import Test.Framework.BlackBoxTest-import Test.Framework.TestManager+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,5 +1,6 @@+{-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009   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,7 +23,13 @@ driver program that is run in various input files. For each input file, the HTF checks that the driver program exits with the correct exit code and that it produces the expected output.+The samples directory of the HTF source tree shows an example+for a black box test, see <https://github.com/skogsbaer/HTF/tree/master/sample>. +/NOTE:/ If you use black box tests, you have to compile your program+with the @-threaded@ option. Otherwise, your program just blocks+indefinitely!+ -} module Test.Framework.BlackBoxTest ( @@ -34,30 +41,28 @@  ) where +#if !MIN_VERSION_base(4,6,0) 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) @@ -65,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@@ -116,14 +121,35 @@ endOfOutput :: String -> String endOfOutput s = "[end of " ++ s ++ "]" -data BBTArgs = BBTArgs { bbtArgs_stdinSuffix    :: String-                       , bbtArgs_stdoutSuffix   :: String-                       , bbtArgs_stderrSuffix   :: String-                       , bbtArgs_dynArgsName    :: String-                       , bbtArgs_verbose        :: Bool-                       , bbtArgs_stdoutDiff     :: Diff-                       , bbtArgs_stderrDiff     :: Diff }+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.+-}+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. 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.+                       }++{- |+Sensible default values for 'BBTArgs':++@+defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = \".in\"+                         , bbtArgs_stdoutSuffix   = \".out\"+                         , bbtArgs_stderrSuffix   = \".err\"+                         , bbtArgs_dynArgsName    = \"BBTArgs\"+                         , bbtArgs_stdoutDiff     = defaultDiff+                         , bbtArgs_stderrDiff     = defaultDiff+                         , bbtArgs_verbose        = False }+@+-} defaultBBTArgs :: BBTArgs defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = ".in"                          , bbtArgs_stdoutSuffix   = ".out"@@ -133,31 +159,70 @@                          , bbtArgs_stderrDiff     = defaultDiff                          , bbtArgs_verbose        = False } +{- |+A default value for the 'Diff' datatype that simple resorts to the+@diff@ commandline utility.+-} 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) -blackBoxTests :: FilePath  -- root directory of the test hierarchy-              -> String    -- name of executable-              -> String    -- filename suffix for input file-              -> BBTArgs   -- configuration+{- |+Collects all black box tests with the given file extension stored in a specific directory.+For example, the invocation++> blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs++returns a list of 'Test' values, one 'Test' for each @.num@ file found in+@bbt-dir@ and its subdirectories. (The samples directory of the HTF source tree+contains the example shown here,+see <https://github.com/skogsbaer/HTF/tree/master/sample>.)++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 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 '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.++ [@Fail@] Specify that the test should succeed if it exits with a non-zero exit code.++ [@Flags: flags@] Passes the given @flags@ to the program under test.++-}+blackBoxTests :: FilePath  -- ^ root directory of the test hierarchy+              -> String    -- ^ name of program under test+              -> String    -- ^ filename suffix for input file+              -> BBTArgs   -- ^ configuration               -> IO [Test] blackBoxTests root exe suf cfg =     do let prune root _ = do dynCfg <- readDynCfg Map.empty
+ Test/Framework/CmdlineOptions.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# 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 commandline options of the test driver provided by HTF.++-}+module Test.Framework.CmdlineOptions (++    CmdlineOptions(..), defaultCmdlineOptions, parseTestArgs, helpString,+    testConfigFromCmdlineOptions++) where++import Test.Framework.TestReporter+import Test.Framework.TestTypes+import Test.Framework.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+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Conc ( numCapabilities )+#endif++import qualified Data.ByteString as BS+import Control.Monad++--+-- CmdlineOptions+--++-- | Commandline options for running tests.+data CmdlineOptions = CmdlineOptions {+      opts_quiet :: Bool                -- ^ Be quiet or not.+    , opts_filter :: TestFilter         -- ^ Run only tests matching this filter.+    , opts_help :: Bool                 -- ^ If 'True', display a help message and exit.+    , opts_negated :: [String]          -- ^ Regular expressions matching test names which should /not/ run.+    , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.+    , 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.+    }++{- |+The default 'CmdlineOptions'.+-}+defaultCmdlineOptions :: CmdlineOptions+defaultCmdlineOptions = CmdlineOptions {+      opts_quiet = False+    , opts_filter = const True+    , opts_help = False+    , opts_negated = []+    , 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 __GLASGOW_HASKELL__+processorCount = numCapabilities+#else+processorCount = 1+#endif++optionDescriptions :: [OptDescr (CmdlineOptions -> Either String CmdlineOptions)]+optionDescriptions =+    [ 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 = Right processorCount+      parseThreads (Just s) =+          case readM s of+            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 is a synopsis+of the format of the commandline arguments:++> USAGE: COMMAND [OPTION ...] PATTERN ...+>+>   where PATTERN is a posix regular expression matching+>   the names of the tests to run.+>+>   -q          --quiet                     Only display errors.+>   -n PATTERN  --not=PATTERN               Tests to exclude.+>   -l          --list                      List all matching tests.+>   -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, []) ->+          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)+               _ -> 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+      matches r s = isJust $ R.matchRegex r s+      mkRegex s = R.mkRegexWithOpts s True False++usageHeader :: String+usageHeader = ("USAGE: COMMAND [OPTION ...] PATTERN ...\n\n" +++               "  where PATTERN is a posix regular expression matching\n" +++               "  the names of the tests to run.\n")++-- | The string displayed for the @--help@ option.+helpString :: String+helpString = usageInfo usageHeader optionDescriptions++--+-- TestConfig+--++-- | Turn the 'CmdlineOptions' into a 'TestConfig'.+testConfigFromCmdlineOptions :: CmdlineOptions -> IO TestConfig+testConfigFromCmdlineOptions opts =+    do (output, colors) <-+           case (opts_outputFile opts, opts_split opts) of+             (Just fname, True) -> return (TestOutputSplitted fname, False)+             _ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile+                     colors <- checkColors mOutputFd+                     return (TestOutputHandle outputHandle closeOutput, colors)+       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_shuffle = opts_shuffle opts+                           , tc_output = output+                           , tc_outputXml = opts_machineOutputXml opts+                           , tc_reporters = reporters+                           , 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 =+          case opts_outputFile opts of+            Nothing -> return (stdout, False, Nothing)+            Just fname ->+                do f <- openFile fname WriteMode+                   return (f, True, Nothing)+      checkColors mOutputFd =+          case opts_useColors opts of+            Just b -> return b+            Nothing -> return False+#else+      openOutputFile =+          case opts_outputFile opts of+            Nothing -> return (stdout, False, Just stdOutput)+            Just fname ->+                do f <- openFile fname WriteMode+                   return (f, True, Nothing)+      checkColors mOutputFd =+          case opts_useColors opts of+            Just b -> return b+            Nothing ->+                do mterm <- getEnv "TERM"+                   case mterm of+                     Nothing -> return False+                     Just s | map toLower s == "dumb" -> return False+                     _ -> do mx <- getEnv "HTF_NO_COLORS"+                             case mx of+                               Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False+                               _ -> case mOutputFd of+                                      Just fd -> queryTerminal fd+                                      _ -> return False+#endif+      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   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,16 +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  ) where -import Test.Framework.TestConfig---- 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@@ -39,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"@@ -65,16 +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)++instance IsString ColorString where+    fromString = noColor++emptyColorString :: ColorString+emptyColorString = noColor ""++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/CriterionWrapper.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}------- Copyright (c) 2011   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.CriterionWrapper (--    HtfBenchmark, ComparisonBenchmark-  , mkComparison, mkComparisonWithMargin-  , simpleBenchmark, withBenchmarkConfig-  , withBenchmarkComparison, withBenchmarkComparisonAndConfig-  , IsHtfBenchmark, asHtfBenchmark, prepareHtfBenchmark-  , defaultBenchmarkConfig--) where----import qualified Data.Vector.Unboxed as V---import Control.Monad.Trans--import Data.Maybe (isJust)--import Criterion-import Criterion.Monad-import Criterion.Environment-import Criterion.Config--import Test.Framework.TestConfig--data AnyBenchmarkable = forall b . Benchmarkable b => AnyBenchmarkable b--instance Benchmarkable AnyBenchmarkable where-    run (AnyBenchmarkable b) n = run b n--data HtfBenchmark-    = HtfBenchmark-      { htfb_benchmarkable :: AnyBenchmarkable-      , htfb_config :: Config-      , htfb_comparison :: Maybe ComparisonBenchmark-      , htfb_pending :: Bool-      }--instance Benchmarkable HtfBenchmark where-    run b n = run (htfb_benchmarkable b) n--data ComparisonBenchmark-    = ComparisonBenchmark-      { cb_benchmarkable :: AnyBenchmarkable-      , cb_factor :: Double-      , cb_margin :: Double-      }--defaultBenchmarkConfig :: Config-defaultBenchmarkConfig = defaultConfig--mkComparison :: Benchmarkable b => b -> Double -> ComparisonBenchmark-mkComparison b f = mkComparisonWithMargin b f 0.1--mkComparisonWithMargin :: Benchmarkable b => b -> Double -> Double -> ComparisonBenchmark-mkComparisonWithMargin b f m = ComparisonBenchmark (AnyBenchmarkable b) f m--simpleBenchmark :: Benchmarkable b => b -> HtfBenchmark-simpleBenchmark b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = defaultConfig-    , htfb_comparison = Nothing-    , htfb_pending = False-    }--withBenchmarkConfig :: Benchmarkable b => Config -> b -> HtfBenchmark-withBenchmarkConfig cfg b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = cfg-    , htfb_comparison = Nothing-    , htfb_pending = False-    }--withBenchmarkComparison :: Benchmarkable b => ComparisonBenchmark -> b -> HtfBenchmark-withBenchmarkComparison cmp b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = defaultConfig-    , htfb_comparison = Just cmp-    , htfb_pending = False-    }--withBenchmarkComparisonAndConfig ::-    Benchmarkable b => ComparisonBenchmark -> Config -> b -> HtfBenchmark-withBenchmarkComparisonAndConfig cmp cfg b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = cfg-    , htfb_comparison = Just cmp-    , htfb_pending = False-    }--{--getSamples :: Benchmarkable b => b -> IO [Double]-getSamples b =-    do samples <- withConfig defaultConfig $ do env <- measureEnvironment-                                                liftIO $ putStrLn "running benchmark"-                                                runBenchmark env b-       return $ V.toList samples--}--class IsHtfBenchmark a where-    isHtfBenchmark :: a -> Maybe HtfBenchmark--instance IsHtfBenchmark HtfBenchmark where-    isHtfBenchmark = Just--instance Benchmarkable b => IsHtfBenchmark b where-    isHtfBenchmark = Just . simpleBenchmark--asHtfBenchmark :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark-asHtfBenchmark b =-    case isHtfBenchmark b of-      Nothing -> simpleBenchmark b-      Just h -> h--prepareHtfBenchmark :: HtfBenchmark -> (TestConfig -> Bool, IO ())-prepareHtfBenchmark bench =-    (\tc -> tc_benchmarks tc || isJust (htfb_comparison bench),-     putStrLn "running benchmarks not yet implemented")--benchmarkPending :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark-benchmarkPending x =-    (asHtfBenchmark x) { htfb_pending = True }
Test/Framework/Diff.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----- Copyright (c) 2011   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,32 +19,32 @@  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  import Control.Exception (catch, finally, IOException) import qualified Data.List as List-import Data.Algorithm.Diff-import Data.Char (isDigit)-import Test.QuickCheck-import Text.PrettyPrint-import Debug.Trace (trace)-+import Data.Char+import qualified Data.Algorithm.Diff as D+import Data.Algorithm.DiffOutput import Test.Framework.Colors-import Test.Framework.TestConfig  -- for testing import System.IO-import System.Environment import System.Directory-import System.IO.Unsafe (unsafePerformIO) import System.Exit import System.Process+import System.Environment (getArgs)+import qualified Data.Text as T  data Pos = First | Middle | Last | FirstLast          deriving (Eq)@@ -58,85 +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 = getGroupedDiff s1 s2-        in foldr (\(group, pos) string ->-                      (showDiffGroup pos group) ++-                      (if not (isLast pos) then dc_sep dc else "") +++        let groups = D.getGroupedDiff s1 s2+        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-      showDiffGroup _ (F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc-      showDiffGroup _ (S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc-      showDiffGroup pos (B, inBoth) =+      showDiffGroup _ (D.First s) = dc_fromFirst dc s+      showDiffGroup _ (D.Second s) = dc_fromSecond dc s+      showDiffGroup pos (D.Both inBoth _) =           let showStart = not $ isFirst pos               showEnd = not $ isLast pos               (contextStart, ignored, contextEnd) =@@ -148,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@@ -160,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@@ -390,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: --@@ -399,4 +259,3 @@ -- vs. -- > 1 -- > 2--}
Test/Framework/HUnitWrapper.hs view
@@ -1,346 +1,932 @@-{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}-{-# LANGUAGE ScopedTypeVariables #-}------ 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--- 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-----{-|-You should not use the functions provided by this module directly.-Instead, for each function @assertXXX_@ defined in this module,-there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically.-|-}--module Test.Framework.HUnitWrapper (--  -- * General failure-  assertFailure, unitTestPending, unitTestPending',--  -- * 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_,--  -- * Assertions on Either values-  assertLeft_, assertLeftVerbose_,-  assertLeftNoShow_, assertLeftNoShowVerbose_,-  assertRight_, assertRightVerbose_,-  assertRightNoShow_, assertRightNoShowVerbose_,--  -- * Assertions on Just values-  assertJust_, assertJustVerbose_,-  assertNothing_, assertNothingVerbose_,-  assertNothingNoShow_, assertNothingNoShowVerbose_--) where--import System.IO ( stderr )-import Data.List ( (\\) )-import Control.Exception-import Control.Monad-import qualified Test.HUnit as HU hiding ( assertFailure )-import qualified Language.Haskell.Exts.Parser as HE-import qualified Language.Haskell.Exts.Pretty as HE--import Test.Framework.TestManager-import Test.Framework.TestManagerInternal-import Test.Framework.Location-import Test.Framework.Utils-import Test.Framework.Diff-import Test.Framework.Colors-import Test.Framework.Pretty---- WARNING: do not forget to add a preprocessor macro for new assertions!!--assertFailure :: String -> IO a-assertFailure s = unitTestFail s--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__)------- Boolean Assertions----_assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion-_assertBool_ name loc s False =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))-_assertBool_ _ _ _   True = return ()-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 (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()-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 (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()-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 (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()-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 (mkMsg name s $ "failed at " ++ showLoc loc ++ x)-       else return ()-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 (mkMsg name s ("failed at " ++ showLoc loc))-       else return ()-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 (mkMsg name s ("failed at " ++ showLoc loc))-       else return ()-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 (mkMsg name s-                                ("failed at " ++ showLoc loc-                                 ++ "\n expected length: " ++ show ne-                                 ++ "\n actual length: " ++ show na))-             | not (unorderedEq expected actual) ->-                 do x <- equalityFailedMessage (show expected) (show actual)-                    assertFailure (mkMsg "assertSetEqual" s-                                   ("failed at " ++ showLoc loc ++ x))-             | otherwise -> return ()-    where unorderedEq l1 l2 =-              null (l1 \\ l2) && null (l2 \\ l1)-CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a])--_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion-_assertNotEmpty_ name loc s [] =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))-_assertNotEmpty_ _ _ _ (_:_) = return ()-CreateAssertions(assertNotEmpty, [a])--_assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion-_assertEmpty_ name loc s (_:_) =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc))-_assertEmpty_ _ _ _ [] = return ()-CreateAssertions(assertEmpty, [a])------- Assertions for Exceptions-----_assertThrows_ :: Exception e-               => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion-_assertThrows_ name loc s x f =-    do res <- try (evaluate x)-       case res of-         Right _ -> assertFailure (mkMsg name s-                                   ("failed at " ++ showLoc loc ++-                                    ": no exception was thrown"))-         Left e -> if f e then return ()-                   else assertFailure (mkMsg name s-                                       ("failed at " ++-                                        showLoc loc ++-                                        ": wrong exception was thrown: " ++-                                        show e))-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)-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 (mkMsg name s-                   ("failed at " ++ showLoc loc ++-                    ": expected a Left value, given " ++-                    show (Right x :: Either b b)))-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 (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected a Left value, given a Right value"))-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 (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected a Right value, given " ++-                                 show (Left x :: Either a a)))-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 (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected a Right value, given a Left value"))-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 (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected a Just value, given 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 (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected Nothing, given " ++ show jx))-CreateAssertionsCtx(assertNothing, Show a, Maybe a)--_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion-_assertNothingNoShow_ _ _ _ Nothing = return ()-_assertNothingNoShow_ name loc s _ =-    assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++-                                 ": expected Nothing, given a Just value"))-CreateAssertions(assertNothingNoShow, Maybe a)+{-# 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,101 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- 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 )-import Control.Exception ( evaluate, catch, SomeException )-import Prelude hiding ( catch )--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 Test.Framework.Location--type Name = String--data Decl = Decl { decl_loc :: Location-                 , decl_name :: Name }--data ParseResult a = ParseOK a | ParseError Location String--data Module = Module { mod_name :: Name-                     , mod_imports :: [ImportDecl]-                     , mod_decls :: [Decl] }--data ImportDecl = ImportDecl { imp_moduleName :: Name-                             , imp_qualified :: Bool-                             , imp_alias :: Maybe Name }--parse :: FilePath -> String -> IO (ParseResult Module)-parse originalFileName input =-    do r <- (evaluate $ Exts.parseFileContentsWithMode 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 -> return $ ParseOK (transformModule m)-    where-      -- fixedInput serves two purposes:-      -- 1. add a trailing \n-      -- 2. comment out lines starting with #-      fixedInput :: String-      fixedInput = (unlines . map fixLine . lines) input-          where-            fixLine s =-                case dropWhile isSpace s of-                  '#':_ -> "-- " ++ 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) =-          Module moduleName (map transformImport imports)-                            (mapMaybe transformDecl decls)-      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'-      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-      transformLoc (Syn.SrcLoc f n _) = makeLoc f n-      transformName :: Syn.Name -> String-      transformName (Syn.Ident s) = s-      transformName (Syn.Symbol s) = s
+ 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
@@ -0,0 +1,233 @@+{-# 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+by a newline followed by two semicolons followed again by a newline.++There are four types of JSON messages. Each JSON object has a "type" attribute denoting+this type. The types are: @test-start@, @test-end@, and @test-list@, @test-results@.+Their haskell representations are 'TestStartEventObj', 'TestEndEventObj', 'TestListObj', and+'TestResultsObj'. The corresponding JSON rendering is defined in this module.++  *  The @test-start@ message denotes the start of a single test case. Example (whitespace inserted for better readability):++> {"test": {"flatName": "Main:nonEmpty",+>           "location": {"file": "Tutorial.hs", "line": 17},+>           "path": ["Main","nonEmpty"],+>           "sort": "unit-test"},+>  "type":"test-start"}++  *  The @test-end@ message denotes the end of a single test case. It contains information about the outcome of the test. Example:++> {"result": "pass",+>  "message":"",+>  "test":{"flatName": "Main:nonEmpty",+>          "location": {"file": "Tutorial.hs", "line": 17},+>          "path": ["Main","nonEmpty"],+>          "sort": "unit-test"},+>  "wallTime": 0,  // in milliseconds+>  "type": "test-end",+>  "location":null}++  *  The @test-results@ message occurs after all tests have been run and summarizes their results. Example:++> {"failures": 0,+>  "passed": 4,+>  "pending": 0,+>  "wallTime": 39, // in milliseconds+>  "errors": 0,+>  "type":"test-results"}++  *  The @test-list@ message contains all tests defined. It is used for the --list commandline options. Example:++> {"tests": [{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},+>            {"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},+>            {"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},+>            {"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"}],+>  "type":"test-list"}++For an exact specification, please have a look at the code of this module.+-}+module Test.Framework.JsonOutput (++    TestStartEventObj, TestEndEventObj, TestListObj, TestObj, TestResultsObj,++    mkTestStartEventObj, mkTestEndEventObj, mkTestListObj, mkTestResultsObj,++    decodeObj, HTFJsonObj++) where++import Test.Framework.TestTypes+import Test.Framework.Location+import 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++-- "test-start" message+data TestStartEventObj+    = TestStartEventObj+      { ts_test :: TestObj }++instance J.ToJSON TestStartEventObj where+    toJSON ts =+        J.object ["type" .= J.String "test-start"+                 ,"test" .= J.toJSON (ts_test ts)]++instance HTFJsonObj TestStartEventObj++-- "test-end" message+data TestEndEventObj+    = TestEndEventObj+      { te_test :: TestObj+      , te_result :: TestResult+      , te_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 (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)+                 ,"timedOut" .= J.toJSON (te_timedOut te)]++instance HTFJsonObj TestEndEventObj++-- "test-list" message+data TestListObj+    = TestListObj+      { tlm_tests :: [TestObj]+      }++instance J.ToJSON TestListObj where+    toJSON tl =+        J.object ["type" .= J.String "test-list"+                 ,"tests" .= J.toJSON (tlm_tests tl)]++instance HTFJsonObj TestListObj++-- "test-results"+data TestResultsObj+    = TestResultsObj+      { tr_wallTimeMs :: Int+      , tr_passed :: Int+      , tr_pending :: Int+      , tr_failed :: Int+      , tr_errors :: Int+      , tr_timedOut :: Int+      , tr_filtered :: Int+      }++instance J.ToJSON TestResultsObj where+    toJSON r = J.object ["type" .= J.String "test-results"+                        ,"passed" .= J.toJSON (tr_passed r)+                        ,"pending" .= J.toJSON (tr_pending r)+                        ,"failures" .= J.toJSON (tr_failed r)+                        ,"errors" .= J.toJSON (tr_errors r)+                        ,"timedOut" .= J.toJSON (tr_timedOut r)+                        ,"filtered" .= J.toJSON (tr_filtered r)+                        ,"wallTime" .= J.toJSON (tr_wallTimeMs r)]++instance HTFJsonObj TestResultsObj++data TestObj+    = TestObj+      { to_flatName :: String+      , to_path :: TestPath+      , to_location :: Maybe Location+      , to_sort :: TestSort+      }++instance J.ToJSON TestObj where+    toJSON t = J.object (["flatName" .= J.toJSON (to_flatName t)+                         ,"path" .= J.toJSON (to_path t)+                         ,"sort" .= J.toJSON (to_sort t)] +++                         (case to_location t of+                            Just loc -> ["location" .= J.toJSON loc]+                            Nothing -> []))++instance J.ToJSON TestPath where+    toJSON p = J.toJSON (testPathToList p)++instance J.ToJSON TestSort where+    toJSON s =+        case s of+          UnitTest -> J.String "unit-test"+          QuickCheckTest -> J.String "quickcheck-property"+          BlackBoxTest -> J.String "blackbox-test"+++instance J.ToJSON Location where+    toJSON loc = J.object ["file" .= J.toJSON (fileName loc)+                          ,"line" .= J.toJSON (lineNumber loc)]+++mkTestObj :: GenFlatTest a -> String -> TestObj+mkTestObj ft flatName =+    TestObj flatName (ft_path ft) (ft_location ft) (ft_sort ft)++mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj+mkTestStartEventObj ft flatName =+    TestStartEventObj (mkTestObj ft flatName)++mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj+mkTestEndEventObj ftr flatName =+    let r = ft_payload ftr+        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 :: ReportGlobalResultsArg -> TestResultsObj+mkTestResultsObj arg =+    TestResultsObj+    { 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+decodeObj x =+    J.encode x `BSL.append` (BSLC.pack "\n;;\n")
Test/Framework/Location.hs view
@@ -1,5 +1,5 @@ ----- Copyright (c) 2005   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@@ -16,6 +16,12 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++Internal module for types and functions dealing with source code locations.++-}+ module Test.Framework.Location (    Location, unknownLocation,@@ -29,13 +35,17 @@  -- | An abstract type representing locations in a file. data Location = Location String Int+                deriving (Eq, Ord, Show, Read) +-- | Render a 'Location' as a 'String'. showLoc :: Location -> String showLoc (Location f n) = f ++ ":" ++ show n +-- | Extract the file name of a 'Location'. fileName :: Location -> String fileName (Location f _ ) = f +-- | Extract the line number of a 'Location'. lineNumber :: Location -> Int lineNumber (Location _ i) = i @@ -45,5 +55,6 @@         -> Location makeLoc = Location +-- | The unknown location (file @?@ and line @0@). unknownLocation :: Location unknownLocation = Location "?" 0
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   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,154 +24,434 @@ -- 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.Maybe ( mapMaybe )-import Data.List ( intercalate )-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"  htfModule :: String htfModule = "Test.Framework" -testDeclName :: String-testDeclName = "allHTFTests"+mkName varName fullModuleName =+    "htf_" +++    map (\c -> if c == '.' then '_' else c)+        (fullModuleName ++ "." +++         (case varName of+            'h':'t':'f':'_':s -> s+            s -> s)) -allAsserts :: [String]-allAsserts = ["assertBool"-             ,"assertEqual"-             ,"assertEqualPretty"-             ,"assertEqualNoShow"-             ,"assertNotEqual"-             ,"assertNotEqualPretty"-             ,"assertNotEqualNoShow"-             ,"assertListsEqualAsSets"-             ,"assertEmpty"-             ,"assertNotEmpty"-             ,"assertThrows"-             ,"assertThrowsSome"-             ,"assertLeft"-             ,"assertLeftNoShow"-             ,"assertRight"-             ,"assertRightNoShow"-             ,"assertJust"-             ,"assertNothing"-             ,"assertNothingNoShow"-             ]+thisModulesTestsFullName :: String -> String+thisModulesTestsFullName = mkName thisModulesTestsName -assertDefines :: Bool -> String -> [(String, String)]-assertDefines hunitBackwardsCompat prefix =-    concatMap fun allAsserts-    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__))"+importedTestListFullName :: String -> String+importedTestListFullName = mkName importedTestListName -warn :: String -> IO ()-warn s =-    hPutStrLn stderr $ progName ++ " warning: " ++ s+thisModulesTestsName :: String+thisModulesTestsName = "htf_thisModulesTests" -data ModuleInfo = ModuleInfo { mi_prefix     :: String+importedTestListName :: String+importedTestListName = "htf_importedTests"++nameDefines :: ModuleInfo -> [(String, String)]+nameDefines info =+    [(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-                | BenchDef String Location String+                  deriving (Eq, Show) -analyse :: FilePath -> String-        -> IO (ParseResult ModuleInfo)-analyse originalFileName s =-    do parseResult <- parse originalFileName s-       case parseResult of-         ParseOK (Module moduleName imports decls) ->-             do -- putStrLn $ show decls-                let defs = mapMaybe defFromDecl decls-                htfPrefix <--                  case mapMaybe prefixFromImport imports of-                    (s:_) -> return s-                    [] -> do warn ("No import found for " ++ htfModule ++-                                   " in " ++ originalFileName)-                             return (htfModule ++ ".")-                return $ ParseOK (ModuleInfo htfPrefix defs moduleName)-         ParseError loc err -> return (ParseError loc err)+type Name = String++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)-            ('b':'e':'n':'c':'h':'_':rest) | not (null rest) ->-                Just (BenchDef rest loc name)-            _ -> Nothing+      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")-         ParseOK info ->-             preprocess info+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 -> IO String-      preprocess info =-          do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName-                                           input-             return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"-      cpphsOptions :: ModuleInfo -> CpphsOptions-      cpphsOptions info =+      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+            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_prefix 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 =-          testDeclName ++ " :: " ++ mi_prefix info ++ "TestSuite\n" ++-          testDeclName ++ " = " ++ mi_prefix info ++ "makeTestSuite" ++-          " " ++ show (mi_moduleName info) ++-          " [\n    " ++ intercalate ",\n    "-                          (map (codeForDef (mi_prefix info)) (mi_defs info))-          ++ "\n  ]"+          thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " +++            mi_htfPrefix info ++ "TestSuite\n" +++          thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " = " +++            mi_htfPrefix info ++ "makeTestSuite" +++          " " ++ show (mi_moduleNameWithDefault info) +++          " [\n" ++ List.intercalate ",\n"+                          (map (codeForDef (mi_htfPrefix info)) (mi_defs info))+          ++ "\n  ]\n" ++ importedTestListCode info       codeForDef :: String -> Definition -> String       codeForDef pref (TestDef s loc name) =-          pref ++ "makeUnitTest " ++ (show s) ++ " " ++ codeForLoc pref loc +++          locPragma loc ++ pref ++ "makeUnitTest " ++ (show s) ++ " " ++ codeForLoc pref loc ++           " " ++ name       codeForDef pref (PropDef s loc name) =-          pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++-          codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++-          pref ++ "asTestableWithQCArgs " ++ name ++ "))"-      codeForDef pref (BenchDef s loc name) =-          pref ++ "makeBenchmarkTest " ++ show s ++ " " ++-          codeForLoc pref loc ++ "(" ++ pref ++ "prepareHtfBenchmark (" ++-          pref ++ "asHtfBenchmark " ++ name ++ "))"+          locPragma loc ++ pref ++ "makeQuickCheckTest " ++ (show s) ++ " " +++          codeForLoc pref loc ++ " (" ++ pref ++ "qcAssertion " ++ name ++ ")"+      locPragma :: Location -> String+      locPragma loc =+          "{-# LINE " ++ show (lineNumber loc) ++ " " ++ show (fileName loc) ++ " #-}\n    "       codeForLoc :: String -> Location -> String       codeForLoc pref loc = "(" ++ pref ++ "makeLoc " ++ show (fileName loc) ++                             " " ++ show (lineNumber loc) ++ ")"+      importedTestListCode :: ModuleInfo -> String+      importedTestListCode info =+          let l = mi_htfImports info+          in case l of+               [] -> ""+               _ -> (importedTestListFullName (mi_moduleNameWithDefault info)+                     ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" +++                     importedTestListFullName (mi_moduleNameWithDefault info)+                     ++ " = [\n    " +++                     List.intercalate ",\n     " (map htfTestsInModule l) +++                     "\n  ]\n")+      htfTestsInModule :: ImportDecl -> String+      htfTestsInModule imp = qualify imp (thisModulesTestsFullName (imp_moduleName imp))+      qualify :: ImportDecl -> String -> String+      qualify imp name =+          case (imp_qualified imp, imp_alias imp) of+            (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,5 +1,32 @@-{-# 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+-- +{- |++This module defines the 'Pretty' type class. The assert functions+from 'Test.Framework.HUnitWrapper' use the pretty-printing functionality+provided by this type class so as to provide nicely formatted+error messages.++Additionally, this module re-exports the standard Haskell pretty-printing module+'Text.PrettyPrint'+-} module Test.Framework.Pretty (    Pretty(..), (<=>),@@ -9,13 +36,23 @@  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@. class Pretty a where+    -- | Pretty-print a single value.     pretty :: a -> Doc+    -- | Pretty-print a list of things.     prettyList :: [a] -> Doc     prettyList l =         char '[' <> vcat (punctuate comma (map pretty l)) <> char ']'+    -- | Pretty-print a single value as a 'String'.     showPretty :: a -> String     showPretty = render . pretty @@ -29,7 +66,7 @@     prettyList s = text s  instance Pretty a => Pretty [a] where-    pretty = prettyList +    pretty = prettyList  instance Pretty Int where     pretty = int@@ -37,6 +74,6 @@ instance Pretty Bool where     pretty = text . show +-- | Utility function for inserting a @=@ between two 'Doc' values. (<=>) :: Doc -> Doc -> Doc d1 <=> d2 = d1 <+> equals <+> d2-
+ 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
@@ -31,18 +31,25 @@ import Control.Concurrent       (forkIO) import qualified Control.Exception -popenShell :: String -> Maybe String -> IO (String,String,ExitCode)+-- | Run a command using the shell.+popenShell :: String        -- ^ Command+           -> Maybe String  -- ^ Content of stdin+           -> IO (String,String,ExitCode)  -- ^ (stdout, stderr, exit code) popenShell cmd = popen' $ runInteractiveCommand cmd -popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ExitCode)-popen file args = +-- | Run a command.+popen :: FilePath         -- ^ Binary+      -> [String]         -- ^ Arguments+      -> Maybe String     -- ^ Content of stdin+      -> IO (String,String,ExitCode)  -- ^ (stdout, stderr, exit code)+popen file args =     popen' $ runInteractiveProcess file args Nothing Nothing -popen' :: IO (Handle, Handle, Handle, ProcessHandle) +popen' :: IO (Handle, Handle, Handle, ProcessHandle)        -> Maybe String        -> IO (String,String,ExitCode)-popen' run minput = -    Control.Exception.handle (\ (e :: Control.Exception.SomeException) -> +popen' run minput =+    Control.Exception.handle (\ (e :: Control.Exception.SomeException) ->                                 return ([],show e,error (show e))) $ do      (inp,out,err,pid) <- run@@ -60,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 #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  ----- Copyright (c) 2005,2009-2011 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@@ -19,100 +23,158 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.QuickCheckWrapper (+{- | -  testableAsAssertion,+This module integrates the 'Test.QuickCheck' library into HTF. It re-exports+all functionality of 'Test.QuickCheck' and defines some additional functions. +-}++module Test.Framework.QuickCheckWrapper (+   module Test.QuickCheck, -  TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs,-  qcPending+  -- * Arguments for evaluating properties+  defaultArgs, getCurrentArgs, setDefaultArgs,+  withQCArgs, WithQCArgs, setReplayFromString,+  QCAssertion, +  -- * Pending properties+  qcPending,++  -- * Auxiliary functions+#if !MIN_VERSION_QuickCheck(2,7,0)+  ioProperty,+#endif+  assertionAsProperty,++  -- * Internal functions+  qcAssertion+ ) where -import qualified Data.Map as Map-import Control.Concurrent.MVar+#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif import Control.Exception ( SomeException, Exception, Handler(..),                            throw, catch, catches, evaluate )-import System.IO-import System.IO.Unsafe-import System.Random-import Data.List( group, sort, intersperse, isPrefixOf )-import Data.Char import Data.Typeable (Typeable)+import Data.Char+import qualified Data.List as List+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef  import Test.QuickCheck-import Test.QuickCheck.Property hiding (reason)+#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. defaultArgs :: Args defaultArgs = stdArgs { chatty = False } +-- | 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 -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 `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 ()+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.+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@@ -121,33 +183,60 @@             _ -> s       trimTrailing = reverse . dropWhile isSpace . reverse -data TestableWithQCArgs = forall a . Testable a =>-                          TestableWithQCArgs (Args -> Args) a+-- | Abstract type for representing quick check properties with custom 'Args'.+--   Used only internally.+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 -class WithQCArgs a where+-- | Type class providing access to the custom 'Args' of a quick check property.+--   Used only internally.+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--instance WithQCArgs TestableWithQCArgs where-    argsModifier (TestableWithQCArgs f _) = f-    original a = Just a+    testable = AnyTestable -withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a-           -> TestableWithQCArgs-withQCArgs = TestableWithQCArgs+instance {-# OVERLAPPING  #-} Testable a => QCAssertion (WithQCArgs a) where+    argsModifier (WithQCArgs f _) = f+    testable (WithQCArgs _ x) = AnyTestable x -asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs-asTestableWithQCArgs a =-    case original a of-      Just a' -> a'-      Nothing -> TestableWithQCArgs id a+-- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.+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/TestConfig.hs 
@@ -1,66 +0,0 @@------ Copyright (c) 2009-2011   Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.TestConfig (--    TestConfig(..), defaultTestConfig, ReportLevel(..), report-  , useColors--) where--import Data.Char (toLower)-import Control.Monad (unless)-import System.IO--import System.Posix.Terminal-import System.Posix.IO (stdOutput)-import System.Posix.Types (Fd)-import System.Posix.Env (getEnv)--data TestConfig = TestConfig { tc_quiet :: Bool-                             , tc_benchmarks :: Bool }-                deriving (Read,Show,Eq)--defaultTestConfig :: TestConfig-defaultTestConfig = TestConfig { tc_quiet = False-                               , tc_benchmarks = False }--data ReportLevel = Debug | Info-                 deriving (Eq,Ord)--reportHandle :: Handle-reportHandle = stdout -- keep in sync with reportFd!--reportFd :: Fd-reportFd = stdOutput -- keep in sync with reportHandle!--report :: TestConfig -> ReportLevel -> String -> IO ()-report tc level msg =-    unless (tc_quiet tc && level < Info) $ do hPutStrLn reportHandle msg-                                              hFlush reportHandle--useColors :: IO Bool-useColors =-    do mterm <- getEnv "TERM"-       case mterm of-         Nothing -> return False-         Just s | map toLower s == "dump" -> return False-         _ -> do mx <- getEnv "HTF_NO_COLORS"-                 case mx of-                   Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False-                   _ -> queryTerminal reportFd
+ 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-2011   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@@ -16,94 +18,126 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++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+generated by the @hftpp@ pre-processor.+-}+ module Test.Framework.TestManager ( -  TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),+  -- * Re-exports+  module Test.Framework.TestTypes,++  -- * Running tests+  htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs',+  runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',++  -- * Organzing tests   TestableHTF,+  WrappableHTF(..), -  makeQuickCheckTest, makeBenchmarkTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,+  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,   makeAnonTestSuite,   addToTestSuite, testSuiteAsTest, -  parseTestArgs, runTest, runTestWithArgs, runTestWithOptions+  flattenTest, +  -- * Tests (for internal use)+  wrappableTests ) where -import Control.Monad import Control.Monad.RWS-import System.Exit (ExitCode(..))-import Data.List ( isInfixOf, isPrefixOf, partition )-import Text.PrettyPrint+import System.Exit (ExitCode(..), exitWith)+import System.Environment (getArgs)+import qualified Control.Exception as Exc+import Data.Maybe+import Data.Time import qualified Data.List as List-import Data.Maybe (isJust)+import qualified Data.ByteString as BS+import Data.IORef+import Control.Concurrent -import System.Directory (getTemporaryDirectory, removeFile) import System.IO-import System.Console.GetOpt-import GHC.IO.Handle-import qualified Data.ByteString.Lazy as BSL-import qualified Text.Regex as R -import qualified Test.HUnit.Lang as HU-+import Test.Framework.Utils+import Test.Framework.TestInterface+import Test.Framework.TestTypes+import Test.Framework.CmdlineOptions+import Test.Framework.TestReporter import Test.Framework.Location-import Test.Framework.Utils ( readM, ensureNewline )-import {-# SOURCE #-} Test.Framework.TestManagerInternal-import Test.Framework.TestConfig import Test.Framework.Colors--type Assertion = IO ()--type TestID = String+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) (const True) ass--makeUnitTest :: TestID -> Location -> IO a -> Test-makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (const True) (ass >> return ())+makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass -makeBenchmarkTest :: TestID -> Location -> (TestConfig -> Bool, Assertion) -> Test-makeBenchmarkTest id loc x = BaseTest BenchmarkTest id (Just loc) (fst x) (snd x)+-- | Construct a unit test from the given 'IO' action.+-- Mainly used internally by the htfpp preprocessor.+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 (const True) ass+makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass +-- | Create a named 'TestSuite' from a list of 'Test' values. makeTestSuite :: TestID -> [Test] -> TestSuite makeTestSuite = TestSuite +-- | Create an unnamed 'TestSuite' from a list of 'Test' values. makeAnonTestSuite :: [Test] -> TestSuite makeAnonTestSuite = AnonTestSuite +-- | Turn a 'TestSuite' into a proper 'Test'. testSuiteAsTest :: TestSuite -> Test testSuiteAsTest = CompoundTest +-- | Extend a 'TestSuite' with a list of 'Test' values addToTestSuite :: TestSuite -> [Test] -> TestSuite addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') -data TestSort = UnitTest | QuickCheckTest | BlackBoxTest | BenchmarkTest-              deriving (Eq,Show,Read)--data Test = BaseTest TestSort TestID (Maybe Location) (TestConfig -> Bool) Assertion-          | CompoundTest TestSuite+-- | 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 -data TestSuite = TestSuite TestID [Test]-               | AnonTestSuite [Test]+instance WrappableHTF TestSuite where+    wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests+    wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests -data FlatTest = FlatTest { ft_sort :: TestSort-                         , ft_id :: TestID-                         , ft_loc :: Maybe Location-                         , ft_runnable :: TestConfig -> Bool-                         , ft_action :: Assertion }+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     flatten :: t -> [FlatTest]  instance TestableHTF Test where-    flatten = flattenTest Nothing+    flatten = flattenTest  instance TestableHTF TestSuite where-    flatten = flattenTestSuite Nothing+    flatten = flattenTestSuite  instance TestableHTF t => TestableHTF [t] where     flatten = concatMap flatten@@ -111,270 +145,364 @@ instance TestableHTF (IO a) where     flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action) -type Path = Maybe String--flattenTest :: Path -> Test -> [FlatTest]-flattenTest path (BaseTest sort id mloc pred ass) =-    [FlatTest sort (path `concatPath` id) mloc pred ass]-flattenTest path (CompoundTest ts) =-    flattenTestSuite path ts--flattenTestSuite :: Path -> TestSuite -> [FlatTest]-flattenTestSuite path (TestSuite id ts) =-    concatMap (flattenTest (Just (path `concatPath` id))) ts-flattenTestSuite path (AnonTestSuite ts) =-    concatMap (flattenTest path) ts--concatPath :: Path -> String -> String-concatPath Nothing s = s-concatPath (Just s1) s2 = s1 ++ pathSep ++ s2-    where pathSep = ":"--data TestState = TestState { ts_passed  :: [String]-                           , ts_failed  :: [String]-                           , ts_error   :: [String]-                           , ts_pending :: [String] }+flattenTest :: Test -> [FlatTest]+flattenTest (BaseTest sort id mloc opts x) =+    [FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)]+flattenTest (CompoundTest ts) =+    flattenTestSuite ts -initTestState :: TestState-initTestState = TestState [] [] [] []+flattenTestSuite :: TestSuite -> [FlatTest]+flattenTestSuite (TestSuite id ts) =+    let fts = concatMap flattenTest ts+    in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts+flattenTestSuite (AnonTestSuite ts) =+    let fts = concatMap flattenTest ts+    in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -type TR = RWST TestConfig () TestState IO+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 -data HandleRedirection = HandleRedirection { hr_original :: Handle-                                           , hr_originalCopy :: Handle-                                           , hr_newHandle :: Handle-                                           , hr_newFilePath :: FilePath }+-- | 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))) -redirectHandle :: String -> Handle -> IO HandleRedirection-redirectHandle nameTmpl h =-    do tmpDir <- getTemporaryDirectory-       (path, new) <- openBinaryTempFile tmpDir nameTmpl-       copy <- hDuplicate h-       hDuplicateTo new h-       return $ HandleRedirection { hr_original = h-                                  , hr_originalCopy = copy-                                  , hr_newHandle = new-                                  , hr_newFilePath = path }+data TimeoutResult a+    = TimeoutResultOk a+    | TimeoutResultException Exc.SomeException+    | TimeoutResultTimeout -unredirectHandle :: HandleRedirection -> IO ()-unredirectHandle hr =-    do hClose (hr_newHandle hr)-       hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore+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 -cleanupRedirection :: Bool -> HandleRedirection -> IO ()-cleanupRedirection printOutput hr =-    do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr)-                               BSL.hPut (hr_original hr) x-                               hFlush (hr_original hr)-       removeFile (hr_newFilePath hr)+data PrimTestResult+    = PrimTestResultNoTimeout FullTestResult+    | PrimTestResultTimeout -runFlatTest :: FlatTest -> TR ()-runFlatTest (FlatTest sort id mloc _ ass) =-    do let name = id ++ case mloc of-                          Nothing -> ""-                          Just loc -> " (" ++ showLoc loc ++ ")"-       x <- atStart name-       res <- liftIO $ HU.performTestCase ass-       let (testResult, msg) =-             case res of-               Nothing -> (Pass, "")-               Just (isFailure, msg') ->-                   if sort /= QuickCheckTest-                      then if isFailure-                              then case extractPendingMessage msg' of-                                     Nothing -> (Fail, msg')-                                     Just msg'' -> (Pending, msg'')-                              else (Error, msg')-                      else case readM msg' :: Maybe (TestResult, Maybe String) of-                             Nothing ->-                                 error ("ERROR: " ++-                                        "Cannot deserialize QuickCheck " ++-                                        "error message.\n[BEGIN]\n" ++-                                        show msg' ++ "\n[END]\n")-                             Just (r, ms) ->-                                 case ms of-                                   Nothing -> (r, "")-                                   Just s -> (r, s)-       afterRunning x name testResult-       case testResult of-         Pass -> reportSuccess name msg-         Pending ->-             do modify (\s -> s { ts_pending = name : (ts_pending s) })-                reportPending msg-         Fail ->-             do modify (\s -> s { ts_failed = name : (ts_failed s) })-                reportFailure msg-         Error ->-             do modify (\s -> s { ts_error = name : (ts_error s) })-                reportError msg-       atEnd testResult+mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)+mkFlatTestRunner tc ft = (pre, action, post)     where-      testStartMessage name =-          do t <- colorize testStartColor "[TEST] "-             return $ t ++ name-      atStart name =-          do tc <- ask-             if tc_quiet tc-                then liftIO $-                     do stdoutRedir <- redirectHandle "HTF.out" stdout-                        stderrRedir <- redirectHandle "HTF.err" stderr-                        return $ Just (stdoutRedir, stderrRedir)-                else do msg <- liftIO $ testStartMessage name-                        reportTR Debug msg-                        return Nothing-      afterRunning x name testResult =-          do tc <- ask-             if tc_quiet tc-                then case x of-                       Just (stdoutRedir, stderrRedir) -> liftIO $-                          do unredirectHandle stderrRedir-                             unredirectHandle stdoutRedir-                             let printOutput = needsReport testResult-                             when printOutput $-                                  do msg <- testStartMessage name-                                     report tc Info msg-                             cleanupRedirection printOutput stderrRedir-                             cleanupRedirection printOutput stdoutRedir-                else return ()-      atEnd testResult =-          do tc <- ask-             if not (tc_quiet tc) || needsReport testResult-                then reportTR Info ""-                else return ()-      needsReport testResult = testResult `elem` [Fail, Error, Pending]-      reportSuccess name msg =-          do modify (\s -> s { ts_passed = name : (ts_passed s) })-             pref <- okPrefix-             reportTR Debug (ensureNewline msg ++ pref)-      reportPending msg =-          do pref <- pendingPrefix-             reportMessage Info msg  pref-      reportFailure msg =-          do pref <- failurePrefix-             reportMessage Info msg pref-      reportError msg =-          do pref <- errorPrefix-             reportMessage Info msg pref-      reportMessage isImportant msg prefix =-          reportTR isImportant (ensureNewline msg ++ prefix)-      failurePrefix = liftIO $ colorize warningColor "*** Failed! "-      errorPrefix = liftIO $ colorize warningColor "@@@ Error! "-      pendingPrefix = liftIO $ colorize pendingColor "^^^ Pending! "-      okPrefix = liftIO $ colorize testOkColor  "+++ OK"+      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 -runFlatTests :: [FlatTest] -> TR ()-runFlatTests = mapM_ runFlatTest+runAllFlatTests :: [FlatTest] -> TR ()+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 -runTest :: TestableHTF t => t -> IO ExitCode-runTest = runTestWithOptions defaultTestOptions+-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.+runTest :: TestableHTF t => t              -- ^ Testable thing+                         -> IO ExitCode    -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result+runTest = runTestWithOptions defaultCmdlineOptions -optionDescriptions :: [OptDescr (TestOptions -> TestOptions)]-optionDescriptions =-    [ Option ['v'] ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output"-    , Option ['q'] ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"-    , Option ['n'] ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })-                                       "TEST_PATTERN") "tests to exclude"-    , Option ['b'] ["benchmarks"] (NoArg (\o -> o { opts_benchmarks = True })) "run benchmarks"-    , Option ['h'] ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"-    ]+-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.+runTest' :: TestableHTF t => t              -- ^ Testable thing+                         -> IO (IO (), ExitCode)    -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result+runTest' = runTestWithOptions' defaultCmdlineOptions -runTestWithArgs :: TestableHTF t => [String] -> t -> IO ExitCode+-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.+-- Does not print the overall test results but returns an 'IO' action for doing so.+runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments+                                 -> t               -- ^ Testable thing+                                 -> IO ExitCode     -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result. runTestWithArgs args t =+    do (printSummary, ecode) <- runTestWithArgs' args t+       printSummary+       return ecode+++-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.+runTestWithArgs' :: TestableHTF t => [String]        -- ^ Commandline arguments+                                 -> t               -- ^ Testable thing+                                 -> IO (IO (), ExitCode)  -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithArgs' args t =     case parseTestArgs args of       Left err ->           do hPutStrLn stderr err-             return $ ExitFailure 1+             return $ (return (), ExitFailure 1)       Right opts ->-          runTestWithOptions opts t+          runTestWithOptions' opts t -parseTestArgs :: [String] -> Either String TestOptions-parseTestArgs args =-    case getOpt Permute optionDescriptions args of-      (optTrans, tests, []  ) ->-          let posStrs = tests-              negStrs = opts_negated opts-              pos = map mkRegex posStrs-              neg = map mkRegex negStrs-              pred (FlatTest _ id _ _ _) =-                  if (any (\s -> s `matches` id) neg)-                     then False-                     else null pos || any (\s -> s `matches` id) pos-              opts = (foldr ($) defaultTestOptions optTrans) { opts_filter = pred }-          in Right opts-      (_,_,errs) ->-          Left (concat errs ++ usageInfo usageHeader optionDescriptions)-    where-      matches r s = isJust $ R.matchRegex r s-      mkRegex s = R.mkRegexWithOpts s True False+-- | Runs something testable with the given 'CmdlineOptions'.+-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode+runTestWithOptions opts t =+    do (printSummary, ecode) <- runTestWithOptions' opts t+       printSummary+       return ecode -usageHeader :: String-usageHeader = ("USAGE: COMMAND [OPTION ...] TEST_PATTERN ...\n\n" ++-               "       where TEST_PATTERN is a posix regular expression.\n")+-- | Runs something testable with the given 'CmdlineOptions'. Does not+-- print the overall test results but returns an 'IO' action for doing so.+-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.+runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)+runTestWithOptions' opts t =+    if opts_help opts+       then do hPutStrLn stderr helpString+               return $ (return (), ExitFailure 1)+       else do tc <- testConfigFromCmdlineOptions opts+               (printSummary, ecode) <-+                   (if opts_listTests opts+                      then let fts = filter (opts_filter opts) (flatten t)+                           in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)+                      else 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)) -type Filter = FlatTest -> Bool+-- | Runs something testable with the given 'TestConfig'.+-- The result is 'ExitSuccess' if all tests were executed successfully,+-- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates+-- that failures but no errors occurred, otherwise the error code @2@ is used.+--+-- A test is /successful/ if the test terminates and no assertion fails.+-- A test is said to /fail/ if an assertion fails but no other error occur.+runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory)+runTestWithConfig tc t =+    do (printSummary, ecode, history) <- runTestWithConfig' tc t+       printSummary+       return (ecode, history) -data TestOptions = TestOptions {-      opts_quiet :: Bool-    , opts_filter :: Filter-    , opts_help :: Bool-    , opts_benchmarks :: Bool-    , opts_negated :: [String]+-- | 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, TestHistory)+runTestWithConfig' tc t =+     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 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 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+               ,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 -defaultTestOptions = TestOptions {-      opts_quiet = tc_quiet defaultTestConfig-    , opts_filter = const True-    , opts_help = False-    , opts_benchmarks = False-    , opts_negated = []-    }+-- | Runs something testable by parsing the commandline arguments as test options+-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.+-- This function is the main entry point for running tests.+htfMain :: TestableHTF t => t -> IO ()+htfMain tests =+    do args <- getArgs+       htfMainWithArgs args tests -runTestWithOptions :: TestableHTF t => TestOptions -> t -> IO ExitCode-runTestWithOptions opts t =-    if opts_help opts-       then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions)-               return $ ExitFailure 1-       else-         do let tc = optsToConfig opts-                pred ft = ft_runnable ft tc && opts_filter opts ft-            (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc initTestState-            let passed = length (ts_passed s)-                pending = length (ts_pending s)-                failed = length (ts_failed s)-                error = length (ts_error s)-                total = passed + failed + error + pending-            pendings <- colorize pendingColor "* Pending:"-            failures <- colorize warningColor "* Failures:"-            errors <- colorize warningColor "* Errors:"-            report tc Info ("* Tests:    " ++ show total ++ "\n" ++-                            "* Passed:   " ++ show passed ++ "\n" ++-                            pendings ++ "  " ++ show pending ++ "\n" ++-                            failures ++ " " ++ show failed ++ "\n" ++-                            errors ++ "   " ++ show error )-            when (pending > 0) $-               reportDoc tc Info-                   (text ('\n' : pendings) $$ renderTestNames (reverse (ts_pending s)))-            when (failed > 0) $-               reportDoc tc Info-                   (text ('\n' : failures) $$ renderTestNames (reverse (ts_failed s)))-            when (error > 0) $-               reportDoc tc Info-                   (text ('\n' : errors) $$ renderTestNames (reverse (ts_error s)))-            return $ case () of-                       _| failed == 0 && error == 0 -> ExitSuccess-                        | error == 0                -> ExitFailure 1-                        | otherwise                 -> ExitFailure 2-    where-      renderTestNames l =-          nest 2 (vcat (map (\name -> text "*" <+> text name) l))-      optsToConfig opts =-          TestConfig { tc_quiet = opts_quiet opts-                     , tc_benchmarks = opts_benchmarks opts }+-- | 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 -reportDoc :: TestConfig -> ReportLevel -> Doc -> IO ()-reportDoc tc level doc = report tc level (render doc)+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 -reportTR :: ReportLevel -> String -> TR ()-reportTR level msg =-    do tc <- ask-       liftIO $ report tc level msg+wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)]
− Test/Framework/TestManagerInternal.hs 
@@ -1,80 +0,0 @@------ Copyright (c) 2009-2011   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 (--  extractPendingMessage,-  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,-  quickCheckTestPass,-  unitTestFail, unitTestPending, blackBoxTestFail,--  TestResult(..)--) where--import Data.List ( isPrefixOf )-import qualified Test.HUnit.Lang as HU--import Test.Framework.TestManager--data TestResult = Error | Fail | Pending | Pass-                  deriving (Show, Read, Eq)---- A pending test case is treated as a failed testcase, but the error message--- starts with the given prefix.-pendingPrefix :: String-pendingPrefix = "__PENDING__"--makePendingMessage :: String -> String-makePendingMessage = (++) pendingPrefix--extractPendingMessage :: String -> Maybe String-extractPendingMessage msg =-    if pendingPrefix `isPrefixOf` msg-       then Just $ drop (length pendingPrefix) msg-       else Nothing--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))--unitTestFail :: String -> IO a-unitTestFail s =-    do assertFailureHTF s-       error "unitTestFail: UNREACHABLE"--unitTestPending :: String -> IO a-unitTestPending s = unitTestFail (makePendingMessage s)--blackBoxTestFail :: String -> Assertion-blackBoxTestFail = assertFailureHTF
− Test/Framework/TestManagerInternal.hs-boot 
@@ -1,8 +0,0 @@-module Test.Framework.TestManagerInternal where--data TestResult = Error | Fail | Pending | Pass-instance Read TestResult-instance Show TestResult-instance Eq TestResult--extractPendingMessage :: String -> Maybe String
+ Test/Framework/TestReporter.hs view
@@ -0,0 +1,346 @@+{-# 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+particular events in the lifecycle of a test run.++Further, it defines the standard test reporters for HTF's various output formats.++-}+module Test.Framework.TestReporter (++    IsParallel(..), isParallelFromBool, IsJsonOutput(..), IsXmlOutput(..),+    reportAllTests, reportGlobalStart, reportTestStart, reportTestResult,+    reportGlobalResults, defaultTestReporters++) where++import Test.Framework.TestTypes+import Test.Framework.Location+import Test.Framework.Colors+import Test.Framework.JsonOutput+import Test.Framework.XmlOutput++import System.IO+import Control.Monad+import Control.Monad.RWS+import Text.PrettyPrint++import qualified Data.Text.IO as T+import qualified Data.ByteString.Lazy as BSL++-- | Invokes 'tr_reportAllTests' on all test reporters registered.+reportAllTests :: ReportAllTests+reportAllTests tests =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportAllTests r tests) reps++-- | Invokes 'tr_reportGlobalStart' on all test reporters registered.+reportGlobalStart :: ReportGlobalStart+reportGlobalStart tests =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportGlobalStart r tests) reps++-- | Invokes 'tr_reportTestStart' on all test reporters registered.+reportTestStart :: ReportTestStart+reportTestStart t =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportTestStart r t) reps++-- | Invokes 'tr_reportTestResult' on all test reporters registered.+reportTestResult :: ReportTestResult+reportTestResult t =+    do reps <- asks tc_reporters+       mapM_ (\r -> tr_reportTestResult r t) reps++-- | Invokes 'tr_reportGlobalResults' on all test reporters registered.+reportGlobalResults :: ReportGlobalResults+reportGlobalResults arg =+    do reps <- asks tc_reporters+       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 :: IsParallel+                     -> IsJsonOutput+                     -> IsXmlOutput+                     -> [TestReporter]+defaultTestReporters inParallel forMachine doXml =+    case (inParallel, forMachine) of+      (NonParallel, NoJsonOutput) ->+          [TestReporter+           { tr_id = "rep_seq_human"+           , tr_reportAllTests = reportAllTestsH+           , tr_reportGlobalStart = reportGlobalStartHS+           , tr_reportTestStart = reportTestStartHS+           , tr_reportTestResult = reportTestResultHS+           , tr_reportGlobalResults = reportGlobalResultsH+           }] ++ xmlReporters+      (Parallel, NoJsonOutput) ->+          [TestReporter+           { tr_id = "rep_par_human"+           , tr_reportAllTests = reportAllTestsH+           , tr_reportGlobalStart = reportGlobalStartHP+           , tr_reportTestStart = reportTestStartHP+           , tr_reportTestResult = reportTestResultHP+           , tr_reportGlobalResults = reportGlobalResultsH+           }] ++ xmlReporters+      (NonParallel, JsonOutput) ->+          [TestReporter+           { tr_id = "rep_seq_machine"+           , tr_reportAllTests = reportAllTestsM+           , tr_reportGlobalStart = reportGlobalStartMS+           , tr_reportTestStart = reportTestStartMS+           , tr_reportTestResult = reportTestResultMS+           , tr_reportGlobalResults = reportGlobalResultsM+           }] ++ xmlReporters+      (Parallel, JsonOutput) ->+          [TestReporter+           { tr_id = "rep_par_machine"+           , tr_reportAllTests = reportAllTestsM+           , tr_reportGlobalStart = reportGlobalStartMP+           , 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+--++humanTestName :: GenFlatTest a -> String+humanTestName ft =+    flatName (ft_path ft) +++    case ft_location ft of+      Nothing -> ""+      Just loc -> " (" ++ showLoc loc ++ ")"++reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()+reportHumanTestStartMessage level ft =+    do let t = colorize testStartColor "[TEST] "+       reportTR level (t +++ noColor (humanTestName ft))++-- sequential+reportGlobalStartHS :: ReportGlobalStart+reportGlobalStartHS _ = return ()++reportTestStartHS :: ReportTestStart+reportTestStartHS ft = reportHumanTestStartMessage Debug ft++reportTestResultHS :: ReportTestResult+reportTestResultHS ftr =+    let res = rr_result (ft_payload ftr)+        msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr))+    in case res of+         Pass ->+             reportMessage Debug msg okSuffix+         Pending ->+             do reportHumanTestStartMessageIfNeeded+                reportMessage Info msg pendingSuffix+         Fail ->+             do reportHumanTestStartMessageIfNeeded+                reportMessage Info msg failureSuffix+         Error ->+             do reportHumanTestStartMessageIfNeeded+                reportMessage Info msg errorSuffix+   where+     reportHumanTestStartMessageIfNeeded =+         do tc <- ask+            when (tc_quiet tc) (reportHumanTestStartMessage Info ftr)+     reportMessage level msg suffix =+         reportTR level (ensureNewlineColorString msg +++ suffix +++ noColor timeStr)+     timeStr = " (" ++ show (rr_wallTimeMs (ft_payload ftr)) ++ "ms)\n"+     failureSuffix = colorize warningColor "*** Failed!"+     errorSuffix = colorize warningColor "@@@ Error!"+     pendingSuffix = colorize pendingColor "^^^ Pending!"+     okSuffix = colorize testOkColor  "+++ OK"++-- parallel+reportGlobalStartHP :: ReportGlobalStart+reportGlobalStartHP _ = return ()++reportTestStartHP :: ReportTestStart+reportTestStartHP ft =+     do reportStringTR Debug ("Starting " ++ (humanTestName ft))++reportTestResultHP :: ReportTestResult+reportTestResultHP ftr =+    do reportHumanTestStartMessage Debug ftr+       reportTestResultHS ftr++-- results and all tests+reportAllTestsH :: ReportAllTests+reportAllTestsH l =+    reportStringTR Info (render (renderTestNames l))++reportGlobalResultsH :: ReportGlobalResults+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+       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) $+          reportTR Info+              ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg)))+       when (failed > 0) $+          reportTR Info+              ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg)))+       when (error > 0) $+          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 =+          noColor $ render $ nest 2 $ renderTestNames rrs++renderTestNames :: [GenFlatTest a] -> Doc+renderTestNames l =+    vcat (map (\ft -> text "*" <+>+                      text (humanTestName ft)) l)++--+-- output for machines+--++-- sequential+reportGlobalStartMS :: ReportGlobalStart+reportGlobalStartMS _ = return ()++reportTestStartMS :: ReportTestStart+reportTestStartMS ft =+    let json = mkTestStartEventObj ft (flatName (ft_path ft))+    in reportJsonTR json++reportTestResultMS :: ReportTestResult+reportTestResultMS ftr =+    let json = mkTestEndEventObj ftr (flatName (ft_path ftr))+    in reportJsonTR json++-- parallel+reportGlobalStartMP :: ReportGlobalStart+reportGlobalStartMP _ = return ()++reportTestStartMP :: ReportTestStart+reportTestStartMP = reportTestStartMS++reportTestResultMP :: ReportTestResult+reportTestResultMP = reportTestResultMS++-- results and all tests+reportAllTestsM :: ReportAllTests+reportAllTestsM l =+    let json = mkTestListObj (map (\ft -> (ft, flatName (ft_path ft))) l)+    in reportJsonTR json++reportGlobalResultsM :: ReportGlobalResults+reportGlobalResultsM 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+--++reportTR :: ReportLevel -> ColorString -> TR ()+reportTR level msg =+    do tc <- ask+       let s = renderColorString msg (tc_useColors tc)+       reportGen tc level (\h -> T.hPutStrLn h s)++reportStringTR :: ReportLevel -> String -> TR ()+reportStringTR level msg =+    do tc <- ask+       reportGen tc level (\h -> hPutStrLn h msg)++reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR ()+reportLazyBytesTR level msg =+    do tc <- ask+       reportGen tc level (\h -> BSL.hPut h msg)++reportJsonTR :: HTFJsonObj a => a -> TR ()+reportJsonTR x = reportLazyBytesTR Info (decodeObj x)++data ReportLevel = Debug | Info+                 deriving (Eq,Ord)++reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()+reportGen tc level fun =+    unless (tc_quiet tc && level < Info) $+    case tc_output tc of+      TestOutputHandle h _ -> liftIO (fun h)+      TestOutputSplitted fp ->+          do -- split mode: one file for each result to avoid locking on windows+             ix <- gets ts_index+             let realFp = fp ++ (show ix) -- just append the index at the end of the file given as output parameter+             modify (\x -> x { ts_index = ts_index x + 1 })+             liftIO $ withFile realFp WriteMode fun
+ Test/Framework/TestTypes.hs view
@@ -0,0 +1,298 @@+{-# 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, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),+  TestSuite(..), TestSort(..),+  TestPath(..), GenFlatTest(..), FlatTest, TestFilter,+  testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey,++  -- * Executing tests+  TR, TestState(..), initTestState, TestConfig(..), TestOutput(..),++  -- * Reporting results+  ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..),+  TestReporter(..), emptyTestReporter, attachCallStack, CallStack,++  -- * Specifying results.+  TestResult(..), FlatTestResult, Milliseconds, RunResult(..)++) 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+import qualified Data.Text as T++-- | Type for naming tests.+type TestID = String++-- | Type for distinguishing different sorts of tests.+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) TestOptions Assertion+          | CompoundTest TestSuite++-- | Abstract type for test suites and their results.+data TestSuite = TestSuite TestID [Test]+               | AnonTestSuite [Test]++-- | A type denoting the hierarchical name of a test.+data TestPath = TestPathBase TestID+              | TestPathCompound (Maybe TestID) TestPath+                deriving (Show)++-- | Splits a 'TestPath' into a list of test identifiers.+testPathToList :: TestPath -> [Maybe TestID]+testPathToList (TestPathBase i) = [Just i]+testPathToList (TestPathCompound mi p) =+    mi : testPathToList p++-- | Creates a string representation from a 'TestPath'.+flatName :: TestPath -> String+flatName p =+    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+      { ft_sort :: TestSort           -- ^ The sort of the test.+      , ft_path :: TestPath           -- ^ Hierarchival path.+      , ft_location :: Maybe Location -- ^ Place of definition.+      , ft_payload :: a               -- ^ A generic payload.+      }++-- | 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 (WithTestOptions Assertion)++-- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run.+type TestFilter = FlatTest -> Bool++-- | 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_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++-- | The state type for the 'TR' monad.+data TestState = TestState { ts_results :: [FlatTestResult] -- ^ Results collected so far.+                           , ts_index :: Int                -- ^ Current index for splitted output.+                           }++-- | The initial test state.+initTestState :: TestState+initTestState = TestState [] 0++-- | The 'TR' (test runner) monad.+type TR = RWST TestConfig () TestState IO++-- | The destination of progress and result messages from HTF.+data TestOutput = TestOutputHandle Handle Bool -- ^ Output goes to 'Handle', boolean flag indicates whether the handle should be closed at the end.+                | TestOutputSplitted FilePath  -- ^ Output goes to files whose names are derived from 'FilePath' by appending a number to it. Numbering starts at zero.+                  deriving (Show, Eq)++-- | Configuration of test execution.+data TestConfig+    = TestConfig+      { tc_quiet :: Bool                -- ^ If set, displays messages only for failed tests.+      , tc_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.+      , 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+    showsPrec prec tc =+        showParen (prec > 0) $+        showString "TestConfig { " .+        showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .+        showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+        showString ", tc_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.+data TestReporter+    = TestReporter+      { tr_id :: String+      , tr_reportAllTests :: ReportAllTests        -- ^ Called to report the IDs of all tests available.+      , tr_reportGlobalStart :: ReportGlobalStart  -- ^ Called to report the start of test execution.+      , tr_reportTestStart :: ReportTestStart      -- ^ Called to report the start of a single test.+      , tr_reportTestResult :: ReportTestResult    -- ^ Called to report the result of a single test.+      , tr_reportGlobalResults :: ReportGlobalResults  -- ^ Called to report the overall results of all tests.+      }++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)++instance Eq TestReporter where+    x == y = (tr_id x) == (tr_id y)++-- | Reports the IDs of all tests available.+type ReportAllTests = [FlatTest] -> TR ()++-- | Signals that test execution is about to start.+type ReportGlobalStart = [FlatTest] -> TR ()++-- | Reports the start of a single test.+type ReportTestStart = FlatTest -> TR ()++-- | Reports the result of a single test.+type ReportTestResult = FlatTestResult -> TR ()++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 = 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,21 +1,121 @@-{-|-+--+-- 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 possible to use the HTF with other Haskell environments, only the steps taken to invoke the custom preprocessor of the HTF may differ in this case.) -Suppose you are writing a function for reversing lists:+-} +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 :++@ myReverse :: [a] -> [a]-myReverse [] = []-myReverse [x] = [x]+myReverse []     = []+myReverse [x]    = [x] myReverse (x:xs) = myReverse xs @ -To test this function using the HTF, you first create a new source+To test this function using the HTF, you would first create a new source file with a @OPTIONS_GHC@ pragma in the first line.  @@@ -25,10 +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 Test.Framework @ @@ -44,15 +143,12 @@ 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. (Backwards-compatibility-with the HUnit library is discussed at the end of this tutorial.)-Moreover, the-preprocessor collects all top-level definitions starting with @test_@-or @prop_@ in a test suite with name allHTFTests of type 'TestSuite'.+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@+as a shorthand for the rather lengthy name @htf_@/M/@_thisModulesTests@.  Definitions starting with @test_@ denote unit tests and must be of type 'Assertion'.@@ -60,13 +156,10 @@ denote QuickCheck properties and must be of type /T/ such that /T/ is an instance of the type class 'Testable'. -To run the tests, use the 'runTestWithArgs' function, which-takes a list of strings and the test.+To run the tests, use the 'htfMain' function.  @-main =-    do args <- getArgs-       runTestWithArgs args allHTFTests+main = htfMain htf_thisModulesTests @  Here is the skeleton of a @.cabal@ file which you may want to use to@@ -75,43 +168,68 @@ @ Name:          HTF-tutorial Version:       0.1-Cabal-Version: >= 1.6+Cabal-Version: >= 1.10 Build-type:    Simple -Executable tutorial-  Main-is: Tutorial.hs-  Build-depends: base >= 4 && < 5, HTF == 0.5.*+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 @myReverse@ as well), and then running the resulting program with no-further commandline arguments yields the following output:+further commandline arguments yields the following output (colors had to+be omitted, so the diff output does not look very useful): -> Main:nonEmpty (Tutorial.hs:17)-> *** Failed! assertEqual failed at Tutorial.hs:18->  expected: [3,2,1]->  but got:  [3]+> [TEST] Main:nonEmpty (Tutorial.hs:17)+> assertEqual failed at Tutorial.hs:18+> * expected: [3, 2, 1]+> * but got:  [3]+> * diff:     [3, 2, 1]+> *** Failed! (0ms) >-> Main:empty (Tutorial.hs:19)-> +++ OK+> [TEST] Main:empty (Tutorial.hs:19)+> +++ OK (0ms) >-> Main:reverse (Tutorial.hs:22)-> *** Failed! Falsifiable (after 3 tests and 1 shrink):+> [TEST] Main:reverse (Tutorial.hs:22)+> Falsifiable (after 6 tests and 5 shrinks): > [0,0]-> Replay argument: "Just (847701486 2147483396,2)"+> Replay argument: "Just (200055706 2147483393,5)"+> *** Failed! (0ms) >-> * Tests:    3+> [TEST] Main:reverseReplay (Tutorial.hs:24)+> Falsifiable (after 1 test and 2 shrinks):+> [0,0]+> Replay argument: "Just (1060394807 2147483396,2)"+> *** Failed! (0ms)+>+> * Tests:    4 > * Passed:   1-> * Failures: 2+> * Pending:  0+> * Failures: 3 > * Errors:   0+>+> * Failures:+>   * Main:reverseReplay (Tutorial.hs:24)+>   * Main:reverse (Tutorial.hs:22)+>   * Main:nonEmpty (Tutorial.hs:17)+>+> Total execution time: 4ms  (To check only specific tests, you can pass commandline arguments to the program: the HTF then runs only those tests whose name contain at least one of the commandline arguments as a substring.)  You see that the message for the first failure contains exact location-information, which is quite convenient. Moreover, for the QuickCheck-property @Main.reverse@, the HTF also outputs a string+information, which is quite convenient. Also, HTF provides a diff between+the expected and the given output. (For this simple example, a diff is kind+of useless, but with longer output strings, a diff allows you to identify+very quickly where the expected and the given results disagree.)++For the QuickCheck property @Main.reverse@, the HTF outputs a string represenation of the random generator used to check the property. This string representation can be used to replay the property.  (The replay feature may not be useful for this simple example but it helps in more@@ -123,11 +241,11 @@  @ prop_reverseReplay =-  'withQCArgs' (\a -> a { 'replay' = 'read' \"Just (1060394807 2147483396,2)\" })+  'withQCArgs' (\\a -> a { 'replay' = 'read' \"Just (1060394807 2147483396,2)\" })   prop_reverse @ -To finish this tutorial, we now give a correct definition for @myReverse@:+To finish this simple example, we now give a correct definition for @myReverse@:  @ myReverse :: [a] -> [a]@@ -138,43 +256,185 @@ Running our tests again on the fixed definition then yields the desired result: -> Main:nonEmpty (Tutorial.hs:17)-> +++ OK+> [TEST] Main:nonEmpty (Tutorial.hs:17)+> +++ OK (0ms) >-> Main:empty (Tutorial.hs:19)-> +++ OK+> [TEST] Main:empty (Tutorial.hs:19)+> +++ OK (0ms) >-> Main:reverse (Tutorial.hs:22)-> +++ OK, passed 100 tests.+> [TEST] Main:reverse (Tutorial.hs:22)+> Passed 100 tests.+> +++ OK (20ms) >-> Main:reverseReplay (Tutorial.hs:24)-> +++ OK, passed 100 tests.+> [TEST] Main:reverseReplay (Tutorial.hs:24)+> Passed 100 tests.+> +++ OK (4ms) > > * Tests:    4 > * Passed:   4+> * Pending:  0 > * Failures: 0 > * Errors:   0+>+> Total execution time: 28ms -The HTF also allows the definition of black box tests. See the documentation-of the "Test.Framework.BlackBoxTest" module for further information.+The HTF also allows the definition of black box tests. Essentially, black box+tests allow you to verify that the output of your program matches your expectations.+See the documentation of the "Test.Framework.BlackBoxTest" module for further information. -/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@.+-- * Test definitions in multiple modules -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.--}-module Test.Framework.Tutorial where+{- | +For testing real-world programs or libraries, it is often conventient to+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>.++File @MyPkg/A.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module MyPkg.A (funA, htf_thisModulesTests) where+ import Test.Framework-import qualified Test.HUnit.Base++funA :: Int -> Int+funA x = x + 1++test_funA1 = assertEqual (funA 41) 42++test_funA2 = assertEqual (funA 2) 3+@++File @MyPkg/B.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module MyPkg.B (funB, htf_thisModulesTests) where++import Test.Framework++funB :: Int -> Int+funB x = x * 2++test_funB1 = assertEqual (funB 21) 42++test_funB2 = assertEqual (funB 0) 0+@++For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules'+testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a+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 @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+a main module and import @MyPkg.A@ and @MyPkg.B@ with the special+import annotation @&#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d;@. The effect of this annotation+is that the @htfpp@ preprocessor makes all test cases defined in+such modules imported+available in a variable called @htf_importedTests@. Thus, your+main module would look like this:++File @TestMain.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module Main where++import Test.Framework+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.B++main = htfMain htf_importedTests+@++-}++-- * Machine-readable output++-- ** JSON++{- |++For better integration with your testing environment, HTF provides the ability to produce+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":+++> {"test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"type":"test-start"}+> ;;+> {"result":"pass","message":"","test":{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"type":"test-start"}+> ;;+> {"result":"pass","message":"","test":{"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},"wallTime":0,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"type":"test-start"}+> ;;+> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},"wallTime":19,"type":"test-end","location":null}+> ;;+> {"test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"type":"test-start"}+> ;;+> {"result":"pass","message":"Passed 100 tests.","test":{"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"},"wallTime":4,"type":"test-end","location":null}+> ;;+> {"failures":0,"passed":4,"pending":0,"wallTime":39,"errors":0,"type":"test-results"}+> ;;++Machine-readable ouput is requested by the @--json@ flag. You can specify a dedicated output file+using the @--output-file=@ option. On some platforms (e.g. Windows) it might not be possible to read+from the output file while the tests are running (due to file-locking). In this case, you might want+to use the @--split@ option. With this option, HTF writes each JSON message to a separate ouput file.+The name of the output file is derived from the name given with the @--output-file=@ flag by+appending an index (starting at 0) that is incremented for every message.++-}++-- ** XML++{- | 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.++-}+-- * Commandline options++{- |++Here is the list of commandline options for programs using @htfMain@:++@+USAGE: COMMAND [OPTION ...] PATTERN ...++  where PATTERN is a posix regular expression matching+  the names of the tests to run.++  -q          --quiet                     Only display errors.+  -n PATTERN  --not=PATTERN               Tests to exclude.+  -l          --list                      List all matching tests.+  -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
Test/Framework/Utils.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----- Copyright (c) 2005   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@@ -21,6 +22,10 @@  import System.Directory import Data.Char+import System.Time hiding (diffClockTimes)+import System.Random+import Data.Array.IO+import Control.Monad  infixr 6 </> @@ -115,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 =@@ -127,3 +136,40 @@            '\n':_ -> ""            _ | null s -> ""              | otherwise -> "\n"++strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- Measures execution time of the given IO action in milliseconds+measure :: IO a -> IO (a, Int)+measure ma =+    do t0 <- getClockTime+       a <- ma+       t1 <- a `seq` getClockTime+       let diffMicro = t1 `diffClockTimes` t0+       return (a, fromInteger (diffMicro `div` 1000))++diffClockTimes :: ClockTime -> ClockTime -> Integer+diffClockTimes (TOD s1 p1) (TOD s0 p0) =+    (picoseconds p1 + seconds s1) -+    (picoseconds p0 + seconds s0)+    where+      -- bring all into microseconds+      picoseconds i = i `div` (1000 * 1000)+      seconds i = i * 1000000++-- | 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)
+ sample/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Stefan Wehr++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Stefan Wehr nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ sample/Main.hs view
@@ -0,0 +1,34 @@+module Main where++-- A simple main program. The program reads the contents of the+-- given input file, checks whether the content is a number, and+-- then ouputs the results of apply funA and funB to this number.++import MyPkg.A+import MyPkg.B++import Test.Framework+import System.Environment (getArgs)+import System.Exit+import System.IO++main =+    do args <- getArgs+       case args of+         ["-h"] -> usage+         ["--help"] -> usage+         [file] -> doWork file+         _ -> usage+    where+      usage =+          do hPutStrLn stderr "Usage: sample [-h|--help] FILE"+             exitWith (ExitFailure 1)+      doWork file =+          do s <- readFile file+             case reads s of+               [(n, "")] ->+                   do putStrLn $ show (funA n)+                      putStrLn $ show (funB n)+                      exitWith ExitSuccess+               _ -> do hPutStrLn stderr "invalid input"+                       exitWith (ExitFailure 1)
+ sample/MyPkg/A.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module MyPkg.A (funA, htf_thisModulesTests) where++import Test.Framework++funA :: Int -> Int+funA x = x + 1++test_funA1 = assertEqual (funA 41) 42++test_funA2 = assertEqual (funA 2) 3
+ sample/MyPkg/B.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module MyPkg.B (funB, htf_thisModulesTests) where++import Test.Framework++funB :: Int -> Int+funB x = x * 2++test_funB1 = assertEqual (funB 21) 42++test_funB2 = assertEqual (funB 0) 0
+ sample/README view
@@ -0,0 +1,12 @@+A very simple and trivial sample project showing how to use HTF,+the Haskell Test Framework (https://github.com/skogsbaer/HTF/).++Usage:++$ cabal configure --enable-tests+$ cabal build+$ cabal test++To execute the tests directly, run++$ dist/build/sample-tests/sample-tests
+ sample/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sample/TestMain.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++-- The main test program.++import Test.Framework+import Test.Framework.BlackBoxTest+import {-@ HTF_TESTS @-} MyPkg.A+import {-@ HTF_TESTS @-} MyPkg.B++main =+    do bbts <- blackBoxTests "bbt-dir" "../scripts/run-sample" ".num" defaultBBTArgs+       htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts])
+ sample/bbt-dir/should-fail/BBTArgs view
@@ -0,0 +1,1 @@+Fail
+ sample/bbt-dir/should-fail/z.err view
@@ -0,0 +1,1 @@+invalid input
+ sample/bbt-dir/should-fail/z.num view
@@ -0,0 +1,1 @@+hello world
+ sample/bbt-dir/should-pass/x.num view
@@ -0,0 +1,1 @@+42
+ sample/bbt-dir/should-pass/x.out view
@@ -0,0 +1,2 @@+43+84
+ sample/sample-HTF.cabal view
@@ -0,0 +1,27 @@+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+author:              Stefan Wehr+maintainer:          mail@stefanwehr.de+category:            Testing+build-type:          Simple+cabal-version:       >=1.10++executable sample+  main-is:           Main.hs+  other-modules:     MyPkg.A MyPkg.B+  build-depends:     base, HTF+  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+  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
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+{-# LANGUAGE CPP #-}++module Foo.A where++import Test.Framework++#include "test.h"++test_a_FAIL =+    assertEqual x y
+ tests/Foo/B.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}++module Foo.B (htf_thisModulesTests) where++import qualified Test.Framework as HTF++test_b_OK = HTF.assertEqual 1 1
+ tests/Foo/test.h view
@@ -0,0 +1,9 @@++x :: Int+x = 1++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
@@ -0,0 +1,482 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+--+-- Copyright (c) 2005,2010   Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--+import Test.Framework+import Test.Framework.Location+import Test.Framework.TestManager+import Test.Framework.BlackBoxTest+import Test.Framework.TestInterface++import System.Environment+import System.Directory+import System.FilePath+import System.Process+import System.Exit+import System.IO+import System.IO.Temp+import Control.Exception+import 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 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!"+-}+stringGap = "hello world!"++handleExc :: a -> SomeException -> a+handleExc x _ = x++-- 世界不是英文的 Test for #47++-- Test for #48+data HVect (ts :: [*]) where+  HNil :: HVect '[]+  HCons :: t -> HVect ts -> HVect (t ': ts)++fun :: HVect '[Int, Int] -> String+fun = undefined++-- Test for #45+foobar = [q|INSERT INTO a (name) VALUES ('')|]++test_assertFailure_FAIL = assertFailure "I'm a failure"++test_stringGap_OK = assertEqual stringGap "hello world!"++test_assertEqual_FAIL = assertEqual 1 2++test_assertEqualV_FAIL = assertEqualVerbose "blub" 1 2++test_assertEqualNoShow_FAIL = withOptions (\opts -> opts { to_parallel = False }) $+                              assertEqualNoShow A B++test_assertListsEqualAsSets_FAIL = assertListsEqualAsSets [1,2] [2]++test_assertSetEqualSuccess_OK = assertListsEqualAsSets [1,2] [2,1]++test_assertNotEmpty_FAIL = assertNotEmpty []++test_assertEmpty_FAIL = assertEmpty [1]++test_assertElem_FAIL = assertElem 1 [0,2,3]++test_assertThrows_FAIL = assertThrows (return () :: IO ()) (handleExc True)++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)++data Expr = PlusExpr Expr Expr+          | MultExpr Expr Expr+          | Literal Int+          | Variable String+            deriving (Eq, Show)++test_diff_FAIL =+    assertEqual (mkExpr 1) (mkExpr 2)+    where+      mkExpr i =+          PlusExpr (PlusExpr (MultExpr (PlusExpr (Variable "foo")+                                                     (MultExpr (Literal 42) (Variable "bar")))+                                       (PlusExpr (Literal i) (Literal 2)))+                             (Literal 581))+                   (Variable "egg")++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++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_ok_OK :: [Int] -> Property+prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs))++prop_fail_FAIL :: [Int] -> Bool+prop_fail_FAIL xs = xs == (reverse xs)++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'_OK = withQCArgs (\a -> a { maxSuccess = 1}) $+                        \xs -> classify (null xs) "trivial" $+                               (xs::[Int]) == (reverse (reverse xs))++prop_fail'_FAIL =+    prop+    where prop xs = xs == (reverse xs)+              where types = xs::[Int]++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 (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_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 "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 "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\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) ->+                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 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 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+             then []+             else case BSL.span (/= 10) bsl of+                    (start, rest) ->+                        if BSLC.pack "\n;;\n" `BSL.isPrefixOf` rest+                           then start : splitJson (BSL.drop 4 rest)+                           else case splitJson rest of+                                  [] -> error "invalid json output from HTF"+                                  (x:xs) -> (start `BSL.append` x : xs)+      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"+       let dirPrefix = if b then "tests" else ""+       bbts <- blackBoxTests (dirPrefix </> "bbt") (dirPrefix </> "./run-bbt.sh") ".x"+                 (defaultBBTArgs { bbtArgs_verbose = False })+       let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests+       when ("--help" `elem` args || "-h" `elem` args) $+            do hPutStrLn stderr ("USAGE: PROG [--direct]")+               ecode <- runTestWithArgs ["--help"] ([] :: [Test])+               exitWith ecode+       case args of+         "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 ()+                  _ -> fail ("unexpected exit code: " ++ show ecode)+         _ ->+             do withSystemTempFile "HTF-out" $ \outFile h ->+                  do hClose h+                     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)+                runRealBlackBoxTests
+ 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
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module Tutorial where++import System.Environment ( getArgs )+import System.Exit ( exitWith )+import Test.Framework++{-+myReverse :: [a] -> [a]+myReverse [] = []+myReverse [x] = [x]+myReverse (x:xs) = myReverse xs+-}++myReverse :: [a] -> [a]+myReverse [] = []+myReverse (x:xs) = myReverse xs ++ [x]++test_nonEmpty = do assertEqual [1] (myReverse [1])+                   assertEqual [3,2,1] (myReverse [1,2,3])+test_empty = assertEqual ([] :: [Int]) (myReverse [])++prop_reverse :: [Int] -> Bool+prop_reverse xs = xs == (myReverse (myReverse xs))++prop_reverseReplay =+  withQCArgs (\a -> a { replay = read "Just (1060394807 2147483396,2)" })+  prop_reverse++main = htfMain htf_thisModulesTests
+ tests/bbt/Skip/BBTArgs view
@@ -0,0 +1,1 @@+Skip
+ tests/bbt/Skip/some_unknown_but_skipped_file.x view
+ tests/bbt/Verbose/BBTArgs view
@@ -0,0 +1,1 @@+Verbose
+ tests/bbt/Verbose/not_ok_because_stdout1.out view
@@ -0,0 +1,1 @@+x
+ tests/bbt/Verbose/not_ok_because_stdout1.x view
+ tests/bbt/should_fail/BBTArgs view
@@ -0,0 +1,1 @@+Fail
+ tests/bbt/should_fail/not_ok_because_stderr1.err view
@@ -0,0 +1,1 @@+x
+ tests/bbt/should_fail/not_ok_because_stderr1.x view
+ tests/bbt/should_fail/not_ok_because_stderr2.err view
+ tests/bbt/should_fail/not_ok_because_stderr2.x view
+ tests/bbt/should_fail/not_ok_because_stdout1.out view
@@ -0,0 +1,1 @@+x
+ tests/bbt/should_fail/not_ok_because_stdout1.x view
+ tests/bbt/should_fail/not_ok_because_stdout2.out view
+ tests/bbt/should_fail/not_ok_because_stdout2.x view
+ tests/bbt/should_fail/not_ok_because_succeeds.x view
+ tests/bbt/should_fail/ok1.out view
+ tests/bbt/should_fail/ok1.x view
+ tests/bbt/should_fail/ok2.err view
@@ -0,0 +1,1 @@+y
+ tests/bbt/should_fail/ok2.out view
@@ -0,0 +1,1 @@+x
+ tests/bbt/should_fail/ok2.x view
+ tests/bbt/should_pass/not_ok_because_fails.x view
+ tests/bbt/should_pass/not_ok_because_stderr1.err view
@@ -0,0 +1,1 @@+1
+ tests/bbt/should_pass/not_ok_because_stderr1.x view
+ tests/bbt/should_pass/not_ok_because_stderr2.err view
+ tests/bbt/should_pass/not_ok_because_stderr2.x view
+ tests/bbt/should_pass/not_ok_because_stdout1.out view
@@ -0,0 +1,1 @@+1
+ tests/bbt/should_pass/not_ok_because_stdout1.x view
+ tests/bbt/should_pass/not_ok_because_stdout2.out view
+ tests/bbt/should_pass/not_ok_because_stdout2.x view
+ tests/bbt/should_pass/ok1.out view
+ tests/bbt/should_pass/ok1.x view
+ tests/bbt/should_pass/ok2.err view
@@ -0,0 +1,1 @@+y
+ tests/bbt/should_pass/ok2.out view
@@ -0,0 +1,1 @@+x
+ tests/bbt/should_pass/ok2.x view
+ tests/bbt/should_pass/stdin_ok.in view
@@ -0,0 +1,5 @@+1+2+3+4+5
+ tests/bbt/should_pass/stdin_ok.out view
@@ -0,0 +1,5 @@+1+2+3+4+5
+ tests/bbt/should_pass/stdin_ok.x view
+ tests/compile-errors/Foo.h view
@@ -0,0 +1,3 @@+-- 1+-- 2+-- 3
+ tests/compile-errors/Test1.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-}++import "HTF" Test.Framework+#include "Foo.h"++foo :: Int -> Int+foo i = i + "Stefan"++main :: IO ()+main = return ()
+ tests/compile-errors/Test2.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-}++import "HTF" Test.Framework+#include "Foo.h"+foo :: Int -> Int+foo i = i + "Stefan"++main :: IO ()+main = return ()
+ tests/compile-errors/Test3.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-}++import "HTF" Test.Framework++-- error must be in line 7+test_foo :: Int+test_foo = 5++main :: IO ()+main = return ()
+ tests/compile-errors/Test4.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-}++import "HTF" Test.Framework+data D = D+-- error must be in line 7+prop_foo :: D -> Bool+prop_foo _ = False++main :: IO ()+main = return ()
+ tests/compile-errors/run-tests.sh view
@@ -0,0 +1,31 @@+#!/bin/bash++cd "$(dirname $0)"++lineno=7+function check()+{+    test="$1"+    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}"+        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+check Test2.hs+check Test3.hs+check Test4.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-bbt.sh view
@@ -0,0 +1,66 @@+#!/bin/sh++case "$1" in+  *bbt/should_fail/ok1.x)+    exit 1+  ;;+  *bbt/should_fail/ok2.x)+    echo x +    echo y 1>&2+    exit 2+  ;;+  *bbt/should_fail/not_ok_because_succeeds.x)+    exit 0+  ;;+  *bbt/should_fail/not_ok_because_stdout1.x)+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stdout2.x)+    echo x+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stderr1.x)+    exit 1+  ;;+  *bbt/should_fail/not_ok_because_stderr2.x)+    echo x 1>&2+    exit 1+  ;;++  *bbt/should_pass/ok1.x)+    exit 0+  ;;+  *bbt/should_pass/ok2.x)+    echo x +    echo y 1>&2+    exit 0+  ;;+  *bbt/should_pass/stdin_ok.x)+    cat+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_fails.x)+    exit 6+  ;;+  *bbt/should_pass/not_ok_because_stdout1.x)+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stdout2.x)+    echo x+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stderr1.x)+    exit 0+  ;;+  *bbt/should_pass/not_ok_because_stderr2.x)+    echo x 1>&2+    exit 0+  ;;+  *bbt/Verbose/not_ok_because_stdout1.x)+    exit 0+  ;;+  *)+    echo "$0: Illegal failname: <$1>"+    exit 127+  ;;+esac