HTF 0.11.4.0 → 0.15.0.2
raw patch · 75 files changed
Files
- ChangeLog +88/−0
- HTF.cabal +129/−131
- HTFPP.hs +11/−10
- README.md +13/−22
- Setup.hs +0/−5
- TODO.org +0/−11
- Test/Framework.hs +7/−4
- Test/Framework/AssertM.hs +47/−38
- Test/Framework/BlackBoxTest.hs +28/−26
- Test/Framework/CmdlineOptions.hs +188/−54
- Test/Framework/Colors.hs +4/−1
- Test/Framework/Diff.hs +70/−14
- Test/Framework/HUnitWrapper.hs +932/−581
- Test/Framework/HaskellParser.hs +0/−191
- Test/Framework/History.hs +183/−0
- Test/Framework/JsonOutput.hs +43/−26
- Test/Framework/Location.hs +2/−2
- Test/Framework/Preprocessor.hs +341/−211
- Test/Framework/Pretty.hs +23/−1
- Test/Framework/PrettyHaskell.hs +103/−0
- Test/Framework/QuickCheckWrapper.hs +76/−34
- Test/Framework/TestInterface.hs +189/−0
- Test/Framework/TestManager.hs +271/−53
- Test/Framework/TestManagerInternal.hs +0/−134
- Test/Framework/TestReporter.hs +62/−24
- Test/Framework/TestTypes.hs +71/−34
- Test/Framework/ThreadPool.hs +34/−17
- Test/Framework/Tutorial.hs +139/−69
- Test/Framework/Utils.hs +6/−1
- Test/Framework/XmlOutput.hs +75/−24
- run-all-tests-for-all-compilers.sh +0/−40
- run-all-tests.sh +0/−14
- sample/TestMain.hs +1/−1
- sample/sample-HTF.cabal +5/−2
- scripts/check.sh +40/−0
- scripts/dist.sh +50/−0
- scripts/local-htfpp +36/−0
- scripts/prepare +6/−0
- scripts/run-sample +3/−0
- stack-ghc-8.10.yaml +4/−0
- stack-ghc-8.2.yaml +5/−0
- stack-ghc-8.4.yaml +6/−0
- stack-ghc-8.6.yaml +6/−0
- stack-ghc-8.8.yaml +6/−0
- stack-ghc-9.0.yaml +4/−0
- stack-ghc-9.2.yaml +4/−0
- stack-ghc-9.4.yaml +4/−0
- stack.yaml +6/−0
- tests/Foo/A.hs +2/−2
- tests/Foo/B.hs +2/−2
- tests/Foo/test.h +3/−0
- tests/MiscTest.hs +38/−0
- tests/Quasi.hs +11/−0
- tests/TestHTF.hs +300/−73
- tests/TestHTFHunitBackwardsCompatible.hs +0/−10
- tests/Tutorial.hs +1/−1
- tests/bbt/should_fail/not_ok_because_stderr2.err +0/−0
- tests/bbt/should_fail/not_ok_because_stdout2.out +0/−0
- tests/bbt/should_pass/not_ok_because_stderr2.err +0/−0
- tests/bbt/should_pass/not_ok_because_stdout2.out +0/−0
- tests/compile-errors/Test1.hs +2/−2
- tests/compile-errors/Test2.hs +2/−2
- tests/compile-errors/Test3.hs +2/−2
- tests/compile-errors/Test4.hs +2/−2
- tests/compile-errors/run-tests.sh +11/−4
- tests/real-bbt/FailFast.hs +9/−0
- tests/real-bbt/MaxCurTime.hs +14/−0
- tests/real-bbt/MaxPrevTime.hs +13/−0
- tests/real-bbt/PrevFactor.hs +19/−0
- tests/real-bbt/Repeat.hs +23/−0
- tests/real-bbt/SortByPrevTime.hs +13/−0
- tests/real-bbt/UniqTests1.hs +10/−0
- tests/real-bbt/UniqTests2.hs +16/−0
- tests/run-tests.sh +0/−18
- tests/test-HTF.cabal +0/−41
ChangeLog view
@@ -1,3 +1,91 @@+* 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
HTF.cabal view
@@ -1,10 +1,11 @@+Cabal-Version: 2.0 Name: HTF-Version: 0.11.4.0-License: LGPL+Version: 0.15.0.2+License: LGPL-2.1 License-File: LICENSE-Copyright: (c) 2005-2012 Stefan Wehr-Author: Stefan Wehr <wehr@factisresearch.com>-Maintainer: Stefan Wehr <wehr@factisresearch.com>+Copyright: (c) 2005-2024 Stefan Wehr+Author: Stefan Wehr+Maintainer: Stefan Wehr Stability: Beta Category: Testing Synopsis: The Haskell Test Framework@@ -12,85 +13,42 @@ Bug-Reports: https://github.com/skogsbaer/HTF/issues Description: - The Haskell Test Framework (/HTF/ for short) lets you define unit- tests (<http://hunit.sourceforge.net>), QuickCheck properties- (<http://www.cs.chalmers.se/~rjmh/QuickCheck/>), and black box- tests in an easy and convenient way. HTF uses a custom- preprocessor that collects test definitions automatically.- Furthermore, the preprocessor allows HTF to report failing- test cases with exact file name and line number information.- Additionally, HTF tries to produce highly readable output- for failing tests: for example, it colors and pretty prints expected and- actual results and provides a diff between the two values.-- .-- The documentation of the "Test.Framework.Tutorial" module- provides a tutorial for HTF. There is also a slightly out-dated- blog article (<http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html>)- demonstrating HTF's coloring, pretty-printing and diff functionality.-- .-- /HEADS UP, backwards incomatibility with prior versions:/-- .-- In version 0.10.0.0, the following changes could break code compiled against version 0.9.*:-- .-- * "Test.Framework" now longer exports all of "Test.Framework.TestManager" and- "Test.Framework.BlackBoxTest". For modules that only define tests, no changes- should be necessary. However, you likely need to adjust your test runner- module by importing "Test.Framework.TestManager" and possibly "Test.Framework.BlackBoxTest".-- .-- * Some reorganization in "Test.Framework.TestManager" and related modules, introduction- of "Test.Framework.TestTypes". Usually, your code should not be affected- by these changes.-- .- Starting with version 0.9.0.0, HTF uses a new strategy- for collecting the testcases defined in your project- (see "Test.Framework.Tutorial" for a description of this strategy).- If you used version 0.8.* or earlier of HTF, this /will break your build!/- However, it's rather easy to bring you project in line with the new HTF- version. Here are the steps that will most likely resolve- your backwards incompatibility problems:-- .-- * If a module exports the @allHTFTests@ symbol, this export must- be changed to @htf_thisModulesTests@.+ The Haskell Test Framework (/HTF/ for short) lets you define and organize unit tests,+ QuickCheck properties,+ and black box tests in an+ easy and convenient way. HTF uses a custom preprocessor that collects+ test definitions automatically. . - * If an import declaration of some module hides the @allHTFTests@- symbol, you can simply remove the hiding clause for @allHTFTests@.+ HTF produces highly readable output+ for failing test cases: it provides exact file name and line number+ information,+ it colors and pretty prints expected and+ actual results, and it displays a diff highlighting the mismatching parts. . - * If a module collects and executes tests from several other modules,- the collecting module has to be changed as follows: add- @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ to the top- of the collecting module, import- the other modules with the @{-@ HTF_TESTS @-}@- annotation, use the symbol @htf_importedTests@ for referencing- the imported tests. See "Test.Framework.Tutorial" for details.+ The documentation of the "Test.Framework.Tutorial" module+ provides a tutorial for HTF. The /sample/ directory in+ the HTF repo provides a good starting point for+ a project using HTF. -Tested-With:- GHC==7.4.2,- GHC==7.6.2 Build-Type: Simple-Cabal-Version: >= 1.10+ Extra-Source-Files: README.md- TODO.org ChangeLog+ stack.yaml+ stack-ghc-8.2.yaml+ stack-ghc-8.4.yaml+ stack-ghc-8.6.yaml+ stack-ghc-8.8.yaml+ stack-ghc-8.10.yaml+ stack-ghc-9.0.yaml+ stack-ghc-9.2.yaml+ stack-ghc-9.4.yaml tests/bbt/should_fail/BBTArgs- -- tests/bbt/should_fail/*.in tests/bbt/should_fail/*.err tests/bbt/should_fail/*.out tests/bbt/should_fail/*.x@@ -106,8 +64,6 @@ tests/Foo/test.h tests/Tutorial.hs tests/run-bbt.sh- tests/test-HTF.cabal- tests/run-tests.sh tests/compile-errors/Foo.h tests/compile-errors/run-tests.sh tests/compile-errors/Test1.hs@@ -127,110 +83,152 @@ sample/bbt-dir/should-fail/z.num sample/bbt-dir/should-pass/x.num sample/bbt-dir/should-pass/x.out- run-all-tests-for-all-compilers.sh- run-all-tests.sh+ scripts/local-htfpp+ scripts/dist.sh+ scripts/check.sh+ scripts/run-sample+ scripts/prepare++tested-with:+ GHC == 9.4.4+ GHC == 9.2.6+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ Source-Repository head Type: git Location: http://github.com/skogsbaer/HTF.git Executable htfpp Main-Is: HTFPP.hs- Build-Depends: cpphs >= 1.12,- haskell-src-exts >= 1.14,- old-time >= 1.0,- directory >= 1.0,+ Build-Depends: HUnit, array,+ base >= 4.10 && < 5,+ cpphs >= 1.19,+ directory >= 1.0,+ mtl >= 1.1,+ old-time >= 1.0, random >= 1.0,- base == 4.*,- text+ 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:+ Build-Depends: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3,- base == 4.*,- random >= 1.0,- containers >= 0.4.2.1,- process >= 1.0,+ aeson >= 0.11,+ array,+ base >= 4.10 && < 5,+ base64-bytestring,+ bytestring >= 0.9,+ containers >= 0.5,+ cpphs >= 1.19,+ haskell-src, directory >= 1.0,- mtl >= 1.1,- monad-control >= 0.3, lifted-base >= 0.1,+ monad-control >= 0.3,+ mtl >= 1.1,+ old-time >= 1.0, pretty >= 1.0,- Diff >= 0.3,- bytestring >= 0.9,+ process >= 1.0,+ random >= 1.0, regex-compat >= 0.92,- haskell-src-exts >= 1.11,- aeson >= 0.6, text >= 0.11,- old-time >= 1.0,- array,- xmlgen >= 0.6,- base64-bytestring+ time,+ vector,+ xmlgen >= 0.6 if !os(windows) Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework+ Test.Framework.AssertM+ Test.Framework.BlackBoxTest Test.Framework.HUnitWrapper+ Test.Framework.History+ Test.Framework.JsonOutput+ Test.Framework.Location+ Test.Framework.Preprocessor+ Test.Framework.Pretty+ Test.Framework.PrettyHaskell+ Test.Framework.QuickCheckWrapper+ Test.Framework.TestInterface Test.Framework.TestManager Test.Framework.TestTypes- Test.Framework.TestReporter- Test.Framework.CmdlineOptions- Test.Framework.QuickCheckWrapper- Test.Framework.BlackBoxTest- Test.Framework.Location+ Test.Framework.ThreadPool Test.Framework.Tutorial- Test.Framework.Pretty- Test.Framework.JsonOutput Test.Framework.XmlOutput- Test.Framework.ThreadPool- Test.Framework.AssertM 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+ Ghc-Options:+ -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+ -Wcompat +Test-Suite MiscTests+ Main-is: MiscTest.hs+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: tests+ Build-depends: HTF,+ HUnit,+ base >= 4.10 && < 5,+ mtl,+ random+ Build-tool-depends: HTF:htfpp+ Default-language: Haskell2010+ Test-Suite TestHTF Main-is: TestHTF.hs- Hs-Source-Dirs: tests+ Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0- Build-depends: base == 4.*,+ Build-depends: HTF,+ aeson >= 0.11,+ aeson-pretty,+ base >= 4.10 && < 5, bytestring >= 0.9,- aeson >= 0.6,- unordered-containers >= 0.2,- temporary >= 1.1,- text >= 0.11,- process >= 1.0,- filepath >= 1.1, directory >= 1.0,- regex-compat >= 0.92,+ filepath >= 1.1,+ process >= 1.0, random,- HTF+ 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, TestHTFHunitBackwardsCompatible+ Foo.A, Foo.B, FailFast, MaxCurTime,+ MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi,+ Tutorial, Repeat Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests- Build-depends: base == 4.*,- random,+ Build-depends: HTF,+ base >= 4.10 && < 5, mtl,- HTF- Default-language: Haskell2010--Test-Suite Tutorial- Type: exitcode-stdio-1.0- Main-is: Tutorial.hs- Hs-Source-Dirs: tests- Build-depends: base >= 4, HTF+ random+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010
HTFPP.hs view
@@ -35,7 +35,7 @@ usage = hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++- "Usage: " ++ progName ++ " [--hunit] [FILE1 [FILE2 [FILE3]]]\n\n" +++ "Usage: " ++ progName ++ " [--debug|--version|--literate-tex] [FILE1 [FILE2 [FILE3]]]\n\n" ++ "* If no argument is given, input is read from stdin and\n" ++ " output is written to stdout.\n" ++ "* If only FILE1 is given, input is read from this file\n" ++@@ -45,13 +45,14 @@ "* If FILE1, FILE2, and FILE3 are given, input is read\n" ++ " from FILE2, output is written to FILE3, and\n" ++ " FILE1 serves as the original input filename.\n\n" ++- "The `--hunit' flag causes assert-like macros to be expanded in a way\n" ++- "that is backwards-compatible with the corresponding functions of the\n" ++- "HUnit library.")+ "The `--hunit' flag has been deprecated starting with version 0.15." +++ "The `--literate-tex` flag causes the additional generated code to be wrapped\n" +++ "in TeX-style literate code blocks.") outputVersion :: IO () outputVersion = hPutStrLn stderr (showVersion Paths_HTF.version)+ saveOpenFile :: FilePath -> IOMode -> IO Handle saveOpenFile path mode = openFile path mode `catch` exHandler@@ -72,10 +73,9 @@ when ("--version" `elem` args) $ do outputVersion exitWith ExitSuccess- let (restArgs, hunitBackwardsCompat) =- case reverse args of- "--hunit":rrest -> (reverse rrest, True)- rrest -> (reverse rrest, False)+ let transformOpts = TransformOptions { debug = "--debug" `elem` args+ , literateTex = "--literate-tex" `elem` args }+ restArgs = flip filter args $ \x -> not $ x `elem` ["--hunit", "--debug", "--literate-tex"] (origInputFilename, hIn, hOut) <- case restArgs of [] ->@@ -92,10 +92,11 @@ h2 <- saveOpenFile file3 WriteMode return (file1, h1, h2) _ ->- do usage+ do hPutStrLn stderr ("Too many arguments: " ++ show restArgs)+ usage exitWith (ExitFailure 1) input <- hGetContents hIn- output <- transform hunitBackwardsCompat origInputFilename input `catch`+ output <- transform transformOpts origInputFilename input `catch` (\ (e::SomeException) -> do hPutStrLn stderr (progName ++ ": unexpected exception: " ++
README.md view
@@ -1,36 +1,27 @@ # HTF - The Haskell Test Framework +[](https://github.com/skogsbaer/HTF/actions/workflows/haskell-ci.yml)+[](http://hackage.haskell.org/package/HTF)+ * Documentation: http://hackage.haskell.org/package/HTF * Source Repository: https://github.com/skogsbaer/HTF/ * Issue tracker: https://github.com/skogsbaer/HTF/issues?state=open * Author: Stefan Wehr (http://www.stefanwehr.de)-* License: LGPL+* License: LGPL ## Summary -The Haskell Test Framework (HTF for short) lets you define unit tests-(http://hunit.sourceforge.net), QuickCheck properties-(http://www.cs.chalmers.se/~rjmh/QuickCheck/), and black box tests in an+The Haskell Test Framework (HTF for short) lets you define and organize unit tests+(http://hackage.haskell.org/package/HUnit), QuickCheck properties+(https://hackage.haskell.org/package/QuickCheck), and black box tests in an easy and convenient way. HTF uses a custom preprocessor that collects-test definitions automatically. Furthermore, the preprocessor allows-HTF to report failing test cases with exact file name and line number-information. Additionally, HTF tries to produce highly readable output-for failing tests: for example, it colors and pretty prints expected and-actual results and provides a diff between the two values.--Look [here](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html)-for a short tutorial on HTF. The following slightly out-dated-[blog article](http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html)-demonstrates HTF's coloring, pretty-printing and diff functionality.--## Installation instructions--* Install from http://hackage.haskell.org/ using `cabal install HTF`-* Install from source:+test definitions automatically. - $ git clone git@github.com:skogsbaer/HTF.git- $ cd HTF- $ cabal install+HTF produces highly readable output+for failing test cases: it provides exact file name and line number+information,+it colors and pretty prints expected and+actual results, and it displays a diff highlighting the mismatching parts. ## Getting started
− Setup.hs
@@ -1,5 +0,0 @@-#!/usr/bin/runhaskell--import Distribution.Simple--main = defaultMain
− TODO.org
@@ -1,11 +0,0 @@-* Relase 0.12-** New parser-*** Add support for MultiWayIf and LambdaCase to haskell-src-exts-*** Allow default Fixities for haskell-src-exts-** Support for timeouts (--timeout=SECS)-** External interface for integrating other test frameworks-*** Support for Smallcheck and/or Lazy Smallcheck-*** Configuration file for htfpp-**** Expansion templates (extensible!)-** Support for benchmarks-** Collect testmodules with a new preprocessor (new preprocessor runs on the main module)
Test/Framework.hs view
@@ -1,11 +1,11 @@--- +-- -- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version.--- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU@@ -21,9 +21,11 @@ Top-level module that re-exports functionality from sub-modules. Modules that only define unit tests and quickcheck properties typically only need to import this module.-Your test driver should additionally import 'Test.Framework.TestManager' and,+Test drivers should additionally import 'Test.Framework.TestManager' and, if needed, 'Test.Framework.BlackBoxTest'. +See "Test.Framework.Tutorial" for a description how to use HTF.+ -} module Test.Framework ( @@ -37,7 +39,8 @@ module Test.Framework.AssertM, -- * Organizing tests- TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc+ TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest,+ TM.WrappableHTF(..) ) where
Test/Framework/AssertM.hs view
@@ -1,3 +1,21 @@+{-# 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@@ -6,64 +24,66 @@ -} module Test.Framework.AssertM ( - AssertM(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack+ AssertM(..), AssertBool(..), boolValue, eitherValue ) where -import Data.Maybe+import Control.Monad (liftM, ap)+import GHC.Stack import qualified Data.Text as T -import Test.Framework.TestManagerInternal-import Test.Framework.Location+import Test.Framework.TestInterface import Test.Framework.Colors -- | A typeclass for generic assertions. class Monad m => AssertM m where- genericAssertFailure__ :: Location -> ColorString -> m a- genericSubAssert :: Location -> Maybe String -> m a -> m a+ genericAssertFailure :: HasCallStack => ColorString -> m a+ genericSubAssert :: HasCallStack => Maybe String -> m a -> m a instance AssertM IO where- genericAssertFailure__ loc s = unitTestFail (Just loc) s- genericSubAssert loc mMsg action = unitTestSubAssert loc mMsg action---- | Stack trace element for generic assertions.-data AssertStackElem- = AssertStackElem- { ase_message :: Maybe String- , ase_location :: Maybe Location- }- deriving (Eq, Ord, Show, Read)+ 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 [AssertStackElem]+ | 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 >>= _ = AssertFailed stack+ AssertFailed stack msg >>= _ = AssertFailed stack msg AssertOk x >>= k = k x- fail msg = AssertFailed [AssertStackElem (Just msg) Nothing]+#if !(MIN_VERSION_base(4,13,0))+ fail msg = AssertFailed emptyHtfStack msg+#endif instance AssertM AssertBool where- genericAssertFailure__ loc s =- AssertFailed [AssertStackElem (Just (T.unpack $ renderColorString s False)) (Just loc)]-- genericSubAssert loc mMsg action =+ genericAssertFailure s =+ AssertFailed (mkHtfStack callStack) (T.unpack $ renderColorString s False)+ genericSubAssert subMsg action = case action of AssertOk x -> AssertOk x- AssertFailed stack ->- AssertFailed (AssertStackElem mMsg (Just loc) : stack)+ 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+ AssertFailed _ _ -> False -- | Evaluates a generic assertion to an 'Either' value. The result -- is @Right x@ if the assertion passes and yields value @x@, otherwise@@ -72,15 +92,4 @@ eitherValue x = case x of AssertOk z -> Right z- AssertFailed stack -> Left (formatStack stack)---- | Formats a stack trace.-formatStack :: [AssertStackElem] -> String-formatStack stack =- unlines $ map formatStackElem $ zip [0..] $ reverse stack- where- formatStackElem (pos, AssertStackElem mMsg mLoc) =- let floc = fromMaybe "<unknown location>" $ fmap showLoc mLoc- fmsg = fromMaybe "" $ fmap (\s -> ": " ++ s) mMsg- pref = if pos > 0 then " called from " else ""- in pref ++ floc ++ fmsg+ AssertFailed stack msg -> Left (msg ++ "\n" ++ formatHtfStack stack)
Test/Framework/BlackBoxTest.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009,2012,2013 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@@ -50,19 +50,19 @@ import qualified Data.Map as Map 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) @@ -121,6 +121,9 @@ endOfOutput :: String -> String endOfOutput s = "[end of " ++ s ++ "]" +blackBoxTestFail :: String -> Assertion+blackBoxTestFail s = failHTF $ mkFullTestResult Fail (Just s)+ {- | Use a value of this datatype to customize various aspects of your black box tests.@@ -128,8 +131,8 @@ data BBTArgs = BBTArgs { bbtArgs_stdinSuffix :: String -- ^ File extension for the file used as stdin. , bbtArgs_stdoutSuffix :: String -- ^ File extension for the file specifying expected output on stdout. , bbtArgs_stderrSuffix :: String -- ^ File extension for the file specifying expected output on stderr.- , bbtArgs_dynArgsName :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format.- , bbtArgs_verbose :: Bool -- ^ Ge verbose or not.+ , bbtArgs_dynArgsName :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. Default: BBTArgs+ , bbtArgs_verbose :: Bool -- ^ Be verbose or not. , bbtArgs_stdoutDiff :: Diff -- ^ Diff program for comparing output on stdout with the expected value. , bbtArgs_stderrDiff :: Diff -- ^ Diff program for comparing output on stderr with the expected value. }@@ -162,24 +165,21 @@ -} defaultDiff :: Diff defaultDiff expectFile real =- do mexe <- findExecutable "diff"- let exe = case mexe of- Just p -> p- Nothing -> error ("diff command not in path")- case expectFile of- Nothing | null real -> return Nothing- | otherwise -> return $ Just ("no output expected, but " ++- "given:\n" ++ real ++- (endOfOutput "given output"))- Just expect ->- do (out, err, exitCode) <- popen exe ["-u", expect, "-"]- (Just real)- case exitCode of- ExitSuccess -> return Nothing -- no difference- ExitFailure 1 -> -- files differ- return $ Just (out ++ (endOfOutput "diff output"))- ExitFailure i -> error ("diff command failed with exit " ++- "code " ++ show i ++ ": " ++ err)+ case expectFile of+ Nothing -> return Nothing+ Just expect ->+ do mexe <- findExecutable "diff"+ let exe = case mexe of+ Just p -> p+ Nothing -> error ("diff command not in path")+ (out, err, exitCode) <- popen exe ["-u", expect, "-"]+ (Just real)+ case exitCode of+ ExitSuccess -> return Nothing -- no difference+ ExitFailure 1 -> -- files differ+ return $ Just (out ++ (endOfOutput "diff output"))+ ExitFailure i -> error ("diff command failed with exit " +++ "code " ++ show i ++ ": " ++ err) {- | Collects all black box tests with the given file extension stored in a specific directory.@@ -198,13 +198,15 @@ 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).+(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
Test/Framework/CmdlineOptions.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} ----- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -31,26 +33,39 @@ 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 (getEnv)+import System.Posix.Env #endif #ifdef __GLASGOW_HASKELL__ import GHC.Conc ( numCapabilities ) #endif +import qualified Data.ByteString as BS+import Control.Monad+ -- -- CmdlineOptions --@@ -62,13 +77,21 @@ , 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' (the default), shuffle tests when running them in parallel.+ , 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. } {- |@@ -81,13 +104,21 @@ , opts_help = False , opts_negated = [] , opts_threads = Nothing- , opts_shuffle = True+ , 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@@ -97,39 +128,86 @@ processorCount = 1 #endif -optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+optionDescriptions :: [OptDescr (CmdlineOptions -> Either String CmdlineOptions)] optionDescriptions =- [ Option ['q'] ["quiet"] (NoArg (\o -> o { opts_quiet = True })) "only display errors"- , Option ['n'] ["not"] (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })- "PATTERN") "tests to exclude"- , Option ['l'] ["list"] (NoArg (\o -> o { opts_listTests = True })) "list all matching tests"- , Option ['j'] ["threads"] (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N")- ("run N tests in parallel, default N=" ++ show processorCount)- , Option [] ["deterministic"] (NoArg (\o -> o { opts_shuffle = False })) "do not shuffle tests when executing them in parallel."- , Option ['o'] ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s })- "FILE") "name of output file"- , Option [] ["json"] (NoArg (\o -> o { opts_machineOutput = True }))- "output results in machine-readable JSON format (incremental)"- , Option [] ["xml"] (ReqArg (\s o -> o { opts_machineOutputXml = Just s }) "FILE")- "output results in junit-style XML format"- , Option [] ["split"] (NoArg (\o -> o { opts_split = True }))- "splits results in separate files to avoid file locking (requires -o/--output-file)"- , Option [] ["colors"] (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) })- "BOOL") "use colors or not"- , Option ['h'] ["help"] (NoArg (\o -> o { opts_help = True })) "display this message"+ [ Option ['q'] ["quiet"]+ (NoArg (\o -> Right $ o { opts_quiet = True }))+ "Only display errors."+ , Option ['n'] ["not"]+ (ReqArg (\s o -> Right $ o { opts_negated = s : (opts_negated o) }) "PATTERN")+ "Tests to exclude."+ , Option ['l'] ["list"]+ (NoArg (\o -> Right $ o { opts_listTests = True }))+ "List all matching tests."+ , Option ['j'] ["threads"]+ (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N")+ ("Run N tests in parallel, default N=" ++ show processorCount ++ ".")+ , Option [] ["shuffle"]+ (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL")+ "Shuffle test order. Default: false"+ , Option ['o'] ["output-file"]+ (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE")+ "Name of output file."+ , Option [] ["json"]+ (NoArg (\o -> Right $ o { opts_machineOutput = True }))+ "Output results in machine-readable JSON format (incremental)."+ , Option [] ["xml"]+ (ReqArg (\s o -> Right $ o { opts_machineOutputXml = Just s }) "FILE")+ "Output results in junit-style XML format."+ , Option [] ["split"]+ (NoArg (\o -> Right $ o { opts_split = True }))+ "Splits results in separate files to avoid file locking (requires -o/--output-file)."+ , Option [] ["colors"]+ (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_useColors = Just b }) "BOOL")+ "Use colors or not."+ , Option [] ["history"]+ (ReqArg (\s o -> Right $ o { opts_historyFile = Just s }) "FILE")+ "Path to the history file. Default: ./.HTF/<ProgramName>.history"+ , Option [] ["fail-fast"]+ (NoArg (\o -> Right $ o { opts_failFast = True }))+ "Fail and abort test run as soon as the first test fails."+ , Option [] ["sort-by-prev-time"]+ (NoArg (\o -> Right $ o { opts_sortByPrevTime = True }))+ "Sort tests ascending by their execution of the previous test run (if available). Default: false"+ , Option [] ["max-prev-ms"]+ (ReqArg (\s o -> parseRead "--max-prev-ms" s >>= \(ms::Int) -> Right $ o { opts_maxPrevTimeMs = Just ms }) "MILLISECONDS")+ "Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run."+ , Option [] ["max-cur-ms"]+ (ReqArg (\s o -> parseRead "--max-cur-ms" s >>= \(ms::Int) ->+ Right $ o { opts_maxCurTimeMs = Just ms }) "MILLISECONDS")+ "Abort a test that runs more than MILLISECONDS."+ , Option [] ["prev-factor"]+ (ReqArg (\s o -> parseRead "--prev-factor" s >>= \(ms::Double) ->+ Right $ o { opts_prevFactor = Just ms }) "DOUBLE")+ "Abort a test that runs more than DOUBLE times slower than in a previous run."+ , Option [] ["timeout-is-success"]+ (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True }))+ "Do not regard a test timeout as an error."+ , Option [] ["repeat"]+ (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) ->+ Right $ o { opts_repeat = i}) "NUMBER")+ "Execute the tests selected on the command line NUMBER times."+ , Option ['h'] ["help"]+ (NoArg (\o -> Right $ o { opts_help = True }))+ "Display this message." ] where- parseThreads Nothing = processorCount+ parseThreads Nothing = Right processorCount parseThreads (Just s) = case readM s of- Just i -> i- Nothing -> error ("invalid number of threads: " ++ s)+ Just i -> Right i+ Nothing -> Left ("invalid number of threads: " ++ s) parseBool s =+ Right $ if map toLower s `elem` ["1", "true", "yes", "on"] then True else False+ parseRead opt s =+ case readM s of+ Just i -> Right i+ Nothing -> Left ("invalid value for option " ++ opt ++ ": " ++ s) {- | -Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis+Parse commandline arguments into 'CmdlineOptions'. Here is a synopsis of the format of the commandline arguments: > USAGE: COMMAND [OPTION ...] PATTERN ...@@ -137,38 +215,49 @@ > where PATTERN is a posix regular expression matching > the names of the tests to run. >-> -q --quiet only display errors-> -n PATTERN --not=PATTERN tests to exclude-> -l --list list all matching tests-> -j[N] --threads[=N] run N tests in parallel, default N=4-> --deterministic do not shuffle tests when executing them in parallel.-> -o FILE --output-file=FILE name of output file-> --json output results in machine-readable JSON format (incremental)-> --xml=FILE output results in junit-style XML format-> --split splits results in separate files to avoid file locking (requires -o/--output-file)-> --colors=BOOL use colors or not-> -h --help display this message+> -q --quiet Only display errors.+> -n PATTERN --not=PATTERN Tests to exclude.+> -l --list List all matching tests.+> -j[N] --threads[=N] Run N tests in parallel, default N=1.+> --shuffle=BOOL Shuffle test order. Default: false+> -o FILE --output-file=FILE Name of output file.+> --json Output results in machine-readable JSON format (incremental).+> --xml=FILE Output results in junit-style XML format.+> --split Splits results in separate files to avoid file locking (requires -o/--output-file).+> --colors=BOOL Use colors or not.+> --history=FILE Path to the history file. Default: ./.HTF/<ProgramName>.history+> --fail-fast Fail and abort test run as soon as the first test fails.+> --sort-by-prev-time Sort tests ascending by their execution of the previous test run (if available). Default: false+> --max-prev-ms=MILLISECONDS Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+> --max-cur-ms=MILLISECONDS Abort a test that runs more than MILLISECONDS.+> --prev-factor=DOUBLE Abort a test that runs more than DOUBLE times slower than in a previous run.+> --timeout-is-success Do not regard a test timeout as an error.+> -h --help Display this message. -} parseTestArgs :: [String] -> Either String CmdlineOptions parseTestArgs args = case getOpt Permute optionDescriptions args of- (optTrans, tests, [] ) ->- let posStrs = tests- negStrs = opts_negated opts- pos = map mkRegex posStrs- neg = map mkRegex negStrs- pred (FlatTest _ path _ _) =- let flat = flatName path- in if (any (\s -> s `matches` flat) neg)- then False- else null pos || any (\s -> s `matches` flat) pos- opts = (foldr ($) defaultCmdlineOptions optTrans) { opts_filter = pred }- in case (opts_outputFile opts, opts_split opts) of+ (optTrans, tests, []) ->+ do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans+ when (opts_shuffle opts && opts_sortByPrevTime opts) $+ Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " +++ "Can only use one of both.\n\n" +++ usageInfo usageHeader optionDescriptions)+ case (opts_outputFile opts, opts_split opts) of (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions)- _ -> Right opts+ _ -> let posStrs = tests+ negStrs = opts_negated opts+ pos = map mkRegex posStrs+ neg = map mkRegex negStrs+ pred (FlatTest _ path _ _) =+ let flat = flatName path+ in if (any (\s -> s `matches` flat) neg)+ then False+ else null pos || any (\s -> s `matches` flat) pos+ in Right (opts { opts_filter = pred }) (_,_,errs) -> Left (concat errs ++ usageInfo usageHeader optionDescriptions) where@@ -201,14 +290,25 @@ 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- , tc_useColors = colors }+ , 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 =@@ -243,3 +343,37 @@ Just fd -> queryTerminal fd _ -> return False #endif+ getHistoryFile =+ case opts_historyFile opts of+ Just fp -> return fp+ Nothing ->+ do progName <- getProgName+ let x = if progName == "<interactive>" then "interactive" else progName+ curDir <- getCurrentDirectory+ let dir = curDir </> ".HTF"+ createDirectoryIfMissing False dir+ return $ dir </> (x ++ ".history")+ getHistory fp =+ do b <- doesFileExist fp+ if not b+ then return emptyTestHistory+ else do bs <- BS.readFile fp+ case deserializeTestHistory bs of+ Right history -> return history+ Left err ->+ do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err)+ return emptyTestHistory+ `catch` (\(e::IOException) ->+ do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e)+ return emptyTestHistory)+ mergeFilters f1 f2 t =+ f1 t && f2 t+ historicFilter history t =+ case opts_maxPrevTimeMs opts of+ Nothing -> True+ Just ms ->+ case max (fmap htr_timeMs (findHistoricTestResult (historyKey t) history))+ (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey t) history))+ of+ Nothing -> True+ Just t -> t <= ms
Test/Framework/Colors.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{- |+Utility module dealing with ANSI colors.+-} ----- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public
Test/Framework/Diff.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} ----- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -23,6 +23,10 @@ ) 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@@ -84,12 +88,50 @@ contextSize :: Int contextSize = 10 +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- | s1 == s2 = emptyColorString+singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2)+ where+ loop :: (Int, Int) -> (String, String) -> ColorString+ loop (skipped1, skipped2) (s1, s2) =+ let (start1, start2, cont) = prepareStringsForDiff s1 s2+ in case singleLineDiff' dc start1 start2 of+ Just cs ->+ let prefix =+ if skipped1 == 0 && skipped1 == 0+ then emptyColorString+ else dc_skip dc+ ("skipped " ++ show skipped1 +++ " chars from first string, "+ ++ show skipped2 ++ " chars from second string")+ suffix =+ case cont of+ Nothing -> emptyColorString+ Just (r1, r2) ->+ dc_skip dc+ ("skipped " ++ show (length r1) +++ " chars from first string, " +++ show (length r2) ++ " chars from second string")+ in prefix +++ cs +++ suffix+ Nothing ->+ case cont of+ Just (r1, r2) ->+ loop (skipped1 + length start1, skipped2 + length start2) (r1, r2)+ Nothing -> emptyColorString++singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString+singleLineDiff' dc s1 s2+ | s1 == s2 = Nothing | otherwise = let groups = D.getGroupedDiff s1 s2- in foldr (\(group, pos) string ->+ in Just $+ foldr (\(group, pos) string -> (showDiffGroup pos group) +++ (if not (isLast pos) then dc_sep dc else emptyColorString) +++ string)@@ -124,12 +166,20 @@ 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] ""+ (do (ecode, out, _err) <- readProcessWithExitCode "diff" ["-u", leftFile, rightFile] "" case ecode of ExitSuccess -> return (format out) ExitFailure 1 -> return (format out)@@ -141,8 +191,8 @@ 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 =@@ -166,12 +216,12 @@ fromSecond s = dc_fromSecond cfg s diff :: DiffConfig -> String -> String -> IO ColorString-diff cfg left right =+diff cfg left right = do case (lines left, lines right) of ([], []) -> return emptyColorString- ([], [_]) -> return $ singleLineDiff cfg left right- ([_], []) -> return $ singleLineDiff cfg left right- ([_], [_]) -> return $ singleLineDiff cfg left right+ ([], [_]) -> return (singleLineDiff cfg left right)+ ([_], []) -> return (singleLineDiff cfg left right)+ ([_], [_]) -> return (singleLineDiff cfg left right) _ -> multiLineDiff cfg left right diffWithSensibleConfig :: String -> String -> IO ColorString@@ -183,7 +233,13 @@ -} multiLineDiffHaskell :: String -> String -> ColorString multiLineDiffHaskell left right =- noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) -- this code is now part of the Diff library (hence the >0.3 in Cabal)+ 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+ maxLen = 10000 main = do args <- getArgs
Test/Framework/HUnitWrapper.hs view
@@ -1,581 +1,932 @@-{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}------- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----{-|--This module provides assert-like functions for writing unit tests.--/Hint:/ Do not use the @assertXXX_@ functions-directly. Instead, for each function @assertXXX_@,-there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically. Use these macros, which-are available automatically if you add--@{-# OPTIONS_GHC -F -pgmF htfpp #-}@--at the top of your source file (see the 'Test.Framework.Tutorial').---}--module Test.Framework.HUnitWrapper (-- -- * Assertions on Bool values- assertBool_, assertBoolVerbose_,- gassertBool_, gassertBoolVerbose_,-- -- * Equality assertions- assertEqual_, assertEqualVerbose_,- gassertEqual_, gassertEqualVerbose_,- assertEqualPretty_, assertEqualPrettyVerbose_,- gassertEqualPretty_, gassertEqualPrettyVerbose_,- assertEqualNoShow_, assertEqualNoShowVerbose_,- gassertEqualNoShow_, gassertEqualNoShowVerbose_,- assertNotEqual_, assertNotEqualVerbose_,- gassertNotEqual_, gassertNotEqualVerbose_,- assertNotEqualPretty_, assertNotEqualPrettyVerbose_,- gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_,- assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,- gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_,-- -- * Assertions on lists- assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,- gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_,- assertNotEmpty_, assertNotEmptyVerbose_,- gassertNotEmpty_, gassertNotEmptyVerbose_,- assertEmpty_, assertEmptyVerbose_,- gassertEmpty_, gassertEmptyVerbose_,- assertElem_, assertElemVerbose_,- gassertElem_, gassertElemVerbose_,-- -- * Assertions for exceptions- assertThrows_, assertThrowsVerbose_,- assertThrowsSome_, assertThrowsSomeVerbose_,- assertThrowsIO_, assertThrowsIOVerbose_,- assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,- assertThrowsM_, assertThrowsMVerbose_,- assertThrowsSomeM_, assertThrowsSomeMVerbose_,-- -- * Assertions on Either values- assertLeft_, assertLeftVerbose_,- gassertLeft_, gassertLeftVerbose_,- assertLeftNoShow_, assertLeftNoShowVerbose_,- gassertLeftNoShow_, gassertLeftNoShowVerbose_,- assertRight_, assertRightVerbose_,- gassertRight_, gassertRightVerbose_,- assertRightNoShow_, assertRightNoShowVerbose_,- gassertRightNoShow_, gassertRightNoShowVerbose_,-- -- * Assertions on Just values- assertJust_, assertJustVerbose_,- gassertJust_, gassertJustVerbose_,- assertNothing_, assertNothingVerbose_,- gassertNothing_, gassertNothingVerbose_,- assertNothingNoShow_, assertNothingNoShowVerbose_,- gassertNothingNoShow_, gassertNothingNoShowVerbose_,-- -- * General failure- assertFailure_,- gassertFailure_,-- -- * Pending unit tests- unitTestPending, unitTestPending',-- -- * Sub assertions- subAssert_, subAssertVerbose_,- gsubAssert_, gsubAssertVerbose_,-- -- * HUnit re-exports- HU.HUnitFailure--) where--import Control.Exception-import qualified Control.Exception.Lifted as ExL-import Control.Monad.Trans.Control-import Control.Monad.Trans-import qualified Language.Haskell.Exts.Pretty as HE-import qualified Language.Haskell.Exts.Parser as HE-import qualified Test.HUnit.Lang as HU--import Data.List ( (\\) )-import System.IO.Unsafe (unsafePerformIO)--import Test.Framework.TestManagerInternal-import Test.Framework.Location-import Test.Framework.Diff-import Test.Framework.Colors-import Test.Framework.Pretty-import Test.Framework.AssertM---- WARNING: do not forget to add a preprocessor macro for new assertions!!--{- |-Fail with the given reason, supplying the error location and the error message.--}-gassertFailure_ :: AssertM m => Location -> String -> m a-gassertFailure_ loc s =- genericAssertFailure__ loc (mkMsg "assertFailure" ""- ("failed at " ++ showLoc loc ++ ": " ++ s))---- | Specialization of 'gassertFailure'.-assertFailure_ :: Location -> String -> IO a-assertFailure_ = gassertFailure_--{- |-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------- Dirty macro hackery (I'm too lazy ...)----#define CreateAssertionsGenericNoGVariant(__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 CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \-g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \-g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \-g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \-CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__)--#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ())-#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ())--#define CreateAssertions(__name__, __type__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ())-#define CreateAssertionsNoGVariant(__name__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ())--#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__)-#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__)--#define CreateAssertionsRet(__name__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__)-#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __ret__)--#define DocAssertion(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variants can be used to provide extra information about the error. The \- variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \- they run in the IO monad and can be evaluated to a 'Bool' value. \- Do not use the \- @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \- functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \- @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}-#define DocAssertionNoGVariant(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variant can be used to provide extra information about the error. \- Do not use the \- @__name__##_@ and @__name__##Verbose_@ \- functions directly, use the macros @__name__@ and @__name__##Verbose@ \- instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}------ Boolean Assertions-----_assertBool_ :: AssertM m => String -> Location -> String -> Bool -> m ()-_assertBool_ name loc s False =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertBool_ _ _ _ True = return ()--DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)-CreateAssertions(assertBool, Bool)------- Equality Assertions-----equalityFailedMessage :: String -> String -> ColorString-equalityFailedMessage exp act =- let !diff = unsafePerformIO (diffWithSensibleConfig expP actP)- expected_ = colorize firstDiffColor "* expected:"- but_got_ = colorize secondDiffColor "* but got:"- diff_ = colorize diffColor "* diff:"- in ("\n" +++ expected_ +++ " " +++ noColor (withNewline expP) +++- "\n" +++ but_got_ +++ " " +++ noColor (withNewline actP) +++- "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff +++- (if stringEq- 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)- (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 -> String-notEqualityFailedMessage exp =- (": 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, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqual_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage (show expected) (show actual)- genericAssertFailure__ loc (mkColorMsg name s $- noColor ("failed at " ++ showLoc loc) +++ x)- else return ()--DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertNotEqual_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqual_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage (show expected)- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()--DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualPretty_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage (showPretty expected) (showPretty actual)- genericAssertFailure__ loc (mkColorMsg name s- (noColor ("failed at " ++ showLoc loc) +++ x))- else return ()--DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualPretty_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage (showPretty expected)- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()-DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualNoShow_ name loc s expected actual =- if expected /= actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)--_assertNotEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualNoShow_ name loc s expected actual =- if expected == actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertNotEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)------- Assertions on Lists-----_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> [a] -> [a] -> m ()-_assertListsEqualAsSets_ name loc s expected actual =- let ne = length expected- na = length actual- in case () of- _| ne /= na ->- do let x = equalityFailedMessage (show expected) (show actual)- genericAssertFailure__ loc (mkColorMsg name s- (noColor- ("failed at " ++ showLoc loc- ++ "\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 (show expected) (show actual)- genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s- (noColor ("failed at " ++ showLoc loc) +++ x))- | otherwise -> return ()- where unorderedEq l1 l2 =- null (l1 \\ l2) && null (l2 \\ l1)-DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal- when considered as sets. The first list parameter- denotes the expected value.)-CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), (Eq a, Show a, AssertM m), [a] -> [a])--_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertNotEmpty_ name loc s [] =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertNotEmpty_ _ _ _ (_:_) = return ()-DocAssertion(assertNotEmpty, Fail if the given list is empty.)-CreateAssertions(assertNotEmpty, [a])--_assertEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertEmpty_ name loc s (_:_) =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertEmpty_ _ _ _ [] = return ()-DocAssertion(assertEmpty, Fail if the given list is a non-empty list.)-CreateAssertions(assertEmpty, [a])--_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m ()-_assertElem_ name loc s x l =- if x `elem` l- then return ()- else genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- "\n element: " ++ show x ++- "\n list: " ++ show l))-DocAssertion(assertElem, Fail if the given element is not in the list.)-CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a])------- Assertions for Exceptions-----_assertThrowsIO_ :: Exception e- => String -> Location -> String -> IO a -> (e -> Bool) -> IO ()-_assertThrowsIO_ name loc s x f =- _assertThrowsM_ name loc s x f-DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool))--_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO ()-_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a)--_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e)- => String -> Location -> String -> m a -> (e -> Bool) -> m ()-_assertThrowsM_ name loc s x f =- do res <- ExL.try x- case res of- Right _ -> liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": no exception was thrown"))- Left e -> if f e then return ()- else liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++- showLoc loc ++- ": wrong exception was thrown: " ++- show e))-DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,- m a -> (e -> Bool), m ())--_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m)- => String -> Location -> String -> m a -> m ()-_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not- throw an exception.)-CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ())--_assertThrows_ :: Exception e- => String -> Location -> String -> a -> (e -> Bool) -> IO ()-_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f-DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool))--_assertThrowsSome_ :: String -> Location -> String -> a -> IO ()-_assertThrowsSome_ name loc s x =- _assertThrows_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSome, a)------- Assertions on Either-----_assertLeft_ :: forall a b m . (AssertM m, Show b)- => String -> Location -> String -> Either a b -> m a-_assertLeft_ _ _ _ (Left x) = return x-_assertLeft_ name loc s (Right x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given " ++- show (Right x :: Either b b)))-DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.- Use this function if @b@ is an instance of 'Show')-CreateAssertionsCtxRet(assertLeft, Show b, (Show b, AssertM m), Either a b, a)--_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a-_assertLeftNoShow_ _ _ _ (Left x) = return x-_assertLeftNoShow_ name loc s (Right _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given a Right value"))-DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.)-CreateAssertionsRet(assertLeftNoShow, Either a b, a)--_assertRight_ :: forall a b m . (Show a, AssertM m)- => String -> Location -> String -> Either a b -> m b-_assertRight_ _ _ _ (Right x) = return x-_assertRight_ name loc s (Left x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given " ++- show (Left x :: Either a a)))-DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.- Use this function if @a@ is an instance of 'Show')-CreateAssertionsCtxRet(assertRight, Show a, (Show a, AssertM m), Either a b, b)--_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b-_assertRightNoShow_ _ _ _ (Right x) = return x-_assertRightNoShow_ name loc s (Left _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given a Left value"))-DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.)-CreateAssertionsRet(assertRightNoShow, Either a b, b)------- Assertions on Maybe-----_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a-_assertJust_ _ _ _ (Just x) = return x-_assertJust_ name loc s Nothing =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Just value, given Nothing"))-DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.)-CreateAssertionsRet(assertJust, Maybe a, a)--_assertNothing_ :: (Show a, AssertM m)- => String -> Location -> String -> Maybe a -> m ()-_assertNothing_ _ _ _ Nothing = return ()-_assertNothing_ name loc s jx =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given " ++ show jx))-DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.- Use this function if @a@ is an instance of 'Show'.)-CreateAssertionsCtx(assertNothing, Show a, (Show a, AssertM m), Maybe a)--_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m ()-_assertNothingNoShow_ _ _ _ Nothing = return ()-_assertNothingNoShow_ name loc s _ =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given a Just value"))-DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.)-CreateAssertions(assertNothingNoShow, Maybe a)------- Sub assertions------- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location--- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write------ > assertIsPositive :: Int -> Assertion--- > assertIsPositive n = assertBool (n > 0)------ You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly--- you will lose location information: if @assertIsPositive i@ fails you will only get the location where--- @assertIsPositive@ is defined but not from where it has been called.------ To recover the location information you simply use @subAssert (assertIsPositive i)@.--- In this case, if @i@ is not positive, you will get the location of the caller.------ /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@.-subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a-subAssert_ loc ass = unitTestSubAssert loc Nothing ass---- | Generic variant of 'subAssert_'.-gsubAssert_ :: AssertM m => Location -> m a -> m a-gsubAssert_ loc ass = genericSubAssert loc Nothing ass---- | Same as 'subAssert_' but with an additional error message.-subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a-subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass---- | Generic variant of 'subAssertVerbose_'.-gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a-gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{-|++This module provides assert-like functions for writing unit tests.++-}++module Test.Framework.HUnitWrapper (++ -- * Assertions on Bool values+ assertBool, assertBoolVerbose,++ -- * Equality assertions+ assertEqual, assertEqualVerbose,+ assertEqualPretty, assertEqualPrettyVerbose,+ assertEqualNoShow, assertEqualNoShowVerbose,++ -- * Inequality assertions+ assertNotEqual, assertNotEqualVerbose,+ assertNotEqualPretty, assertNotEqualPrettyVerbose,+ assertNotEqualNoShow, assertNotEqualNoShowVerbose,++ -- * Assertions on lists+ assertListsEqualAsSets, assertListsEqualAsSetsVerbose,+ assertNotEmpty, assertNotEmptyVerbose,+ assertEmpty, assertEmptyVerbose,+ assertElem, assertElemVerbose,++ -- * Assertions for exceptions+ assertThrows, assertThrowsVerbose,+ assertThrowsSome, assertThrowsSomeVerbose,+ assertThrowsIO, assertThrowsIOVerbose,+ assertThrowsSomeIO, assertThrowsSomeIOVerbose,+ assertThrowsM, assertThrowsMVerbose,+ assertThrowsSomeM, assertThrowsSomeMVerbose,++ -- * Assertions on Either values+ assertLeft, assertLeftVerbose,+ assertLeftNoShow, assertLeftNoShowVerbose,+ assertRight, assertRightVerbose,+ assertRightNoShow, assertRightNoShowVerbose,++ -- * Assertions on Just values+ assertJust, assertJustVerbose,+ assertNothing, assertNothingVerbose,+ assertNothingNoShow, assertNothingNoShowVerbose,++ -- * General failure+ assertFailure,++ -- * Pending unit tests+ unitTestPending, unitTestPending',++ -- * Sub assertions+ subAssert, subAssertVerbose,++ -- * Generalized assertions and failures in AssertM+ {- |+ The following definitions generalize the the monad in which assertions are executed.+ Usually, assertions are executed in the @IO@ monad. The @AssertM@ monad+ (see "Test.Framework.AssertM") allows you to evaluate assertions also as pure functions.+ -}+ -- ** Assertions on Bool values+ gassertBool, gassertBoolVerbose,++ -- ** Equality assertions+ gassertEqual, gassertEqualVerbose,+ gassertEqualPretty, gassertEqualPrettyVerbose,+ gassertEqualNoShow, gassertEqualNoShowVerbose,++ -- ** Inequality assertions+ gassertNotEqual, gassertNotEqualVerbose,+ gassertNotEqualPretty, gassertNotEqualPrettyVerbose,+ gassertNotEqualNoShow, gassertNotEqualNoShowVerbose,++ -- ** Assertions on lists+ gassertListsEqualAsSets, gassertListsEqualAsSetsVerbose,+ gassertNotEmpty, gassertNotEmptyVerbose,+ gassertEmpty, gassertEmptyVerbose,+ gassertElem, gassertElemVerbose,++ -- ** Assertions on Either values+ gassertLeft, gassertLeftVerbose,+ gassertLeftNoShow, gassertLeftNoShowVerbose,+ gassertRight, gassertRightVerbose,+ gassertRightNoShow, gassertRightNoShowVerbose,++ -- ** Assertions on Just values+ gassertJust, gassertJustVerbose,+ gassertNothing, gassertNothingVerbose,+ gassertNothingNoShow, gassertNothingNoShowVerbose,++ -- ** General failure+ gassertFailure,++ -- ** Sub assertions+ gsubAssert, gsubAssertVerbose,++ -- * HUnit re-exports+ HU.HUnitFailure,++ -- * Tests (for internal use)+ hunitWrapperTests++) where++import Control.Exception+import qualified Control.Exception.Lifted as ExL+import Control.Monad.Trans.Control+import Control.Monad.Trans+import qualified Test.HUnit.Lang as HU+#if !MIN_VERSION_HUnit(1,4,0)+import qualified Test.HUnit.Base as HU+#endif++import GHC.Stack++import Data.List ( (\\) )+import System.IO.Unsafe (unsafePerformIO)++import Test.Framework.TestInterface+import Test.Framework.Location+import Test.Framework.Diff+import Test.Framework.Colors+import Test.Framework.Pretty+import Test.Framework.AssertM+import Test.Framework.PrettyHaskell+import Test.Framework.Utils++import qualified Data.Text as T+import qualified Data.List as List++-- WARNING: do not forget to add a preprocessor macro for new assertions!!++{- |+Fail with the given reason in some 'AssertM' monad.+-}+gassertFailure :: (HasCallStack, AssertM m) => String -> m a+gassertFailure s =+ genericAssertFailure (mkMsg "assertFailure" "" s)++-- | Specialization of 'gassertFailure' to @IO@.+assertFailure :: HasCallStack => String -> IO a+assertFailure = gassertFailure++{- |+Signals that the current unit test is pending.+-}+unitTestPending :: String -> IO a+unitTestPending s =+ failHTF (FullTestResult emptyHtfStack (Just $ noColor s) (Just Pending))++{- |+Use @unitTestPending' msg test@ to mark the given test as pending+without removing it from the test suite and without deleting or commenting out the test code.+-}+unitTestPending' :: String -> IO a -> IO a+unitTestPending' msg _ = unitTestPending msg++mkMsg :: String -> String -> String -> ColorString+mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)++mkColorMsg :: String -> String -> ColorString -> ColorString+mkColorMsg fun extraInfo s =+ let pref = if null extraInfo+ then fun ++ " "+ else fun ++ " (" ++ extraInfo ++ ") "+ in noColor pref +++ s++--+-- Boolean Assertions+--++assertBool_ :: (HasCallStack, AssertM m) => String -> String -> Bool -> m ()+assertBool_ name s False = genericAssertFailure (mkMsg name s "failed")+assertBool_ _ _ True = return ()++-- | Fail if the 'Bool' value is 'False'.+assertBool :: HasCallStack => Bool -> IO ()+assertBool = assertBool_ "assertBool" ""++assertBoolVerbose :: HasCallStack => String -> Bool -> IO ()+assertBoolVerbose = assertBool_ "assertBoolVerbose"++gassertBool :: (HasCallStack, AssertM m) => Bool -> m ()+gassertBool = assertBool_ "gassertBool" ""++gassertBoolVerbose :: (HasCallStack, AssertM m) => String -> Bool -> m ()+gassertBoolVerbose = assertBool_ "gassertBoolVerbose"++--+-- Equality Assertions+--++equalityFailedMessage' :: String -> String -> ColorString+equalityFailedMessage' exp act =+ let !diff = unsafePerformIO (diffWithSensibleConfig exp act)+ expected_ = colorize firstDiffColor "* expected:"+ but_got_ = colorize secondDiffColor "* but got:"+ diff_ = colorize diffColor "* diff:"+ in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) ++++ "\n" +++ but_got_ +++ " " +++ noColor (withNewline (trim act)) ++++ "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff ++++ (if (exp == act)+ then "\nWARNING: strings are equal but actual values differ!"+ else ""))+ where+ withNewline s =+ case lines s of+ [] -> s+ [_] -> s+ _ -> '\n':s+ newlineBeforeDiff d =+ let f b = case colorStringFind (\c -> c == '\n') d b of+ Just _ -> "\n"+ Nothing -> ""+ in noColor' (f True) (f False)+ trim s =+ case List.splitAt maxLen s of+ (_, []) -> s+ (prefix, rest) ->+ prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)"+ maxLen = 10000++asString :: Show a => a -> Maybe String+asString x = readM (show x)++equalityFailedMessage :: (Show a) => a -> a -> ColorString+equalityFailedMessage exp act =+ equalityFailedMessage' expP actP+ where+ (expP, actP) =+ case (asString exp, asString act) of+ (Just expS, Just actS)+ | expS /= actS -> (expS, actS)+ _ ->+ case (prettyHaskell' exp, prettyHaskell' act) of+ (Nothing, _) -> (show exp, show act)+ (_, Nothing) -> (show exp, show act)+ (Just expP, Just actP)+ | expP == actP ->+ (show exp, show act)+ | otherwise -> (expP, actP)++notEqualityFailedMessage :: Show a => a -> String+notEqualityFailedMessage exp =+ notEqualityFailedMessage' (prettyHaskell exp)++notEqualityFailedMessage' :: String -> String+notEqualityFailedMessage' exp =+ (": Objects are equal\n" ++ exp)++failedAt :: HasCallStack => String+failedAt =+ case failureLocation of+ Nothing -> "failed"+ Just loc -> "failed at " ++ showLoc loc++assertEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqual_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s $+ noColor failedAt +++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualVerbose = assertEqual_ "gassertEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqual = assertEqual_ "gassertEqual" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertEqualVerbose = assertEqual_ "assertEqualVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertEqual = assertEqual_ "assertEqual" ""++assertNotEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqual_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage expected+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualVerbose = assertNotEqual_ "gassertNotEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqual = assertNotEqual_ "gassertNotEqual" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualVerbose = assertNotEqual_ "assertNotEqualVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertNotEqual = assertNotEqual_ "assertNotEqual" ""++assertEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualPretty_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)+ genericAssertFailure (mkColorMsg name s+ (noColor failedAt +++ x))+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualPrettyVerbose = assertEqualPretty_ "gassertEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualPretty = assertEqualPretty_ "gassertEqualPretty" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertEqualPrettyVerbose = assertEqualPretty_ "assertEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertEqualPretty = assertEqualPretty_ "assertEqualPretty" ""++assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualPretty_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage' (showPretty expected)+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualPrettyVerbose = assertNotEqualPretty_ "gassertNotEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualPretty = assertNotEqualPretty_ "gassertNotEqualPretty" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualPrettyVerbose = assertNotEqualPretty_ "assertNotEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertNotEqualPretty = assertNotEqualPretty_ "assertNotEqualPretty" ""++assertEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualNoShow_ name s expected actual =+ if expected /= actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualNoShowVerbose = assertEqualNoShow_ "gassertEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualNoShow = assertEqualNoShow_ "gassertEqualNoShow" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertEqualNoShowVerbose = assertEqualNoShow_ "assertEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertEqualNoShow = assertEqualNoShow_ "assertEqualNoShow" ""++assertNotEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualNoShow_ name s expected actual =+ if expected == actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualNoShowVerbose = assertNotEqualNoShow_ "gassertNotEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualNoShow = assertNotEqualNoShow_ "gassertNotEqualNoShow" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualNoShowVerbose = assertNotEqualNoShow_ "assertNotEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertNotEqualNoShow = assertNotEqualNoShow_ "assertNotEqualNoShow" ""++--+-- Assertions on Lists+--++assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> [a] -> [a] -> m ()+assertListsEqualAsSets_ name s expected actual =+ let ne = length expected+ na = length actual+ in case () of+ _| ne /= na ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s+ (noColor+ (failedAt+ ++ "\n expected length: " ++ show ne+ ++ "\n actual length: " ++ show na) ++++ (if maxLength x < 5000+ then x else emptyColorString)))+ | not (unorderedEq expected actual) ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg "assertSetEqual" s+ (noColor failedAt +++ x))+ | otherwise -> return ()+ where unorderedEq l1 l2 =+ null (l1 \\ l2) && null (l2 \\ l1)++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+gassertListsEqualAsSetsVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> [a] -> [a] -> m ()+gassertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "gassertListsEqualAsSetsVerbose"++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets.+gassertListsEqualAsSets :: (Eq a, Show a, AssertM m, HasCallStack) => [a] -> [a] -> m ()+gassertListsEqualAsSets= assertListsEqualAsSets_ "gassertListsEqualAsSets" ""++-- | Fail if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+assertListsEqualAsSetsVerbose :: (Eq a, Show a, HasCallStack) => String -> [a] -> [a] -> IO ()+assertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "assertListsEqualAsSetsVerbose"++-- | Fail if the two given lists are not equal when considered as sets.+assertListsEqualAsSets :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> IO ()+assertListsEqualAsSets = assertListsEqualAsSets_ "assertListsEqualAsSets" ""++assertNotEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertNotEmpty_ name s [] =+ genericAssertFailure (mkMsg name s failedAt)+assertNotEmpty_ _ _ (_:_) = return ()++-- | Fail in some 'AssertM' monad if the given list is empty, supplying an+-- additional error message.+gassertNotEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertNotEmptyVerbose = assertNotEmpty_ "gassertNotEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is empty.+gassertNotEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertNotEmpty = assertNotEmpty_ "gassertNotEmpty" ""++-- | Fail if the given list is empty, supplying an+-- additional error message.+assertNotEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertNotEmptyVerbose = assertNotEmpty_ "assertNotEmptyVerbose"++-- | Fail if the given list is empty.+assertNotEmpty :: HasCallStack => [a] -> IO ()+assertNotEmpty = assertNotEmpty_ "assertNotEmpty" ""++assertEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertEmpty_ name s (_:_) =+ genericAssertFailure (mkMsg name s failedAt)+assertEmpty_ _ _ [] = return ()++-- | Fail in some 'AssertM' monad if the given list is not empty, supplying an+-- additional error message.+gassertEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertEmptyVerbose = assertEmpty_ "gassertEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is not empty.+gassertEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertEmpty = assertEmpty_ "gassertEmpty" ""++-- | Fail if the given list is not empty, supplying an+-- additional error message.+assertEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertEmptyVerbose = assertEmpty_ "assertEmptyVerbose"++-- | Fail if the given list is not empty.+assertEmpty :: HasCallStack => [a] -> IO ()+assertEmpty = assertEmpty_ "assertEmpty" ""++assertElem_ :: (Eq a, Show a, AssertM m, HasCallStack) => String -> String -> a -> [a] -> m ()+assertElem_ name s x l =+ if x `elem` l+ then return ()+ else genericAssertFailure (mkMsg name s+ (failedAt +++ "\n element: " ++ show x +++ "\n list: " ++ show l))++-- | Fail in some 'AssertM' monad if the element given is not contained in the list, supplying+-- an additional error message.+gassertElemVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> [a] -> m ()+gassertElemVerbose = assertElem_ "gassertElemVerbose"++-- | Fail in some 'AssertM' monad if the element given is not contained in the list.+gassertElem :: (Eq a, Show a, AssertM m, HasCallStack) => a -> [a] -> m ()+gassertElem = assertElem_ "gassertElem" ""++-- | Fail if the element given is not contained in the list, supplying+-- an additional error message.+assertElemVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> [a] -> IO ()+assertElemVerbose = assertElem_ "assertElemVerbose"++-- | Fail if the element given is not contained in the list.+assertElem :: (Eq a, Show a, HasCallStack) => a -> [a] -> IO ()+assertElem = assertElem_ "assertElem" ""++--+-- Assertions for Exceptions+--++assertThrowsIO_ :: (HasCallStack, Exception e)+ => String -> String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIO_ name s x f =+ assertThrowsM_ name s x f++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsIOVerbose :: (HasCallStack, Exception e) => String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIOVerbose = assertThrowsIO_ "assertThrowsIOVerbose"++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsIO :: (HasCallStack, Exception e) => IO a -> (e -> Bool) -> IO ()+assertThrowsIO = assertThrowsIO_ "assertThrowsIO" ""++assertThrowsSomeIO_ :: HasCallStack => String -> String -> IO a -> IO ()+assertThrowsSomeIO_ name s x = assertThrowsIO_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the 'IO' action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeIOVerbose :: HasCallStack => String -> IO a -> IO ()+assertThrowsSomeIOVerbose = assertThrowsSomeIO_ "assertThrowsSomeIOVerbose"++-- | Fail if executing the 'IO' action does not throw any exception.+assertThrowsSomeIO :: HasCallStack => IO a -> IO ()+assertThrowsSomeIO = assertThrowsSomeIO_ "assertThrowsSomeIO" ""++assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> String -> m a -> (e -> Bool) -> m ()+assertThrowsM_ name s x f =+ do res <- ExL.try x+ case res of+ Right _ -> liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": no exception was thrown"))+ Left e -> if f e then return ()+ else liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": wrong exception was thrown: " +++ show e))+-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsMVerbose ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> m a -> (e -> Bool) -> m ()+assertThrowsMVerbose = assertThrowsM_ "assertThrowsMVerbose"++-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsM ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => m a -> (e -> Bool) -> m ()+assertThrowsM = assertThrowsM_ "assertThrowsM" ""++assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> String -> m a -> m ()+assertThrowsSomeM_ name s x = assertThrowsM_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the @m@ action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeMVerbose ::+ (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> m a -> m ()+assertThrowsSomeMVerbose = assertThrowsSomeM_ "assertThrowsSomeMVerbose"++-- | Fail if executing the @m@ action does not throw any exception.+assertThrowsSomeM :: (MonadBaseControl IO m, MonadIO m, HasCallStack) => m a -> m ()+assertThrowsSomeM = assertThrowsSomeM_ "assertThrowsSomeM" ""++assertThrows_ :: (HasCallStack, Exception e)+ => String -> String -> a -> (e -> Bool) -> IO ()+assertThrows_ name s x f = assertThrowsIO_ name s (evaluate x) f++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@,+-- supplying an additional error message.+assertThrowsVerbose :: (HasCallStack, Exception e) => String -> a -> (e -> Bool) -> IO ()+assertThrowsVerbose = assertThrows_ "assertThrowsVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@.+assertThrows :: (HasCallStack, Exception e) => a -> (e -> Bool) -> IO ()+assertThrows = assertThrows_ "assertThrows" ""++assertThrowsSome_ :: HasCallStack => String -> String -> a -> IO ()+assertThrowsSome_ name s x =+ assertThrows_ name s x (\ (_e::SomeException) -> True)++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception, supplying an additional error message.+assertThrowsSomeVerbose :: HasCallStack => String -> a -> IO ()+assertThrowsSomeVerbose = assertThrowsSome_ "assertThrowsSomeVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception.+assertThrowsSome :: HasCallStack => a -> IO ()+assertThrowsSome = assertThrowsSome_ "assertThrowsSome" ""++--+-- Assertions on Either+--++assertLeft_ :: forall a b m . (AssertM m, Show b, HasCallStack)+ => String -> String -> Either a b -> m a+assertLeft_ _ _ (Left x) = return x+assertLeft_ name s (Right x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given " +++ show (Right x :: Either b b)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeftVerbose :: (Show b, AssertM m, HasCallStack) => String -> Either a b -> m a+gassertLeftVerbose = assertLeft_ "gassertLeftVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeft :: (Show b, AssertM m, HasCallStack) => Either a b -> m a+gassertLeft = assertLeft_ "gassertLeft" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+assertLeftVerbose :: (Show b, HasCallStack) => String -> Either a b -> IO a+assertLeftVerbose = assertLeft_ "assertLeftVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+assertLeft :: (HasCallStack, Show b) => Either a b -> IO a+assertLeft = assertLeft_ "assertLeft" ""++assertLeftNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m a+assertLeftNoShow_ _ _ (Left x) = return x+assertLeftNoShow_ name s (Right _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given a Right value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m a+gassertLeftNoShowVerbose = assertLeftNoShow_ "gassertLeftNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShow :: (HasCallStack, AssertM m) => Either a b -> m a+gassertLeftNoShow = assertLeftNoShow_ "gassertLeftNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShowVerbose :: HasCallStack => String -> Either a b -> IO a+assertLeftNoShowVerbose = assertLeftNoShow_ "assertLeftNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShow :: HasCallStack => Either a b -> IO a+assertLeftNoShow = assertLeftNoShow_ "assertLeftNoShow" ""++assertRight_ :: forall a b m . (AssertM m, Show a, HasCallStack)+ => String -> String -> Either a b -> m b+assertRight_ _ _ (Right x) = return x+assertRight_ name s (Left x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given " +++ show (Left x :: Either a a)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertRightVerbose :: (Show a, AssertM m, HasCallStack) => String -> Either a b -> m b+gassertRightVerbose = assertRight_ "gassertRightVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+gassertRight :: (Show a, AssertM m, HasCallStack) => Either a b -> m b+gassertRight = assertRight_ "gassertRight" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+assertRightVerbose :: (Show a, HasCallStack) => String -> Either a b -> IO b+assertRightVerbose = assertRight_ "assertRightVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+assertRight :: (HasCallStack, Show a) => Either a b -> IO b+assertRight = assertRight_ "assertRight" ""++assertRightNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m b+assertRightNoShow_ _ _ (Right x) = return x+assertRightNoShow_ name s (Left _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given a Left value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m b+gassertRightNoShowVerbose = assertRightNoShow_ "gassertRightNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShow :: (HasCallStack, AssertM m) => Either a b -> m b+gassertRightNoShow = assertRightNoShow_ "gassertRightNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShowVerbose :: HasCallStack => String -> Either a b -> IO b+assertRightNoShowVerbose = assertRightNoShow_ "assertRightNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShow :: HasCallStack => Either a b -> IO b+assertRightNoShow = assertRightNoShow_ "assertRightNoShow" ""++--+-- Assertions on Maybe+--++assertJust_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m a+assertJust_ _ _ (Just x) = return x+assertJust_ name s Nothing =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Just value, given Nothing"))++-- | Fail in some 'AssertM' monad if the given value is a Nothing, supplying an additional+-- error message.+gassertJustVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m a+gassertJustVerbose = assertJust_ "gassertJustVerbose"++-- | Fail in some 'AssertM' monad if the given value is a Nothing.+gassertJust :: (HasCallStack, AssertM m) => Maybe a -> m a+gassertJust = assertJust_ "gassertJust" ""++-- | Fail if the given value is a Nothing, supplying an additional+-- error message.+assertJustVerbose :: HasCallStack => String -> Maybe a -> IO a+assertJustVerbose = assertJust_ "assertJustVerbose"++-- | Fail if the given value is a Nothing.+assertJust :: HasCallStack => Maybe a -> IO a+assertJust = assertJust_ "assertJust" ""++assertNothing_ :: (Show a, AssertM m, HasCallStack)+ => String -> String -> Maybe a -> m ()+assertNothing_ _ _ Nothing = return ()+assertNothing_ name s jx =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given " ++ show jx))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothingVerbose :: (Show a, AssertM m, HasCallStack) => String -> Maybe a -> m ()+gassertNothingVerbose = assertNothing_ "gassertNothingVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothing :: (Show a, AssertM m, HasCallStack) => Maybe a -> m ()+gassertNothing = assertNothing_ "gassertNothing" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+assertNothingVerbose :: (Show a, HasCallStack) => String -> Maybe a -> IO ()+assertNothingVerbose = assertNothing_ "assertNothingVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+assertNothing :: (HasCallStack, Show a) => Maybe a -> IO ()+assertNothing = assertNothing_ "assertNothing" ""++assertNothingNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m ()+assertNothingNoShow_ _ _ Nothing = return ()+assertNothingNoShow_ name s _ =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given a Just value"))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShowVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m ()+gassertNothingNoShowVerbose = assertNothingNoShow_ "gassertNothingNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShow :: (HasCallStack, AssertM m) => Maybe a -> m ()+gassertNothingNoShow = assertNothingNoShow_ "gassertNothingNoShow" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShowVerbose :: HasCallStack => String -> Maybe a -> IO ()+assertNothingNoShowVerbose = assertNothingNoShow_ "assertNothingNoShowVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShow :: HasCallStack => Maybe a -> IO ()+assertNothingNoShow = assertNothingNoShow_ "assertNothingNoShow" ""++--+-- Sub assertions+--++-- | Use 'subAssert' if you want location information for the call site but the function+-- being called does not carry a 'HasCallStack' constraint.+subAssert :: (HasCallStack, MonadBaseControl IO m) => m a -> m a+subAssert = subAssertHTF Nothing++gsubAssert :: (HasCallStack, AssertM m) => m a -> m a+gsubAssert = genericSubAssert Nothing++subAssertVerbose :: (HasCallStack, MonadBaseControl IO m) => String -> m a -> m a+subAssertVerbose msg = subAssertHTF (Just msg)++gsubAssertVerbose :: (HasCallStack, AssertM m) => String -> m a -> m a+gsubAssertVerbose msg = genericSubAssert (Just msg)++testEqualityFailedMessage1 :: IO ()+testEqualityFailedMessage1 =+ let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3,4]) False+ in HU.assertEqual "error" msg exp+ where+ exp = "\n* expected: [1, 2, 3]\n* but got: [1, 2, 3, 4]\n* " +++ "diff: \nC <...[1, 2, 3...>C \nS , 4\nC ]<......>C "++testEqualityFailedMessage2 :: IO ()+testEqualityFailedMessage2 =+ let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3]) False+ in HU.assertEqual "error" msg exp+ where+ exp = "\n* expected: [1,2,3]\n* but got: [1,2,3]\n* " +++ "diff: \nWARNING: strings are equal but actual values differ!"++hunitWrapperTests =+ [("testEqualityFailedMessage1", testEqualityFailedMessage1)+ ,("testEqualityFailedMessage2", testEqualityFailedMessage2)]
− Test/Framework/HaskellParser.hs
@@ -1,191 +0,0 @@-{-# LANGUAGE ScopedTypeVariables,CPP #-}---- This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.HaskellParser where--import Data.Maybe-import Data.Char ( isSpace, isDigit )-import qualified Data.List as List-import Control.Exception ( evaluate, catch, SomeException )-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding ( catch )-#endif--import qualified Language.Haskell.Exts as Exts-import qualified Language.Haskell.Exts.Parser as Parser-import qualified Language.Haskell.Exts.Syntax as Syn-import qualified Language.Haskell.Exts.Extension as Ext-import qualified Language.Haskell.Exts.Fixity as Fix-import qualified Language.Haskell.Exts.SrcLoc as Src--import Test.Framework.Location-import Test.Framework.Utils--type Name = String--data Decl = Decl { decl_loc :: Location- , decl_name :: Name }- deriving (Show)--data Pragma = Pragma { pr_name :: String- , pr_args :: String- , pr_loc :: Location }- deriving (Show)--data ParseResult a = ParseOK a | ParseError Location String--data Module = Module { mod_name :: Name- , mod_imports :: [ImportDecl]- , mod_decls :: [Decl]- , mod_htfPragmas :: [Pragma] }- deriving (Show)--data ImportDecl = ImportDecl { imp_moduleName :: Name- , imp_qualified :: Bool- , imp_alias :: Maybe Name- , imp_loc :: Location }- deriving (Show)---- Returns for lines of the form '# <number> "<filename>"'--- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)--- the value 'Just <number> "<filename>"'-parseCppLineInfoOut :: String -> Maybe (String, String)-parseCppLineInfoOut line =- case line of- '#':' ':c:rest- | isDigit c ->- case List.span isDigit rest of- (restDigits, ' ' : '"' : rest) ->- case dropWhile (/= '"') (reverse rest) of- '"' : fileNameRev ->- let line = (c:restDigits)- file = "\"" ++ reverse fileNameRev ++ "\""- in Just (line, file)- _ -> Nothing- _ -> Nothing- _ -> Nothing--parse :: FilePath -> String -> IO (ParseResult Module)-parse originalFileName input =- do r <- (evaluate $ Exts.parseFileContentsWithComments parseMode fixedInput)- `catch` (\(e::SomeException) ->- return $ Parser.ParseFailed unknownLoc (show e))- case r of- Parser.ParseFailed loc err -> return (ParseError (transformLoc loc) err)- Parser.ParseOk (m, comments) -> return $ ParseOK (transformModule m comments)- where- -- fixedInput serves two purposes:- -- 1. add a trailing \n- -- 2. turn lines of the form '# <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'- -- 2. turn lines of the form '#line <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'- -- 3. comment out lines starting with #- fixedInput :: String- fixedInput = (unlines . map fixLine . lines) input- where- fixLine s =- case parseCppLineInfoOut s of- Just (line, file) -> "{-# LINE " ++ line ++ " " ++ file ++ " #-}"- Nothing ->- case dropWhile isSpace s of- '#':'l':'i':'n':'e':rest -> "{-# LINE " ++ rest ++ " #-}"- '#':_ -> "-- " ++ s- _ -> s- {- FIXME: fixities needed for all operators. Heuristic:- all operators are considered to be any sequence- of the symbols _:"'>!#$%&*+./<=>?@\^|-~ with at most length 8 -}- parseMode :: Parser.ParseMode- parseMode = Parser.ParseMode { Parser.parseFilename = originalFileName- , Parser.baseLanguage = Ext.Haskell2010- , Parser.ignoreLanguagePragmas = False- , Parser.ignoreLinePragmas = False- , Parser.extensions = (map Ext.EnableExtension- extensions)- , Parser.fixities = Nothing- }- extensions =- [ Ext.ForeignFunctionInterface- , Ext.UnliftedFFITypes- , Ext.GADTs- , Ext.ScopedTypeVariables- , Ext.UnboxedTuples- , Ext.TypeSynonymInstances- , Ext.StandaloneDeriving- , Ext.DeriveDataTypeable- , Ext.FlexibleContexts- , Ext.FlexibleInstances- , Ext.ConstrainedClassMethods- , Ext.MultiParamTypeClasses- , Ext.FunctionalDependencies- , Ext.MagicHash- , Ext.PolymorphicComponents- , Ext.ExistentialQuantification- , Ext.UnicodeSyntax- , Ext.PostfixOperators- , Ext.PatternGuards- , Ext.LiberalTypeSynonyms- , Ext.RankNTypes- , Ext.ImpredicativeTypes- , Ext.TypeOperators- , Ext.RecursiveDo- , Ext.ParallelListComp- , Ext.EmptyDataDecls- , Ext.KindSignatures- , Ext.GeneralizedNewtypeDeriving- , Ext.TypeFamilies- , Ext.NamedFieldPuns- , Ext.RecordWildCards- , Ext.PackageImports- , Ext.ViewPatterns- , Ext.TupleSections- , Ext.NondecreasingIndentation- , Ext.DoAndIfThenElse- ]- unknownLoc :: Syn.SrcLoc- unknownLoc = Syn.SrcLoc originalFileName 0 0- transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls)- comments =- Module moduleName (map transformImport imports)- (mapMaybe transformDecl decls)- (mapMaybe transformComment comments)- transformImport (Syn.ImportDecl loc (Syn.ModuleName s)- qualified _ _ alias _) =- let alias' = case alias of- Nothing -> Nothing- Just (Syn.ModuleName s) -> Just s- in ImportDecl s qualified alias' (transformLoc loc)- transformDecl (Syn.PatBind loc (Syn.PVar name) _ _ _) =- Just $ Decl (transformLoc loc) (transformName name)- transformDecl (Syn.FunBind (Syn.Match loc name _ _ _ _ : _)) =- Just $ Decl (transformLoc loc) (transformName name)- transformDecl _ = Nothing- transformSpan span = makeLoc (Src.srcSpanFilename span) (Src.srcSpanStartLine span)- transformLoc (Syn.SrcLoc f n _) = makeLoc f n- transformName :: Syn.Name -> String- transformName (Syn.Ident s) = s- transformName (Syn.Symbol s) = s- transformComment (Exts.Comment True span ('@':s)) =- case reverse s of- '@':r ->- let stripped = strip (reverse r)- in if "HTF_" `List.isPrefixOf` stripped- then let (name, args) = List.span (not . isSpace) stripped- argsStripped = dropWhile isSpace args- loc = transformSpan span- in Just $ Pragma name argsStripped loc- else Nothing- _ -> Nothing- transformComment _ = Nothing
+ Test/Framework/History.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--+{- |+Internal module for retaining a history of test runs.+-}+module Test.Framework.History (++ TestHistory, HistoricTestResult(..), emptyTestHistory, Milliseconds, TestResult(..)+ , serializeTestHistory, deserializeTestHistory+ , findHistoricTestResult, findHistoricSuccessfulTestResult+ , updateTestHistory, mkTestRunHistory+ , historyTests++) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.List as L+import qualified Data.Vector as V+import Data.Time.Clock+import Test.HUnit+import Data.Aeson hiding (Error)+import Data.Aeson.TH+import Test.Framework.TestInterface++-- | A type synonym for time in milliseconds.+type Milliseconds = Int++data TestHistory+ = TestHistory+ { th_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+ , th_index :: !(Map T.Text (HistoricTestResult))+ , th_successfulIndex :: !(Map T.Text (HistoricTestResult))+ }+ deriving (Eq)++instance Show (TestHistory) where+ showsPrec _ _ = showString "<TestHistory>"++emptyTestHistory :: TestHistory+emptyTestHistory =+ TestHistory V.empty Map.empty Map.empty++data TestRunHistory+ = TestRunHistory+ { trh_startTime :: !UTCTime+ , trh_tests :: !(V.Vector (HistoricTestResult))+ }+ deriving (Eq)++instance Show TestRunHistory where+ showsPrec d trh =+ showParen (d > 10) $+ showString "TestRunHistory <hidden time> " .+ showsPrec 11 (trh_tests trh)++data HistoricTestResult+ = HistoricTestResult+ { htr_testId :: !T.Text+ , htr_result :: !TestResult+ , htr_timedOut :: !Bool+ , htr_timeMs :: !Milliseconds+ }+ deriving (Show, Eq)++mkTestRunHistory :: UTCTime -> [HistoricTestResult] -> TestRunHistory+mkTestRunHistory time results = TestRunHistory {+ trh_startTime = time+ , trh_tests = V.fromList results+ }++isSuccess :: HistoricTestResult -> Bool+isSuccess r = htr_result r == Pass && not (htr_timedOut r)++updateTestHistory :: TestRunHistory -> TestHistory -> TestHistory+updateTestHistory runHistory history =+ let runs = runHistory : V.toList (th_runs history)+ in TestHistory (V.fromList runs) (createIndex runs (const True)) (createIndex runs isSuccess)++-- The [TestRunHistory] list is sorted reverse chronologically+createIndex :: [TestRunHistory] -> (HistoricTestResult -> Bool) -> Map T.Text (HistoricTestResult)+createIndex list pred =+ L.foldl' updateMap Map.empty flatRunHistory+ where+ updateMap m res =+ Map.insertWith (\_new old -> old) (htr_testId res) res m+ flatRunHistory =+ filter pred $ concatMap (\trh -> V.toList (trh_tests trh)) list++findHistoricTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricTestResult id hist = Map.lookup id (th_index hist)++findHistoricSuccessfulTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)+findHistoricSuccessfulTestResult id hist = Map.lookup id (th_successfulIndex hist)++data SerializableTestHistory+ = SerializableTestHistory+ { sth_version :: Int+ , sth_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted+ }++_CURRENT_VERSION_ :: Int+_CURRENT_VERSION_ = 0++instance ToJSON TestResult where+ toJSON r = String $+ case L.lookup r testResultStringMapping of+ Just s -> s+ Nothing -> error ("TestResult " ++ show r ++ " not defined in testResultStringMapping")++instance FromJSON TestResult where+ parseJSON v =+ case v of+ String s+ | Just r <- L.lookup s (map (\(x, y) -> (y, x)) testResultStringMapping)+ -> return r+ _ -> fail ("could not parse JSON value as a test result: " ++ show v)++testResultStringMapping :: [(TestResult, T.Text)]+testResultStringMapping =+ [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")]++deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory++serializeTestHistory :: TestHistory -> BS.ByteString+serializeTestHistory hist =+ let serHist = SerializableTestHistory {+ sth_version = _CURRENT_VERSION_+ , sth_runs = th_runs hist+ }+ in BSL.toStrict $ encode serHist++deserializeTestHistory :: BS.ByteString -> Either String (TestHistory)+deserializeTestHistory bs =+ -- assume version 0 for now. Later we have to look into the json, find the version and then decide which parser to user+ case decodeStrict bs of+ Nothing -> Left ("could not decode JSON: " ++ show bs)+ Just !serHist ->+ let list = V.toList (sth_runs serHist)+ in Right (TestHistory (sth_runs serHist) (createIndex list (const True)) (createIndex list isSuccess))++testCreateIndex =+ do time <- getCurrentTime+ let index = createIndex (historyList time) (const True)+ if index == expectedIndex+ then return ()+ else assertFailure ("== Expected index:\n" ++ show expectedIndex +++ "\n== Given index:\n" ++ show index)+ where+ historyList time =+ [mkHist time [mkRes "foo" 1]+ ,mkHist time [mkRes "foo" 2, mkRes "bar" 10]+ ,mkHist time [mkRes "bar" 20, mkRes "egg" 3]]+ expectedIndex = Map.fromList [("foo", mkRes "foo" 1)+ ,("bar", mkRes "bar" 10)+ ,("egg", mkRes "egg" 3)]+ mkHist time l = TestRunHistory time (V.fromList l)+ mkRes id ms = HistoricTestResult id Pass False ms++historyTests = [("testCreateIndex", testCreateIndex)]
Test/Framework/JsonOutput.hs view
@@ -1,3 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {- | HTF's machine-readable output is a sequence of JSON messages. Each message is terminated@@ -47,8 +65,6 @@ For an exact specification, please have a look at the code of this module. -}--{-# LANGUAGE OverloadedStrings #-} module Test.Framework.JsonOutput ( TestStartEventObj, TestEndEventObj, TestListObj, TestObj, TestResultsObj,@@ -62,6 +78,7 @@ 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 ((.=))@@ -89,34 +106,28 @@ = TestEndEventObj { te_test :: TestObj , te_result :: TestResult- , te_location :: Maybe Location- , te_callers :: [(Maybe String, Location)]+ , te_stack :: HtfStack , te_message :: T.Text , te_wallTimeMs :: Int+ , te_timedOut :: Bool } instance J.ToJSON TestEndEventObj where toJSON te = J.object ["type" .= J.String "test-end" ,"test" .= J.toJSON (te_test te)- ,"location" .= J.toJSON (te_location te)- ,"callers" .= J.toJSON (map (\(msg, loc) -> J.object ["message" .= J.toJSON msg- ,"location" .= J.toJSON loc])- (te_callers te))+ ,"location" .= J.toJSON (failureLocationFromStack (te_stack te))+ ,"callers" .=+ J.toJSON (map (\entry -> J.object ["location" .= J.toJSON (hse_location entry)+ ,"message" .= J.toJSON (hse_message entry)])+ (restCallStack (te_stack te))) ,"result" .= J.toJSON (te_result te) ,"message" .= J.toJSON (te_message te)- ,"wallTime" .= J.toJSON (te_wallTimeMs te)]+ ,"wallTime" .= J.toJSON (te_wallTimeMs te)+ ,"timedOut" .= J.toJSON (te_timedOut te)] instance HTFJsonObj TestEndEventObj -instance J.ToJSON TestResult where- toJSON r = J.String $- case r of- Pass -> "pass"- Pending -> "pending"- Fail -> "fail"- Error -> "error"- -- "test-list" message data TestListObj = TestListObj@@ -138,6 +149,8 @@ , tr_pending :: Int , tr_failed :: Int , tr_errors :: Int+ , tr_timedOut :: Int+ , tr_filtered :: Int } instance J.ToJSON TestResultsObj where@@ -146,6 +159,8 @@ ,"pending" .= J.toJSON (tr_pending r) ,"failures" .= J.toJSON (tr_failed r) ,"errors" .= J.toJSON (tr_errors r)+ ,"timedOut" .= J.toJSON (tr_timedOut r)+ ,"filtered" .= J.toJSON (tr_filtered r) ,"wallTime" .= J.toJSON (tr_wallTimeMs r)] instance HTFJsonObj TestResultsObj@@ -194,21 +209,23 @@ mkTestEndEventObj ftr flatName = let r = ft_payload ftr msg = renderColorString (rr_message r) False- in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r)- msg (rr_wallTimeMs r)+ in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_stack r)+ msg (rr_wallTimeMs r) (rr_timeout r) mkTestListObj :: [(FlatTest, String)] -> TestListObj mkTestListObj l = TestListObj (map (\(ft, flatName) -> mkTestObj ft flatName) l) -mkTestResultsObj :: Milliseconds -> Int -> Int -> Int -> Int -> TestResultsObj-mkTestResultsObj time passed pending failed errors =+mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj+mkTestResultsObj arg = TestResultsObj- { tr_wallTimeMs = time- , tr_passed = passed- , tr_pending = pending- , tr_failed = failed- , tr_errors = errors+ { tr_wallTimeMs = rgra_timeMs arg+ , tr_passed = length (rgra_passed arg)+ , tr_pending = length (rgra_pending arg)+ , tr_failed = length (rgra_failed arg)+ , tr_errors = length (rgra_errors arg)+ , tr_timedOut = length (rgra_timedOut arg)+ , tr_filtered = length (rgra_filtered arg) } decodeObj :: HTFJsonObj a => a -> BSL.ByteString
Test/Framework/Location.hs view
@@ -1,5 +1,5 @@ ----- Copyright (c) 2005, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -18,7 +18,7 @@ {- | -This module defines types and functions dealing with source code locations.+Internal module for types and functions dealing with source code locations. -}
Test/Framework/Preprocessor.hs view
@@ -1,8 +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-2014 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@@ -19,20 +24,37 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Preprocessor ( transform, progName ) where+module Test.Framework.Preprocessor ( + transform, progName, preprocessorTests, TransformOptions(..)++) where++-- import Debug.Trace import Control.Monad-import qualified Data.Text as T-import Data.Char ( toLower, isSpace, isDigit )-import Data.Maybe ( mapMaybe )-import qualified Data.List as List-import System.IO ( hPutStrLn, stderr )-import Language.Preprocessor.Cpphs ( runCpphs,+import Data.Char+import Language.Preprocessor.Cpphs ( runCpphsPass1,+ runCpphsPass2, CpphsOptions(..), BoolOptions(..),- defaultCpphsOptions)+ 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@@ -66,230 +88,316 @@ nameDefines :: ModuleInfo -> [(String, String)] nameDefines info =- [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleName info)),- (importedTestListName, importedTestListFullName (mi_moduleName info))]--allAsserts :: [String]-allAsserts =- withGs ["assertBool"- ,"assertEqual"- ,"assertEqualPretty"- ,"assertEqualNoShow"- ,"assertNotEqual"- ,"assertNotEqualPretty"- ,"assertNotEqualNoShow"- ,"assertListsEqualAsSets"- ,"assertElem"- ,"assertEmpty"- ,"assertNotEmpty"- ,"assertLeft"- ,"assertLeftNoShow"- ,"assertRight"- ,"assertRightNoShow"- ,"assertJust"- ,"assertNothing"- ,"assertNothingNoShow"- ,"subAssert"- ,"subAssertVerbose"- ] ++ ["assertThrows"- ,"assertThrowsSome"- ,"assertThrowsIO"- ,"assertThrowsSomeIO"- ,"assertThrowsM"- ,"assertThrowsSomeM"]- where- withGs l =- concatMap (\s -> [s, 'g':s]) l--assertDefines :: Bool -> String -> [(String, String)]-assertDefines hunitBackwardsCompat prefix =- concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")]- where- fun a =- if hunitBackwardsCompat- then [(a, expansion a "Verbose_"), (a ++ "HTF", expansion a "_")]- else [(a, expansion a "_"), (a ++ "Verbose", expansion a "Verbose_")]- expansion a suffix = "(" ++ prefix ++ a ++ suffix ++ " (" ++- prefix ++ "makeLoc __FILE__ __LINE__))"--warn :: String -> IO ()-warn s =- hPutStrLn stderr $ progName ++ " warning: " ++ s--note :: String -> IO ()-note s =- when _DEBUG_ $ hPutStrLn stderr $ progName ++ " note: " ++ s+ [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)),+ (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault info))] data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition]- , mi_moduleName :: String }- deriving (Show)+ , mi_moduleName :: Maybe String }+ deriving (Show, Eq) +mi_moduleNameWithDefault :: ModuleInfo -> String+mi_moduleNameWithDefault = fromMaybe "Main" . mi_moduleName++data ImportDecl = ImportDecl { imp_moduleName :: Name+ , imp_qualified :: Bool+ , imp_alias :: Maybe Name+ , imp_loc :: Location }+ deriving (Show, Eq)+ data Definition = TestDef String Location String | PropDef String Location String- deriving (Show)+ deriving (Eq, Show) -data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma- deriving (Show)+type Name = String -analyse :: FilePath -> String- -> IO (ParseResult ModuleInfo)-analyse originalFileName inputString =- do parseResult <- parse originalFileName inputString- case parseResult of- ParseOK (Module moduleName imports decls pragmas) ->- do -- putStrLn $ show decls- let defs = mapMaybe defFromDecl decls- htfImports = findHtfImports imports pragmas- htfPrefix <-- case mapMaybe prefixFromImport imports of- (s:_) -> return s- [] -> do warn ("No import found for " ++ htfModule ++- " in " ++ originalFileName)- return (htfModule ++ ".")- return $ ParseOK (ModuleInfo htfPrefix htfImports defs moduleName)- ParseError loc err -> return (ParseError loc err)+type PMA a = State ModuleInfo a++setModName :: String -> PMA ()+setModName name =+ do oldName <- gets mi_moduleName+ when (isNothing oldName) $ modify $ \mi -> mi { mi_moduleName = Just name }++addTestDef :: String -> String -> Location -> PMA ()+addTestDef name fullName loc =+ modify $ \mi -> mi { mi_defs = (TestDef name loc fullName) : mi_defs mi }++addPropDef :: String -> String -> Location -> PMA ()+addPropDef name fullName loc =+ modify $ \mi -> mi { mi_defs = (PropDef name loc fullName) : mi_defs mi }++addHtfImport :: ImportDecl -> PMA ()+addHtfImport decl =+ modify $ \mi -> mi { mi_htfImports = decl : mi_htfImports mi }++setTestFrameworkImport :: String -> PMA ()+setTestFrameworkImport name =+ modify $ \mi -> mi { mi_htfPrefix = name }++data Tok+ = TokModule+ | TokQname Location String+ | TokName Location Bool String+ | TokHtfImport Location+ | TokImport Location++transWordStyles :: [WordStyle] -> [Tok]+transWordStyles styles = loop styles True where- prefixFromImport :: ImportDecl -> Maybe String- prefixFromImport (ImportDecl s qualified alias _)- | s == htfModule =- if qualified- then case alias of- Just s' -> Just $ s' ++ "."- Nothing -> Just $ s ++ "."- else Just ""- prefixFromImport _ = Nothing- defFromDecl :: Decl -> Maybe Definition- defFromDecl (Decl loc name) = defFromNameAndLoc name loc- defFromNameAndLoc :: Name -> Location -> Maybe Definition- defFromNameAndLoc name loc =- case name of- ('t':'e':'s':'t':'_':rest) | not (null rest) ->- Just (TestDef rest loc name)- ('p':'r':'o':'p':'_':rest) | not (null rest) ->- Just (PropDef rest loc name)- _ -> Nothing- findHtfImports allImports allPragmas =- let importPragmas = filter (\p -> pr_name p == "HTF_TESTS") allPragmas- importsAndPragmas = List.sortBy cmpByLine (map IsImport allImports ++- map IsPragma importPragmas)- loop (IsImport imp : IsPragma prag : rest) =- if lineNumber (imp_loc imp) == lineNumber (pr_loc prag)- then imp : loop rest- else loop rest- loop (_ : rest) = loop rest- loop [] = []- in loop importsAndPragmas- cmpByLine x y = getLine x `compare` getLine y- getLine (IsImport imp) = (lineNumber (imp_loc imp))- getLine (IsPragma prag) = (lineNumber (pr_loc prag))+ loop styles startOfLine =+ case styles of+ [] -> []+ Ident pos name : rest ->+ case name of+ "module" -> TokModule : loop rest False+ "import" ->+ case dropWhite rest of+ Other "{-@ HTF_TESTS @-}" : rest2 ->+ TokHtfImport (posToLocation pos) : loop rest2 False+ _ ->+ TokImport (posToLocation pos) : loop rest False+ _ ->+ case parseQname rest of+ ([], rest2) ->+ TokName (posToLocation pos) startOfLine name : loop rest2 False+ (nameParts, rest2) ->+ TokQname (posToLocation pos) (List.intercalate "." (name:nameParts)) : loop rest2 False+ Other str : rest ->+ let startOfLine =+ case reverse str of+ '\n':_ -> True+ _ -> False+ in loop rest startOfLine+ Cmd _ : rest -> loop rest False+ dropWhite styles =+ case styles of+ Other str : rest ->+ case dropWhile isSpace str of+ [] -> dropWhite rest+ str' -> Other str' : rest+ _ -> styles+ parseQname styles =+ case styles of+ Other "." : Ident _ name : rest ->+ let (restParts, rest2) = parseQname rest+ in (name:restParts, rest2)+ _ -> ([], styles)+ posToLocation pos = makeLoc (filename pos) (lineno pos) -breakOn :: T.Text -> T.Text -> Maybe (T.Text, T.Text)-breakOn t1 t2 =- let (pref, suf) = T.breakOn t1 t2- in if pref == t2- then Nothing- else Just (pref, T.drop (T.length t1) suf)+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+ 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) -poorMensAnalyse :: FilePath -> String -> IO ModuleInfo-poorMensAnalyse originalFileName inputString =- let (modName, defs, impDecls) = doAna (zip [1..] (lines inputString)) ("", [], [])- in return $ ModuleInfo "Test.Framework." impDecls defs modName+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- doAna [] (modName, revDefs, impDecls) = (modName, reverse revDefs, reverse impDecls)- doAna ((lineNo, line) : restLines) (modName, defs, impDecls) =- case line of- 'm':'o':'d':'u':'l':'e':rest ->- if null modName- then doAna restLines (takeWhile (not . isSpace) (dropWhile isSpace rest),- defs, impDecls)- else doAna restLines (modName, defs, impDecls)- 't':'e':'s':'t':'_':rest ->- let testName = takeWhile (not . isSpace) rest- def = TestDef testName loc ("test_" ++ testName)- in doAna restLines (modName, def : defs, impDecls)- 'p':'r':'o':'p':'_':rest ->- let testName = takeWhile (not . isSpace) rest- def = PropDef testName loc ("prop_" ++ testName)- in doAna restLines (modName, def : defs, impDecls)- 'i':'m':'p':'o':'r':'t':rest ->- case breakOn importPragma (T.pack rest) of- Just (pref, suf) ->- case poorMensParseImportLine loc (pref `T.append` suf) of- Just impDecl -> doAna restLines (modName, defs, impDecl : impDecls)- Nothing -> doAna restLines (modName, defs, impDecls)- Nothing -> doAna restLines (modName, defs, impDecls)- _ -> doAna restLines (modName, defs, impDecls)- where- loc = makeLoc originalFileName lineNo- importPragma = T.pack "{-@ HTF_TESTS @-}"+ 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) -poorMensParseImportLine :: Location -> T.Text -> Maybe ImportDecl-poorMensParseImportLine loc t =- let (q, rest) =- case breakOn "qualified" t of- Nothing -> (False, T.strip t)- Just (_, rest) -> (True, T.strip rest)- modName = T.takeWhile (not . isSpace) rest- afterModName = T.strip $ T.drop (T.length modName) rest- in case breakOn "as" afterModName of- Nothing -> Just $ ImportDecl (T.unpack modName) q Nothing loc- Just (_, suf) ->- let strippedSuf = T.strip suf- alias = if T.null strippedSuf then Nothing else Just (T.unpack strippedSuf)- in Just $ ImportDecl (T.unpack modName) q alias loc+cpphsOptions :: CpphsOptions+cpphsOptions =+ defaultCpphsOptions {+ boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell+ } -transform :: Bool -> FilePath -> String -> IO String-transform hunitBackwardsCompat originalFileName input =- do analyseResult <- analyse originalFileName input- case analyseResult of- ParseError loc err ->- do poorInfo <- poorMensAnalyse originalFileName input- note ("Parsing of " ++ originalFileName ++ " failed at line "- ++ show (lineNumber loc) ++ ": " ++ err ++- "\nFalling back to poor man's parser. This parser may " ++- "return incomplete results. The result returned was: " ++- "\nPrefix: " ++ mi_htfPrefix poorInfo ++- "\nModule name: " ++ mi_moduleName poorInfo ++- "\nDefinitions: " ++ show (mi_defs poorInfo) ++- "\nHTF imports: " ++ show (mi_htfImports poorInfo))- preprocess poorInfo input- ParseOK info ->- preprocess info input+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 :: ModuleInfo -> String -> IO String- preprocess info input =- do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName- fixedInput- return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+ preprocess info toks pass1 =+ do when debug $+ do hPutStrLn stderr ("Tokens: " ++ show toks)+ hPutStrLn stderr ("Module info:\n" ++ show info)+ let opts = mkOptionsForModule info+ preProcessedInput <-+ runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1+ return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n"+ -- fixedInput serves two purposes:+ -- 1. add a trailing \n+ -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'+ -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output).+ fixedInput :: String+ fixedInput = (unlines . map fixLine . lines) input where- -- fixedInput serves two purposes:- -- 1. add a trailing \n- -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'- -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output).- fixedInput :: String- fixedInput = (unlines . map fixLine . lines) input- where- fixLine s =- case parseCppLineInfoOut s of- Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName- _ -> s- cpphsOptions :: ModuleInfo -> CpphsOptions- cpphsOptions info =+ fixLine s =+ case parseCppLineInfoOut s of+ Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName+ _ -> s+ mkOptionsForModule :: ModuleInfo -> CpphsOptions+ mkOptionsForModule info = defaultCpphsOptions { defines = defines defaultCpphsOptions ++- assertDefines hunitBackwardsCompat (mi_htfPrefix info) ++ nameDefines info , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell }+ possiblyWrap :: Bool -> String -> String+ possiblyWrap b s = if b then "\\begin{code}\n" ++ s ++ "\\end{code}" else s additionalCode :: ModuleInfo -> String additionalCode info =- thisModulesTestsFullName (mi_moduleName info) ++ " :: " +++ thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++ mi_htfPrefix info ++ "TestSuite\n" ++- thisModulesTestsFullName (mi_moduleName info) ++ " = " +++ thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " = " ++ mi_htfPrefix info ++ "makeTestSuite" ++- " " ++ show (mi_moduleName info) +++ " " ++ show (mi_moduleNameWithDefault info) ++ " [\n" ++ List.intercalate ",\n" (map (codeForDef (mi_htfPrefix info)) (mi_defs info)) ++ "\n ]\n" ++ importedTestListCode info@@ -311,9 +419,9 @@ let l = mi_htfImports info in case l of [] -> ""- _ -> (importedTestListFullName (mi_moduleName info)+ _ -> (importedTestListFullName (mi_moduleNameWithDefault info) ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++- importedTestListFullName (mi_moduleName info)+ importedTestListFullName (mi_moduleNameWithDefault info) ++ " = [\n " ++ List.intercalate ",\n " (map htfTestsInModule l) ++ "\n ]\n")@@ -325,3 +433,25 @@ (False, _) -> name (True, Just alias) -> alias ++ "." ++ name (True, _) -> imp_moduleName imp ++ "." ++ name++-- Returns for lines of the form '# <number> "<filename>"'+-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)+-- the value 'Just <number> "<filename>"'+parseCppLineInfoOut :: String -> Maybe (String, String)+parseCppLineInfoOut line =+ case line of+ '#':' ':c:rest+ | isDigit c ->+ case List.span isDigit rest of+ (restDigits, ' ' : '"' : rest) ->+ case dropWhile (/= '"') (reverse rest) of+ '"' : fileNameRev ->+ let line = (c:restDigits)+ file = "\"" ++ reverse fileNameRev ++ "\""+ in Just (line, file)+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing++preprocessorTests =+ [("testAnalyze", testAnalyze)]
Test/Framework/Pretty.hs view
@@ -1,4 +1,21 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {- | @@ -19,7 +36,12 @@ where +#if MIN_VERSION_base(4,11,0)+-- Text.PrettyPrint exports (<>) conflicting with newer Prelude.+import Text.PrettyPrint hiding ((<>))+#else import Text.PrettyPrint+#endif -- | A type class for pretty-printable things. -- Minimal complete definition: @pretty@.
+ Test/Framework/PrettyHaskell.hs view
@@ -0,0 +1,103 @@+{- |+Internal module for pretty-printing showable Haskell values.+-}+--+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--+module Test.Framework.PrettyHaskell (++ prettyHaskell, prettyHaskell', prettyHaskellTests++) where++import qualified Data.List as List+import Language.Haskell.Parser+import Language.Haskell.Pretty+import Test.HUnit+import Test.Framework.Utils++prettyHaskell :: Show a => a -> String+prettyHaskell x =+ case prettyHaskell' x of+ Just s -> s+ Nothing -> "FALLBACK: " ++ show x++prettyHaskell' :: Show a => a -> Maybe String+prettyHaskell' x =+ fmap (postProcess (show x)) (prettyHaskell'' x )++prettyHaskell'' :: Show a => a -> Maybe String+prettyHaskell'' x =+ let str = show x+ code = "module M where TOP = " ++ str+ in case parseModule code of+ ParseOk x -> Just (prettyPrint x)+ ParseFailed _ _ -> Nothing++postProcess :: String -> String -> String+postProcess fallback s =+ case dropWhile (\l -> not ('=' `elem` l)) (lines s) of+ [] -> fallback+ (l:ls) ->+ case List.span (/= '=') l of+ (prefix, '=':' ':suffix) ->+ let indentLen = length prefix + 2+ in strip $ unlines (suffix : (map (drop indentLen) ls))+ _ -> fallback++prettyHaskellTests =+ [("testPrettyHaskell", testPrettyHaskell)]++data MySuperHero+ = MySuperHero+ { msh_age :: Int+ , msh_name :: String+ , msh_address :: String+ , msh_fun :: Int+ }+ deriving (Show)++data MySuperSuperHero+ = MySuperSuperHero+ { mssh_isHere :: Bool+ , mssh_hero :: MySuperHero+ }+ deriving (Show)++testPrettyHaskell =+ do assertPretty "Just 1" (Just 1)+ let hero =+ MySuperHero+ { msh_age = 35+ , msh_name = "FOO"+ , msh_address = "address"+ , msh_fun = 1+ }+ assertPretty+ ("MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" +++ " msh_address = \"address\", msh_fun = 1}")+ hero+ assertPretty+ ("MySuperSuperHero{mssh_isHere = True,\n" +++ " mssh_hero =\n" +++ " MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" +++ " msh_address = \"address\", msh_fun = 1}}")+ (MySuperSuperHero { mssh_isHere = True, mssh_hero = hero })+ where+ assertPretty s x =+ assertEqual (s ++ " /=\n" ++ prettyHaskell x)+ s (prettyHaskell x)
Test/Framework/QuickCheckWrapper.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances,- ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -32,7 +36,8 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs,- withQCArgs, WithQCArgs,+ withQCArgs, WithQCArgs, setReplayFromString,+ QCAssertion, -- * Pending properties qcPending,@@ -52,23 +57,26 @@ import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..),- throw, throwIO, catch, catches, evaluate )+ throw, catch, catches, evaluate ) import Data.Typeable (Typeable) import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef-import qualified Data.ByteString.Char8 as BSC-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Base64 as Base64 import Test.QuickCheck-import Test.QuickCheck.Property hiding (reason)-import Test.Framework.TestManager-import Test.Framework.TestManagerInternal-import Test.HUnit.Lang (HUnitFailure(..))+#if !MIN_VERSION_QuickCheck(2,7,0)+import Test.QuickCheck.Property (morallyDubiousIOProperty)+#endif+import Test.Framework.TestInterface+import Test.Framework.Utils +_DEBUG_ :: Bool+_DEBUG_ = False++debug :: String -> IO ()+debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return ()+ data QCState = QCState { qc_args :: !Args } qcState :: IORef QCState@@ -98,6 +106,18 @@ instance Exception QCPendingException +quickCheckTestError :: Maybe String -> Assertion+quickCheckTestError m = failHTF $ mkFullTestResult Error m++quickCheckTestFail :: Maybe String -> Assertion+quickCheckTestFail m = failHTF $ mkFullTestResult Fail m++quickCheckTestPending :: String -> Assertion+quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m)++quickCheckTestPass :: String -> Assertion+quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m)+ -- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function -- is used internally in the code generated by @htfpp@, do not use it directly. qcAssertion :: (QCAssertion t) => t -> Assertion@@ -119,31 +139,42 @@ AnyTestable t' -> quickCheckWithResult args t' return (Right x) `catches`- [Handler $ \(QCPendingException msg) -> return $ Left (True, msg)- ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]+ [Handler $ \(QCPendingException msg) -> return $ Left msg]+ debug ("QuickCheck result: " ++ show res) case res of- Left (isPending, err) ->- if isPending- then quickCheckTestPending err- else quickCheckTestError (Just err)+ Left err ->+ quickCheckTestPending err Right (Success { output=msg }) -> quickCheckTestPass (adjustOutput msg) Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->- if pendingPrefix `List.isPrefixOf` reason- then let pendingMsg = let s = drop (length pendingPrefix) reason- in take (length s - length pendingSuffix) s- in quickCheckTestPending pendingMsg- else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))- out = adjustOutput msg- quickCheckTestFail (Just (out ++ "\n" ++ replay))+ 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@@ -166,11 +197,11 @@ argsModifier :: a -> (Args -> Args) testable :: a -> AnyTestable -instance Testable a => QCAssertion a where+instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where argsModifier _ = id testable = AnyTestable -instance Testable a => QCAssertion (WithQCArgs a) where+instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where argsModifier (WithQCArgs f _) = f testable (WithQCArgs _ x) = AnyTestable x @@ -192,9 +223,20 @@ assertionAsProperty :: IO () -> Property assertionAsProperty action =- ioProperty $ catch action transHUnitFail >> return True- where- transHUnitFail exc@(HUnitFailure msg) =- let exc' = "<<<HTF<<<" ++ (BSC.unpack $ Base64.encode $ T.encodeUtf8 $ T.pack msg)- ++ ">>>HTF>>>"- in throwIO (HUnitFailure exc')+ ioProperty $ action >> return True++-- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string.+setReplayFromString :: Args -> String -> Args+setReplayFromString args str =+#if !MIN_VERSION_QuickCheck(2,7,0)+ case readM str of+ Just x -> args { replay = x }+ Nothing -> error ("Could not parse replay parameter from string " ++ show str)+#else+ -- Starting with QC 2.7 the type of the replay field changed from+ -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)'+ case readM str of+ Just x -> args { replay = x }+ Nothing ->+ error ("Could not parse replay parameter from string " ++ show str)+#endif
+ Test/Framework/TestInterface.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+--+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{- |++This module defines the API for HTF tests, i.e. unit tests and quickcheck properties.++This functionality is mainly used internally in the code+generated by the @hftpp@ pre-processor.+-}++module Test.Framework.TestInterface (++ Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..)+ , HtfStackEntry(..), HtfStack, emptyHtfStack, mkHtfStack, formatHtfStack+ , failureLocationFromStack, failureLocation+ , restCallStack, htfStackToList+ , failHTF, subAssertHTF, addCallerToSubAssertStack+ , mkFullTestResult++) where++import Test.Framework.Location+import Test.Framework.Colors++import Control.Monad.Trans.Control+import Data.Typeable+import GHC.Stack+import qualified Data.List as L+import qualified Control.Exception as Exc+import qualified Control.Exception.Lifted as ExcLifted++{- | An assertion is just an 'IO' action. Internally, the body of any test+in HTF is of type 'Assertion'. If a test specification of a certain plugin+has a type different from 'Assertion', the plugin's preprocessor pass must+inject wrapper code to convert the test specification into an assertion.++Assertions may use 'failHTF' to signal a 'TestResult' different from+'Pass'. If the assertion finishes successfully, the tests passes+implicitly.++Please note: the assertion must not swallow any exceptions! Otherwise,+timeouts and other things might not work as expected.+-}+type Assertion = IO ()++-- | The summary result of a test.+data TestResult = Pass | Pending | Fail | Error+ deriving (Show, Read, Eq)++data HtfStackEntry+ = HtfStackEntry+ { hse_location :: Location+ , hse_calledFunction :: String+ , hse_message :: Maybe String+ } deriving (Eq, Ord, Show, Read)++-- The first entry in the list is the location of the assertion failure+data HtfStack+ = HtfStack+ { hs_assertStack :: [HtfStackEntry]+ , hs_subAssertStack :: [HtfStackEntry]+ }+ deriving (Eq, Ord, Show, Read)++mkHtfStack :: CallStack -> HtfStack+mkHtfStack cs = HtfStack (map mkHtfStackEntry (removeHtfPrefix (getCallStack cs))) []++removeHtfPrefix :: [(String, SrcLoc)] -> [(String, SrcLoc)]+removeHtfPrefix [] = []+removeHtfPrefix all@((_, srcLoc) : rest) =+ if "Test.Framework" `L.isPrefixOf` srcLocModule srcLoc+ then removeHtfPrefix rest+ else all++mkHtfStackEntry :: (String, SrcLoc) -> HtfStackEntry+mkHtfStackEntry x = mkHtfStackEntry' x Nothing++mkHtfStackEntry' :: (String, SrcLoc) -> Maybe String -> HtfStackEntry+mkHtfStackEntry' (funName, srcLoc) mMsg =+ HtfStackEntry+ { hse_location = makeLoc (srcLocFile srcLoc) (srcLocStartLine srcLoc)+ , hse_calledFunction = funName+ , hse_message = mMsg+ }++htfStackToList :: HtfStack -> [HtfStackEntry]+htfStackToList s = hs_assertStack s ++ reverse (hs_subAssertStack s)++emptyHtfStack :: HtfStack+emptyHtfStack = HtfStack [] []++failureLocation :: HasCallStack => Maybe Location+failureLocation = failureLocationFromStack (mkHtfStack callStack)++failureLocationFromStack :: HtfStack -> Maybe Location+failureLocationFromStack stack =+ case htfStackToList stack of+ [] -> Nothing+ e:_ -> Just (hse_location e)++restCallStack :: HtfStack -> [HtfStackEntry]+restCallStack stack =+ case htfStackToList stack of+ [] -> []+ _:rest -> rest++-- | Formats a stack trace.+formatHtfStack :: HtfStack -> String+formatHtfStack stack =+ unlines $ map formatStackElem $ zip [0..] $ htfStackToList stack+ where+ formatStackElem (pos, HtfStackEntry loc _ mMsg) =+ let pref = if pos > 0 then " called from " else " at "+ in pref ++ showLoc loc ++ showMsg mMsg+ showMsg Nothing = ""+ showMsg (Just m) = " (" ++ m ++ ")"++-- | The full result of a test, as used by HTF plugins.+data FullTestResult+ = FullTestResult+ { ftr_stack :: HtfStack -- ^ The stack to the location of a possible failure+ , ftr_message :: Maybe ColorString -- ^ An error message+ , ftr_result :: Maybe TestResult -- ^ The outcome of the test, 'Nothing' means timeout+ } deriving (Eq, Show, Read)++-- | Auxiliary function for contructing a 'FullTestResult'.+mkFullTestResult :: TestResult -> Maybe String -> FullTestResult+mkFullTestResult r msg =+ FullTestResult+ { ftr_stack = emptyHtfStack+ , ftr_message = fmap noColor msg+ , ftr_result = Just r+ }++-- Internal exception type for propagating exceptions.+data HTFFailureException+ = HTFFailure FullTestResult+ deriving (Show, Typeable)++instance Exc.Exception HTFFailureException++{- |+Terminate a HTF test, usually to signal a failure. The result of the test+is given in the 'FullTestResult' argument.+-}+failHTF :: MonadBaseControl IO m => FullTestResult -> m a+-- Important: force the string argument, otherwise an error embedded+-- lazily inside the string might escape.+failHTF r = length (show r) `seq` ExcLifted.throwIO (HTFFailure r)++addCallerToSubAssertStack :: CallStack -> HtfStack -> Maybe String -> HtfStack+addCallerToSubAssertStack ghcStack stack@(HtfStack s1 s2) mMsg =+ case removeHtfPrefix (getCallStack ghcStack) of+ [] -> stack+ (entry : _) -> HtfStack s1 ((mkHtfStackEntry' entry mMsg) : s2)++{- |+Opens a new assertion stack frame to allow for sensible location information.+This function should be used if the function being called does not carry+a 'HasCallStack' annotation.+-}+subAssertHTF :: (HasCallStack, MonadBaseControl IO m) => Maybe String -> m a -> m a+subAssertHTF mMsg action =+ let stack = callStack+ in action `ExcLifted.catch`+ (\(HTFFailure res) ->+ let newRes =+ res { ftr_stack =+ addCallerToSubAssertStack stack (ftr_stack res) mMsg }+ in failHTF newRes)
Test/Framework/TestManager.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} ----- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -20,7 +22,9 @@ This module defines function for running a set of tests. Furthermore, it provides functionality for organzing tests into a hierarchical-structure. This functionality is mainly used internally in the code+structure.++This functionality is mainly used internally in the code generated by the @hftpp@ pre-processor. -} @@ -30,38 +34,47 @@ module Test.Framework.TestTypes, -- * Running tests- htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',+ htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs', runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig', -- * Organzing tests TestableHTF,+ WrappableHTF(..), makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, + flattenTest,++ -- * Tests (for internal use)+ wrappableTests ) where import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs)-import Control.Exception (finally)+import qualified Control.Exception as Exc import Data.Maybe+import Data.Time import qualified Data.List as List+import qualified Data.ByteString as BS+import Data.IORef+import Control.Concurrent import System.IO -import qualified Test.HUnit.Lang as HU- import Test.Framework.Utils-import Test.Framework.TestManagerInternal+import Test.Framework.TestInterface import Test.Framework.TestTypes import Test.Framework.CmdlineOptions import Test.Framework.TestReporter import Test.Framework.Location import Test.Framework.Colors import Test.Framework.ThreadPool+import Test.Framework.History +import qualified Test.HUnit as HU -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test@@ -95,6 +108,26 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') +-- | Kind of specialised 'Functor' type class for tests, which allows you to+-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any+-- test code.+--+-- E.g. if you want to add timeouts to all tests of a module, you could write:+--+-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded"+-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests+class WrappableHTF t where+ wrap :: (Assertion -> Assertion) -> t -> t++instance WrappableHTF TestSuite where+ wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests+ wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests++instance WrappableHTF Test where+ wrap wrapper (BaseTest ts tid loc topt assertion) =+ BaseTest ts tid loc topt (wrapper assertion)+ wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite+ -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where@@ -126,63 +159,198 @@ let fts = concatMap flattenTest ts in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int)-mkFlatTestRunner ft = (pre, action, post)+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++-- | HTF uses this function to execute the given assertion as a HTF test.+performTestHTF :: Assertion -> IO FullTestResult+performTestHTF action =+ do action+ return (mkFullTestResult Pass Nothing)+ `Exc.catches`+ [Exc.Handler (\(HTFFailure res) -> return res)+ ,Exc.Handler handleUnexpectedException] where+ handleUnexpectedException exc =+ case Exc.fromException exc of+ Just (async :: Exc.AsyncException) ->+ case async of+ Exc.StackOverflow -> exceptionAsError exc+ _ -> Exc.throwIO exc+ _ -> exceptionAsError exc+ exceptionAsError exc =+ return (mkFullTestResult Error (Just $ show (exc :: Exc.SomeException)))++data TimeoutResult a+ = TimeoutResultOk a+ | TimeoutResultException Exc.SomeException+ | TimeoutResultTimeout++timeout :: Int -> IO a -> IO (Maybe a)+timeout microSecs action+ | microSecs < 0 = fmap Just action+ | microSecs == 0 = return Nothing+ | otherwise =+ do resultChan <- newChan+ finishedVar <- newIORef False+ workerTid <- forkIO (wrappedAction resultChan finishedVar)+ _ <- forkIO (threadDelay microSecs >> writeChan resultChan TimeoutResultTimeout)+ res <- readChan resultChan+ case res of+ TimeoutResultTimeout ->+ do atomicModifyIORef finishedVar (\_ -> (True, ()))+ killThread workerTid+ return Nothing+ TimeoutResultOk x ->+ return (Just x)+ TimeoutResultException exc ->+ Exc.throwIO exc+ where+ wrappedAction resultChan finishedVar =+ Exc.mask $ \restore ->+ (do x <- restore action+ writeChan resultChan (TimeoutResultOk x))+ `Exc.catch`+ (\(exc::Exc.SomeException) ->+ do b <- shouldReraiseException exc finishedVar+ if b then Exc.throwIO exc else writeChan resultChan (TimeoutResultException exc))+ shouldReraiseException exc finishedVar =+ case Exc.fromException exc of+ Just (async :: Exc.AsyncException) ->+ case async of+ Exc.ThreadKilled -> atomicModifyIORef finishedVar (\old -> (old, old))+ _ -> return False+ _ -> return False++data PrimTestResult+ = PrimTestResultNoTimeout FullTestResult+ | PrimTestResultTimeout++mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)+mkFlatTestRunner tc ft = (pre, action, post)+ where pre = reportTestStart ft- action _ = measure $ HU.performTestCase (wto_payload (ft_payload 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, (mLoc, callers, msg, time)) =+ let (testResult, time) = case excOrResult of- Left exc -> (Error, (Nothing,- [],- noColor ("Running test unexpectedly failed: " ++ show exc),- (-1)))+ 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- Nothing -> (Pass, (Nothing, [], emptyColorString, time))- Just (isFailure, msg') ->- if ft_sort ft /= QuickCheckTest- then let utr = deserializeHUnitMsg msg'- r = case () of- _| utr_pending utr -> Pending- | isFailure -> Fail- | otherwise -> Error- in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time))- else let (r, mUnitTestResult, s) = deserializeQuickCheckMsg msg'- loc = join $ fmap utr_location mUnitTestResult- callers = fromMaybe [] $ fmap utr_callingLocations mUnitTestResult- msg =- case mUnitTestResult of- Just utr -> utr_message utr +++ noColor "\n" +++ noColor s- Nothing -> noColor s- in (r, (loc, callers, msg, time))+ 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 testResult mLoc callers msg time }+ , ft_payload = RunResult sumRes (ftr_stack testResult)+ (fromMaybe emptyColorString (ftr_message testResult))+ time isTimeout+ } in do modify (\s -> s { ts_results = rr : ts_results s }) reportTestResult rr+ return (stopFlag sumRes)+ stopFlag result =+ if not (tc_failFast tc)+ then DoNotStop+ else case result of+ Pass -> DoNotStop+ Pending -> DoNotStop+ Fail -> DoStop+ Error -> DoStop runAllFlatTests :: [FlatTest] -> TR ()-runAllFlatTests tests =- do reportGlobalStart tests- tc <- ask+runAllFlatTests tests' =+ do tc <- ask+ tests <- orderTests tc tests'+ reportGlobalStart tests case tc_threads tc of Nothing ->- let entries = map mkFlatTestRunner tests+ 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 ptests- sentries = map mkFlatTestRunner stests+ pentries = map (mkFlatTestRunner tc) ptests+ sentries = map (mkFlatTestRunner tc) stests in do tp <- parallelThreadPool i- pentries <- if tc_shuffle tc- then liftIO (shuffleIO pentries')- else return pentries' tp_run tp pentries tp_run sequentialThreadPool sentries+ where+ orderTests tc ts+ | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts+ | tc_shuffle tc = shuffleTests ts+ | otherwise = return ts+ shuffleTests = liftIO . shuffleIO+ sortByPrevTime tc ts =+ map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts)+ compareTests tc (t1, _) (t2, _) =+ case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc)))+ (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc)))+ ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc)))+ (fmap htr_timeMs (findHistoricTestResult t2 (tc_history tc))))+ of+ (Just t1, Just t2) -> compare t1 t2+ (Just _, Nothing) -> GT+ (Nothing, Just _) -> LT+ (Nothing, Nothing) -> EQ -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t -- ^ Testable thing@@ -238,13 +406,19 @@ (if opts_listTests opts then let fts = filter (opts_filter opts) (flatten t) in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)- else runTestWithConfig' tc t)- return (printSummary `finally` cleanup tc, ecode)+ else do (printSummary, ecode, history) <- runTestWithConfig' tc t+ storeHistory (tc_historyFile tc) history+ return (printSummary, ecode))+ return (printSummary `Exc.finally` cleanup tc, ecode) where cleanup tc = case tc_output tc of TestOutputHandle h True -> hClose h _ -> return ()+ storeHistory file history =+ BS.writeFile file (serializeTestHistory history)+ `Exc.catch` (\(e::Exc.IOException) ->+ hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e)) -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,@@ -253,32 +427,59 @@ -- -- A test is /successful/ if the test terminates and no assertion fails. -- A test is said to /fail/ if an assertion fails but no other error occur.-runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode+runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory) runTestWithConfig tc t =- do (printSummary, ecode) <- runTestWithConfig' tc t+ do (printSummary, ecode, history) <- runTestWithConfig' tc t printSummary- return ecode+ return (ecode, history) -- | Runs something testable with the given 'TestConfig'. Does not -- print the overall test results but returns an 'IO' action for doing so. -- See 'runTestWithConfig' for a specification of the 'ExitCode' result.-runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode)+runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory) runTestWithConfig' tc t =- do ((_, s, _), time) <-+ do let allTests = flatten t+ activeTests = filter (tc_filter tc) allTests+ filteredTests = filter (not . tc_filter tc) allTests+ startTime <- getCurrentTime+ ((_, s, _), time) <- measure $- runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState+ runRWST (runAllFlatTests activeTests) tc initTestState let results = reverse (ts_results s) passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results error = filter (\ft -> (rr_result . ft_payload) ft == Error) results+ timedOut = filter (\ft -> (rr_timeout . ft_payload) ft) results+ arg = ReportGlobalResultsArg+ { rgra_timeMs = time+ , rgra_passed = passed+ , rgra_pending = pending+ , rgra_failed = failed+ , rgra_errors = error+ , rgra_timedOut = timedOut+ , rgra_filtered = filteredTests+ } let printSummary =- runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run+ runRWST (reportGlobalResults arg) tc (TestState [] (ts_index s)) -- keep index from run+ !newHistory = updateHistory startTime results (tc_history tc) return (printSummary >> return (), case () of _| length failed == 0 && length error == 0 -> ExitSuccess | length error == 0 -> ExitFailure 1- | otherwise -> ExitFailure 2)+ | otherwise -> ExitFailure 2+ ,newHistory)+ where+ updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory+ updateHistory time results history =+ let runHistory = mkTestRunHistory time (map (\res -> HistoricTestResult {+ htr_testId = historyKey res+ , htr_result = rr_result (ft_payload res)+ , htr_timedOut = rr_timeout (ft_payload res)+ , htr_timeMs = rr_wallTimeMs (ft_payload res)+ })+ results)+ in updateTestHistory runHistory history -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.@@ -286,5 +487,22 @@ htfMain :: TestableHTF t => t -> IO () htfMain tests = do args <- getArgs- ecode <- runTestWithArgs args tests+ htfMainWithArgs args tests++-- | Runs something testable by parsing the commandline arguments as test options+-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.+htfMainWithArgs :: TestableHTF t => [String] -> t -> IO ()+htfMainWithArgs args tests =+ do ecode <- runTestWithArgs args tests exitWith ecode++testWrapCanCauseFailure :: IO ()+testWrapCanCauseFailure =+ do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest+ HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest+ where+ unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ())+ wrappedUnitTest = wrap wrapper unitTest+ wrapper test = HU.assertFailure "Fail" >> test++wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)]
− Test/Framework/TestManagerInternal.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}------ Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.TestManagerInternal (-- UnitTestResult(..),-- quickCheckTestFail, quickCheckTestError, quickCheckTestPending,- quickCheckTestPass, deserializeQuickCheckMsg,- unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert,- blackBoxTestFail,--) where--import Test.Framework.TestTypes-import Test.Framework.Utils-import Test.Framework.Location-import Test.Framework.Colors--import qualified Test.HUnit.Lang as HU-import Control.Monad.Trans.Control-import qualified Control.Exception.Lifted as Exc-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Base64 as Base64-import qualified Data.ByteString.Char8 as BSC--assertFailureHTF :: String -> Assertion--- Important: force the string argument, otherwise an error embedded--- lazily inside the string might escape.-assertFailureHTF s = length s `seq` HU.assertFailure s---- This is a HACK: we encode a custom error message for QuickCheck--- failures and errors in a string, which is later parsed using read!-quickCheckTestError :: Maybe String -> Assertion-quickCheckTestError m = assertFailureHTF (show (Error, m))--quickCheckTestFail :: Maybe String -> Assertion-quickCheckTestFail m = assertFailureHTF (show (Fail, m))--quickCheckTestPending :: String -> Assertion-quickCheckTestPending m = assertFailureHTF (show (Pending, Just m))--quickCheckTestPass :: String -> Assertion-quickCheckTestPass m = assertFailureHTF (show (Pass, Just m))--deserializeQuickCheckMsg :: String -> (TestResult, Maybe UnitTestResult, String)-deserializeQuickCheckMsg msg =- case readM msg of- Nothing ->- (Error, Nothing, msg)- Just (r, ms) ->- case ms of- Nothing -> (r, Nothing, "")- Just s ->- let (utr, msg) = extractUnitTestResult (T.pack s)- in (r, utr, T.unpack msg)- where- extractUnitTestResult t =- case breakOn (T.pack "<<<HTF<<<") t of- Nothing -> (Nothing, t)- Just (pref, rest) ->- case breakOn (T.pack ">>>HTF>>>") rest of- Nothing -> (Nothing, t)- Just (serUtr, suf) ->- case Base64.decode (BSC.pack (T.unpack serUtr)) of- Left _ -> (Nothing, t)- Right bs ->- case T.decodeUtf8' bs of- Left _ -> (Nothing, t)- Right x ->- case readM (T.unpack x) of- Nothing -> (Nothing, t)- Just utr ->- (Just utr,- pref `T.append` suf)- breakOn x t =- case T.breakOn x t of- (pref, suf) ->- if T.null suf- then Nothing- else Just (pref, T.drop (T.length x) suf)---- This is a HACK: we encode location and pending information as a datatype--- that we show and parse later using read.-data UnitTestResult- = UnitTestResult- { utr_location :: Maybe Location- , utr_callingLocations :: [(Maybe String, Location)]- , utr_message :: ColorString- , utr_pending :: Bool- } deriving (Eq, Show, Read)--unitTestFail :: Maybe Location -> ColorString -> IO a-unitTestFail loc s =- do assertFailureHTF (show (UnitTestResult loc [] s False))- error "unitTestFail: UNREACHABLE"--unitTestSubAssert :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a-unitTestSubAssert loc mMsg action =- action `Exc.catch` (\(HU.HUnitFailure s) -> let res = deserializeHUnitMsg s- newRes = res { utr_callingLocations = (mMsg, loc) : utr_callingLocations res }- in Exc.throwIO (HU.HUnitFailure $ show newRes))---- Mark a unit test as pending without removing it from the test suite.-unitTestPending :: String -> IO a-unitTestPending s =- do assertFailureHTF (show (UnitTestResult Nothing [] (noColor s) True))- error "unitTestFail: UNREACHABLE"--deserializeHUnitMsg :: String -> UnitTestResult-deserializeHUnitMsg msg =- case readM msg of- Just r -> r- _ -> UnitTestResult Nothing [] (noColor msg) False--blackBoxTestFail :: String -> Assertion-blackBoxTestFail = assertFailureHTF
Test/Framework/TestReporter.hs view
@@ -1,4 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {-| This module defines functions for notifying all test reporters registered about@@ -22,6 +39,7 @@ import Test.Framework.XmlOutput import System.IO+import Control.Monad import Control.Monad.RWS import Text.PrettyPrint @@ -54,9 +72,9 @@ -- | Invokes 'tr_reportGlobalResults' on all test reporters registered. reportGlobalResults :: ReportGlobalResults-reportGlobalResults t l1 l2 l3 l4 =+reportGlobalResults arg = do reps <- asks tc_reporters- mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps+ mapM_ (\r -> tr_reportGlobalResults r arg) reps data IsParallel = Parallel | NonParallel @@ -144,7 +162,7 @@ reportTestResultHS :: ReportTestResult reportTestResultHS ftr = let res = rr_result (ft_payload ftr)- msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr))+ msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr)) in case res of Pass -> reportMessage Debug msg okSuffix@@ -188,30 +206,50 @@ reportStringTR Info (render (renderTestNames l)) reportGlobalResultsH :: ReportGlobalResults-reportGlobalResultsH t passedL pendingL failedL errorL =- do let passed = length passedL- pending = length pendingL- failed = length failedL- error = length errorL+reportGlobalResultsH arg =+ do let passed = length (rgra_passed arg)+ pending = length (rgra_pending arg)+ failed = length (rgra_failed arg)+ error = length (rgra_errors arg)+ timedOut = length (rgra_timedOut arg)+ filtered = length (rgra_filtered arg) total = passed + failed + error + pending- let pendings = colorize pendingColor "* Pending:"- failures = colorize warningColor "* Failures:"- errors = colorize warningColor "* Errors:"- reportTR Info ("* Tests: " +++ showC total +++ "\n" +++- "* Passed: " +++ showC passed +++ "\n" +++- pendings +++ " " +++ showC pending +++ "\n" +++- failures +++ " " +++ showC failed +++ "\n" +++- errors +++ " " +++ showC error)+ 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 pendingL))+ ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg))) when (failed > 0) $ reportTR Info- ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse failedL))+ ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg))) when (error > 0) $ reportTR Info- ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse errorL))- reportStringTR Info ("\nTotal execution time: " ++ show t ++ "ms")+ ("\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 =@@ -257,13 +295,13 @@ in reportJsonTR json reportGlobalResultsM :: ReportGlobalResults-reportGlobalResultsM t pass pending failed errors =- let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors)+reportGlobalResultsM arg =+ let json = mkTestResultsObj arg in reportJsonTR json reportGlobalResultsXml :: ReportGlobalResults-reportGlobalResultsXml t pass pending failed errors =- do let xml = mkGlobalResultsXml t pass pending failed errors+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
Test/Framework/TestTypes.hs view
@@ -1,24 +1,43 @@ {-# LANGUAGE FlexibleInstances #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {-| This module defines types (and small auxiliary functions) for organizing tests, for configuring the execution of tests, and for representing and reporting their results. +This functionality is mainly used internally in the code+generated by the @hftpp@ pre-processor. -} module Test.Framework.TestTypes ( -- * Organizing tests- TestID, Assertion, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),+ TestID, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..), TestSuite(..), TestSort(..), TestPath(..), GenFlatTest(..), FlatTest, TestFilter,- testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions,+ testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey, -- * Executing tests TR, TestState(..), initTestState, TestConfig(..), TestOutput(..), -- * Reporting results- ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults,+ ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..), TestReporter(..), emptyTestReporter, attachCallStack, CallStack, -- * Specifying results.@@ -28,14 +47,14 @@ import Test.Framework.Location import Test.Framework.Colors+import Test.Framework.History+import Test.Framework.TestInterface import Control.Monad.RWS import System.IO import Data.Maybe import qualified Data.List as List---- | An assertion is just an 'IO' action.-type Assertion = IO ()+import qualified Data.Text as T -- | Type for naming tests. type TestID = String@@ -91,6 +110,7 @@ -- | A type denoting the hierarchical name of a test. data TestPath = TestPathBase TestID | TestPathCompound (Maybe TestID) TestPath+ deriving (Show) -- | Splits a 'TestPath' into a list of test identifiers. testPathToList :: TestPath -> [Maybe TestID]@@ -130,19 +150,16 @@ , 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 --- | The summary result of a test.-data TestResult = Pass | Pending | Fail | Error- deriving (Show, Read, Eq)---- | A type synonym for time in milliseconds.-type Milliseconds = Int- -- | A type for call-stacks type CallStack = [(Maybe String, Location)] @@ -150,23 +167,18 @@ data RunResult = RunResult { rr_result :: TestResult -- ^ The summary result of the test.- , rr_location :: Maybe Location -- ^ The location where the test failed (if applicable).- , rr_callers :: CallStack -- ^ Information about the callers of the location where the test failed+ , 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 -> CallStack -> ColorString-attachCallStack msg callStack =- case reverse callStack of- [] -> msg- l -> ensureNewlineColorString msg +++- noColor (unlines (map formatCallStackElem l))- where- formatCallStackElem (mMsg, loc) =- " called from " ++ showLoc loc ++ (case mMsg of- Nothing -> ""- Just s -> " (" ++ s ++ ")")+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@@ -199,6 +211,14 @@ , 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@@ -206,10 +226,21 @@ showParen (prec > 0) $ showString "TestConfig { " . showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .--- showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+ showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .+ showString ", tc_shuffle=" . showsPrec 1 (tc_shuffle tc) . showString ", tc_output=" . showsPrec 1 (tc_output tc) .+ showString ", tc_outputXml=" . showsPrec 1 (tc_outputXml tc) . showString ", tc_filter=<filter>" . showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) .+ showString ", tc_useColors=" . showsPrec 1 (tc_useColors tc) .+ showString ", tc_historyFile=" . showsPrec 1 (tc_historyFile tc) .+ showString ", tc_history=" . showsPrec 1 (tc_history tc) .+ showString ", tc_sortByPrevTime=" . showsPrec 1 (tc_sortByPrevTime tc) .+ showString ", tc_failFast=" . showsPrec 1 (tc_failFast tc) .+ showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) .+ showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) .+ showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) .+ showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) . showString " }" -- | A 'TestReporter' provides hooks to customize the output of HTF.@@ -231,7 +262,7 @@ , tr_reportGlobalStart = \_ -> return () , tr_reportTestStart = \_ -> return () , tr_reportTestResult = \_ -> return ()- , tr_reportGlobalResults = \_ _ _ _ _ -> return ()+ , tr_reportGlobalResults = \_ -> return () } instance Show TestReporter where@@ -252,10 +283,16 @@ -- | Reports the result of a single test. type ReportTestResult = FlatTestResult -> TR () +data ReportGlobalResultsArg+ = ReportGlobalResultsArg+ { rgra_timeMs :: Milliseconds+ , rgra_passed :: [FlatTestResult]+ , rgra_pending :: [FlatTestResult]+ , rgra_failed :: [FlatTestResult]+ , rgra_errors :: [FlatTestResult]+ , rgra_timedOut :: [FlatTestResult]+ , rgra_filtered :: [FlatTest]+ }+ -- | Reports the overall results of all tests.-type ReportGlobalResults = Milliseconds -- ^ wall time in ms- -> [FlatTestResult] -- ^ passed tests- -> [FlatTestResult] -- ^ pending tests- -> [FlatTestResult] -- ^ failed tests- -> [FlatTestResult] -- ^ erroneous tests- -> TR ()+type ReportGlobalResults = ReportGlobalResultsArg -> TR ()
Test/Framework/ThreadPool.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-}+{- |+Internal module providing a pool of threads.+-} ----- Copyright (c) 2013 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@@ -19,7 +22,7 @@ module Test.Framework.ThreadPool ( - ThreadPoolEntry, ThreadPool(..), sequentialThreadPool, parallelThreadPool+ ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool , threadPoolTest ) where@@ -32,9 +35,16 @@ -- 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 () -- post-action, must not throw exceptions+ , 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@@ -46,19 +56,23 @@ parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) parallelThreadPool n =- do when (n < 1) $ fail ("invalid number of workers: " ++ show 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 =- mapM_ run 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 ()) | Done+data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m StopFlag) | Done instance Show (WorkItem m b) where show (Work _ _) = "Work"@@ -69,7 +83,7 @@ type ToWorker m b = NamedMVar (WorkItem m b) -data WorkResult m b = WorkResult (m ()) (ToWorker m b)+data WorkResult m b = WorkResult (m StopFlag) (ToWorker m b) instance Show (WorkResult m b) where show _ = "WorkResult"@@ -79,7 +93,7 @@ runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () runParallel _ [] = return () runParallel n entries =- do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+ 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]@@ -91,21 +105,23 @@ loop fromWorker nWorkers [] = cleanup fromWorker nWorkers loop fromWorker nWorkers (x:xs) =- do toWorker <- waitForWorkerResult fromWorker- runEntry x toWorker- loop fromWorker nWorkers 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+ (toWorker, _) <- waitForWorkerResult fromWorker liftIO $ putNamedMVar toWorker Done when (n > 1) $ cleanup fromWorker (n - 1)- waitForWorkerResult :: FromWorker m b -> m (ToWorker m b)+ waitForWorkerResult :: FromWorker m b -> m (ToWorker m b, StopFlag) waitForWorkerResult fromWorker = do WorkResult postAction toWorker <- liftIO $ readNamedChan fromWorker- postAction- return toWorker+ b <- postAction+ return (toWorker, b) runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m () runEntry (pre, action, post) toWorker = do a <- pre@@ -173,7 +189,7 @@ runTestParallel :: Int -> Int -> IO () runTestParallel nEntries n =- do putStrLn ("Running test " ++ show n)+ do debug ("Running test " ++ show n) boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i) return (mvar, i)) [1..nEntries]@@ -182,7 +198,7 @@ debug ("Checking boxes in test " ++ show n) --runSequentially entries mapM_ assertBox boxes- putStrLn ("Test " ++ show n ++ " successful")+ debug ("Test " ++ show n ++ " successful") where mkEntry (mvar, i) = let pre = myThreadId@@ -190,6 +206,7 @@ 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)
Test/Framework/Tutorial.hs view
@@ -1,3 +1,20 @@+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {- | This module provides a short tutorial on how to use the HTF. It assumes that you are using GHC for compiling your Haskell code. (It is@@ -5,18 +22,90 @@ taken to invoke the custom preprocessor of the HTF may differ in this case.) -We start with a simple example. Then we show how to use HTF to easily-collect test definitions from multiple modules and discuss-backwards-compatibility for projects already using `HUnit`. Finally,-we give a brief cookbook-like summary on how to setup your tests with HTF.- -} module Test.Framework.Tutorial ( +-- * Quickstart++{- |++For the impatient, we start with a brief cookbook-like summary and then go into details.+You should also have a look at the sample project at+<https://github.com/skogsbaer/HTF/tree/master/sample>.++-}++-- ** Writing tests++{- |++You should use the following skeleton for each module defining test cases:++@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+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:++@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main ( main ) where++-- Import modules defining HTF tests like this:+import {-@ HTF_TESTS @-} MyModule++main :: IO ()+main = htfMain htf_importedTests -- all tests in modules imported via {-@ HTF_TESTS @-} 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 : @@@ -54,13 +143,8 @@ prop_reverse xs = xs == (myReverse (myReverse xs)) @ -When @htfpp@ consumes the source file, it replaces the @assertEqual@-tokens (and other @assert@-like tokens, see-"Test.Framework.HUnitWrapper") with calls to-'assertEqual_', passing-the current location in the file as the first argument.-Moreover, the-preprocessor collects all top-level definitions starting with @test_@+When @htfpp@ consumes the source file, it+collects all top-level definitions starting with @test_@ or @prop_@ in a test suite of type 'TestSuite' and name @htf_@/M/@_thisModulesTests@, where /M/ is the name of the current module with dots @.@ replaced by underscores @_@. For your convenience, the preprocessor also defines the token @htf_thisModulesTests@@@ -88,10 +172,11 @@ Build-type: Simple Test-Suite tutorial- Type: exitcode-stdio-1.0- Main-is: Tutorial.hs- Build-depends: base == 4.*, HTF == 0.10.*- Default-language: Haskell2010+ 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@@ -207,7 +292,7 @@ split the tests into several modules. For example, suppose your library contains of two modules @MyPkg.A@ and @MyPkg.B@, each containing test functions. You can find a slightly extended of this scenario in the samples directory-of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>.)+of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>. File @MyPkg/A.hs@ @@ -243,9 +328,9 @@ For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules' testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a-preprocessor token @thisModulesTests@ as a shorthand for this variable.+preprocessor token @htf_thisModulesTests@ as a shorthand for this variable. Thus, to expose all HTF tests defined in @MyPkg.A@, we only-need to put @thisModulesTests@ into the export list. The same holds+need to put @htf_thisModulesTests@ into the export list. The same holds analogously for module @MyPkg.B@. To execute all tests defined in these two modules, you would create@@ -263,7 +348,6 @@ module Main where import Test.Framework-import Test.Framework.BlackBoxTest import {-@ HTF_TESTS @-} MyPkg.A import {-@ HTF_TESTS @-} MyPkg.B @@ -274,10 +358,14 @@ -- * Machine-readable output +-- ** JSON+ {- | For better integration with your testing environment, HTF provides the ability to produce-machine-readable output in JSON format. Here is a short example how the JSON output looks like,+machine-readable output in JSON format. The output is produced incrementally, line by line.++Here is a short example how the JSON output looks like, for details see "Test.Framework.JsonOutput": @@ -309,62 +397,44 @@ -} --- * Backwards-compatibility with HUnit--{- |-The types of the various @assert@-like macros of the HTF are not backwards-compatible-with the corresponding functions of HUnit. This incompatibility is intentional, of course:-with HUnit, the programmer has to provide suitable location information by explicitly-passing a string argument to the @assert@-like functions, whereas HTF provides-location information implicitly through its pre-processor @htfpp@.--To simplify transition from HUnit to HTF, @htfpp@ provides a commandline flag-@--hunit@. This flag causes @htfpp@ to exand the assertion macros in a way compatible-with the types of the corresponding HUnit functions. For example, with the @--hunit@-flag being present, @assertEqual@ is exanded to-@'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type-@(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with-the type of HUnit's 'Test.HUnit.Base.assertEqual' function.---}---- * Summary--{- |+-- ** XML -Here is a quick summary of how to write, collect, and execute your tests.-You should also have a look at the sample project at-<https://github.com/skogsbaer/HTF/tree/master/sample>.+{- | Machine-readable output is also available as XML, following the specification of the JUnit+output format. XML-output is requested by the @--xml=OUTPUT_FILE@ flag.+See "Test.Framework.XmlOutput" for details. -}---- ** Writing tests+-- * Commandline options {- | -* Place @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ at the top of your module.--* Put @htf_thisModulesTests@ into the export list of your module.--* Import @Test.Framework@.--* Prefix your unit tests with @test_@, see "Test.Framework.HUnitWrapper" for the assertions provided.--* Prefix your QuickCheck properties with @prop_@.---}---- ** Collecting and executing tests--{- |-* Place @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ at the top of your module.--* Import @Test.Framework@.+Here is the list of commandline options for programs using @htfMain@: -* Import modules defining HTF tests with @import {-@ HTF_TESTS @-} MyPkg.A@.+@+USAGE: COMMAND [OPTION ...] PATTERN ... -* Use @main = htfMain htf_importedTests@ to run all imported tests.+ where PATTERN is a posix regular expression matching+ the names of the tests to run. + -q --quiet Only display errors.+ -n PATTERN --not=PATTERN Tests to exclude.+ -l --list List all matching tests.+ -j[N] --threads[=N] Run N tests in parallel, default N=1.+ --shuffle=BOOL Shuffle test order. Default: false+ -o FILE --output-file=FILE Name of output file.+ --json Output results in machine-readable JSON format (incremental).+ --xml=FILE Output results in junit-style XML format.+ --split Splits results in separate files to avoid file locking (requires -o/--output-file).+ --colors=BOOL Use colors or not.+ --history=FILE Path to the history file. Default: ./.HTF/<ProgramName>.history+ --fail-fast Fail and abort test run as soon as the first test fails.+ --sort-by-prev-time Sort tests ascending by their execution of the previous test run (if available). Default: false+ --max-prev-ms=MILLISECONDS Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+ --max-cur-ms=MILLISECONDS Abort a test that runs more than MILLISECONDS.+ --prev-factor=DOUBLE Abort a test that runs more than DOUBLE times slower than in a previous run.+ --timeout-is-success Do not regard a test timeout as an error.+ --repeat=NUMBER Execute the tests selected on the command line NUMBER times.+ -h --help Display this message.+@ -}- ) where
Test/Framework/Utils.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----- Copyright (c) 2005, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -119,7 +120,11 @@ (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
Test/Framework/XmlOutput.hs view
@@ -1,27 +1,80 @@ {-# 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+-- {- | -See <http://pzolee.blogs.balabit.com/2012/11/jenkins-vs-junit-xml-format/>-for a description of the format used.+XML-output following the JUnit output format. -The source code of this module also contains a rough specification of-the output format in terms of Haskell data types.+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 ( - mkGlobalResultsXml+ 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 @@ -30,11 +83,13 @@ 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)+-- | 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@@ -166,29 +221,25 @@ , r_message = T.takeWhile (/= '\n') msg , r_type = elemName , r_textContent = msg }- msg = renderColorString (attachCallStack (rr_message payload) (rr_callers payload)) False+ msg = renderColorString (attachCallStack (rr_message payload) (rr_stack payload)) False millisToSeconds :: Milliseconds -> Seconds millisToSeconds millis = fromInteger (toInteger millis) / 1000.0 -mkGlobalResultsXml :: Milliseconds -- ^ wall time in ms- -> [FlatTestResult] -- ^ passed tests- -> [FlatTestResult] -- ^ pending tests- -> [FlatTestResult] -- ^ failed tests- -> [FlatTestResult] -- ^ erroneous tests- -> BSL.ByteString-mkGlobalResultsXml t pass pending failed errors =- let nPassed = length pass- nPending = length pending- nFailed = length failed- nErrors = length errors- byModules = groupByModule (pass ++ pending ++ failed ++ errors)+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 t+ , tss_time = millisToSeconds (rgra_timeMs arg) , tss_suites = suites } in renderAsXml (JunitXmlOutput root)
− run-all-tests-for-all-compilers.sh
@@ -1,40 +0,0 @@-#!/bin/bash--compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal | tr -d ,)--for x in $compilers-do- switch-ghc $x > /dev/null- ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g')- if [ "$x" != "$ghc_version" ]- then- echo "Could not switch to GHC version $x as requested, version is now $ghc_version"- exit 1- fi- echo- echo- echo "============================================================"- echo "============================================================"- echo "==> Running tests for GHC version $ghc_version <=="- echo "==> Running tests for GHC version $ghc_version <=="- echo "==> Running tests for GHC version $ghc_version <=="- echo "============================================================"- echo "============================================================"- echo- ./run-all-tests.sh- ecode=$?- if [ $ecode -eq 0 ]- then- result="ok"- else- result="FAIL"- fi- RESULT="$RESULT\nResult for GHC version $ghc_version: $result"- if [ $ecode -ne 0 ]- then- exit 1- fi-done--echo-echo -e $RESULT
− run-all-tests.sh
@@ -1,14 +0,0 @@-#!/bin/bash--set -e-ghc-pkg unregister HTF || true--cabal configure --enable-tests || exit 1-cabal build || exit 1-cabal test || exit 1-cabal install || exit 1--cd sample-cabal configure --enable-tests || exit 1-cabal build || exit 1-cabal test || exit 1
sample/TestMain.hs view
@@ -9,5 +9,5 @@ import {-@ HTF_TESTS @-} MyPkg.B main =- do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs+ do bbts <- blackBoxTests "bbt-dir" "../scripts/run-sample" ".num" defaultBBTArgs htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts])
sample/sample-HTF.cabal view
@@ -1,6 +1,7 @@ name: sample-HTF version: 0.1.0.0 synopsis: Sample project showing how to use HTF+description: Sample project showing how to use HTF homepage: https://github.com/skogsbaer/HTF/ license: BSD3 license-file: LICENSE@@ -13,12 +14,14 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B- build-depends: base, HTF == 0.11.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B- build-depends: base, HTF == 0.11.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp
+ scripts/check.sh view
@@ -0,0 +1,40 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+ echo "Checks that HTF compiles against all resolvers mentioned in .travis.yml"+ exit 1+fi++set -e++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+TRAVIS="$TOP/.travis.yml"+if [ ! -e "$TRAVIS" ]; then+ echo "$TRAVIS does not exist!"+ exit 1+fi++YAMLS=$(grep '^- HTF_TEST_STACK_ARGS' "$TRAVIS" | sed 's/^.*="--stack-yaml //g; s/"$//g')++if [ -z "$TRAVIS_BUILD_DIR" ]; then+ export TRAVIS_BUILD_DIR="$TOP"+fi++for yaml in $YAMLS; do+ echo >&2+ eval yaml="$yaml" # evaluate variables contained in $yaml+ echo >&2 "Checking with $yaml ..."+ export HTF_TEST_STACK_ARGS="--stack-yaml $yaml"+ stack $HTF_TEST_STACK_ARGS build+ ecode=$?+ if [ $ecode -ne 0 ]; then+ echo >&2 "Build for $yaml failed!"+ exit 1+ fi+ stack $HTF_TEST_STACK_ARGS test+ ecode=$?+ if [ $ecode -ne 0 ]; then+ echo >&2 "Test for $yaml failed!"+ exit 1+ fi+done
+ scripts/dist.sh view
@@ -0,0 +1,50 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+ echo "USAGE: $0 [--no-check]"+ echo "Creates an dist tarball and checks that it builds."+ exit 1+fi++no_check=no+if [ "$1" == "--no-check" ]; then+ no_check=yes+fi++version=$(gawk -F: '/^Version:/ { print $2 }' HTF.cabal | sed 's/ //g')++echo "Building version $version"++# Somehow, --test-tarball always because of a strange permission error. That's why+# we do the checks here by hand.++stack sdist . --no-test-tarball || exit 1+tarball=$(find $(pwd)/.stack-work/dist -name "*${version}.tar.gz" | xargs ls -t | head -1)++echo "Distribution tarball is $tarball"++tmp=$(mktemp -d)+tar -C "$tmp" -x -z -f "$tarball" || exit 1++if [ "$no_check" == "yes" ]; then+ echo "Skipping tests as requested"+else+ pushd "${tmp}/HTF-${version}" > /dev/null+ echo "Running checks in directory $(pwd)"+ scripts/check.sh || exit 1+ popd > /dev/null+fi++git_tag="release/${version}"+if ! git tag --points-at HEAD | grep -E "^$git_tag$" > /dev/null; then+ git tag "$git_tag" || exit 1+ echo "Tagged HEAD with $git_tag"+fi++echo+echo+echo 'All checks succeeded, now upload to archive using the following command:'+echo '$ stack upload . --no-test-tarball'+echo+echo 'And do not forget to push all tags:'+echo '$ git push --tags'
+ scripts/local-htfpp view
@@ -0,0 +1,36 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)++if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_TEST_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_TEST_STACK_YAML"+fi+if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_STACK_YAML"+fi++dist=$(stack $HTF_TEST_STACK_ARGS path --dist-dir 2> /dev/null)+find=find+if [ "$(uname)" == "Darwin" ]; then+ find=gfind+fi++function find_bin()+{+ local d="$TOP/$dist"+ if [ ! -d "$d" ]; then+ d="$(dirname $d)"+ fi+ bin=$($find "$d" -name htfpp -type f -executable -printf "%T+\t%p\n" | sort -r | head -1 | cut -f 2)+}++find_bin++if [ -z "$bin" ]; then+ echo "TOP=$TOP" >&2+ echo "dist=$dist" >&2+ echo "bin=$bin" >&2+ echo "No executable named htfpp found in $TOP/$dist. Aborting!" >&2+ exit 1+fi+"$bin" "$@"
+ scripts/prepare view
@@ -0,0 +1,6 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+echo "Preparing everything for building ..."+chmod 755 "$TOP/scripts/local-htfpp"+echo "Done with preparing!"
+ scripts/run-sample view
@@ -0,0 +1,3 @@+#!/bin/bash++stack exec sample -- "$@"
+ stack-ghc-8.10.yaml view
@@ -0,0 +1,4 @@+resolver: lts-18.28+flags: {}+packages:+- '.'
+ stack-ghc-8.2.yaml view
@@ -0,0 +1,5 @@+resolver: lts-11.22+flags: {}+packages:+- '.'+extra-deps: []
+ stack-ghc-8.4.yaml view
@@ -0,0 +1,6 @@+resolver: lts-12.26+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ stack-ghc-8.6.yaml view
@@ -0,0 +1,6 @@+resolver: lts-14.27+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ stack-ghc-8.8.yaml view
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
+ stack-ghc-9.0.yaml view
@@ -0,0 +1,4 @@+resolver: lts-19.33+flags: {}+packages:+- '.'
+ stack-ghc-9.2.yaml view
@@ -0,0 +1,4 @@+resolver: lts-20.12+flags: {}+packages:+- '.'
+ stack-ghc-9.4.yaml view
@@ -0,0 +1,4 @@+resolver: lts-21.25+flags: {}+packages:+- '.'
+ stack.yaml view
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
tests/Foo/A.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} {-# LANGUAGE CPP #-} module Foo.A where@@ -7,5 +7,5 @@ #include "test.h" -test_a =+test_a_FAIL = assertEqual x y
tests/Foo/B.hs view
@@ -1,7 +1,7 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Foo.B (htf_thisModulesTests) where import qualified Test.Framework as HTF -test_b = assertEqual 1 1+test_b_OK = HTF.assertEqual 1 1
tests/Foo/test.h view
@@ -4,3 +4,6 @@ y :: Int y = 2++test_h_FAIL =+ assertEqual 4 5
+ tests/MiscTest.hs view
@@ -0,0 +1,38 @@+--+-- Copyright (c) 2013 Stefan Wehr - http://www.stefanwehr.de+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++import Test.Framework.History+import Test.Framework.Preprocessor+import Test.Framework.PrettyHaskell+import Test.Framework.HUnitWrapper+import Test.Framework.TestManager+import System.Exit+import Test.HUnit++allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests ++ wrappableTests++main :: IO ()+main =+ do counts <- runTestTT hunitTests+ if errors counts /= 0 || failures counts /= 0+ then exitWith (ExitFailure 1)+ else exitWith ExitSuccess+ where+ hunitTests =+ TestList (map (\(name, code) -> TestLabel name (TestCase code)) allTests)
+ tests/Quasi.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+module Quasi where++import Language.Haskell.TH.Quote+import GHC.Exts (IsString(..))++q :: QuasiQuoter+q = QuasiQuoter exprQ undefined undefined undefined+ where+ exprQ =+ (\a -> [|fromString a|]) . filter (/= '\r')
tests/TestHTF.hs view
@@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} -- -- Copyright (c) 2005,2010 Stefan Wehr - http://www.stefanwehr.de --@@ -23,6 +29,7 @@ import Test.Framework.Location import Test.Framework.TestManager import Test.Framework.BlackBoxTest+import Test.Framework.TestInterface import System.Environment import System.Directory@@ -33,18 +40,39 @@ import System.IO.Temp import Control.Exception import Control.Monad-import qualified Data.HashMap.Strict as M++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif+import qualified Data.HashSet as Set import qualified Data.Aeson as J+import qualified Data.Aeson.Encode.Pretty as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.List as List import qualified Text.Regex as R-import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible+import GHC.Stack+ import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B +import FailFast+import MaxCurTime+import MaxPrevTime+import UniqTests1+import UniqTests2+import PrevFactor+import Repeat+import SortByPrevTime+import Quasi+ import Tutorial hiding (main) data T = A | B@@ -58,41 +86,53 @@ handleExc :: a -> SomeException -> a handleExc x _ = x -test_assertFailure =- assertFailure "I'm a failure"+-- 世界不是英文的 Test for #47 -test_stringGap = assertEqual stringGap "hello world!"+-- Test for #48+data HVect (ts :: [*]) where+ HNil :: HVect '[]+ HCons :: t -> HVect ts -> HVect (t ': ts) -test_assertEqual = assertEqual 1 2+fun :: HVect '[Int, Int] -> String+fun = undefined -test_assertEqualV = assertEqualVerbose "blub" 1 2+-- Test for #45+foobar = [q|INSERT INTO a (name) VALUES ('')|] -test_assertEqualNoShow = withOptions (\opts -> opts { to_parallel = False }) $- assertEqualNoShow A B+test_assertFailure_FAIL = assertFailure "I'm a failure" -test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2]+test_stringGap_OK = assertEqual stringGap "hello world!" -test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1]+test_assertEqual_FAIL = assertEqual 1 2 -test_assertNotEmpty = assertNotEmpty []+test_assertEqualV_FAIL = assertEqualVerbose "blub" 1 2 -test_assertEmpty = assertEmpty [1]+test_assertEqualNoShow_FAIL = withOptions (\opts -> opts { to_parallel = False }) $+ assertEqualNoShow A B -test_assertElem = assertElem 1 [0,2,3]+test_assertListsEqualAsSets_FAIL = assertListsEqualAsSets [1,2] [2] -test_assertThrows = assertThrows (return () :: IO ()) (handleExc True)+test_assertSetEqualSuccess_OK = assertListsEqualAsSets [1,2] [2,1] -test_assertThrows' = assertThrows (error "ERROR") (handleExc False)+test_assertNotEmpty_FAIL = assertNotEmpty [] -test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False)+test_assertEmpty_FAIL = assertEmpty [1] -test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True)+test_assertElem_FAIL = assertElem 1 [0,2,3] -test_someError = error "Bart Simpson!!" :: IO ()+test_assertThrows_FAIL = assertThrows (return () :: IO ()) (handleExc True) -test_pendingTest = unitTestPending "This test is pending"+test_assertThrows'_FAIL = assertThrows (error "ERROR") (handleExc False) -test_subAssert = subAssert anotherSub+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)@@ -103,7 +143,7 @@ | Variable String deriving (Eq, Show) -test_diff =+test_diff_FAIL = assertEqual (mkExpr 1) (mkExpr 2) where mkExpr i =@@ -113,105 +153,269 @@ (Literal 581)) (Variable "egg") -prop_ok :: [Int] -> Property-prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs))+test_diff2_FAIL =+ assertEqual s1 s2+ where+ n = 100000+ s1 = mk [0..n]+ s2 = mk ([0..4999] ++ [5001..n])+ mk :: [Int] -> String+ mk [] = ""+ mk (x:[]) = "line " ++ show x+ mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_fail :: [Int] -> Bool-prop_fail xs = xs == (reverse xs)+test_diff3_FAIL =+ assertEqual s1 s2+ where+ n = 100000+ s1 = mk [0..n]+ s2 = mk [0..(n+1)]+ mk :: [Int] -> String+ mk [] = ""+ mk (x:[]) = "line " ++ show x+ mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_pendingProp :: Int -> Bool-prop_pendingProp x = qcPending "This property is pending" (x == 0)+prop_ok_OK :: [Int] -> Property+prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) -prop_exhaust = False ==> True+prop_fail_FAIL :: [Int] -> Bool+prop_fail_FAIL xs = xs == (reverse xs) -prop_error :: Bool-prop_error = error "Lisa"+prop_pendingProp_PENDING :: Int -> Bool+prop_pendingProp_PENDING x = qcPending "This property is pending" (x == 0) +prop_exhaust_FAIL = False ==> True++prop_implies :: Int -> Property+prop_implies n = n <= 10 ==> (\i -> i + n <= i + 10)++prop_forAll = forAll (choose (0::Int, 10::Int)) (\i -> i < 11)++prop_error_FAIL :: Bool+prop_error_FAIL = error "Lisa"+ changeArgs args = args { maxSuccess = 1 } -prop_ok' = withQCArgs (\a -> a { maxSuccess = 1}) $- \xs -> classify (null xs) "trivial" $- (xs::[Int]) == (reverse (reverse xs))+prop_ok'_OK = withQCArgs (\a -> a { maxSuccess = 1}) $+ \xs -> classify (null xs) "trivial" $+ (xs::[Int]) == (reverse (reverse xs)) -prop_fail' =- withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop+prop_fail'_FAIL =+ prop where prop xs = xs == (reverse xs) where types = xs::[Int] -prop_error' :: WithQCArgs Bool-prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool)+prop_error'_FAIL :: WithQCArgs Bool+prop_error'_FAIL = withQCArgs changeArgs $ (error "Lisa" :: Bool) -test_genericAssertions =+test_genericAssertions_OK = case test1 of AssertOk _ -> fail "did not expect AssertOk"- AssertFailed stack ->- do assertEqual 2 (length stack)- let [se1, se2] = stack- assertNothing (ase_message se1)- loc1 <- assertJust (ase_location se1)- _ <- assertJust (ase_message se2)- loc2 <- assertJust (ase_location se2)+ 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 + 1) (lineNumber loc2)+ assertEqual (lineNumber loc1) (line - 1)+ assertEqual (lineNumber loc2) (line - 3)+ assertNotEqual msg "" where- test1 = gsubAssert test2- test2 = gassertEqual 1 (2::Int)+ 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 (31::Int)- ,"passed" .= J.toJSON (13::Int)- ,"pending" .= J.toJSON (2::Int)- ,"errors" .= J.toJSON (1::Int)])+ (J.object ["failures" .= J.toJSON (length failedTests)+ ,"passed" .= J.toJSON (length passedTests)+ ,"pending" .= J.toJSON (length pendingTests)+ ,"errors" .= J.toJSON (length errorTests)+ ,"timedOut" .= J.toJSON (length timedOutTests)]) check jsons (J.object ["type" .= J.String "test-end"- ,"test" .= J.object ["flatName" .= J.String "Main:diff"]])+ ,"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::Int)]]+ ,"line" .= J.toJSON (106+lineOffset)]] ,"location" .= J.object ["file" .= J.String "TestHTF.hs"- ,"line" .= J.toJSON (107::Int)]])+ ,"line" .= J.toJSON (107+lineOffset)]]) check jsons (J.object ["type" .= J.String "test-end"- ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]])+ ,"test" .= J.object ["flatName" .= J.String "Main:diff2_FAIL"]])+ (J.object ["message" .= J.String "NOT:No newline at end of file"])+ check jsons (J.object ["type" .= J.String "test-end"+ ,"test" .= J.object ["flatName" .= J.String "Main:diff3_FAIL"]])+ (J.object ["message" .= J.String "NOT:No newline at end of file"])+ check jsons (J.object ["type" .= J.String "test-end"+ ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]]) (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs" ,"line" .= J.toJSON (10::Int)]] ,"location" .= J.object ["file" .= J.String "./Foo/A.hs" ,"line" .= J.toJSON (11::Int)]]) check jsons (J.object ["type" .= J.String "test-end"- ,"test" .= J.object ["flatName" .= J.String "Main:subAssert"]])- (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null+ ,"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 (95::Int)]]- ,J.object ["message" .= J.String "I'm another sub"+ ,"line" .= J.toJSON (97+lineOffset)]]+ ,J.object ["message" .= J.Null ,"location" .= J.object ["file" .= J.String "TestHTF.hs"- ,"line" .= J.toJSON (97::Int)]]]])+ ,"line" .= J.toJSON (95+lineOffset)]]]]) where+ lineOffset :: Int+ lineOffset = 40+ checkStatus tuple@(pass, fail, error, pending, timedOut) json =+ {-+ {"location":null+ ,"test":{"path":["Main","tests/bbt/should_pass/stdin_ok.x"],"sort":"blackbox-test","flatName":"Main:tests/bbt/should_pass/stdin_ok.x"}+ ,"callers":[]+ ,"result":"pass"+ ,"timedOut":false+ ,"type":"test-end"+ ,"message":""+ ,"wallTime":11}+ -}+ case json of+ J.Object objJson | Just (J.Object testObj) <- KM.lookup "test" objJson+ , Just (J.String flatName) <- KM.lookup "flatName" testObj+ , Just (J.String "test-end") <- KM.lookup "type" objJson+ , Just (J.String result) <- KM.lookup "result" objJson+ , Just (J.Bool to) <- KM.lookup "timedOut" objJson ->+ let shortName =+ let t = T.tail (T.dropWhile (/= ':') flatName)+ in if "tests/" `T.isPrefixOf` t+ then T.drop (T.length "tests/") t+ else t+ newTimedOut = if to then shortName : timedOut else timedOut+ in case () of+ _| result == "pass" -> (shortName : pass, fail, error, pending, newTimedOut)+ _| result == "fail" -> (pass, shortName : fail, error, pending, newTimedOut)+ _| result == "error" -> (pass, fail, shortName : error, pending, newTimedOut)+ _| result == "pending" -> (pass, fail, error, shortName : pending, newTimedOut)+ _ -> tuple+ checkAsSet what expList givenList =+ let expSet = Set.fromList expList+ givenSet = Set.fromList givenList+ in if expSet == givenSet+ then return ()+ else do let unexpected = givenSet `Set.difference` expSet+ notGiven = expSet `Set.difference` givenSet+ fail ("Mismatch for " ++ what ++ ":" +++ "\nExpected: " ++ show expList +++ "\nGiven: " ++ show givenList +++ "\nUnexpected elements: " ++ show unexpected +++ "\nElements expected but not present: " ++ show notGiven) check jsons pred assert = case filter (\j -> matches j pred) jsons of [json] -> if not (matches json assert)- then error ("Predicate " ++ show pred ++ " match JSON " ++ show json ++ ", but assertion " ++- show assert ++ " not satisfied")+ then error ("Predicate\n" ++ ppJ pred ++ " match JSON\n" ++ ppJ json ++ ", but assertion\n" +++ ppJ assert ++ " not satisfied") else return () l -> error ("not exactly one JSON matches predicate " ++ show pred ++ " but " ++ show l) matches :: J.Value -> J.Value -> Bool matches json pred = case (json, pred) of (J.Object objJson, J.Object objPred) ->- M.foldrWithKey (\k vPred b ->- b && case M.lookup k objJson of+ KM.foldrWithKey (\k vPred b ->+ b && case KM.lookup k objJson of Just vJson -> matches vJson vPred Nothing -> False) True objPred (J.String strJson, J.String strPred) ->- regexMatches (mkRegex strPred) strJson+ regexMatches strPred strJson (arrJson@(J.Array _), arrPred@(J.Array _)) -> let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson J.Success (listPred :: [J.Value]) = J.fromJSON arrPred in length listJson == length listPred && all (\(x, y) -> matches x y) (zip listJson listPred) _ -> json == pred- regexMatches r s = isJust $ R.matchRegex r (T.unpack s)+ regexMatches pred t =+ let s = T.unpack t+ in case T.unpack pred of+ 'N':'O':'T':':':rest -> isNothing $ R.matchRegex (mkRegex (T.pack rest)) s+ _ -> isJust $ R.matchRegex (mkRegex pred) s mkRegex s = R.mkRegexWithOpts (T.unpack s) True False splitJson bsl = if BSL.null bsl@@ -223,7 +427,22 @@ else case splitJson rest of [] -> error "invalid json output from HTF" (x:xs) -> (start `BSL.append` x : xs)+ ppJ json =+ T.unpack $+ T.decodeUtf8With T.lenientDecode $+ BSL.toStrict $+ J.encodePretty' J.defConfig json +runRealBlackBoxTests =+ do b <- doesDirectoryExist "tests/bbt"+ let dirPrefix = if b then "tests" else ""+ bbts <- blackBoxTests (dirPrefix </> "real-bbt") ("/bin/bash") ".sh"+ (defaultBBTArgs { bbtArgs_verbose = True })+ ecode <- runTest bbts+ case ecode of+ ExitFailure _ -> fail ("real blackbox tests failed!")+ _ -> return ()+ main = do args <- getArgs b <- doesDirectoryExist "tests/bbt"@@ -232,10 +451,19 @@ (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests when ("--help" `elem` args || "-h" `elem` args) $- do hPutStrLn stderr ("USGAGE: dist/build/test/test [--direct]")+ 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@@ -244,12 +472,11 @@ _ -> do withSystemTempFile "HTF-out" $ \outFile h -> do hClose h- ecode <- runTestWithArgs ["-j4", "--deterministic",+ ecode <- runTestWithArgs ["-j4", "--shuffle=false", "--json", "--output-file=" ++ outFile] tests case ecode of ExitFailure _ -> checkOutput outFile _ -> fail ("unexpected exit code: " ++ show ecode) `onException` (do s <- readFile outFile hPutStrLn stderr s)- ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")- exitWith ecode+ runRealBlackBoxTests
− tests/TestHTFHunitBackwardsCompatible.hs
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp -optF --hunit #-}-module TestHTFHunitBackwardsCompatible where--import Test.Framework--test_1 = do assertEqual "1 == 2" 1 2- assertEqualHTF 1 1--test_2 = do assertJust "foo" (Just 1)- assertJustHTF (Just 1)
tests/Tutorial.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Tutorial where import System.Environment ( getArgs )
+ tests/bbt/should_fail/not_ok_because_stderr2.err view
+ tests/bbt/should_fail/not_ok_because_stdout2.out view
+ tests/bbt/should_pass/not_ok_because_stderr2.err view
+ tests/bbt/should_pass/not_ok_because_stdout2.out view
tests/compile-errors/Test1.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int
tests/compile-errors/Test2.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int foo i = i + "Stefan"
tests/compile-errors/Test3.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework -- error must be in line 7 test_foo :: Int
tests/compile-errors/Test4.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework data D = D -- error must be in line 7 prop_foo :: D -> Bool
tests/compile-errors/run-tests.sh view
@@ -2,20 +2,27 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package base -package-conf ../../dist/package.conf.inplace -package HTF --make" lineno=7- function check() { test="$1"- ghc $FLAGS "$test" 2>&1 | grep "$test":$lineno+ echo "Running test $test ..."+ command -v grep >/dev/null 2>&1 || \+ { echo >&2 "Test $0 requires ``grep'' but it's not installed. Aborting."; exit 1; }+ compile_cmd="stack $HTF_TEST_STACK_ARGS ghc --package HTF -- -XPackageImports $test"+ $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null grep_ecode=${PIPESTATUS[1]} if [ "$grep_ecode" != "0" ] then echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"- ghc $FLAGS "$test"+ echo "Compile command: $compile_cmd"+ echo "Stack version: $(stack --version)"+ echo "GHC version: $(stack $HTF_TEST_STACK_ARGS ghc -- --version)"+ echo "Here is the output of the compiler:"+ $compile_cmd exit 1 fi+ echo "Done with test $test" } check Test1.hs
+ tests/real-bbt/FailFast.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module FailFast (failFastMain) where++import Test.Framework++test_1 = assertEqual 1 2+test_2 = assertEqual 1 2++failFastMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxCurTime.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module MaxCurTime (maxCurTimeMain) where++import Test.Framework+import Control.Concurrent+import System.IO.Unsafe++test_slow :: IO ()+test_slow = threadDelay 20000++prop_verySlow :: Int -> Bool+prop_verySlow _i = unsafePerformIO test_slow `seq` True++maxCurTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module MaxPrevTime (maxPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 20000++test_fast :: IO ()+test_fast = return ()++maxPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/PrevFactor.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module PrevFactor (prevFactorMain) where++import Test.Framework+import Test.Framework.TestManager+import System.Environment+import System.Exit+import Control.Concurrent++doTest :: Bool -> IO ()+doTest slow =+ if slow then threadDelay 100000 else threadDelay 1000++prevFactorMain args =+ do ecode <-+ case args of+ "SLOW":rest -> runTestWithArgs rest [doTest True]+ _ -> runTestWithArgs args [doTest False]+ exitWith ecode
+ tests/real-bbt/Repeat.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module Repeat (repeatMain) where++import Test.Framework++import Data.IORef+import System.IO.Unsafe++globalBool :: IORef Bool+globalBool = unsafePerformIO (newIORef True)+{-# NOINLINE globalBool #-}++readGlobalBool :: IO Bool+readGlobalBool =+ do b <- readIORef globalBool+ writeIORef globalBool False+ return b++test_globalMVarIsTrue =+ do b <- readGlobalBool+ assertEqual b True++repeatMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/SortByPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module SortByPrevTime (sortByPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 300000++test_fast :: IO ()+test_fast = return ()++sortByPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests1.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module UniqTests1 (uniqTests1Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast = return ()++uniqTests1Main args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests2.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-}+module UniqTests2 (uniqTests2Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast =+ let l =+ flip map [True, False] $ \case+ True -> 1+ False -> 2+ in putStrLn (show l)++uniqTests2Main args = htfMainWithArgs args htf_thisModulesTests
− tests/run-tests.sh
@@ -1,18 +0,0 @@-#!/bin/bash--if [ "$1" != "--no-clean" ]-then- cabal clean || exit 1-fi-mkdir -p dist/build/htfpp || exit 1-pushd ..-cabal build || exit 1-popd-cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1-cabal-1.16.0 configure || exit 1-cabal-1.16.0 build || exit 1-dist/build/test/test || exit 1-echo "Tests ok"--./compile-errors/run-tests.sh || exit 1-echo "Line numbers in compile errors ok"
− tests/test-HTF.cabal
@@ -1,41 +0,0 @@-Name: test-HTF-Version: 0.1-Cabal-Version: >= 1.10-Build-type: Simple--Executable test- Main-is: TestHTF.hs- Build-depends: base >= 4,- bytestring >= 0.9,- aeson >= 0.6,- unordered-containers >= 0.2,- temporary >= 1.1,- text >= 0.11,- directory >= 1.0,- filepath >= 1.1,- process >= 1.0,- regex-compat >= 0.92,- random,- mtl,- pretty,- containers,- xmlgen,- unix,- array,- old-time,- lifted-base,- monad-control,- HUnit,- QuickCheck,- Diff,- haskell-src-exts,- base64-bytestring- Default-language: Haskell2010- Ghc-options: -threaded- Hs-source-dirs: ., ..--Test-Suite tutorial- Type: exitcode-stdio-1.0- Main-is: Tutorial.hs- Build-depends: base >= 4, HTF == 0.10.*- Default-language: Haskell2010