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