diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,91 @@ +* 0.15.0.1 + - Fix build for mtl-2.3 #118 + +* 0.15.0.0 + - Remove macros for assertions, location information is now provided + via HasCallStack. For most users, this change should be backwards compatible. + However, if you imported Test.Framework qualified, then all assert macros + where previously in scope unqualified, through macros. In this case, you need to + import Test.Framework unqualified or qualify all uses of assert macros. + - The modules Test.Framework.CmdlineOptions, Test.Framework.Colors, + and Test.Framework.TestReporter are no longer exposed. I don't think that + anyone depends on these internal modules. Let me know I am wrong. + +* 0.14.0.7 (2022-03-03) + - several upper bounds for packages + - minor improvements + +* 0.14.0.5 (2021-01-26) + - make sure htfpp is available before running the tests + +* 0.14.0.4 (2021-01-26) + - fix #99 + - hopefully fix #97 + +* 0.14.0.2 (2019-11-27) + - use haskell-src from hackage + +* 0.14.0.1 (2019-11-27) + - find cpphs + +* 0.14.0.0 (2019-11-26) + - support for GHC 8.8 + - fix for performance problem with long strings + https://github.com/skogsbaer/HTF/issues/85 + +* 0.13.2.5 (2018-11-06) + - fix build problem with quickcheck: + https://github.com/skogsbaer/HTF/issues/70 + - fix some compiler warnings + - support for GHC 8.6 + +* 0.13.2.4 (2018-03-31) + - fix build for ghc 8.4 + +* 0.13.2.{0,1,2} (2017-08-06) + - various build and documentation fixes and improvements + +* 0.13.1.0 (2015-08-21) + - resolved compile error with HUnit == 1.3.0.0 + +* 0.13.0.0 (2015-08-21) + - use cpphs for lexing (fixes many bugs related to lexing) + +* 0.12.2.4 (2015-03-22) + - fixed bug that caused double quoted strings to appear in the output + of error messages produced by assertEqual and co. + +* 0.12.2.3 (2014-10-27) + - fixed another lexing bug (issue #45) + +* 0.12.2.2 (2014-10-22) + - fixed lexing bug (some source files were not parsed properly) + - fixed bug where wrong module name was generated + - fixed source distribution (not all files were included) + +* 0.12.2.1 (2014-10-19) + - fixed compile error with QuickCheck == 2.6 + +* 0.12.2.0 (2014-10-18) + - drop dependency on haskell-src-exts (took too long to compile) + - only color error counts if they are > 0 (thanks to Matthias Fischmann) + +* 0.12.1.0 (2014-09-16) + - support for haskell-src-exts version 1.16 + - Functor and Applicative instances for AssertBool + +* 0.12.0.0 (2014-07-14) + - support for several new commandline options: + --history=FILE Path to the history file. Default: ./.HTF/.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 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.11.4.0 -License: LGPL +Version: 0.15.0.2 +License: LGPL-2.1 License-File: LICENSE -Copyright: (c) 2005-2012 Stefan Wehr -Author: Stefan Wehr -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,85 +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.4.2, - GHC==7.6.2 Build-Type: Simple -Cabal-Version: >= 1.10 + Extra-Source-Files: README.md - TODO.org ChangeLog + stack.yaml + stack-ghc-8.2.yaml + stack-ghc-8.4.yaml + stack-ghc-8.6.yaml + stack-ghc-8.8.yaml + stack-ghc-8.10.yaml + stack-ghc-9.0.yaml + stack-ghc-9.2.yaml + stack-ghc-9.4.yaml tests/bbt/should_fail/BBTArgs - -- tests/bbt/should_fail/*.in tests/bbt/should_fail/*.err tests/bbt/should_fail/*.out tests/bbt/should_fail/*.x @@ -106,8 +64,6 @@ tests/Foo/test.h tests/Tutorial.hs tests/run-bbt.sh - tests/test-HTF.cabal - tests/run-tests.sh tests/compile-errors/Foo.h tests/compile-errors/run-tests.sh tests/compile-errors/Test1.hs @@ -127,110 +83,152 @@ sample/bbt-dir/should-fail/z.num sample/bbt-dir/should-pass/x.num sample/bbt-dir/should-pass/x.out - run-all-tests-for-all-compilers.sh - run-all-tests.sh + scripts/local-htfpp + scripts/dist.sh + scripts/check.sh + scripts/run-sample + scripts/prepare + +tested-with: + GHC == 9.4.4 + GHC == 9.2.6 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + Source-Repository head Type: git Location: http://github.com/skogsbaer/HTF.git Executable htfpp Main-Is: HTFPP.hs - Build-Depends: cpphs >= 1.12, - haskell-src-exts >= 1.14, - old-time >= 1.0, - directory >= 1.0, + Build-Depends: HUnit, array, + base >= 4.10 && < 5, + cpphs >= 1.19, + directory >= 1.0, + mtl >= 1.1, + old-time >= 1.0, random >= 1.0, - base == 4.*, - text + text >= 0.11, + HTF + Build-tool-depends: cpphs:cpphs >= 1.19 Other-Modules: + Paths_HTF + Test.Framework.Location Test.Framework.Preprocessor - Test.Framework.HaskellParser + Autogen-modules: + Paths_HTF Default-language: Haskell2010 Library - Build-Depends: + Build-Depends: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3, - base == 4.*, - random >= 1.0, - containers >= 0.4.2.1, - process >= 1.0, + aeson >= 0.11, + array, + base >= 4.10 && < 5, + base64-bytestring, + bytestring >= 0.9, + containers >= 0.5, + cpphs >= 1.19, + haskell-src, directory >= 1.0, - mtl >= 1.1, - monad-control >= 0.3, lifted-base >= 0.1, + monad-control >= 0.3, + mtl >= 1.1, + old-time >= 1.0, pretty >= 1.0, - Diff >= 0.3, - bytestring >= 0.9, + process >= 1.0, + random >= 1.0, regex-compat >= 0.92, - haskell-src-exts >= 1.11, - aeson >= 0.6, text >= 0.11, - old-time >= 1.0, - array, - xmlgen >= 0.6, - base64-bytestring + time, + vector, + xmlgen >= 0.6 if !os(windows) Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework + Test.Framework.AssertM + Test.Framework.BlackBoxTest Test.Framework.HUnitWrapper + Test.Framework.History + Test.Framework.JsonOutput + Test.Framework.Location + Test.Framework.Preprocessor + Test.Framework.Pretty + Test.Framework.PrettyHaskell + Test.Framework.QuickCheckWrapper + Test.Framework.TestInterface Test.Framework.TestManager Test.Framework.TestTypes - Test.Framework.TestReporter - Test.Framework.CmdlineOptions - Test.Framework.QuickCheckWrapper - Test.Framework.BlackBoxTest - Test.Framework.Location + Test.Framework.ThreadPool Test.Framework.Tutorial - Test.Framework.Pretty - Test.Framework.JsonOutput Test.Framework.XmlOutput - Test.Framework.ThreadPool - Test.Framework.AssertM Other-Modules: - Test.Framework.TestManagerInternal - Test.Framework.Utils + Paths_HTF + Test.Framework.CmdlineOptions Test.Framework.Colors Test.Framework.Diff Test.Framework.Process + Test.Framework.TestReporter + Test.Framework.Utils + Autogen-modules: + Paths_HTF + Build-tool-depends: cpphs:cpphs >= 1.19 Default-language: Haskell2010 - Ghc-Options: -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind + Ghc-Options: + -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind + -Wcompat +Test-Suite MiscTests + Main-is: MiscTest.hs + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Build-depends: HTF, + HUnit, + base >= 4.10 && < 5, + mtl, + random + Build-tool-depends: HTF:htfpp + Default-language: Haskell2010 + Test-Suite TestHTF Main-is: TestHTF.hs - Hs-Source-Dirs: tests + Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0 - Build-depends: base == 4.*, + Build-depends: HTF, + aeson >= 0.11, + aeson-pretty, + base >= 4.10 && < 5, bytestring >= 0.9, - aeson >= 0.6, - unordered-containers >= 0.2, - temporary >= 1.1, - text >= 0.11, - process >= 1.0, - filepath >= 1.1, directory >= 1.0, - regex-compat >= 0.92, + filepath >= 1.1, + process >= 1.0, random, - HTF + regex-compat >= 0.92, + template-haskell, + temporary >= 1.1, + text >= 0.11, + unordered-containers >= 0.2 + Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Other-Modules: - Foo.A, Foo.B, TestHTFHunitBackwardsCompatible + Foo.A, Foo.B, FailFast, MaxCurTime, + MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi, + Tutorial, Repeat Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests - Build-depends: base == 4.*, - random, + Build-depends: HTF, + base >= 4.10 && < 5, mtl, - HTF - Default-language: Haskell2010 - -Test-Suite Tutorial - Type: exitcode-stdio-1.0 - Main-is: Tutorial.hs - Hs-Source-Dirs: tests - Build-depends: base >= 4, HTF + random + Build-tool-depends: HTF:htfpp Default-language: Haskell2010 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.12 -** New parser -*** Add support for MultiWayIf and LambdaCase to haskell-src-exts -*** Allow default Fixities for haskell-src-exts -** Support for timeouts (--timeout=SECS) -** External interface for integrating other test frameworks -*** Support for Smallcheck and/or Lazy Smallcheck -*** Configuration file for htfpp -**** Expansion templates (extensible!) -** Support for benchmarks -** Collect testmodules with a new preprocessor (new preprocessor runs on the main module) 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 ( @@ -37,7 +39,8 @@ module Test.Framework.AssertM, -- * Organizing tests - TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc + TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest, + TM.WrappableHTF(..) ) where diff --git a/Test/Framework/AssertM.hs b/Test/Framework/AssertM.hs --- a/Test/Framework/AssertM.hs +++ b/Test/Framework/AssertM.hs @@ -1,3 +1,21 @@ +{-# LANGUAGE CPP #-} +-- +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- {-| This module defines the 'AssertM' monad, which allows you either to run assertions @@ -6,64 +24,66 @@ -} module Test.Framework.AssertM ( - AssertM(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack + AssertM(..), AssertBool(..), boolValue, eitherValue ) where -import Data.Maybe +import Control.Monad (liftM, ap) +import GHC.Stack import qualified Data.Text as T -import Test.Framework.TestManagerInternal -import Test.Framework.Location +import Test.Framework.TestInterface import Test.Framework.Colors -- | A typeclass for generic assertions. class Monad m => AssertM m where - genericAssertFailure__ :: Location -> ColorString -> m a - genericSubAssert :: Location -> Maybe String -> m a -> m a + genericAssertFailure :: HasCallStack => ColorString -> m a + genericSubAssert :: HasCallStack => Maybe String -> m a -> m a instance AssertM IO where - genericAssertFailure__ loc s = unitTestFail (Just loc) s - genericSubAssert loc mMsg action = unitTestSubAssert loc mMsg action - --- | Stack trace element for generic assertions. -data AssertStackElem - = AssertStackElem - { ase_message :: Maybe String - , ase_location :: Maybe Location - } - deriving (Eq, Ord, Show, Read) + genericAssertFailure s = + failHTF (FullTestResult (mkHtfStack callStack) (Just s) (Just Fail)) + genericSubAssert mMsg action = subAssertHTF mMsg action -- | Type for evaluating a generic assertion as a pure function. data AssertBool a -- | Assertion passes successfully and yields the given value. = AssertOk a -- | Assertion fails with the given stack trace. In the stack trace, the outermost stackframe comes first. - | AssertFailed [AssertStackElem] + | AssertFailed HtfStack String deriving (Eq, Ord, Show, Read) +instance Functor AssertBool where + fmap = liftM + +instance Applicative AssertBool where + pure = AssertOk + (<*>) = ap + instance Monad AssertBool where return = AssertOk - AssertFailed stack >>= _ = AssertFailed stack + AssertFailed stack msg >>= _ = AssertFailed stack msg AssertOk x >>= k = k x - fail msg = AssertFailed [AssertStackElem (Just msg) Nothing] +#if !(MIN_VERSION_base(4,13,0)) + fail msg = AssertFailed emptyHtfStack msg +#endif instance AssertM AssertBool where - genericAssertFailure__ loc s = - AssertFailed [AssertStackElem (Just (T.unpack $ renderColorString s False)) (Just loc)] - - genericSubAssert loc mMsg action = + genericAssertFailure s = + AssertFailed (mkHtfStack callStack) (T.unpack $ renderColorString s False) + genericSubAssert subMsg action = case action of AssertOk x -> AssertOk x - AssertFailed stack -> - AssertFailed (AssertStackElem mMsg (Just loc) : stack) + AssertFailed stack msg -> + let ghcStack = callStack + in AssertFailed (addCallerToSubAssertStack ghcStack stack subMsg) msg -- | Evaluates a generic assertion to a 'Bool' value. boolValue :: AssertBool a -> Bool boolValue x = case x of AssertOk _ -> True - AssertFailed _ -> False + AssertFailed _ _ -> False -- | Evaluates a generic assertion to an 'Either' value. The result -- is @Right x@ if the assertion passes and yields value @x@, otherwise @@ -72,15 +92,4 @@ eitherValue x = case x of AssertOk z -> Right z - AssertFailed stack -> Left (formatStack stack) - --- | Formats a stack trace. -formatStack :: [AssertStackElem] -> String -formatStack stack = - unlines $ map formatStackElem $ zip [0..] $ reverse stack - where - formatStackElem (pos, AssertStackElem mMsg mLoc) = - let floc = fromMaybe "" $ fmap showLoc mLoc - fmsg = fromMaybe "" $ fmap (\s -> ": " ++ s) mMsg - pref = if pos > 0 then " called from " else "" - in pref ++ floc ++ fmsg + AssertFailed stack msg -> Left (msg ++ "\n" ++ formatHtfStack stack) 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,2013 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -50,19 +50,19 @@ import qualified Data.Map as Map import Test.Framework.Process +import Test.Framework.TestInterface import Test.Framework.TestManager -import Test.Framework.TestManagerInternal import Test.Framework.Utils {- | The type of a function comparing the content of a file against a string, similar to the unix tool @diff@. The first parameter is the name of the file containing the -expected output. If this parameter is 'Nothing', then no output -is expected. The second parameter is the actual output produced. +expected output. If this parameter is 'Nothing', then output +should not be checked. The second parameter is the actual output produced. If the result is 'Nothing' then no difference was found. Otherwise, a 'Just' value contains a string explaining the -different. +difference. -} type Diff = Maybe FilePath -> String -> IO (Maybe String) @@ -121,6 +121,9 @@ endOfOutput :: String -> String endOfOutput s = "[end of " ++ s ++ "]" +blackBoxTestFail :: String -> Assertion +blackBoxTestFail s = failHTF $ mkFullTestResult Fail (Just s) + {- | Use a value of this datatype to customize various aspects of your black box tests. @@ -128,8 +131,8 @@ data BBTArgs = BBTArgs { bbtArgs_stdinSuffix :: String -- ^ File extension for the file used as stdin. , bbtArgs_stdoutSuffix :: String -- ^ File extension for the file specifying expected output on stdout. , bbtArgs_stderrSuffix :: String -- ^ File extension for the file specifying expected output on stderr. - , bbtArgs_dynArgsName :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. - , bbtArgs_verbose :: Bool -- ^ Ge verbose or not. + , bbtArgs_dynArgsName :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. Default: BBTArgs + , bbtArgs_verbose :: Bool -- ^ Be verbose or not. , bbtArgs_stdoutDiff :: Diff -- ^ Diff program for comparing output on stdout with the expected value. , bbtArgs_stderrDiff :: Diff -- ^ Diff program for comparing output on stderr with the expected value. } @@ -162,24 +165,21 @@ -} defaultDiff :: Diff defaultDiff expectFile real = - do mexe <- findExecutable "diff" - let exe = case mexe of - Just p -> p - Nothing -> error ("diff command not in path") - case expectFile of - Nothing | null real -> return Nothing - | otherwise -> return $ Just ("no output expected, but " ++ - "given:\n" ++ real ++ - (endOfOutput "given output")) - Just expect -> - do (out, err, exitCode) <- popen exe ["-u", expect, "-"] - (Just real) - case exitCode of - ExitSuccess -> return Nothing -- no difference - ExitFailure 1 -> -- files differ - return $ Just (out ++ (endOfOutput "diff output")) - ExitFailure i -> error ("diff command failed with exit " ++ - "code " ++ show i ++ ": " ++ err) + case expectFile of + Nothing -> return Nothing + Just expect -> + do mexe <- findExecutable "diff" + let exe = case mexe of + Just p -> p + Nothing -> error ("diff command not in path") + (out, err, exitCode) <- popen exe ["-u", expect, "-"] + (Just real) + case exitCode of + ExitSuccess -> return Nothing -- no difference + ExitFailure 1 -> -- files differ + return $ Just (out ++ (endOfOutput "diff output")) + ExitFailure i -> error ("diff command failed with exit " ++ + "code " ++ show i ++ ": " ++ err) {- | Collects all black box tests with the given file extension stored in a specific directory. @@ -198,13 +198,15 @@ with @bbt-dir\/should-pass\/x.num@ as the last commandline argument. The other commandline arguments are taken from the flags specification given in the file whose name is stored in the 'bbtArgs_dynArgsName' field of the 'BBTArgs' record -(see below). +(see below, default is BBTArgs). If @bbt-dir\/should-pass\/x.in@ existed, its content would be used as stdin. The tests succeeds if the exit code of the program is zero and the output on stdout and stderr matches the contents of @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively. +If @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@ do +not exist, then output is not checked. The 'bbtArgs_dynArgsName' field of the 'BBTArgs' record specifies a filename that contains some more configuration flags for the tests. The following 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,26 +33,39 @@ import Test.Framework.TestReporter import Test.Framework.TestTypes +import Test.Framework.History import Test.Framework.Utils +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(a,b,c) 1 +#endif +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding ( catch ) +#endif +import Control.Exception + import Data.Char (toLower) import Data.Maybe import System.IO - +import System.Environment hiding (getEnv) +import System.Directory import System.Console.GetOpt import qualified Text.Regex as R #ifndef mingw32_HOST_OS import System.Posix.Terminal import System.Posix.IO (stdOutput) -import System.Posix.Env (getEnv) +import System.Posix.Env #endif #ifdef __GLASGOW_HASKELL__ import GHC.Conc ( numCapabilities ) #endif +import qualified Data.ByteString as BS +import Control.Monad + -- -- CmdlineOptions -- @@ -62,13 +77,21 @@ , opts_help :: Bool -- ^ If 'True', display a help message and exit. , opts_negated :: [String] -- ^ Regular expressions matching test names which should /not/ run. , opts_threads :: Maybe Int -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution. - , opts_shuffle :: Bool -- ^ If 'True' (the default), shuffle tests when running them in parallel. + , opts_shuffle :: Bool -- ^ If 'True', shuffle tests when running them in parallel. Default: 'False' , opts_machineOutput :: Bool -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format. , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format. , opts_useColors :: Maybe Bool -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors. , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout , opts_listTests :: Bool -- ^ If 'True', lists all tests available and exits. , opts_split :: Bool -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile'). + , opts_historyFile :: Maybe FilePath -- ^ History file, default: @./.HTF/.history@ + , opts_failFast :: Bool -- ^ Fail and terminate test run as soon as the first test fails. Default: 'False' + , opts_sortByPrevTime :: Bool -- ^ Sort tests by their previous run times (ascending). Default: 'False' + , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run. + , opts_maxCurTimeMs :: Maybe Milliseconds -- ^ Abort tests that run more than the given milliseconds. + , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run. + , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error. + , opts_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } {- | @@ -81,13 +104,21 @@ , opts_help = False , opts_negated = [] , opts_threads = Nothing - , opts_shuffle = True + , opts_shuffle = False , opts_machineOutput = False , opts_machineOutputXml = Nothing , opts_useColors = Nothing , opts_outputFile = Nothing , opts_listTests = False , opts_split = False + , opts_historyFile = Nothing + , opts_failFast = False + , opts_sortByPrevTime = False + , opts_maxPrevTimeMs = Nothing + , opts_maxCurTimeMs = Nothing + , opts_prevFactor = Nothing + , opts_timeoutIsSuccess = False + , opts_repeat = 1 } processorCount :: Int @@ -97,39 +128,86 @@ processorCount = 1 #endif -optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +optionDescriptions :: [OptDescr (CmdlineOptions -> Either String CmdlineOptions)] optionDescriptions = - [ Option ['q'] ["quiet"] (NoArg (\o -> o { opts_quiet = True })) "only display errors" - , Option ['n'] ["not"] (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) }) - "PATTERN") "tests to exclude" - , Option ['l'] ["list"] (NoArg (\o -> o { opts_listTests = True })) "list all matching tests" - , Option ['j'] ["threads"] (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N") - ("run N tests in parallel, default N=" ++ show processorCount) - , Option [] ["deterministic"] (NoArg (\o -> o { opts_shuffle = False })) "do not shuffle tests when executing them in parallel." - , Option ['o'] ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s }) - "FILE") "name of output file" - , Option [] ["json"] (NoArg (\o -> o { opts_machineOutput = True })) - "output results in machine-readable JSON format (incremental)" - , Option [] ["xml"] (ReqArg (\s o -> o { opts_machineOutputXml = Just s }) "FILE") - "output results in junit-style XML format" - , Option [] ["split"] (NoArg (\o -> o { opts_split = True })) - "splits results in separate files to avoid file locking (requires -o/--output-file)" - , Option [] ["colors"] (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) }) - "BOOL") "use colors or not" - , Option ['h'] ["help"] (NoArg (\o -> o { opts_help = True })) "display this message" + [ Option ['q'] ["quiet"] + (NoArg (\o -> Right $ o { opts_quiet = True })) + "Only display errors." + , Option ['n'] ["not"] + (ReqArg (\s o -> Right $ o { opts_negated = s : (opts_negated o) }) "PATTERN") + "Tests to exclude." + , Option ['l'] ["list"] + (NoArg (\o -> Right $ o { opts_listTests = True })) + "List all matching tests." + , Option ['j'] ["threads"] + (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N") + ("Run N tests in parallel, default N=" ++ show processorCount ++ ".") + , Option [] ["shuffle"] + (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL") + "Shuffle test order. Default: false" + , Option ['o'] ["output-file"] + (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE") + "Name of output file." + , Option [] ["json"] + (NoArg (\o -> Right $ o { opts_machineOutput = True })) + "Output results in machine-readable JSON format (incremental)." + , Option [] ["xml"] + (ReqArg (\s o -> Right $ o { opts_machineOutputXml = Just s }) "FILE") + "Output results in junit-style XML format." + , Option [] ["split"] + (NoArg (\o -> Right $ o { opts_split = True })) + "Splits results in separate files to avoid file locking (requires -o/--output-file)." + , Option [] ["colors"] + (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_useColors = Just b }) "BOOL") + "Use colors or not." + , Option [] ["history"] + (ReqArg (\s o -> Right $ o { opts_historyFile = Just s }) "FILE") + "Path to the history file. Default: ./.HTF/.history" + , Option [] ["fail-fast"] + (NoArg (\o -> Right $ o { opts_failFast = True })) + "Fail and abort test run as soon as the first test fails." + , Option [] ["sort-by-prev-time"] + (NoArg (\o -> Right $ o { opts_sortByPrevTime = True })) + "Sort tests ascending by their execution of the previous test run (if available). Default: false" + , Option [] ["max-prev-ms"] + (ReqArg (\s o -> parseRead "--max-prev-ms" s >>= \(ms::Int) -> Right $ o { opts_maxPrevTimeMs = Just ms }) "MILLISECONDS") + "Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run." + , Option [] ["max-cur-ms"] + (ReqArg (\s o -> parseRead "--max-cur-ms" s >>= \(ms::Int) -> + Right $ o { opts_maxCurTimeMs = Just ms }) "MILLISECONDS") + "Abort a test that runs more than MILLISECONDS." + , Option [] ["prev-factor"] + (ReqArg (\s o -> parseRead "--prev-factor" s >>= \(ms::Double) -> + Right $ o { opts_prevFactor = Just ms }) "DOUBLE") + "Abort a test that runs more than DOUBLE times slower than in a previous run." + , Option [] ["timeout-is-success"] + (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True })) + "Do not regard a test timeout as an error." + , Option [] ["repeat"] + (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) -> + Right $ o { opts_repeat = i}) "NUMBER") + "Execute the tests selected on the command line NUMBER times." + , Option ['h'] ["help"] + (NoArg (\o -> Right $ o { opts_help = True })) + "Display this message." ] where - parseThreads Nothing = processorCount + parseThreads Nothing = Right processorCount parseThreads (Just s) = case readM s of - Just i -> i - Nothing -> error ("invalid number of threads: " ++ s) + Just i -> Right i + Nothing -> Left ("invalid number of threads: " ++ s) parseBool s = + Right $ if map toLower s `elem` ["1", "true", "yes", "on"] then True else False + parseRead opt s = + case readM s of + Just i -> Right i + Nothing -> Left ("invalid value for option " ++ opt ++ ": " ++ s) {- | -Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis +Parse commandline arguments into 'CmdlineOptions'. Here is a synopsis of the format of the commandline arguments: > USAGE: COMMAND [OPTION ...] PATTERN ... @@ -137,38 +215,49 @@ > where PATTERN is a posix regular expression matching > the names of the tests to run. > -> -q --quiet only display errors -> -n PATTERN --not=PATTERN tests to exclude -> -l --list list all matching tests -> -j[N] --threads[=N] run N tests in parallel, default N=4 -> --deterministic do not shuffle tests when executing them in parallel. -> -o FILE --output-file=FILE name of output file -> --json output results in machine-readable JSON format (incremental) -> --xml=FILE output results in junit-style XML format -> --split splits results in separate files to avoid file locking (requires -o/--output-file) -> --colors=BOOL use colors or not -> -h --help display this message +> -q --quiet Only display errors. +> -n PATTERN --not=PATTERN Tests to exclude. +> -l --list List all matching tests. +> -j[N] --threads[=N] Run N tests in parallel, default N=1. +> --shuffle=BOOL Shuffle test order. Default: false +> -o FILE --output-file=FILE Name of output file. +> --json Output results in machine-readable JSON format (incremental). +> --xml=FILE Output results in junit-style XML format. +> --split Splits results in separate files to avoid file locking (requires -o/--output-file). +> --colors=BOOL Use colors or not. +> --history=FILE Path to the history file. Default: ./.HTF/.history +> --fail-fast Fail and abort test run as soon as the first test fails. +> --sort-by-prev-time Sort tests ascending by their execution of the previous test run (if available). Default: false +> --max-prev-ms=MILLISECONDS Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run. +> --max-cur-ms=MILLISECONDS Abort a test that runs more than MILLISECONDS. +> --prev-factor=DOUBLE Abort a test that runs more than DOUBLE times slower than in a previous run. +> --timeout-is-success Do not regard a test timeout as an error. +> -h --help Display this message. -} parseTestArgs :: [String] -> Either String CmdlineOptions parseTestArgs args = case getOpt Permute optionDescriptions args of - (optTrans, tests, [] ) -> - let posStrs = tests - negStrs = opts_negated opts - pos = map mkRegex posStrs - neg = map mkRegex negStrs - pred (FlatTest _ path _ _) = - let flat = flatName path - in if (any (\s -> s `matches` flat) neg) - then False - else null pos || any (\s -> s `matches` flat) pos - opts = (foldr ($) defaultCmdlineOptions optTrans) { opts_filter = pred } - in case (opts_outputFile opts, opts_split opts) of + (optTrans, tests, []) -> + do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans + when (opts_shuffle opts && opts_sortByPrevTime opts) $ + Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " ++ + "Can only use one of both.\n\n" ++ + usageInfo usageHeader optionDescriptions) + case (opts_outputFile opts, opts_split opts) of (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions) - _ -> Right opts + _ -> let posStrs = tests + negStrs = opts_negated opts + pos = map mkRegex posStrs + neg = map mkRegex negStrs + pred (FlatTest _ path _ _) = + let flat = flatName path + in if (any (\s -> s `matches` flat) neg) + then False + else null pos || any (\s -> s `matches` flat) pos + in Right (opts { opts_filter = pred }) (_,_,errs) -> Left (concat errs ++ usageInfo usageHeader optionDescriptions) where @@ -201,14 +290,25 @@ reporters = defaultTestReporters (isParallelFromBool $ isJust threads) (if opts_machineOutput opts then JsonOutput else NoJsonOutput) (if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput) + historyFile <- getHistoryFile + history <- getHistory historyFile return $ TestConfig { tc_quiet = opts_quiet opts , tc_threads = threads , tc_shuffle = opts_shuffle opts , tc_output = output , tc_outputXml = opts_machineOutputXml opts , tc_reporters = reporters - , tc_filter = opts_filter opts - , tc_useColors = colors } + , tc_filter = opts_filter opts `mergeFilters` (historicFilter history) + , tc_useColors = colors + , tc_historyFile = historyFile + , tc_history = history + , tc_sortByPrevTime = opts_sortByPrevTime opts + , tc_failFast = opts_failFast opts + , tc_maxSingleTestTime = opts_maxCurTimeMs opts + , tc_prevFactor = opts_prevFactor opts + , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts + , tc_repeat = opts_repeat opts + } where #ifdef mingw32_HOST_OS openOutputFile = @@ -243,3 +343,37 @@ Just fd -> queryTerminal fd _ -> return False #endif + getHistoryFile = + case opts_historyFile opts of + Just fp -> return fp + Nothing -> + do progName <- getProgName + let x = if progName == "" 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,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{- | +Utility module dealing with ANSI colors. +-} -- --- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2011-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public 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, ScopedTypeVariables #-} -- --- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2011-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -23,6 +23,10 @@ ) where +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(a,b,c) 1 +#endif + #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif @@ -84,12 +88,50 @@ contextSize :: Int contextSize = 10 +prepareStringsForDiff :: String -> String -> (String, String, Maybe (String, String)) +prepareStringsForDiff s1 s2 = + case (List.splitAt 1024 s1, List.splitAt 1024 s2) of + ((start1, rest1@(_:_)), (start2, rest2@(_:_))) -> (start1, start2, Just (rest1, rest2)) + ((start1, []), (start2, _)) -> (start1, start2, Nothing) + ((start1, _), (start2, [])) -> (start1, start2, Nothing) + singleLineDiff :: DiffConfig -> String -> String -> ColorString -singleLineDiff dc s1 s2 - | s1 == s2 = emptyColorString +singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2) + where + loop :: (Int, Int) -> (String, String) -> ColorString + loop (skipped1, skipped2) (s1, s2) = + let (start1, start2, cont) = prepareStringsForDiff s1 s2 + in case singleLineDiff' dc start1 start2 of + Just cs -> + let prefix = + if skipped1 == 0 && skipped1 == 0 + then emptyColorString + else dc_skip dc + ("skipped " ++ show skipped1 ++ + " chars from first string, " + ++ show skipped2 ++ " chars from second string") + suffix = + case cont of + Nothing -> emptyColorString + Just (r1, r2) -> + dc_skip dc + ("skipped " ++ show (length r1) ++ + " chars from first string, " ++ + show (length r2) ++ " chars from second string") + in prefix +++ cs +++ suffix + Nothing -> + case cont of + Just (r1, r2) -> + loop (skipped1 + length start1, skipped2 + length start2) (r1, r2) + Nothing -> emptyColorString + +singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString +singleLineDiff' dc s1 s2 + | s1 == s2 = Nothing | otherwise = let groups = D.getGroupedDiff s1 s2 - in foldr (\(group, pos) string -> + in Just $ + foldr (\(group, pos) string -> (showDiffGroup pos group) +++ (if not (isLast pos) then dc_sep dc else emptyColorString) +++ string) @@ -124,12 +166,20 @@ multiLineDiff :: DiffConfig -> String -> String -> IO ColorString multiLineDiff cfg left right = withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) -> - do write hLeft left - write hRight right + do write hLeft leftForFile + write hRight rightForFile doDiff fpLeft fpRight where + (leftForFile, rightForFile) = + if lastChar left /= Just '\n' && lastChar right /= Just '\n' + then (left ++ "\n", right ++ "\n") -- avoid "No newline at end of file" error messages + else (left, right) + lastChar s = + case reverse s of + [] -> Nothing + (c:_) -> Just c doDiff leftFile rightFile = - (do (ecode, out, _err) <- readProcessWithExitCode "diff" [leftFile, rightFile] "" + (do (ecode, out, _err) <- readProcessWithExitCode "diff" ["-u", leftFile, rightFile] "" case ecode of ExitSuccess -> return (format out) ExitFailure 1 -> return (format out) @@ -141,8 +191,8 @@ removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException))) withTempFiles action = do dir <- getTemporaryDirectory - left@(fpLeft, _) <- openTempFile dir "HTF-diff-left.txt" - (do right@(fpRight, _) <- openTempFile dir "HTF-diff-right.txt" + left@(fpLeft, _) <- openTempFile dir "HTF-diff-EXPECTED_.txt" + (do right@(fpRight, _) <- openTempFile dir "HTF-diff-ACTUAL_.txt" action left right `finally` saveRemove fpRight `finally` saveRemove fpLeft) write h s = @@ -166,12 +216,12 @@ fromSecond s = dc_fromSecond cfg s diff :: DiffConfig -> String -> String -> IO ColorString -diff cfg left right = +diff cfg left right = do case (lines left, lines right) of ([], []) -> return emptyColorString - ([], [_]) -> return $ singleLineDiff cfg left right - ([_], []) -> return $ singleLineDiff cfg left right - ([_], [_]) -> return $ singleLineDiff cfg left right + ([], [_]) -> return (singleLineDiff cfg left right) + ([_], []) -> return (singleLineDiff cfg left right) + ([_], [_]) -> return (singleLineDiff cfg left right) _ -> multiLineDiff cfg left right diffWithSensibleConfig :: String -> String -> IO ColorString @@ -183,7 +233,13 @@ -} multiLineDiffHaskell :: String -> String -> ColorString multiLineDiffHaskell left right = - noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) -- this code is now part of the Diff library (hence the >0.3 in Cabal) + if length left > maxLen || length right > maxLen + then noColor + ("Refusing to compute a multiline diff for strings with more than " ++ show maxLen ++ + " chars. Please install the 'diff' tool to get a diff ouput.") + else noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) + where + maxLen = 10000 main = do args <- getArgs diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -1,581 +1,932 @@ -{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - --- --- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA --- - -{-| - -This module provides assert-like functions for writing unit tests. - -/Hint:/ Do not use the @assertXXX_@ functions -directly. Instead, for each function @assertXXX_@, -there exist a preprocessor macro @assertXXX@, which provides -the "Location" parameter automatically. Use these macros, which -are available automatically if you add - -@{-# OPTIONS_GHC -F -pgmF htfpp #-}@ - -at the top of your source file (see the 'Test.Framework.Tutorial'). - --} - -module Test.Framework.HUnitWrapper ( - - -- * Assertions on Bool values - assertBool_, assertBoolVerbose_, - gassertBool_, gassertBoolVerbose_, - - -- * Equality assertions - assertEqual_, assertEqualVerbose_, - gassertEqual_, gassertEqualVerbose_, - assertEqualPretty_, assertEqualPrettyVerbose_, - gassertEqualPretty_, gassertEqualPrettyVerbose_, - assertEqualNoShow_, assertEqualNoShowVerbose_, - gassertEqualNoShow_, gassertEqualNoShowVerbose_, - assertNotEqual_, assertNotEqualVerbose_, - gassertNotEqual_, gassertNotEqualVerbose_, - assertNotEqualPretty_, assertNotEqualPrettyVerbose_, - gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_, - assertNotEqualNoShow_, assertNotEqualNoShowVerbose_, - gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_, - - -- * Assertions on lists - assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_, - gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_, - assertNotEmpty_, assertNotEmptyVerbose_, - gassertNotEmpty_, gassertNotEmptyVerbose_, - assertEmpty_, assertEmptyVerbose_, - gassertEmpty_, gassertEmptyVerbose_, - assertElem_, assertElemVerbose_, - gassertElem_, gassertElemVerbose_, - - -- * Assertions for exceptions - assertThrows_, assertThrowsVerbose_, - assertThrowsSome_, assertThrowsSomeVerbose_, - assertThrowsIO_, assertThrowsIOVerbose_, - assertThrowsSomeIO_, assertThrowsSomeIOVerbose_, - assertThrowsM_, assertThrowsMVerbose_, - assertThrowsSomeM_, assertThrowsSomeMVerbose_, - - -- * Assertions on Either values - assertLeft_, assertLeftVerbose_, - gassertLeft_, gassertLeftVerbose_, - assertLeftNoShow_, assertLeftNoShowVerbose_, - gassertLeftNoShow_, gassertLeftNoShowVerbose_, - assertRight_, assertRightVerbose_, - gassertRight_, gassertRightVerbose_, - assertRightNoShow_, assertRightNoShowVerbose_, - gassertRightNoShow_, gassertRightNoShowVerbose_, - - -- * Assertions on Just values - assertJust_, assertJustVerbose_, - gassertJust_, gassertJustVerbose_, - assertNothing_, assertNothingVerbose_, - gassertNothing_, gassertNothingVerbose_, - assertNothingNoShow_, assertNothingNoShowVerbose_, - gassertNothingNoShow_, gassertNothingNoShowVerbose_, - - -- * General failure - assertFailure_, - gassertFailure_, - - -- * Pending unit tests - unitTestPending, unitTestPending', - - -- * Sub assertions - subAssert_, subAssertVerbose_, - gsubAssert_, gsubAssertVerbose_, - - -- * HUnit re-exports - HU.HUnitFailure - -) where - -import Control.Exception -import qualified Control.Exception.Lifted as ExL -import Control.Monad.Trans.Control -import Control.Monad.Trans -import qualified Language.Haskell.Exts.Pretty as HE -import qualified Language.Haskell.Exts.Parser as HE -import qualified Test.HUnit.Lang as HU - -import Data.List ( (\\) ) -import System.IO.Unsafe (unsafePerformIO) - -import Test.Framework.TestManagerInternal -import Test.Framework.Location -import Test.Framework.Diff -import Test.Framework.Colors -import Test.Framework.Pretty -import Test.Framework.AssertM - --- WARNING: do not forget to add a preprocessor macro for new assertions!! - -{- | -Fail with the given reason, supplying the error location and the error message. --} -gassertFailure_ :: AssertM m => Location -> String -> m a -gassertFailure_ loc s = - genericAssertFailure__ loc (mkMsg "assertFailure" "" - ("failed at " ++ showLoc loc ++ ": " ++ s)) - --- | Specialization of 'gassertFailure'. -assertFailure_ :: Location -> String -> IO a -assertFailure_ = gassertFailure_ - -{- | -Use @unitTestPending' msg test@ to mark the given test as pending -without removing it from the test suite and without deleting or commenting out the test code. --} -unitTestPending' :: String -> IO a -> IO a -unitTestPending' msg _ = unitTestPending msg - -mkMsg :: String -> String -> String -> ColorString -mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3) - -mkColorMsg :: String -> String -> ColorString -> ColorString -mkColorMsg fun extraInfo s = - let pref = if null extraInfo - then fun ++ " " - else fun ++ " (" ++ extraInfo ++ ") " - in noColor pref +++ s - --- --- Dirty macro hackery (I'm too lazy ...) --- -#define CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, __ret__) \ -__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \ -__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \ -__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \ -__name__##_ loc = _##__name__##_ #__name__ loc "" -#define CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \ -g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \ -g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \ -g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \ -g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \ -CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__) - -#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \ -CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ()) -#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \ -CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ()) - -#define CreateAssertions(__name__, __type__) \ -CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ()) -#define CreateAssertionsNoGVariant(__name__, __type__) \ -CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ()) - -#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \ -CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__) -#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \ -CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__) - -#define CreateAssertionsRet(__name__, __type__, __ret__) \ -CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__) -#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \ -CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __ret__) - -#define DocAssertion(__name__, __text__) \ - {- | __text__ The 'String' parameter in the @Verbose@ \ - variants can be used to provide extra information about the error. The \ - variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \ - they run in the IO monad and can be evaluated to a 'Bool' value. \ - Do not use the \ - @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \ - functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \ - @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \ - insert the 'Location' parameter automatically. -} -#define DocAssertionNoGVariant(__name__, __text__) \ - {- | __text__ The 'String' parameter in the @Verbose@ \ - variant can be used to provide extra information about the error. \ - Do not use the \ - @__name__##_@ and @__name__##Verbose_@ \ - functions directly, use the macros @__name__@ and @__name__##Verbose@ \ - instead. These macros, provided by the @htfpp@ preprocessor, \ - insert the 'Location' parameter automatically. -} --- --- Boolean Assertions --- - -_assertBool_ :: AssertM m => String -> Location -> String -> Bool -> m () -_assertBool_ name loc s False = - genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) -_assertBool_ _ _ _ True = return () - -DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.) -CreateAssertions(assertBool, Bool) - --- --- Equality Assertions --- - -equalityFailedMessage :: String -> String -> ColorString -equalityFailedMessage exp act = - let !diff = unsafePerformIO (diffWithSensibleConfig expP actP) - expected_ = colorize firstDiffColor "* expected:" - but_got_ = colorize secondDiffColor "* but got:" - diff_ = colorize diffColor "* diff:" - in ("\n" +++ expected_ +++ " " +++ noColor (withNewline expP) +++ - "\n" +++ but_got_ +++ " " +++ noColor (withNewline actP) +++ - "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff +++ - (if stringEq - then "\nWARNING: strings are equal but actual values differ!" - else "")) - where - withNewline s = - case lines s of - [] -> s - [_] -> s - _ -> '\n':s - newlineBeforeDiff d = - let f b = case colorStringFind (\c -> c == '\n') d b of - Just _ -> "\n" - Nothing -> "" - in noColor' (f True) (f False) - (expP, actP, stringEq) = - case (pp exp, pp act) of - (Nothing, _) -> (exp, act, exp == act) - (_, Nothing) -> (exp, act, exp == act) - (Just expP, Just actP) - | expP == actP -> - if exp /= act - then (exp, act, exp == act) - else (expP, actP, True) - | otherwise -> (expP, actP, False) - pp s = - case HE.parseExp s of - HE.ParseOk x -> Just $ HE.prettyPrint x - HE.ParseFailed{} -> Nothing - -notEqualityFailedMessage :: String -> String -notEqualityFailedMessage exp = - (": Objects are equal\n" ++ pp exp) - where - pp s = - case HE.parseExp s of - HE.ParseOk x -> HE.prettyPrint x - HE.ParseFailed{} -> s - -_assertEqual_ :: (Eq a, Show a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertEqual_ name loc s expected actual = - if expected /= actual - then do let x = equalityFailedMessage (show expected) (show actual) - genericAssertFailure__ loc (mkColorMsg name s $ - noColor ("failed at " ++ showLoc loc) +++ x) - else return () - -DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is an instance of 'Show' but not of 'Pretty'.) -CreateAssertionsCtx(assertEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a) - -_assertNotEqual_ :: (Eq a, Show a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertNotEqual_ name loc s expected actual = - if expected == actual - then do let x = notEqualityFailedMessage (show expected) - genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) - else return () - -DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is an instance of 'Show' but not of 'Pretty'.) -CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a) - -_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertEqualPretty_ name loc s expected actual = - if expected /= actual - then do let x = equalityFailedMessage (showPretty expected) (showPretty actual) - genericAssertFailure__ loc (mkColorMsg name s - (noColor ("failed at " ++ showLoc loc) +++ x)) - else return () - -DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is an instance of 'Pretty'.) -CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a) - -_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertNotEqualPretty_ name loc s expected actual = - if expected == actual - then do let x = notEqualityFailedMessage (showPretty expected) - genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x) - else return () -DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is an instance of 'Pretty'.) -CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a) - -_assertEqualNoShow_ :: (Eq a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertEqualNoShow_ name loc s expected actual = - if expected /= actual - then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) - else return () -DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this - case the generated error message might not be very helpful.) -CreateAssertionsCtx(assertEqualNoShow, Eq a, (Eq a, AssertM m), a -> a) - -_assertNotEqualNoShow_ :: (Eq a, AssertM m) - => String -> Location -> String -> a -> a -> m () -_assertNotEqualNoShow_ name loc s expected actual = - if expected == actual - then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) - else return () -DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal. - The first parameter denotes the expected value. Use these two functions - of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this - case the generated error message might not be very helpful.) -CreateAssertionsCtx(assertNotEqualNoShow, Eq a, (Eq a, AssertM m), a -> a) - --- --- Assertions on Lists --- - -_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m) - => String -> Location -> String -> [a] -> [a] -> m () -_assertListsEqualAsSets_ name loc s expected actual = - let ne = length expected - na = length actual - in case () of - _| ne /= na -> - do let x = equalityFailedMessage (show expected) (show actual) - genericAssertFailure__ loc (mkColorMsg name s - (noColor - ("failed at " ++ showLoc loc - ++ "\n expected length: " ++ show ne - ++ "\n actual length: " ++ show na) +++ - (if maxLength x < 5000 - then x else emptyColorString))) - | not (unorderedEq expected actual) -> - do let x = equalityFailedMessage (show expected) (show actual) - genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s - (noColor ("failed at " ++ showLoc loc) +++ x)) - | otherwise -> return () - where unorderedEq l1 l2 = - null (l1 \\ l2) && null (l2 \\ l1) -DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal - when considered as sets. The first list parameter - denotes the expected value.) -CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), (Eq a, Show a, AssertM m), [a] -> [a]) - -_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m () -_assertNotEmpty_ name loc s [] = - genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) -_assertNotEmpty_ _ _ _ (_:_) = return () -DocAssertion(assertNotEmpty, Fail if the given list is empty.) -CreateAssertions(assertNotEmpty, [a]) - -_assertEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m () -_assertEmpty_ name loc s (_:_) = - genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) -_assertEmpty_ _ _ _ [] = return () -DocAssertion(assertEmpty, Fail if the given list is a non-empty list.) -CreateAssertions(assertEmpty, [a]) - -_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m () -_assertElem_ name loc s x l = - if x `elem` l - then return () - else genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - "\n element: " ++ show x ++ - "\n list: " ++ show l)) -DocAssertion(assertElem, Fail if the given element is not in the list.) -CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a]) - --- --- Assertions for Exceptions --- - -_assertThrowsIO_ :: Exception e - => String -> Location -> String -> IO a -> (e -> Bool) -> IO () -_assertThrowsIO_ name loc s x f = - _assertThrowsM_ name loc s x f -DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not - throw an exception satisfying the given predicate @(e -> Bool)@.) -CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool)) - -_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO () -_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (_e::SomeException) -> True) -DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not - throw an exception.) -CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a) - -_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e) - => String -> Location -> String -> m a -> (e -> Bool) -> m () -_assertThrowsM_ name loc s x f = - do res <- ExL.try x - case res of - Right _ -> liftIO $ - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": no exception was thrown")) - Left e -> if f e then return () - else liftIO $ - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ - showLoc loc ++ - ": wrong exception was thrown: " ++ - show e)) -DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not - throw an exception satisfying the given predicate @(e -> Bool)@.) -CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>, - m a -> (e -> Bool), m ()) - -_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m) - => String -> Location -> String -> m a -> m () -_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True) -DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not - throw an exception.) -CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ()) - -_assertThrows_ :: Exception e - => String -> Location -> String -> a -> (e -> Bool) -> IO () -_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f -DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not - throw an exception satisfying the given predicate @(e -> Bool)@.) -CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool)) - -_assertThrowsSome_ :: String -> Location -> String -> a -> IO () -_assertThrowsSome_ name loc s x = - _assertThrows_ name loc s x (\ (_e::SomeException) -> True) -DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not - throw an exception.) -CreateAssertionsNoGVariant(assertThrowsSome, a) - --- --- Assertions on Either --- - -_assertLeft_ :: forall a b m . (AssertM m, Show b) - => String -> Location -> String -> Either a b -> m a -_assertLeft_ _ _ _ (Left x) = return x -_assertLeft_ name loc s (Right x) = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected a Left value, given " ++ - show (Right x :: Either b b))) -DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'. - Use this function if @b@ is an instance of 'Show') -CreateAssertionsCtxRet(assertLeft, Show b, (Show b, AssertM m), Either a b, a) - -_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a -_assertLeftNoShow_ _ _ _ (Left x) = return x -_assertLeftNoShow_ name loc s (Right _) = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected a Left value, given a Right value")) -DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.) -CreateAssertionsRet(assertLeftNoShow, Either a b, a) - -_assertRight_ :: forall a b m . (Show a, AssertM m) - => String -> Location -> String -> Either a b -> m b -_assertRight_ _ _ _ (Right x) = return x -_assertRight_ name loc s (Left x) = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected a Right value, given " ++ - show (Left x :: Either a a))) -DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'. - Use this function if @a@ is an instance of 'Show') -CreateAssertionsCtxRet(assertRight, Show a, (Show a, AssertM m), Either a b, b) - -_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b -_assertRightNoShow_ _ _ _ (Right x) = return x -_assertRightNoShow_ name loc s (Left _) = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected a Right value, given a Left value")) -DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.) -CreateAssertionsRet(assertRightNoShow, Either a b, b) - --- --- Assertions on Maybe --- - -_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a -_assertJust_ _ _ _ (Just x) = return x -_assertJust_ name loc s Nothing = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected a Just value, given Nothing")) -DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.) -CreateAssertionsRet(assertJust, Maybe a, a) - -_assertNothing_ :: (Show a, AssertM m) - => String -> Location -> String -> Maybe a -> m () -_assertNothing_ _ _ _ Nothing = return () -_assertNothing_ name loc s jx = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected Nothing, given " ++ show jx)) -DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'. - Use this function if @a@ is an instance of 'Show'.) -CreateAssertionsCtx(assertNothing, Show a, (Show a, AssertM m), Maybe a) - -_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m () -_assertNothingNoShow_ _ _ _ Nothing = return () -_assertNothingNoShow_ name loc s _ = - genericAssertFailure__ loc (mkMsg name s - ("failed at " ++ showLoc loc ++ - ": expected Nothing, given a Just value")) -DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.) -CreateAssertions(assertNothingNoShow, Maybe a) - --- --- Sub assertions --- - --- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location --- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write --- --- > assertIsPositive :: Int -> Assertion --- > assertIsPositive n = assertBool (n > 0) --- --- You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly --- you will lose location information: if @assertIsPositive i@ fails you will only get the location where --- @assertIsPositive@ is defined but not from where it has been called. --- --- To recover the location information you simply use @subAssert (assertIsPositive i)@. --- In this case, if @i@ is not positive, you will get the location of the caller. --- --- /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@. -subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a -subAssert_ loc ass = unitTestSubAssert loc Nothing ass - --- | Generic variant of 'subAssert_'. -gsubAssert_ :: AssertM m => Location -> m a -> m a -gsubAssert_ loc ass = genericSubAssert loc Nothing ass - --- | Same as 'subAssert_' but with an additional error message. -subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a -subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass - --- | Generic variant of 'subAssertVerbose_'. -gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a -gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass +{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +{-| + +This module provides assert-like functions for writing unit tests. + +-} + +module Test.Framework.HUnitWrapper ( + + -- * Assertions on Bool values + assertBool, assertBoolVerbose, + + -- * Equality assertions + assertEqual, assertEqualVerbose, + assertEqualPretty, assertEqualPrettyVerbose, + assertEqualNoShow, assertEqualNoShowVerbose, + + -- * Inequality assertions + assertNotEqual, assertNotEqualVerbose, + assertNotEqualPretty, assertNotEqualPrettyVerbose, + assertNotEqualNoShow, assertNotEqualNoShowVerbose, + + -- * Assertions on lists + assertListsEqualAsSets, assertListsEqualAsSetsVerbose, + assertNotEmpty, assertNotEmptyVerbose, + assertEmpty, assertEmptyVerbose, + assertElem, assertElemVerbose, + + -- * Assertions for exceptions + assertThrows, assertThrowsVerbose, + assertThrowsSome, assertThrowsSomeVerbose, + assertThrowsIO, assertThrowsIOVerbose, + assertThrowsSomeIO, assertThrowsSomeIOVerbose, + assertThrowsM, assertThrowsMVerbose, + assertThrowsSomeM, assertThrowsSomeMVerbose, + + -- * Assertions on Either values + assertLeft, assertLeftVerbose, + assertLeftNoShow, assertLeftNoShowVerbose, + assertRight, assertRightVerbose, + assertRightNoShow, assertRightNoShowVerbose, + + -- * Assertions on Just values + assertJust, assertJustVerbose, + assertNothing, assertNothingVerbose, + assertNothingNoShow, assertNothingNoShowVerbose, + + -- * General failure + assertFailure, + + -- * Pending unit tests + unitTestPending, unitTestPending', + + -- * Sub assertions + subAssert, subAssertVerbose, + + -- * Generalized assertions and failures in AssertM + {- | + The following definitions generalize the the monad in which assertions are executed. + Usually, assertions are executed in the @IO@ monad. The @AssertM@ monad + (see "Test.Framework.AssertM") allows you to evaluate assertions also as pure functions. + -} + -- ** Assertions on Bool values + gassertBool, gassertBoolVerbose, + + -- ** Equality assertions + gassertEqual, gassertEqualVerbose, + gassertEqualPretty, gassertEqualPrettyVerbose, + gassertEqualNoShow, gassertEqualNoShowVerbose, + + -- ** Inequality assertions + gassertNotEqual, gassertNotEqualVerbose, + gassertNotEqualPretty, gassertNotEqualPrettyVerbose, + gassertNotEqualNoShow, gassertNotEqualNoShowVerbose, + + -- ** Assertions on lists + gassertListsEqualAsSets, gassertListsEqualAsSetsVerbose, + gassertNotEmpty, gassertNotEmptyVerbose, + gassertEmpty, gassertEmptyVerbose, + gassertElem, gassertElemVerbose, + + -- ** Assertions on Either values + gassertLeft, gassertLeftVerbose, + gassertLeftNoShow, gassertLeftNoShowVerbose, + gassertRight, gassertRightVerbose, + gassertRightNoShow, gassertRightNoShowVerbose, + + -- ** Assertions on Just values + gassertJust, gassertJustVerbose, + gassertNothing, gassertNothingVerbose, + gassertNothingNoShow, gassertNothingNoShowVerbose, + + -- ** General failure + gassertFailure, + + -- ** Sub assertions + gsubAssert, gsubAssertVerbose, + + -- * HUnit re-exports + HU.HUnitFailure, + + -- * Tests (for internal use) + hunitWrapperTests + +) where + +import Control.Exception +import qualified Control.Exception.Lifted as ExL +import Control.Monad.Trans.Control +import Control.Monad.Trans +import qualified Test.HUnit.Lang as HU +#if !MIN_VERSION_HUnit(1,4,0) +import qualified Test.HUnit.Base as HU +#endif + +import GHC.Stack + +import Data.List ( (\\) ) +import System.IO.Unsafe (unsafePerformIO) + +import Test.Framework.TestInterface +import Test.Framework.Location +import Test.Framework.Diff +import Test.Framework.Colors +import Test.Framework.Pretty +import Test.Framework.AssertM +import Test.Framework.PrettyHaskell +import Test.Framework.Utils + +import qualified Data.Text as T +import qualified Data.List as List + +-- WARNING: do not forget to add a preprocessor macro for new assertions!! + +{- | +Fail with the given reason in some 'AssertM' monad. +-} +gassertFailure :: (HasCallStack, AssertM m) => String -> m a +gassertFailure s = + genericAssertFailure (mkMsg "assertFailure" "" s) + +-- | Specialization of 'gassertFailure' to @IO@. +assertFailure :: HasCallStack => String -> IO a +assertFailure = gassertFailure + +{- | +Signals that the current unit test is pending. +-} +unitTestPending :: String -> IO a +unitTestPending s = + failHTF (FullTestResult emptyHtfStack (Just $ noColor s) (Just Pending)) + +{- | +Use @unitTestPending' msg test@ to mark the given test as pending +without removing it from the test suite and without deleting or commenting out the test code. +-} +unitTestPending' :: String -> IO a -> IO a +unitTestPending' msg _ = unitTestPending msg + +mkMsg :: String -> String -> String -> ColorString +mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3) + +mkColorMsg :: String -> String -> ColorString -> ColorString +mkColorMsg fun extraInfo s = + let pref = if null extraInfo + then fun ++ " " + else fun ++ " (" ++ extraInfo ++ ") " + in noColor pref +++ s + +-- +-- Boolean Assertions +-- + +assertBool_ :: (HasCallStack, AssertM m) => String -> String -> Bool -> m () +assertBool_ name s False = genericAssertFailure (mkMsg name s "failed") +assertBool_ _ _ True = return () + +-- | Fail if the 'Bool' value is 'False'. +assertBool :: HasCallStack => Bool -> IO () +assertBool = assertBool_ "assertBool" "" + +assertBoolVerbose :: HasCallStack => String -> Bool -> IO () +assertBoolVerbose = assertBool_ "assertBoolVerbose" + +gassertBool :: (HasCallStack, AssertM m) => Bool -> m () +gassertBool = assertBool_ "gassertBool" "" + +gassertBoolVerbose :: (HasCallStack, AssertM m) => String -> Bool -> m () +gassertBoolVerbose = assertBool_ "gassertBoolVerbose" + +-- +-- Equality Assertions +-- + +equalityFailedMessage' :: String -> String -> ColorString +equalityFailedMessage' exp act = + let !diff = unsafePerformIO (diffWithSensibleConfig exp act) + expected_ = colorize firstDiffColor "* expected:" + but_got_ = colorize secondDiffColor "* but got:" + diff_ = colorize diffColor "* diff:" + in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) +++ + "\n" +++ but_got_ +++ " " +++ noColor (withNewline (trim act)) +++ + "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff +++ + (if (exp == act) + then "\nWARNING: strings are equal but actual values differ!" + else "")) + where + withNewline s = + case lines s of + [] -> s + [_] -> s + _ -> '\n':s + newlineBeforeDiff d = + let f b = case colorStringFind (\c -> c == '\n') d b of + Just _ -> "\n" + Nothing -> "" + in noColor' (f True) (f False) + trim s = + case List.splitAt maxLen s of + (_, []) -> s + (prefix, rest) -> + prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)" + maxLen = 10000 + +asString :: Show a => a -> Maybe String +asString x = readM (show x) + +equalityFailedMessage :: (Show a) => a -> a -> ColorString +equalityFailedMessage exp act = + equalityFailedMessage' expP actP + where + (expP, actP) = + case (asString exp, asString act) of + (Just expS, Just actS) + | expS /= actS -> (expS, actS) + _ -> + case (prettyHaskell' exp, prettyHaskell' act) of + (Nothing, _) -> (show exp, show act) + (_, Nothing) -> (show exp, show act) + (Just expP, Just actP) + | expP == actP -> + (show exp, show act) + | otherwise -> (expP, actP) + +notEqualityFailedMessage :: Show a => a -> String +notEqualityFailedMessage exp = + notEqualityFailedMessage' (prettyHaskell exp) + +notEqualityFailedMessage' :: String -> String +notEqualityFailedMessage' exp = + (": Objects are equal\n" ++ exp) + +failedAt :: HasCallStack => String +failedAt = + case failureLocation of + Nothing -> "failed" + Just loc -> "failed at " ++ showLoc loc + +assertEqual_ :: (Eq a, Show a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertEqual_ name s expected actual = + if expected /= actual + then do let x = equalityFailedMessage expected actual + genericAssertFailure (mkColorMsg name s $ + noColor failedAt +++ x) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +gassertEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertEqualVerbose = assertEqual_ "gassertEqualVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +gassertEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m () +gassertEqual = assertEqual_ "gassertEqual" "" + +-- | Fail if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +assertEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO () +assertEqualVerbose = assertEqual_ "assertEqualVerbose" + +-- | Fail if the two values of type @a@ are not equal. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +assertEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO () +assertEqual = assertEqual_ "assertEqual" "" + +assertNotEqual_ :: (Eq a, Show a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertNotEqual_ name s expected actual = + if expected == actual + then do let x = notEqualityFailedMessage expected + genericAssertFailure (mkMsg name s $ failedAt ++ x) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +gassertNotEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertNotEqualVerbose = assertNotEqual_ "gassertNotEqualVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +gassertNotEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m () +gassertNotEqual = assertNotEqual_ "gassertNotEqual" "" + +-- | Fail if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +assertNotEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO () +assertNotEqualVerbose = assertNotEqual_ "assertNotEqualVerbose" + +-- | Fail if the two values of type @a@ are equal. +-- Use if @a@ is an instance of 'Show' but not of 'Pretty'. +assertNotEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO () +assertNotEqual = assertNotEqual_ "assertNotEqual" "" + +assertEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertEqualPretty_ name s expected actual = + if expected /= actual + then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual) + genericAssertFailure (mkColorMsg name s + (noColor failedAt +++ x)) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Pretty'. +gassertEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertEqualPrettyVerbose = assertEqualPretty_ "gassertEqualPrettyVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal. +-- Use if @a@ is an instance of 'Pretty'. +gassertEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m () +gassertEqualPretty = assertEqualPretty_ "gassertEqualPretty" "" + +-- | Fail if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Pretty'. +assertEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO () +assertEqualPrettyVerbose = assertEqualPretty_ "assertEqualPrettyVerbose" + +-- | Fail if the two values of type @a@ are not equal. +-- Use if @a@ is an instance of 'Pretty'. +assertEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO () +assertEqualPretty = assertEqualPretty_ "assertEqualPretty" "" + +assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertNotEqualPretty_ name s expected actual = + if expected == actual + then do let x = notEqualityFailedMessage' (showPretty expected) + genericAssertFailure (mkMsg name s $ failedAt ++ x) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Pretty'. +gassertNotEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertNotEqualPrettyVerbose = assertNotEqualPretty_ "gassertNotEqualPrettyVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal. +-- Use if @a@ is an instance of 'Pretty'. +gassertNotEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m () +gassertNotEqualPretty = assertNotEqualPretty_ "gassertNotEqualPretty" "" + +-- | Fail if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is an instance of 'Pretty'. +assertNotEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO () +assertNotEqualPrettyVerbose = assertNotEqualPretty_ "assertNotEqualPrettyVerbose" + +-- | Fail if the two values of type @a@ are equal. +-- Use if @a@ is an instance of 'Pretty'. +assertNotEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO () +assertNotEqualPretty = assertNotEqualPretty_ "assertNotEqualPretty" "" + +assertEqualNoShow_ :: (Eq a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertEqualNoShow_ name s expected actual = + if expected /= actual + then genericAssertFailure (mkMsg name s failedAt) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +gassertEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertEqualNoShowVerbose = assertEqualNoShow_ "gassertEqualNoShowVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +gassertEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m () +gassertEqualNoShow = assertEqualNoShow_ "gassertEqualNoShow" "" + +-- | Fail if the two values of type @a@ are not equal, supplying +-- an additional message. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +assertEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO () +assertEqualNoShowVerbose = assertEqualNoShow_ "assertEqualNoShowVerbose" + +-- | Fail if the two values of type @a@ are not equal. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +assertEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO () +assertEqualNoShow = assertEqualNoShow_ "assertEqualNoShow" "" + +assertNotEqualNoShow_ :: (Eq a, AssertM m, HasCallStack) + => String -> String -> a -> a -> m () +assertNotEqualNoShow_ name s expected actual = + if expected == actual + then genericAssertFailure (mkMsg name s failedAt) + else return () + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +gassertNotEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m () +gassertNotEqualNoShowVerbose = assertNotEqualNoShow_ "gassertNotEqualNoShowVerbose" + +-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +gassertNotEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m () +gassertNotEqualNoShow = assertNotEqualNoShow_ "gassertNotEqualNoShow" "" + +-- | Fail if the two values of type @a@ are equal, supplying +-- an additional message. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +assertNotEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO () +assertNotEqualNoShowVerbose = assertNotEqualNoShow_ "assertNotEqualNoShowVerbose" + +-- | Fail if the two values of type @a@ are equal. +-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'. +assertNotEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO () +assertNotEqualNoShow = assertNotEqualNoShow_ "assertNotEqualNoShow" "" + +-- +-- Assertions on Lists +-- + +assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m, HasCallStack) + => String -> String -> [a] -> [a] -> m () +assertListsEqualAsSets_ name s expected actual = + let ne = length expected + na = length actual + in case () of + _| ne /= na -> + do let x = equalityFailedMessage expected actual + genericAssertFailure (mkColorMsg name s + (noColor + (failedAt + ++ "\n expected length: " ++ show ne + ++ "\n actual length: " ++ show na) +++ + (if maxLength x < 5000 + then x else emptyColorString))) + | not (unorderedEq expected actual) -> + do let x = equalityFailedMessage expected actual + genericAssertFailure (mkColorMsg "assertSetEqual" s + (noColor failedAt +++ x)) + | otherwise -> return () + where unorderedEq l1 l2 = + null (l1 \\ l2) && null (l2 \\ l1) + +-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets, +-- supplying an additional error message. +gassertListsEqualAsSetsVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> [a] -> [a] -> m () +gassertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "gassertListsEqualAsSetsVerbose" + +-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets. +gassertListsEqualAsSets :: (Eq a, Show a, AssertM m, HasCallStack) => [a] -> [a] -> m () +gassertListsEqualAsSets= assertListsEqualAsSets_ "gassertListsEqualAsSets" "" + +-- | Fail if the two given lists are not equal when considered as sets, +-- supplying an additional error message. +assertListsEqualAsSetsVerbose :: (Eq a, Show a, HasCallStack) => String -> [a] -> [a] -> IO () +assertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "assertListsEqualAsSetsVerbose" + +-- | Fail if the two given lists are not equal when considered as sets. +assertListsEqualAsSets :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> IO () +assertListsEqualAsSets = assertListsEqualAsSets_ "assertListsEqualAsSets" "" + +assertNotEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m () +assertNotEmpty_ name s [] = + genericAssertFailure (mkMsg name s failedAt) +assertNotEmpty_ _ _ (_:_) = return () + +-- | Fail in some 'AssertM' monad if the given list is empty, supplying an +-- additional error message. +gassertNotEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m () +gassertNotEmptyVerbose = assertNotEmpty_ "gassertNotEmptyVerbose" + +-- | Fail in some 'AssertM' monad if the given list is empty. +gassertNotEmpty :: (HasCallStack, AssertM m) => [a] -> m () +gassertNotEmpty = assertNotEmpty_ "gassertNotEmpty" "" + +-- | Fail if the given list is empty, supplying an +-- additional error message. +assertNotEmptyVerbose :: HasCallStack => String -> [a] -> IO () +assertNotEmptyVerbose = assertNotEmpty_ "assertNotEmptyVerbose" + +-- | Fail if the given list is empty. +assertNotEmpty :: HasCallStack => [a] -> IO () +assertNotEmpty = assertNotEmpty_ "assertNotEmpty" "" + +assertEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m () +assertEmpty_ name s (_:_) = + genericAssertFailure (mkMsg name s failedAt) +assertEmpty_ _ _ [] = return () + +-- | Fail in some 'AssertM' monad if the given list is not empty, supplying an +-- additional error message. +gassertEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m () +gassertEmptyVerbose = assertEmpty_ "gassertEmptyVerbose" + +-- | Fail in some 'AssertM' monad if the given list is not empty. +gassertEmpty :: (HasCallStack, AssertM m) => [a] -> m () +gassertEmpty = assertEmpty_ "gassertEmpty" "" + +-- | Fail if the given list is not empty, supplying an +-- additional error message. +assertEmptyVerbose :: HasCallStack => String -> [a] -> IO () +assertEmptyVerbose = assertEmpty_ "assertEmptyVerbose" + +-- | Fail if the given list is not empty. +assertEmpty :: HasCallStack => [a] -> IO () +assertEmpty = assertEmpty_ "assertEmpty" "" + +assertElem_ :: (Eq a, Show a, AssertM m, HasCallStack) => String -> String -> a -> [a] -> m () +assertElem_ name s x l = + if x `elem` l + then return () + else genericAssertFailure (mkMsg name s + (failedAt ++ + "\n element: " ++ show x ++ + "\n list: " ++ show l)) + +-- | Fail in some 'AssertM' monad if the element given is not contained in the list, supplying +-- an additional error message. +gassertElemVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> [a] -> m () +gassertElemVerbose = assertElem_ "gassertElemVerbose" + +-- | Fail in some 'AssertM' monad if the element given is not contained in the list. +gassertElem :: (Eq a, Show a, AssertM m, HasCallStack) => a -> [a] -> m () +gassertElem = assertElem_ "gassertElem" "" + +-- | Fail if the element given is not contained in the list, supplying +-- an additional error message. +assertElemVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> [a] -> IO () +assertElemVerbose = assertElem_ "assertElemVerbose" + +-- | Fail if the element given is not contained in the list. +assertElem :: (Eq a, Show a, HasCallStack) => a -> [a] -> IO () +assertElem = assertElem_ "assertElem" "" + +-- +-- Assertions for Exceptions +-- + +assertThrowsIO_ :: (HasCallStack, Exception e) + => String -> String -> IO a -> (e -> Bool) -> IO () +assertThrowsIO_ name s x f = + assertThrowsM_ name s x f + +-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate +-- @(e -> Bool)@, supplying an additional error message. +assertThrowsIOVerbose :: (HasCallStack, Exception e) => String -> IO a -> (e -> Bool) -> IO () +assertThrowsIOVerbose = assertThrowsIO_ "assertThrowsIOVerbose" + +-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate +-- @(e -> Bool)@. +assertThrowsIO :: (HasCallStack, Exception e) => IO a -> (e -> Bool) -> IO () +assertThrowsIO = assertThrowsIO_ "assertThrowsIO" "" + +assertThrowsSomeIO_ :: HasCallStack => String -> String -> IO a -> IO () +assertThrowsSomeIO_ name s x = assertThrowsIO_ name s x (\ (_e::SomeException) -> True) + +-- | Fail if executing the 'IO' action does not throw any exception, +-- supplying an additional error message. +assertThrowsSomeIOVerbose :: HasCallStack => String -> IO a -> IO () +assertThrowsSomeIOVerbose = assertThrowsSomeIO_ "assertThrowsSomeIOVerbose" + +-- | Fail if executing the 'IO' action does not throw any exception. +assertThrowsSomeIO :: HasCallStack => IO a -> IO () +assertThrowsSomeIO = assertThrowsSomeIO_ "assertThrowsSomeIO" "" + +assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack) + => String -> String -> m a -> (e -> Bool) -> m () +assertThrowsM_ name s x f = + do res <- ExL.try x + case res of + Right _ -> liftIO $ + genericAssertFailure (mkMsg name s + (failedAt ++ + ": no exception was thrown")) + Left e -> if f e then return () + else liftIO $ + genericAssertFailure (mkMsg name s + (failedAt ++ + ": wrong exception was thrown: " ++ + show e)) +-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate +-- @(e -> Bool)@, supplying an additional error message. +assertThrowsMVerbose :: + (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack) + => String -> m a -> (e -> Bool) -> m () +assertThrowsMVerbose = assertThrowsM_ "assertThrowsMVerbose" + +-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate +-- @(e -> Bool)@. +assertThrowsM :: + (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack) + => m a -> (e -> Bool) -> m () +assertThrowsM = assertThrowsM_ "assertThrowsM" "" + +assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m, HasCallStack) + => String -> String -> m a -> m () +assertThrowsSomeM_ name s x = assertThrowsM_ name s x (\ (_e::SomeException) -> True) + +-- | Fail if executing the @m@ action does not throw any exception, +-- supplying an additional error message. +assertThrowsSomeMVerbose :: + (MonadBaseControl IO m, MonadIO m, HasCallStack) + => String -> m a -> m () +assertThrowsSomeMVerbose = assertThrowsSomeM_ "assertThrowsSomeMVerbose" + +-- | Fail if executing the @m@ action does not throw any exception. +assertThrowsSomeM :: (MonadBaseControl IO m, MonadIO m, HasCallStack) => m a -> m () +assertThrowsSomeM = assertThrowsSomeM_ "assertThrowsSomeM" "" + +assertThrows_ :: (HasCallStack, Exception e) + => String -> String -> a -> (e -> Bool) -> IO () +assertThrows_ name s x f = assertThrowsIO_ name s (evaluate x) f + +-- | Fail if evaluating the expression of type @a@ does not +-- throw an exception satisfying the given predicate @(e -> Bool)@, +-- supplying an additional error message. +assertThrowsVerbose :: (HasCallStack, Exception e) => String -> a -> (e -> Bool) -> IO () +assertThrowsVerbose = assertThrows_ "assertThrowsVerbose" + +-- | Fail if evaluating the expression of type @a@ does not +-- throw an exception satisfying the given predicate @(e -> Bool)@. +assertThrows :: (HasCallStack, Exception e) => a -> (e -> Bool) -> IO () +assertThrows = assertThrows_ "assertThrows" "" + +assertThrowsSome_ :: HasCallStack => String -> String -> a -> IO () +assertThrowsSome_ name s x = + assertThrows_ name s x (\ (_e::SomeException) -> True) + +-- | Fail if evaluating the expression of type @a@ does not +-- throw any exception, supplying an additional error message. +assertThrowsSomeVerbose :: HasCallStack => String -> a -> IO () +assertThrowsSomeVerbose = assertThrowsSome_ "assertThrowsSomeVerbose" + +-- | Fail if evaluating the expression of type @a@ does not +-- throw any exception. +assertThrowsSome :: HasCallStack => a -> IO () +assertThrowsSome = assertThrowsSome_ "assertThrowsSome" "" + +-- +-- Assertions on Either +-- + +assertLeft_ :: forall a b m . (AssertM m, Show b, HasCallStack) + => String -> String -> Either a b -> m a +assertLeft_ _ _ (Left x) = return x +assertLeft_ name s (Right x) = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected a Left value, given " ++ + show (Right x :: Either b b))) + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right', +-- supplying an additional error message. +-- Use this function if @b@ is an instance of 'Show'. +gassertLeftVerbose :: (Show b, AssertM m, HasCallStack) => String -> Either a b -> m a +gassertLeftVerbose = assertLeft_ "gassertLeftVerbose" + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'. +-- Use this function if @b@ is an instance of 'Show'. +gassertLeft :: (Show b, AssertM m, HasCallStack) => Either a b -> m a +gassertLeft = assertLeft_ "gassertLeft" "" + +-- | Fail if the given @Either a b@ value is a 'Right', +-- supplying an additional error message. +-- Use this function if @b@ is an instance of 'Show'. +assertLeftVerbose :: (Show b, HasCallStack) => String -> Either a b -> IO a +assertLeftVerbose = assertLeft_ "assertLeftVerbose" + +-- | Fail if the given @Either a b@ value is a 'Right'. +-- Use this function if @b@ is an instance of 'Show'. +assertLeft :: (HasCallStack, Show b) => Either a b -> IO a +assertLeft = assertLeft_ "assertLeft" "" + +assertLeftNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m a +assertLeftNoShow_ _ _ (Left x) = return x +assertLeftNoShow_ name s (Right _) = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected a Left value, given a Right value")) + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right', +-- supplying an additional error message. +-- Use this function if @b@ is not an instance of 'Show'. +gassertLeftNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m a +gassertLeftNoShowVerbose = assertLeftNoShow_ "gassertLeftNoShowVerbose" + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'. +-- Use this function if @b@ is not an instance of 'Show'. +gassertLeftNoShow :: (HasCallStack, AssertM m) => Either a b -> m a +gassertLeftNoShow = assertLeftNoShow_ "gassertLeftNoShow" "" + +-- | Fail if the given @Either a b@ value is a 'Right', +-- supplying an additional error message. +-- Use this function if @b@ is not an instance of 'Show'. +assertLeftNoShowVerbose :: HasCallStack => String -> Either a b -> IO a +assertLeftNoShowVerbose = assertLeftNoShow_ "assertLeftNoShowVerbose" + +-- | Fail if the given @Either a b@ value is a 'Right'. +-- Use this function if @b@ is not an instance of 'Show'. +assertLeftNoShow :: HasCallStack => Either a b -> IO a +assertLeftNoShow = assertLeftNoShow_ "assertLeftNoShow" "" + +assertRight_ :: forall a b m . (AssertM m, Show a, HasCallStack) + => String -> String -> Either a b -> m b +assertRight_ _ _ (Right x) = return x +assertRight_ name s (Left x) = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected a Right value, given " ++ + show (Left x :: Either a a))) + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left', +-- supplying an additional error message. +-- Use this function if @a@ is an instance of 'Show'. +gassertRightVerbose :: (Show a, AssertM m, HasCallStack) => String -> Either a b -> m b +gassertRightVerbose = assertRight_ "gassertRightVerbose" + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'. +-- Use this function if @a@ is an instance of 'Show'. +gassertRight :: (Show a, AssertM m, HasCallStack) => Either a b -> m b +gassertRight = assertRight_ "gassertRight" "" + +-- | Fail if the given @Either a b@ value is a 'Left', +-- supplying an additional error message. +-- Use this function if @a@ is an instance of 'Show'. +assertRightVerbose :: (Show a, HasCallStack) => String -> Either a b -> IO b +assertRightVerbose = assertRight_ "assertRightVerbose" + +-- | Fail if the given @Either a b@ value is a 'Left'. +-- Use this function if @a@ is an instance of 'Show'. +assertRight :: (HasCallStack, Show a) => Either a b -> IO b +assertRight = assertRight_ "assertRight" "" + +assertRightNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m b +assertRightNoShow_ _ _ (Right x) = return x +assertRightNoShow_ name s (Left _) = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected a Right value, given a Left value")) + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left', +-- supplying an additional error message. +-- Use this function if @a@ is not an instance of 'Show'. +gassertRightNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m b +gassertRightNoShowVerbose = assertRightNoShow_ "gassertRightNoShowVerbose" + +-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'. +-- Use this function if @a@ is not an instance of 'Show'. +gassertRightNoShow :: (HasCallStack, AssertM m) => Either a b -> m b +gassertRightNoShow = assertRightNoShow_ "gassertRightNoShow" "" + +-- | Fail if the given @Either a b@ value is a 'Left', +-- supplying an additional error message. +-- Use this function if @a@ is not an instance of 'Show'. +assertRightNoShowVerbose :: HasCallStack => String -> Either a b -> IO b +assertRightNoShowVerbose = assertRightNoShow_ "assertRightNoShowVerbose" + +-- | Fail if the given @Either a b@ value is a 'Left'. +-- Use this function if @a@ is not an instance of 'Show'. +assertRightNoShow :: HasCallStack => Either a b -> IO b +assertRightNoShow = assertRightNoShow_ "assertRightNoShow" "" + +-- +-- Assertions on Maybe +-- + +assertJust_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m a +assertJust_ _ _ (Just x) = return x +assertJust_ name s Nothing = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected a Just value, given Nothing")) + +-- | Fail in some 'AssertM' monad if the given value is a Nothing, supplying an additional +-- error message. +gassertJustVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m a +gassertJustVerbose = assertJust_ "gassertJustVerbose" + +-- | Fail in some 'AssertM' monad if the given value is a Nothing. +gassertJust :: (HasCallStack, AssertM m) => Maybe a -> m a +gassertJust = assertJust_ "gassertJust" "" + +-- | Fail if the given value is a Nothing, supplying an additional +-- error message. +assertJustVerbose :: HasCallStack => String -> Maybe a -> IO a +assertJustVerbose = assertJust_ "assertJustVerbose" + +-- | Fail if the given value is a Nothing. +assertJust :: HasCallStack => Maybe a -> IO a +assertJust = assertJust_ "assertJust" "" + +assertNothing_ :: (Show a, AssertM m, HasCallStack) + => String -> String -> Maybe a -> m () +assertNothing_ _ _ Nothing = return () +assertNothing_ name s jx = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected Nothing, given " ++ show jx)) + +-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional +-- error message. +-- Use this function if @a@ is an instance of 'Show'. +gassertNothingVerbose :: (Show a, AssertM m, HasCallStack) => String -> Maybe a -> m () +gassertNothingVerbose = assertNothing_ "gassertNothingVerbose" + +-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'. +-- Use this function if @a@ is an instance of 'Show'. +gassertNothing :: (Show a, AssertM m, HasCallStack) => Maybe a -> m () +gassertNothing = assertNothing_ "gassertNothing" "" + +-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional +-- error message. +-- Use this function if @a@ is an instance of 'Show'. +assertNothingVerbose :: (Show a, HasCallStack) => String -> Maybe a -> IO () +assertNothingVerbose = assertNothing_ "assertNothingVerbose" + +-- | Fail if the given @Maybe a@ value is a 'Just'. +-- Use this function if @a@ is an instance of 'Show'. +assertNothing :: (HasCallStack, Show a) => Maybe a -> IO () +assertNothing = assertNothing_ "assertNothing" "" + +assertNothingNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m () +assertNothingNoShow_ _ _ Nothing = return () +assertNothingNoShow_ name s _ = + genericAssertFailure (mkMsg name s + (failedAt ++ + ": expected Nothing, given a Just value")) + +-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional +-- error message. +-- Use this function if @a@ is not an instance of 'Show'. +gassertNothingNoShowVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m () +gassertNothingNoShowVerbose = assertNothingNoShow_ "gassertNothingNoShowVerbose" + +-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'. +-- Use this function if @a@ is not an instance of 'Show'. +gassertNothingNoShow :: (HasCallStack, AssertM m) => Maybe a -> m () +gassertNothingNoShow = assertNothingNoShow_ "gassertNothingNoShow" "" + +-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional +-- error message. +-- Use this function if @a@ is not an instance of 'Show'. +assertNothingNoShowVerbose :: HasCallStack => String -> Maybe a -> IO () +assertNothingNoShowVerbose = assertNothingNoShow_ "assertNothingNoShowVerbose" + +-- | Fail if the given @Maybe a@ value is a 'Just'. +-- Use this function if @a@ is not an instance of 'Show'. +assertNothingNoShow :: HasCallStack => Maybe a -> IO () +assertNothingNoShow = assertNothingNoShow_ "assertNothingNoShow" "" + +-- +-- Sub assertions +-- + +-- | Use 'subAssert' if you want location information for the call site but the function +-- being called does not carry a 'HasCallStack' constraint. +subAssert :: (HasCallStack, MonadBaseControl IO m) => m a -> m a +subAssert = subAssertHTF Nothing + +gsubAssert :: (HasCallStack, AssertM m) => m a -> m a +gsubAssert = genericSubAssert Nothing + +subAssertVerbose :: (HasCallStack, MonadBaseControl IO m) => String -> m a -> m a +subAssertVerbose msg = subAssertHTF (Just msg) + +gsubAssertVerbose :: (HasCallStack, AssertM m) => String -> m a -> m a +gsubAssertVerbose msg = genericSubAssert (Just msg) + +testEqualityFailedMessage1 :: IO () +testEqualityFailedMessage1 = + let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3,4]) False + in HU.assertEqual "error" msg exp + where + exp = "\n* expected: [1, 2, 3]\n* but got: [1, 2, 3, 4]\n* " ++ + "diff: \nC <...[1, 2, 3...>C \nS , 4\nC ]<......>C " + +testEqualityFailedMessage2 :: IO () +testEqualityFailedMessage2 = + let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3]) False + in HU.assertEqual "error" msg exp + where + exp = "\n* expected: [1,2,3]\n* but got: [1,2,3]\n* " ++ + "diff: \nWARNING: strings are equal but actual values differ!" + +hunitWrapperTests = + [("testEqualityFailedMessage1", testEqualityFailedMessage1) + ,("testEqualityFailedMessage2", testEqualityFailedMessage2)] diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs deleted file mode 100644 --- a/Test/Framework/HaskellParser.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables,CPP #-} - --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA --- - -module Test.Framework.HaskellParser where - -import Data.Maybe -import Data.Char ( isSpace, isDigit ) -import qualified Data.List as List -import Control.Exception ( evaluate, catch, SomeException ) -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding ( catch ) -#endif - -import qualified Language.Haskell.Exts as Exts -import qualified Language.Haskell.Exts.Parser as Parser -import qualified Language.Haskell.Exts.Syntax as Syn -import qualified Language.Haskell.Exts.Extension as Ext -import qualified Language.Haskell.Exts.Fixity as Fix -import qualified Language.Haskell.Exts.SrcLoc as Src - -import Test.Framework.Location -import Test.Framework.Utils - -type Name = String - -data Decl = Decl { decl_loc :: Location - , decl_name :: Name } - deriving (Show) - -data Pragma = Pragma { pr_name :: String - , pr_args :: String - , pr_loc :: Location } - deriving (Show) - -data ParseResult a = ParseOK a | ParseError Location String - -data Module = Module { mod_name :: Name - , mod_imports :: [ImportDecl] - , mod_decls :: [Decl] - , mod_htfPragmas :: [Pragma] } - deriving (Show) - -data ImportDecl = ImportDecl { imp_moduleName :: Name - , imp_qualified :: Bool - , imp_alias :: Maybe Name - , imp_loc :: Location } - deriving (Show) - --- Returns for lines of the form '# ""' --- (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.baseLanguage = Ext.Haskell2010 - , Parser.ignoreLanguagePragmas = False - , Parser.ignoreLinePragmas = False - , Parser.extensions = (map Ext.EnableExtension - extensions) - , Parser.fixities = Nothing - } - extensions = - [ Ext.ForeignFunctionInterface - , Ext.UnliftedFFITypes - , Ext.GADTs - , Ext.ScopedTypeVariables - , Ext.UnboxedTuples - , Ext.TypeSynonymInstances - , Ext.StandaloneDeriving - , Ext.DeriveDataTypeable - , Ext.FlexibleContexts - , Ext.FlexibleInstances - , Ext.ConstrainedClassMethods - , Ext.MultiParamTypeClasses - , Ext.FunctionalDependencies - , Ext.MagicHash - , Ext.PolymorphicComponents - , Ext.ExistentialQuantification - , Ext.UnicodeSyntax - , Ext.PostfixOperators - , Ext.PatternGuards - , Ext.LiberalTypeSynonyms - , Ext.RankNTypes - , Ext.ImpredicativeTypes - , Ext.TypeOperators - , Ext.RecursiveDo - , Ext.ParallelListComp - , Ext.EmptyDataDecls - , Ext.KindSignatures - , Ext.GeneralizedNewtypeDeriving - , Ext.TypeFamilies - , Ext.NamedFieldPuns - , Ext.RecordWildCards - , Ext.PackageImports - , Ext.ViewPatterns - , Ext.TupleSections - , Ext.NondecreasingIndentation - , Ext.DoAndIfThenElse - ] - unknownLoc :: Syn.SrcLoc - unknownLoc = Syn.SrcLoc originalFileName 0 0 - transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls) - comments = - Module moduleName (map transformImport imports) - (mapMaybe transformDecl decls) - (mapMaybe transformComment comments) - transformImport (Syn.ImportDecl loc (Syn.ModuleName s) - qualified _ _ alias _) = - let alias' = case alias of - Nothing -> Nothing - Just (Syn.ModuleName s) -> Just s - in ImportDecl s qualified alias' (transformLoc loc) - transformDecl (Syn.PatBind loc (Syn.PVar name) _ _ _) = - Just $ Decl (transformLoc loc) (transformName name) - transformDecl (Syn.FunBind (Syn.Match loc name _ _ _ _ : _)) = - Just $ Decl (transformLoc loc) (transformName name) - transformDecl _ = Nothing - transformSpan span = makeLoc (Src.srcSpanFilename span) (Src.srcSpanStartLine span) - transformLoc (Syn.SrcLoc f n _) = makeLoc f n - transformName :: Syn.Name -> String - transformName (Syn.Ident s) = s - transformName (Syn.Symbol s) = s - transformComment (Exts.Comment True span ('@':s)) = - case reverse s of - '@':r -> - let stripped = strip (reverse r) - in if "HTF_" `List.isPrefixOf` stripped - then let (name, args) = List.span (not . isSpace) stripped - argsStripped = dropWhile isSpace args - loc = transformSpan span - in Just $ Pragma name argsStripped loc - else Nothing - _ -> Nothing - transformComment _ = Nothing 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, @@ -62,6 +78,7 @@ import Test.Framework.TestTypes import Test.Framework.Location import Test.Framework.Colors +import Test.Framework.TestInterface import qualified Data.Aeson as J import Data.Aeson ((.=)) @@ -89,34 +106,28 @@ = TestEndEventObj { te_test :: TestObj , te_result :: TestResult - , te_location :: Maybe Location - , te_callers :: [(Maybe String, Location)] + , te_stack :: HtfStack , te_message :: T.Text , te_wallTimeMs :: Int + , te_timedOut :: Bool } instance J.ToJSON TestEndEventObj where toJSON te = J.object ["type" .= J.String "test-end" ,"test" .= J.toJSON (te_test te) - ,"location" .= J.toJSON (te_location te) - ,"callers" .= J.toJSON (map (\(msg, loc) -> J.object ["message" .= J.toJSON msg - ,"location" .= J.toJSON loc]) - (te_callers te)) + ,"location" .= J.toJSON (failureLocationFromStack (te_stack te)) + ,"callers" .= + J.toJSON (map (\entry -> J.object ["location" .= J.toJSON (hse_location entry) + ,"message" .= J.toJSON (hse_message entry)]) + (restCallStack (te_stack te))) ,"result" .= J.toJSON (te_result te) ,"message" .= J.toJSON (te_message te) - ,"wallTime" .= J.toJSON (te_wallTimeMs te)] + ,"wallTime" .= J.toJSON (te_wallTimeMs te) + ,"timedOut" .= J.toJSON (te_timedOut te)] instance HTFJsonObj TestEndEventObj -instance J.ToJSON TestResult where - toJSON r = J.String $ - case r of - Pass -> "pass" - Pending -> "pending" - Fail -> "fail" - Error -> "error" - -- "test-list" message data TestListObj = TestListObj @@ -138,6 +149,8 @@ , tr_pending :: Int , tr_failed :: Int , tr_errors :: Int + , tr_timedOut :: Int + , tr_filtered :: Int } instance J.ToJSON TestResultsObj where @@ -146,6 +159,8 @@ ,"pending" .= J.toJSON (tr_pending r) ,"failures" .= J.toJSON (tr_failed r) ,"errors" .= J.toJSON (tr_errors r) + ,"timedOut" .= J.toJSON (tr_timedOut r) + ,"filtered" .= J.toJSON (tr_filtered r) ,"wallTime" .= J.toJSON (tr_wallTimeMs r)] instance HTFJsonObj TestResultsObj @@ -194,21 +209,23 @@ mkTestEndEventObj ftr flatName = let r = ft_payload ftr msg = renderColorString (rr_message r) False - in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_location r) (rr_callers r) - msg (rr_wallTimeMs r) + in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_stack r) + msg (rr_wallTimeMs r) (rr_timeout r) mkTestListObj :: [(FlatTest, String)] -> TestListObj mkTestListObj l = TestListObj (map (\(ft, flatName) -> mkTestObj ft flatName) l) -mkTestResultsObj :: Milliseconds -> Int -> Int -> Int -> Int -> TestResultsObj -mkTestResultsObj time passed pending failed errors = +mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj +mkTestResultsObj arg = TestResultsObj - { tr_wallTimeMs = time - , tr_passed = passed - , tr_pending = pending - , tr_failed = failed - , tr_errors = errors + { tr_wallTimeMs = rgra_timeMs arg + , tr_passed = length (rgra_passed arg) + , tr_pending = length (rgra_pending arg) + , tr_failed = length (rgra_failed arg) + , tr_errors = length (rgra_errors arg) + , tr_timedOut = length (rgra_timedOut arg) + , tr_filtered = length (rgra_filtered arg) } decodeObj :: HTFJsonObj a => a -> BSL.ByteString 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,8 +1,13 @@ +{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{- | +Internal module providing access to some functionality of cpphs. +-} -- --- Copyright (c) 2009-2014 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -19,20 +24,37 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Preprocessor ( transform, progName ) where +module Test.Framework.Preprocessor ( + transform, progName, preprocessorTests, TransformOptions(..) + +) where + +-- import Debug.Trace import Control.Monad -import qualified Data.Text as T -import Data.Char ( toLower, isSpace, isDigit ) -import Data.Maybe ( mapMaybe ) -import qualified Data.List as List -import System.IO ( hPutStrLn, stderr ) -import Language.Preprocessor.Cpphs ( runCpphs, +import Data.Char +import Language.Preprocessor.Cpphs ( runCpphsPass1, + runCpphsPass2, CpphsOptions(..), BoolOptions(..), - defaultCpphsOptions) + defaultCpphsOptions, + WordStyle(..), + Posn, + filename, + lineno, + newfile, + tokenise + ) +import System.IO ( hPutStrLn, stderr ) +#if MIN_VERSION_HUnit(1,4,0) +import Test.HUnit hiding (State) +#else +import Test.HUnit hiding (State, Location) +#endif +import Control.Monad.State.Strict +import qualified Data.List as List +import Data.Maybe -import Test.Framework.HaskellParser import Test.Framework.Location _DEBUG_ :: Bool @@ -66,230 +88,316 @@ nameDefines :: ModuleInfo -> [(String, String)] nameDefines info = - [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleName info)), - (importedTestListName, importedTestListFullName (mi_moduleName info))] - -allAsserts :: [String] -allAsserts = - withGs ["assertBool" - ,"assertEqual" - ,"assertEqualPretty" - ,"assertEqualNoShow" - ,"assertNotEqual" - ,"assertNotEqualPretty" - ,"assertNotEqualNoShow" - ,"assertListsEqualAsSets" - ,"assertElem" - ,"assertEmpty" - ,"assertNotEmpty" - ,"assertLeft" - ,"assertLeftNoShow" - ,"assertRight" - ,"assertRightNoShow" - ,"assertJust" - ,"assertNothing" - ,"assertNothingNoShow" - ,"subAssert" - ,"subAssertVerbose" - ] ++ ["assertThrows" - ,"assertThrowsSome" - ,"assertThrowsIO" - ,"assertThrowsSomeIO" - ,"assertThrowsM" - ,"assertThrowsSomeM"] - where - withGs l = - concatMap (\s -> [s, 'g':s]) l - -assertDefines :: Bool -> String -> [(String, String)] -assertDefines hunitBackwardsCompat prefix = - concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")] - where - fun a = - if hunitBackwardsCompat - then [(a, expansion a "Verbose_"), (a ++ "HTF", expansion a "_")] - else [(a, expansion a "_"), (a ++ "Verbose", expansion a "Verbose_")] - expansion a suffix = "(" ++ prefix ++ a ++ suffix ++ " (" ++ - prefix ++ "makeLoc __FILE__ __LINE__))" - -warn :: String -> IO () -warn s = - hPutStrLn stderr $ progName ++ " warning: " ++ s - -note :: String -> IO () -note s = - when _DEBUG_ $ hPutStrLn stderr $ progName ++ " note: " ++ s + [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)), + (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault info))] data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition] - , mi_moduleName :: String } - deriving (Show) + , mi_moduleName :: Maybe String } + deriving (Show, Eq) +mi_moduleNameWithDefault :: ModuleInfo -> String +mi_moduleNameWithDefault = fromMaybe "Main" . mi_moduleName + +data ImportDecl = ImportDecl { imp_moduleName :: Name + , imp_qualified :: Bool + , imp_alias :: Maybe Name + , imp_loc :: Location } + deriving (Show, Eq) + data Definition = TestDef String Location String | PropDef String Location String - deriving (Show) + deriving (Eq, Show) -data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma - deriving (Show) +type Name = String -analyse :: FilePath -> String - -> IO (ParseResult ModuleInfo) -analyse originalFileName inputString = - do parseResult <- parse originalFileName inputString - case parseResult of - ParseOK (Module moduleName imports decls pragmas) -> - do -- putStrLn $ show decls - let defs = mapMaybe defFromDecl decls - htfImports = findHtfImports imports pragmas - htfPrefix <- - case mapMaybe prefixFromImport imports of - (s:_) -> return s - [] -> do warn ("No import found for " ++ htfModule ++ - " in " ++ originalFileName) - return (htfModule ++ ".") - return $ ParseOK (ModuleInfo htfPrefix htfImports defs moduleName) - ParseError loc err -> return (ParseError loc err) +type PMA a = State ModuleInfo a + +setModName :: String -> PMA () +setModName name = + do oldName <- gets mi_moduleName + when (isNothing oldName) $ modify $ \mi -> mi { mi_moduleName = Just name } + +addTestDef :: String -> String -> Location -> PMA () +addTestDef name fullName loc = + modify $ \mi -> mi { mi_defs = (TestDef name loc fullName) : mi_defs mi } + +addPropDef :: String -> String -> Location -> PMA () +addPropDef name fullName loc = + modify $ \mi -> mi { mi_defs = (PropDef name loc fullName) : mi_defs mi } + +addHtfImport :: ImportDecl -> PMA () +addHtfImport decl = + modify $ \mi -> mi { mi_htfImports = decl : mi_htfImports mi } + +setTestFrameworkImport :: String -> PMA () +setTestFrameworkImport name = + modify $ \mi -> mi { mi_htfPrefix = name } + +data Tok + = TokModule + | TokQname Location String + | TokName Location Bool String + | TokHtfImport Location + | TokImport Location + +transWordStyles :: [WordStyle] -> [Tok] +transWordStyles styles = loop styles True where - prefixFromImport :: ImportDecl -> Maybe String - prefixFromImport (ImportDecl s qualified alias _) - | s == htfModule = - if qualified - then case alias of - Just s' -> Just $ s' ++ "." - Nothing -> Just $ s ++ "." - else Just "" - prefixFromImport _ = Nothing - defFromDecl :: Decl -> Maybe Definition - defFromDecl (Decl loc name) = defFromNameAndLoc name loc - defFromNameAndLoc :: Name -> Location -> Maybe Definition - defFromNameAndLoc name loc = - case name of - ('t':'e':'s':'t':'_':rest) | not (null rest) -> - Just (TestDef rest loc name) - ('p':'r':'o':'p':'_':rest) | not (null rest) -> - Just (PropDef rest loc name) - _ -> Nothing - findHtfImports allImports allPragmas = - let importPragmas = filter (\p -> pr_name p == "HTF_TESTS") allPragmas - importsAndPragmas = List.sortBy cmpByLine (map IsImport allImports ++ - map IsPragma importPragmas) - loop (IsImport imp : IsPragma prag : rest) = - if lineNumber (imp_loc imp) == lineNumber (pr_loc prag) - then imp : loop rest - else loop rest - loop (_ : rest) = loop rest - loop [] = [] - in loop importsAndPragmas - cmpByLine x y = getLine x `compare` getLine y - getLine (IsImport imp) = (lineNumber (imp_loc imp)) - getLine (IsPragma prag) = (lineNumber (pr_loc prag)) + loop styles startOfLine = + case styles of + [] -> [] + Ident pos name : rest -> + case name of + "module" -> TokModule : loop rest False + "import" -> + case dropWhite rest of + Other "{-@ HTF_TESTS @-}" : rest2 -> + TokHtfImport (posToLocation pos) : loop rest2 False + _ -> + TokImport (posToLocation pos) : loop rest False + _ -> + case parseQname rest of + ([], rest2) -> + TokName (posToLocation pos) startOfLine name : loop rest2 False + (nameParts, rest2) -> + TokQname (posToLocation pos) (List.intercalate "." (name:nameParts)) : loop rest2 False + Other str : rest -> + let startOfLine = + case reverse str of + '\n':_ -> True + _ -> False + in loop rest startOfLine + Cmd _ : rest -> loop rest False + dropWhite styles = + case styles of + Other str : rest -> + case dropWhile isSpace str of + [] -> dropWhite rest + str' -> Other str' : rest + _ -> styles + parseQname styles = + case styles of + Other "." : Ident _ name : rest -> + let (restParts, rest2) = parseQname rest + in (name:restParts, rest2) + _ -> ([], styles) + posToLocation pos = makeLoc (filename pos) (lineno pos) -breakOn :: T.Text -> T.Text -> Maybe (T.Text, T.Text) -breakOn t1 t2 = - let (pref, suf) = T.breakOn t1 t2 - in if pref == t2 - then Nothing - else Just (pref, T.drop (T.length t1) suf) +poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo +poorManAnalyzeTokens styles = + let toks = transWordStyles styles + revRes = + execState (loop toks) $ + ModuleInfo { mi_htfPrefix = htfModule ++ "." + , mi_htfImports = [] + , mi_defs = [] + , mi_moduleName = Nothing } + in ModuleInfo { mi_htfPrefix = mi_htfPrefix revRes + , mi_htfImports = reverse (mi_htfImports revRes) + , mi_defs = reverse $ List.nubBy defEqByName (mi_defs revRes) + , mi_moduleName = mi_moduleName revRes + } + where + defEqByName (TestDef n1 _ _) (TestDef n2 _ _) = n1 == n2 + defEqByName (PropDef n1 _ _) (PropDef n2 _ _) = n1 == n2 + defEqByName _ _ = False + loop toks = + case toks of + TokModule : TokQname _ name : rest -> + do setModName name + loop rest + TokModule : TokName _ _ name : rest -> + do setModName name + loop rest + TokName loc startOfLine name : rest + | startOfLine -> + case name of + 't':'e':'s':'t':'_':shortName -> + do addTestDef shortName name loc + loop rest + 'p':'r':'o':'p':'_':shortName -> + do addPropDef shortName name loc + loop rest + _ -> loop rest + | otherwise -> loop rest + TokHtfImport loc : rest -> + case parseImport loc rest of + Just (imp, rest2) -> + do addHtfImport imp + loop rest2 + Nothing -> loop rest + TokImport loc : rest -> + do case parseImport loc rest of + Nothing -> loop rest + Just (imp, rest2) -> + do when (imp_moduleName imp == htfModule) $ + let prefix = case (imp_alias imp, imp_qualified imp) of + (Just alias, True) -> alias + (Nothing, True) -> imp_moduleName imp + _ -> "" + in setTestFrameworkImport + (if null prefix then prefix else prefix ++ ".") + loop rest2 + _ : rest -> loop rest + [] -> return () + parseImport loc toks = + do let (qualified, toks2) = + case toks of + TokName _ _ "qualified" : rest -> (True, rest) + _ -> (False, toks) + (name, toks3) <- + case toks2 of + TokName _ _ name : rest -> return (name, rest) + TokQname _ name : rest -> return (name, rest) + _ -> fail "no import" + let (mAlias, toks4) = + case toks3 of + TokName _ _ "as" : TokName _ _ alias : rest -> (Just alias, rest) + _ -> (Nothing, toks3) + decl = ImportDecl { imp_moduleName = name + , imp_qualified = qualified + , imp_alias = mAlias + , imp_loc = loc } + return (decl, toks4) -poorMensAnalyse :: FilePath -> String -> IO ModuleInfo -poorMensAnalyse originalFileName inputString = - let (modName, defs, impDecls) = doAna (zip [1..] (lines inputString)) ("", [], []) - in return $ ModuleInfo "Test.Framework." impDecls defs modName +analyze :: FilePath -> String -> IO (ModuleInfo, [WordStyle], [(Posn,String)]) +analyze originalFileName input = + do xs <- runCpphsPass1 cpphsOptions originalFileName input + let bopts = boolopts cpphsOptions + toks = tokenise (stripEol bopts) (stripC89 bopts) (ansi bopts) (lang bopts) ((newfile "preDefined",""):xs) + mi = poorManAnalyzeTokens toks + return (mi, toks, xs) + +analyzeTests = + [(unlines ["module FOO where" + ,"import Test.Framework" + ,"import {-@ HTF_TESTS @-} qualified Foo as Bar" + ,"import {-@ HTF_TESTS @-} qualified Foo.X as Egg" + ,"import {-@ HTF_TESTS @-} Foo.Y as Spam" + ,"import {-@ HTF_TESTS @-} Foo.Z" + ,"import {-@ HTF_TESTS @-} Baz" + ,"deriveSafeCopy 1 'base ''T" + ,"$(deriveSafeCopy 2 'extension ''T)" + ,"test_blub test_foo = 1" + ,"test_blah test_foo = '\''" + ,"prop_abc prop_foo = 2" + ,"prop_xyz = True"] + ,ModuleInfo { mi_htfPrefix = "" + , mi_htfImports = + [ImportDecl { imp_moduleName = "Foo" + , imp_qualified = True + , imp_alias = Just "Bar" + , imp_loc = makeLoc "" 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 - doAna [] (modName, revDefs, impDecls) = (modName, reverse revDefs, reverse impDecls) - doAna ((lineNo, line) : restLines) (modName, defs, impDecls) = - case line of - 'm':'o':'d':'u':'l':'e':rest -> - if null modName - then doAna restLines (takeWhile (not . isSpace) (dropWhile isSpace rest), - defs, impDecls) - else doAna restLines (modName, defs, impDecls) - 't':'e':'s':'t':'_':rest -> - let testName = takeWhile (not . isSpace) rest - def = TestDef testName loc ("test_" ++ testName) - in doAna restLines (modName, def : defs, impDecls) - 'p':'r':'o':'p':'_':rest -> - let testName = takeWhile (not . isSpace) rest - def = PropDef testName loc ("prop_" ++ testName) - in doAna restLines (modName, def : defs, impDecls) - 'i':'m':'p':'o':'r':'t':rest -> - case breakOn importPragma (T.pack rest) of - Just (pref, suf) -> - case poorMensParseImportLine loc (pref `T.append` suf) of - Just impDecl -> doAna restLines (modName, defs, impDecl : impDecls) - Nothing -> doAna restLines (modName, defs, impDecls) - Nothing -> doAna restLines (modName, defs, impDecls) - _ -> doAna restLines (modName, defs, impDecls) - where - loc = makeLoc originalFileName lineNo - importPragma = T.pack "{-@ HTF_TESTS @-}" + runTest (i, (src, mi)) = + do (givenMi, _, _) <- analyze "" src + if givenMi == mi + then return () + else assertFailure ("Error in test " ++ show i ++ + ", expected:\n" ++ show mi ++ + "\nGiven:\n" ++ show givenMi ++ + "\nSrc:\n" ++ src) -poorMensParseImportLine :: Location -> T.Text -> Maybe ImportDecl -poorMensParseImportLine loc t = - let (q, rest) = - case breakOn "qualified" t of - Nothing -> (False, T.strip t) - Just (_, rest) -> (True, T.strip rest) - modName = T.takeWhile (not . isSpace) rest - afterModName = T.strip $ T.drop (T.length modName) rest - in case breakOn "as" afterModName of - Nothing -> Just $ ImportDecl (T.unpack modName) q Nothing loc - Just (_, suf) -> - let strippedSuf = T.strip suf - alias = if T.null strippedSuf then Nothing else Just (T.unpack strippedSuf) - in Just $ ImportDecl (T.unpack modName) q alias loc +cpphsOptions :: CpphsOptions +cpphsOptions = + defaultCpphsOptions { + boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell + } -transform :: Bool -> FilePath -> String -> IO String -transform hunitBackwardsCompat originalFileName input = - do analyseResult <- analyse originalFileName input - case analyseResult of - ParseError loc err -> - do poorInfo <- poorMensAnalyse originalFileName input - note ("Parsing of " ++ originalFileName ++ " failed at line " - ++ show (lineNumber loc) ++ ": " ++ err ++ - "\nFalling back to poor man's parser. This parser may " ++ - "return incomplete results. The result returned was: " ++ - "\nPrefix: " ++ mi_htfPrefix poorInfo ++ - "\nModule name: " ++ mi_moduleName poorInfo ++ - "\nDefinitions: " ++ show (mi_defs poorInfo) ++ - "\nHTF imports: " ++ show (mi_htfImports poorInfo)) - preprocess poorInfo input - ParseOK info -> - preprocess info input +data TransformOptions = TransformOptions { debug :: Bool + , literateTex :: Bool } + +transform :: TransformOptions -> FilePath -> String -> IO String +transform (TransformOptions debug literateTex) originalFileName input = + do (info, toks, pass1) <- analyze originalFileName fixedInput + preprocess info toks pass1 where - preprocess :: ModuleInfo -> String -> IO String - preprocess info input = - do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName - fixedInput - return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n" + preprocess info toks pass1 = + do when debug $ + do hPutStrLn stderr ("Tokens: " ++ show toks) + hPutStrLn stderr ("Module info:\n" ++ show info) + let opts = mkOptionsForModule info + preProcessedInput <- + runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1 + return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n" + -- fixedInput serves two purposes: + -- 1. add a trailing \n + -- 2. turn lines of the form '# ""' 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 @@ -311,9 +419,9 @@ let l = mi_htfImports info in case l of [] -> "" - _ -> (importedTestListFullName (mi_moduleName info) + _ -> (importedTestListFullName (mi_moduleNameWithDefault info) ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++ - importedTestListFullName (mi_moduleName info) + importedTestListFullName (mi_moduleNameWithDefault info) ++ " = [\n " ++ List.intercalate ",\n " (map htfTestsInModule l) ++ "\n ]\n") @@ -325,3 +433,25 @@ (False, _) -> name (True, Just alias) -> alias ++ "." ++ name (True, _) -> imp_moduleName imp ++ "." ++ name + +-- Returns for lines of the form '# ""' +-- (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/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances, - ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -- --- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -32,7 +36,8 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs, - withQCArgs, WithQCArgs, + withQCArgs, WithQCArgs, setReplayFromString, + QCAssertion, -- * Pending properties qcPending, @@ -52,23 +57,26 @@ import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..), - throw, throwIO, catch, catches, evaluate ) + throw, catch, catches, evaluate ) import Data.Typeable (Typeable) import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Base64 as Base64 import Test.QuickCheck -import Test.QuickCheck.Property hiding (reason) -import Test.Framework.TestManager -import Test.Framework.TestManagerInternal -import Test.HUnit.Lang (HUnitFailure(..)) +#if !MIN_VERSION_QuickCheck(2,7,0) +import Test.QuickCheck.Property (morallyDubiousIOProperty) +#endif +import Test.Framework.TestInterface +import Test.Framework.Utils +_DEBUG_ :: Bool +_DEBUG_ = False + +debug :: String -> IO () +debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return () + data QCState = QCState { qc_args :: !Args } qcState :: IORef QCState @@ -98,6 +106,18 @@ instance Exception QCPendingException +quickCheckTestError :: Maybe String -> Assertion +quickCheckTestError m = failHTF $ mkFullTestResult Error m + +quickCheckTestFail :: Maybe String -> Assertion +quickCheckTestFail m = failHTF $ mkFullTestResult Fail m + +quickCheckTestPending :: String -> Assertion +quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m) + +quickCheckTestPass :: String -> Assertion +quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m) + -- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function -- is used internally in the code generated by @htfpp@, do not use it directly. qcAssertion :: (QCAssertion t) => t -> Assertion @@ -119,31 +139,42 @@ AnyTestable t' -> quickCheckWithResult args t' return (Right x) `catches` - [Handler $ \(QCPendingException msg) -> return $ Left (True, msg) - ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))] + [Handler $ \(QCPendingException msg) -> return $ Left msg] + debug ("QuickCheck result: " ++ show res) case res of - Left (isPending, err) -> - if isPending - then quickCheckTestPending err - else quickCheckTestError (Just err) + Left err -> + quickCheckTestPending err Right (Success { output=msg }) -> quickCheckTestPass (adjustOutput msg) Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) -> - if pendingPrefix `List.isPrefixOf` reason - then let pendingMsg = let s = drop (length pendingPrefix) reason - in take (length s - length pendingSuffix) s - in quickCheckTestPending pendingMsg - else do let replay = "Replay argument: " ++ (show (show (Just (gen, size)))) - out = adjustOutput msg - quickCheckTestFail (Just (out ++ "\n" ++ replay)) + case () of + _| pendingPrefix `List.isPrefixOf` reason -> + let pendingMsg = getPayload pendingPrefix pendingSuffix reason + in quickCheckTestPending pendingMsg + | failurePrefix `List.isPrefixOf` reason + , Just result <- readM (getPayload failurePrefix failureSuffix reason) + -> failHTF result + | otherwise -> + let replay = "Replay argument: " ++ (show (show (Just (gen, size)))) + out = adjustOutput msg + in quickCheckTestFail (Just (out ++ "\n" ++ replay)) Right (GaveUp { output=msg }) -> quickCheckTestFail (Just (adjustOutput msg)) Right (NoExpectedFailure { output=msg }) -> quickCheckTestFail (Just (adjustOutput msg)) +#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0) + Right (InsufficientCoverage { output=msg }) -> + quickCheckTestFail (Just (adjustOutput msg)) +#endif return () where pendingPrefix = "Exception: 'QCPendingException \"" pendingSuffix = "\"'" + failurePrefix = "Exception: 'HTFFailure " + failureSuffix = "'" + getPayload pref suf reason = + let s = drop (length pref) reason + in take (length s - length suf) s adjustOutput s = trimTrailing $ case s of '+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest @@ -166,11 +197,11 @@ argsModifier :: a -> (Args -> Args) testable :: a -> AnyTestable -instance Testable a => QCAssertion a where +instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where argsModifier _ = id testable = AnyTestable -instance Testable a => QCAssertion (WithQCArgs a) where +instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where argsModifier (WithQCArgs f _) = f testable (WithQCArgs _ x) = AnyTestable x @@ -192,9 +223,20 @@ assertionAsProperty :: IO () -> Property assertionAsProperty action = - ioProperty $ catch action transHUnitFail >> return True - where - transHUnitFail exc@(HUnitFailure msg) = - let exc' = "<<>>HTF>>>" - in throwIO (HUnitFailure exc') + ioProperty $ action >> return True + +-- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string. +setReplayFromString :: Args -> String -> Args +setReplayFromString args str = +#if !MIN_VERSION_QuickCheck(2,7,0) + case readM str of + Just x -> args { replay = x } + Nothing -> error ("Could not parse replay parameter from string " ++ show str) +#else + -- Starting with QC 2.7 the type of the replay field changed from + -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)' + case readM str of + Just x -> args { replay = x } + Nothing -> + error ("Could not parse replay parameter from string " ++ show str) +#endif 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,38 +34,47 @@ module Test.Framework.TestTypes, -- * Running tests - htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs', + htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs', runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig', -- * Organzing tests TestableHTF, + WrappableHTF(..), makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, + flattenTest, + + -- * Tests (for internal use) + wrappableTests ) where import Control.Monad.RWS import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs) -import Control.Exception (finally) +import qualified Control.Exception as Exc import Data.Maybe +import Data.Time import qualified Data.List as List +import qualified Data.ByteString as BS +import Data.IORef +import Control.Concurrent import System.IO -import qualified Test.HUnit.Lang as HU - import Test.Framework.Utils -import Test.Framework.TestManagerInternal +import Test.Framework.TestInterface import Test.Framework.TestTypes import Test.Framework.CmdlineOptions import Test.Framework.TestReporter import Test.Framework.Location import Test.Framework.Colors import Test.Framework.ThreadPool +import Test.Framework.History +import qualified Test.HUnit as HU -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test @@ -95,6 +108,26 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') +-- | Kind of specialised 'Functor' type class for tests, which allows you to +-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any +-- test code. +-- +-- E.g. if you want to add timeouts to all tests of a module, you could write: +-- +-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded" +-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests +class WrappableHTF t where + wrap :: (Assertion -> Assertion) -> t -> t + +instance WrappableHTF TestSuite where + wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests + wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests + +instance WrappableHTF Test where + wrap wrapper (BaseTest ts tid loc topt assertion) = + BaseTest ts tid loc topt (wrapper assertion) + wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite + -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where @@ -126,63 +159,198 @@ let fts = concatMap flattenTest ts in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts -mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int) -mkFlatTestRunner ft = (pre, action, post) +maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds +maxRunTime tc ft = + let mt1 = tc_maxSingleTestTime tc + mt2 = + case tc_prevFactor tc of + Nothing -> Nothing + Just d -> + case max (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey ft) (tc_history tc))) + (fmap htr_timeMs (findHistoricTestResult (historyKey ft) (tc_history tc))) + of + Nothing -> Nothing + Just t -> Just $ ceiling (fromInteger (toInteger t) * d) + in case (mt1, mt2) of + (Just t1, Just t2) -> Just (min t1 t2) + (_, Nothing) -> mt1 + (Nothing, _) -> mt2 + +-- | HTF uses this function to execute the given assertion as a HTF test. +performTestHTF :: Assertion -> IO FullTestResult +performTestHTF action = + do action + return (mkFullTestResult Pass Nothing) + `Exc.catches` + [Exc.Handler (\(HTFFailure res) -> return res) + ,Exc.Handler handleUnexpectedException] where + handleUnexpectedException exc = + case Exc.fromException exc of + Just (async :: Exc.AsyncException) -> + case async of + Exc.StackOverflow -> exceptionAsError exc + _ -> Exc.throwIO exc + _ -> exceptionAsError exc + exceptionAsError exc = + return (mkFullTestResult Error (Just $ show (exc :: Exc.SomeException))) + +data TimeoutResult a + = TimeoutResultOk a + | TimeoutResultException Exc.SomeException + | TimeoutResultTimeout + +timeout :: Int -> IO a -> IO (Maybe a) +timeout microSecs action + | microSecs < 0 = fmap Just action + | microSecs == 0 = return Nothing + | otherwise = + do resultChan <- newChan + finishedVar <- newIORef False + workerTid <- forkIO (wrappedAction resultChan finishedVar) + _ <- forkIO (threadDelay microSecs >> writeChan resultChan TimeoutResultTimeout) + res <- readChan resultChan + case res of + TimeoutResultTimeout -> + do atomicModifyIORef finishedVar (\_ -> (True, ())) + killThread workerTid + return Nothing + TimeoutResultOk x -> + return (Just x) + TimeoutResultException exc -> + Exc.throwIO exc + where + wrappedAction resultChan finishedVar = + Exc.mask $ \restore -> + (do x <- restore action + writeChan resultChan (TimeoutResultOk x)) + `Exc.catch` + (\(exc::Exc.SomeException) -> + do b <- shouldReraiseException exc finishedVar + if b then Exc.throwIO exc else writeChan resultChan (TimeoutResultException exc)) + shouldReraiseException exc finishedVar = + case Exc.fromException exc of + Just (async :: Exc.AsyncException) -> + case async of + Exc.ThreadKilled -> atomicModifyIORef finishedVar (\old -> (old, old)) + _ -> return False + _ -> return False + +data PrimTestResult + = PrimTestResultNoTimeout FullTestResult + | PrimTestResultTimeout + +mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds) +mkFlatTestRunner tc ft = (pre, action, post) + where pre = reportTestStart ft - action _ = measure $ HU.performTestCase (wto_payload (ft_payload ft)) + action _ = + let run = performTestHTF (wto_payload (ft_payload ft)) + runWithTimeout = + case maxRunTime tc ft of + Nothing -> + do (res, time) <- measure run + return (PrimTestResultNoTimeout res, time) + Just maxMs -> + do mx <- timeout (1000 * maxMs) $ measure run + case mx of + Nothing -> return (PrimTestResultTimeout, maxMs) + Just (res, time) -> + return (PrimTestResultNoTimeout res, time) + isPass primTestRes = + case primTestRes of + PrimTestResultNoTimeout fullTestRes -> + ftr_result fullTestRes == Just Pass + PrimTestResultTimeout -> False + iterRunWithTimeout i = + do (primTestRes, time) <- runWithTimeout + if isPass primTestRes && i >= 2 + then iterRunWithTimeout (i-1) + else return (primTestRes, time) + in iterRunWithTimeout (tc_repeat tc) post excOrResult = - let (testResult, (mLoc, callers, msg, time)) = + let (testResult, time) = case excOrResult of - Left exc -> (Error, (Nothing, - [], - noColor ("Running test unexpectedly failed: " ++ show exc), - (-1))) + Left exc -> + (FullTestResult + { ftr_stack = emptyHtfStack + , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc) + , ftr_result = Just Error + } + ,(-1)) Right (res, time) -> case res of - Nothing -> (Pass, (Nothing, [], emptyColorString, time)) - Just (isFailure, msg') -> - if ft_sort ft /= QuickCheckTest - then let utr = deserializeHUnitMsg msg' - r = case () of - _| utr_pending utr -> Pending - | isFailure -> Fail - | otherwise -> Error - in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time)) - else let (r, mUnitTestResult, s) = deserializeQuickCheckMsg msg' - loc = join $ fmap utr_location mUnitTestResult - callers = fromMaybe [] $ fmap utr_callingLocations mUnitTestResult - msg = - case mUnitTestResult of - Just utr -> utr_message utr +++ noColor "\n" +++ noColor s - Nothing -> noColor s - in (r, (loc, callers, msg, time)) + PrimTestResultTimeout -> + (FullTestResult + { ftr_stack = emptyHtfStack + , ftr_message = Just $ colorize warningColor "timeout" + , ftr_result = Nothing + } + ,time) + PrimTestResultNoTimeout res -> + let res' = + if isNothing (ftr_message res) && isNothing (ftr_result res) + then res { ftr_message = Just (colorize warningColor "timeout") } + else res + in (res', time) + (sumRes, isTimeout) = + case ftr_result testResult of + Just x -> (x, False) + Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True) rr = FlatTest { ft_sort = ft_sort ft , ft_path = ft_path ft , ft_location = ft_location ft - , ft_payload = RunResult testResult mLoc callers msg time } + , ft_payload = RunResult sumRes (ftr_stack testResult) + (fromMaybe emptyColorString (ftr_message testResult)) + time isTimeout + } in do modify (\s -> s { ts_results = rr : ts_results s }) reportTestResult rr + return (stopFlag sumRes) + stopFlag result = + if not (tc_failFast tc) + then DoNotStop + else case result of + Pass -> DoNotStop + Pending -> DoNotStop + Fail -> DoStop + Error -> DoStop runAllFlatTests :: [FlatTest] -> TR () -runAllFlatTests tests = - do reportGlobalStart tests - tc <- ask +runAllFlatTests tests' = + do tc <- ask + tests <- orderTests tc tests' + reportGlobalStart tests case tc_threads tc of Nothing -> - let entries = map mkFlatTestRunner tests + let entries = map (mkFlatTestRunner tc) tests in tp_run sequentialThreadPool entries Just i -> let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests - pentries' = map mkFlatTestRunner ptests - sentries = map mkFlatTestRunner stests + pentries = map (mkFlatTestRunner tc) ptests + sentries = map (mkFlatTestRunner tc) stests in do tp <- parallelThreadPool i - pentries <- if tc_shuffle tc - then liftIO (shuffleIO pentries') - else return pentries' tp_run tp pentries tp_run sequentialThreadPool sentries + where + orderTests tc ts + | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts + | tc_shuffle tc = shuffleTests ts + | otherwise = return ts + shuffleTests = liftIO . shuffleIO + sortByPrevTime tc ts = + map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts) + compareTests tc (t1, _) (t2, _) = + case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc))) + (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc))) + ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc))) + (fmap htr_timeMs (findHistoricTestResult t2 (tc_history tc)))) + of + (Just t1, Just t2) -> compare t1 t2 + (Just _, Nothing) -> GT + (Nothing, Just _) -> LT + (Nothing, Nothing) -> EQ -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'. runTest :: TestableHTF t => t -- ^ Testable thing @@ -238,13 +406,19 @@ (if opts_listTests opts then let fts = filter (opts_filter opts) (flatten t) in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess) - else runTestWithConfig' tc t) - return (printSummary `finally` cleanup tc, ecode) + else do (printSummary, ecode, history) <- runTestWithConfig' tc t + storeHistory (tc_historyFile tc) history + return (printSummary, ecode)) + return (printSummary `Exc.finally` cleanup tc, ecode) where cleanup tc = case tc_output tc of TestOutputHandle h True -> hClose h _ -> return () + storeHistory file history = + BS.writeFile file (serializeTestHistory history) + `Exc.catch` (\(e::Exc.IOException) -> + hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e)) -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully, @@ -253,32 +427,59 @@ -- -- A test is /successful/ if the test terminates and no assertion fails. -- A test is said to /fail/ if an assertion fails but no other error occur. -runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode +runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory) runTestWithConfig tc t = - do (printSummary, ecode) <- runTestWithConfig' tc t + do (printSummary, ecode, history) <- runTestWithConfig' tc t printSummary - return ecode + return (ecode, history) -- | Runs something testable with the given 'TestConfig'. Does not -- print the overall test results but returns an 'IO' action for doing so. -- See 'runTestWithConfig' for a specification of the 'ExitCode' result. -runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode) +runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory) runTestWithConfig' tc t = - do ((_, s, _), time) <- + do let allTests = flatten t + activeTests = filter (tc_filter tc) allTests + filteredTests = filter (not . tc_filter tc) allTests + startTime <- getCurrentTime + ((_, s, _), time) <- measure $ - runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState + runRWST (runAllFlatTests activeTests) tc initTestState let results = reverse (ts_results s) passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results error = filter (\ft -> (rr_result . ft_payload) ft == Error) results + timedOut = filter (\ft -> (rr_timeout . ft_payload) ft) results + arg = ReportGlobalResultsArg + { rgra_timeMs = time + , rgra_passed = passed + , rgra_pending = pending + , rgra_failed = failed + , rgra_errors = error + , rgra_timedOut = timedOut + , rgra_filtered = filteredTests + } let printSummary = - runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run + runRWST (reportGlobalResults arg) tc (TestState [] (ts_index s)) -- keep index from run + !newHistory = updateHistory startTime results (tc_history tc) return (printSummary >> return (), case () of _| length failed == 0 && length error == 0 -> ExitSuccess | length error == 0 -> ExitFailure 1 - | otherwise -> ExitFailure 2) + | otherwise -> ExitFailure 2 + ,newHistory) + where + updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory + updateHistory time results history = + let runHistory = mkTestRunHistory time (map (\res -> HistoricTestResult { + htr_testId = historyKey res + , htr_result = rr_result (ft_payload res) + , htr_timedOut = rr_timeout (ft_payload res) + , htr_timeMs = rr_wallTimeMs (ft_payload res) + }) + results) + in updateTestHistory runHistory history -- | Runs something testable by parsing the commandline arguments as test options -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'. @@ -286,5 +487,22 @@ htfMain :: TestableHTF t => t -> IO () htfMain tests = do args <- getArgs - ecode <- runTestWithArgs args tests + htfMainWithArgs args tests + +-- | Runs something testable by parsing the commandline arguments as test options +-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'. +htfMainWithArgs :: TestableHTF t => [String] -> t -> IO () +htfMainWithArgs args tests = + do ecode <- runTestWithArgs args tests exitWith ecode + +testWrapCanCauseFailure :: IO () +testWrapCanCauseFailure = + do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest + HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest + where + unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ()) + wrappedUnitTest = wrap wrapper unitTest + wrapper test = HU.assertFailure "Fail" >> test + +wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)] diff --git a/Test/Framework/TestManagerInternal.hs b/Test/Framework/TestManagerInternal.hs deleted file mode 100644 --- a/Test/Framework/TestManagerInternal.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- --- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA --- - -module Test.Framework.TestManagerInternal ( - - UnitTestResult(..), - - quickCheckTestFail, quickCheckTestError, quickCheckTestPending, - quickCheckTestPass, deserializeQuickCheckMsg, - unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert, - blackBoxTestFail, - -) where - -import Test.Framework.TestTypes -import Test.Framework.Utils -import Test.Framework.Location -import Test.Framework.Colors - -import qualified Test.HUnit.Lang as HU -import Control.Monad.Trans.Control -import qualified Control.Exception.Lifted as Exc -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BSC - -assertFailureHTF :: String -> Assertion --- Important: force the string argument, otherwise an error embedded --- lazily inside the string might escape. -assertFailureHTF s = length s `seq` HU.assertFailure s - --- This is a HACK: we encode a custom error message for QuickCheck --- failures and errors in a string, which is later parsed using read! -quickCheckTestError :: Maybe String -> Assertion -quickCheckTestError m = assertFailureHTF (show (Error, m)) - -quickCheckTestFail :: Maybe String -> Assertion -quickCheckTestFail m = assertFailureHTF (show (Fail, m)) - -quickCheckTestPending :: String -> Assertion -quickCheckTestPending m = assertFailureHTF (show (Pending, Just m)) - -quickCheckTestPass :: String -> Assertion -quickCheckTestPass m = assertFailureHTF (show (Pass, Just m)) - -deserializeQuickCheckMsg :: String -> (TestResult, Maybe UnitTestResult, String) -deserializeQuickCheckMsg msg = - case readM msg of - Nothing -> - (Error, Nothing, msg) - Just (r, ms) -> - case ms of - Nothing -> (r, Nothing, "") - Just s -> - let (utr, msg) = extractUnitTestResult (T.pack s) - in (r, utr, T.unpack msg) - where - extractUnitTestResult t = - case breakOn (T.pack "<< (Nothing, t) - Just (pref, rest) -> - case breakOn (T.pack ">>>HTF>>>") rest of - Nothing -> (Nothing, t) - Just (serUtr, suf) -> - case Base64.decode (BSC.pack (T.unpack serUtr)) of - Left _ -> (Nothing, t) - Right bs -> - case T.decodeUtf8' bs of - Left _ -> (Nothing, t) - Right x -> - case readM (T.unpack x) of - Nothing -> (Nothing, t) - Just utr -> - (Just utr, - pref `T.append` suf) - breakOn x t = - case T.breakOn x t of - (pref, suf) -> - if T.null suf - then Nothing - else Just (pref, T.drop (T.length x) suf) - --- This is a HACK: we encode location and pending information as a datatype --- that we show and parse later using read. -data UnitTestResult - = UnitTestResult - { utr_location :: Maybe Location - , utr_callingLocations :: [(Maybe String, Location)] - , utr_message :: ColorString - , utr_pending :: Bool - } deriving (Eq, Show, Read) - -unitTestFail :: Maybe Location -> ColorString -> IO a -unitTestFail loc s = - do assertFailureHTF (show (UnitTestResult loc [] s False)) - error "unitTestFail: UNREACHABLE" - -unitTestSubAssert :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a -unitTestSubAssert loc mMsg action = - action `Exc.catch` (\(HU.HUnitFailure s) -> let res = deserializeHUnitMsg s - newRes = res { utr_callingLocations = (mMsg, loc) : utr_callingLocations res } - in Exc.throwIO (HU.HUnitFailure $ show newRes)) - --- Mark a unit test as pending without removing it from the test suite. -unitTestPending :: String -> IO a -unitTestPending s = - do assertFailureHTF (show (UnitTestResult Nothing [] (noColor s) True)) - error "unitTestFail: UNREACHABLE" - -deserializeHUnitMsg :: String -> UnitTestResult -deserializeHUnitMsg msg = - case readM msg of - Just r -> r - _ -> UnitTestResult Nothing [] (noColor msg) False - -blackBoxTestFail :: String -> Assertion -blackBoxTestFail = assertFailureHTF diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs --- a/Test/Framework/TestReporter.hs +++ b/Test/Framework/TestReporter.hs @@ -1,4 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} +-- +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- {-| This module defines functions for notifying all test reporters registered about @@ -22,6 +39,7 @@ import Test.Framework.XmlOutput import System.IO +import Control.Monad import Control.Monad.RWS import Text.PrettyPrint @@ -54,9 +72,9 @@ -- | Invokes 'tr_reportGlobalResults' on all test reporters registered. reportGlobalResults :: ReportGlobalResults -reportGlobalResults t l1 l2 l3 l4 = +reportGlobalResults arg = do reps <- asks tc_reporters - mapM_ (\r -> tr_reportGlobalResults r t l1 l2 l3 l4) reps + mapM_ (\r -> tr_reportGlobalResults r arg) reps data IsParallel = Parallel | NonParallel @@ -144,7 +162,7 @@ reportTestResultHS :: ReportTestResult reportTestResultHS ftr = let res = rr_result (ft_payload ftr) - msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr)) + msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr)) in case res of Pass -> reportMessage Debug msg okSuffix @@ -188,30 +206,50 @@ reportStringTR Info (render (renderTestNames l)) reportGlobalResultsH :: ReportGlobalResults -reportGlobalResultsH t passedL pendingL failedL errorL = - do let passed = length passedL - pending = length pendingL - failed = length failedL - error = length errorL +reportGlobalResultsH arg = + do let passed = length (rgra_passed arg) + pending = length (rgra_pending arg) + failed = length (rgra_failed arg) + error = length (rgra_errors arg) + timedOut = length (rgra_timedOut arg) + filtered = length (rgra_filtered arg) total = passed + failed + error + pending - let pendings = colorize pendingColor "* Pending:" - failures = colorize warningColor "* Failures:" - errors = colorize warningColor "* Errors:" - reportTR Info ("* Tests: " +++ showC total +++ "\n" +++ - "* Passed: " +++ showC passed +++ "\n" +++ - pendings +++ " " +++ showC pending +++ "\n" +++ - failures +++ " " +++ showC failed +++ "\n" +++ - errors +++ " " +++ showC error) + let pendings = (if pending > 0 then colorize pendingColor else noColor) "* Pending:" + failures = (if failed > 0 then colorize warningColor else noColor) "* Failures:" + errors = (if error > 0 then colorize warningColor else noColor) "* Errors:" + reportTR Info ("* Tests: " +++ showC total +++ "\n" +++ + "* Passed: " +++ showC passed +++ "\n" +++ + pendings +++ " " +++ showC pending +++ "\n" +++ + failures +++ " " +++ showC failed +++ "\n" +++ + errors +++ " " +++ showC error +++ "\n" +++ + "* Timed out: " +++ showC timedOut +++ "\n" +++ + "* Filtered: " +++ showC filtered) + when (timedOut > 0) $ + if timedOut < 10 + then + reportTR Info + ("\n" +++ noColor "* Timed out:" +++ "\n" +++ renderTestNames' (reverse (rgra_timedOut arg))) + else + reportTR Info + ("\n" +++ noColor "* Timed out: (" +++ showC timedOut +++ noColor ", too many to list)") + when (filtered > 0) $ + if filtered < 10 + then + reportTR Info + ("\n" +++ noColor "* Filtered:" +++ "\n" +++ renderTestNames' (reverse (rgra_filtered arg))) + else + reportTR Info + ("\n" +++ noColor "* Filtered: (" +++ showC filtered +++ noColor ", too many to list)") when (pending > 0) $ reportTR Info - ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse pendingL)) + ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg))) when (failed > 0) $ reportTR Info - ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse failedL)) + ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg))) when (error > 0) $ reportTR Info - ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse errorL)) - reportStringTR Info ("\nTotal execution time: " ++ show t ++ "ms") + ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse (rgra_errors arg))) + reportStringTR Info ("\nTotal execution time: " ++ show (rgra_timeMs arg) ++ "ms") where showC x = noColor (show x) renderTestNames' rrs = @@ -257,13 +295,13 @@ in reportJsonTR json reportGlobalResultsM :: ReportGlobalResults -reportGlobalResultsM t pass pending failed errors = - let json = mkTestResultsObj t (length pass) (length pending) (length failed) (length errors) +reportGlobalResultsM arg = + let json = mkTestResultsObj arg in reportJsonTR json reportGlobalResultsXml :: ReportGlobalResults -reportGlobalResultsXml t pass pending failed errors = - do let xml = mkGlobalResultsXml t pass pending failed errors +reportGlobalResultsXml arg = + do let xml = mkGlobalResultsXml arg tc <- ask case tc_outputXml tc of Just fname -> liftIO $ withFile fname WriteMode $ \h -> BSL.hPut h xml diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs --- a/Test/Framework/TestTypes.hs +++ b/Test/Framework/TestTypes.hs @@ -1,24 +1,43 @@ {-# LANGUAGE FlexibleInstances #-} +-- +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- {-| This module defines types (and small auxiliary functions) for organizing tests, for configuring the execution of tests, and for representing and reporting their results. +This functionality is mainly used internally in the code +generated by the @hftpp@ pre-processor. -} module Test.Framework.TestTypes ( -- * Organizing tests - TestID, Assertion, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..), + TestID, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..), TestSuite(..), TestSort(..), TestPath(..), GenFlatTest(..), FlatTest, TestFilter, - testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, + testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey, -- * Executing tests TR, TestState(..), initTestState, TestConfig(..), TestOutput(..), -- * Reporting results - ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, + ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..), TestReporter(..), emptyTestReporter, attachCallStack, CallStack, -- * Specifying results. @@ -28,14 +47,14 @@ import Test.Framework.Location import Test.Framework.Colors +import Test.Framework.History +import Test.Framework.TestInterface import Control.Monad.RWS import System.IO import Data.Maybe import qualified Data.List as List - --- | An assertion is just an 'IO' action. -type Assertion = IO () +import qualified Data.Text as T -- | Type for naming tests. type TestID = String @@ -91,6 +110,7 @@ -- | A type denoting the hierarchical name of a test. data TestPath = TestPathBase TestID | TestPathCompound (Maybe TestID) TestPath + deriving (Show) -- | Splits a 'TestPath' into a list of test identifiers. testPathToList :: TestPath -> [Maybe TestID] @@ -130,19 +150,16 @@ , ft_payload :: a -- ^ A generic payload. } +-- | Key of a flat test for the history database. +historyKey :: GenFlatTest a -> T.Text +historyKey ft = T.pack (flatName (ft_path ft)) + -- | Flattened representation of tests. type FlatTest = GenFlatTest (WithTestOptions Assertion) -- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. type TestFilter = FlatTest -> Bool --- | The summary result of a test. -data TestResult = Pass | Pending | Fail | Error - deriving (Show, Read, Eq) - --- | A type synonym for time in milliseconds. -type Milliseconds = Int - -- | A type for call-stacks type CallStack = [(Maybe String, Location)] @@ -150,23 +167,18 @@ data RunResult = RunResult { rr_result :: TestResult -- ^ The summary result of the test. - , rr_location :: Maybe Location -- ^ The location where the test failed (if applicable). - , rr_callers :: CallStack -- ^ Information about the callers of the location where the test failed + , rr_stack :: HtfStack -- ^ The stack leading to the test failure , rr_message :: ColorString -- ^ A message describing the result. , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds. + , rr_timeout :: Bool -- ^ 'True' if the execution took too long } -attachCallStack :: ColorString -> CallStack -> ColorString -attachCallStack msg callStack = - case reverse callStack of - [] -> msg - l -> ensureNewlineColorString msg +++ - noColor (unlines (map formatCallStackElem l)) - where - formatCallStackElem (mMsg, loc) = - " called from " ++ showLoc loc ++ (case mMsg of - Nothing -> "" - Just s -> " (" ++ s ++ ")") +attachCallStack :: ColorString -> HtfStack -> ColorString +attachCallStack msg stack = + let fstack = formatHtfStack stack + in if fstack == "" + then msg + else ensureNewlineColorString msg +++ noColor fstack -- | The result of running a 'FlatTest' type FlatTestResult = GenFlatTest RunResult @@ -199,6 +211,14 @@ , tc_filter :: TestFilter -- ^ Filter for the tests to run. , tc_reporters :: [TestReporter] -- ^ Test reporters to use. , tc_useColors :: Bool -- ^ Whether to use colored output + , tc_historyFile :: FilePath -- ^ Path to history file + , tc_history :: TestHistory -- ^ History of previous test runs + , tc_sortByPrevTime :: Bool -- ^ Sort ascending by previous execution times + , tc_failFast :: Bool -- ^ Stop test run as soon as one test fails + , tc_timeoutIsSuccess :: Bool -- ^ Do not regard timeout as an error + , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run + , tc_prevFactor :: Maybe Double -- ^ Maximum factor a single test is allowed to run slower than its previous execution + , tc_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } instance Show TestConfig where @@ -206,10 +226,21 @@ showParen (prec > 0) $ showString "TestConfig { " . showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) . --- showString ", tc_threads=" . showsPrec 1 (tc_threads tc) . + showString ", tc_threads=" . showsPrec 1 (tc_threads tc) . + showString ", tc_shuffle=" . showsPrec 1 (tc_shuffle tc) . showString ", tc_output=" . showsPrec 1 (tc_output tc) . + showString ", tc_outputXml=" . showsPrec 1 (tc_outputXml tc) . showString ", tc_filter=" . showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) . + showString ", tc_useColors=" . showsPrec 1 (tc_useColors tc) . + showString ", tc_historyFile=" . showsPrec 1 (tc_historyFile tc) . + showString ", tc_history=" . showsPrec 1 (tc_history tc) . + showString ", tc_sortByPrevTime=" . showsPrec 1 (tc_sortByPrevTime tc) . + showString ", tc_failFast=" . showsPrec 1 (tc_failFast tc) . + showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) . + showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) . + showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) . + showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) . showString " }" -- | A 'TestReporter' provides hooks to customize the output of HTF. @@ -231,7 +262,7 @@ , tr_reportGlobalStart = \_ -> return () , tr_reportTestStart = \_ -> return () , tr_reportTestResult = \_ -> return () - , tr_reportGlobalResults = \_ _ _ _ _ -> return () + , tr_reportGlobalResults = \_ -> return () } instance Show TestReporter where @@ -252,10 +283,16 @@ -- | Reports the result of a single test. type ReportTestResult = FlatTestResult -> TR () +data ReportGlobalResultsArg + = ReportGlobalResultsArg + { rgra_timeMs :: Milliseconds + , rgra_passed :: [FlatTestResult] + , rgra_pending :: [FlatTestResult] + , rgra_failed :: [FlatTestResult] + , rgra_errors :: [FlatTestResult] + , rgra_timedOut :: [FlatTestResult] + , rgra_filtered :: [FlatTest] + } + -- | Reports the overall results of all tests. -type ReportGlobalResults = Milliseconds -- ^ wall time in ms - -> [FlatTestResult] -- ^ passed tests - -> [FlatTestResult] -- ^ pending tests - -> [FlatTestResult] -- ^ failed tests - -> [FlatTestResult] -- ^ erroneous tests - -> TR () +type ReportGlobalResults = ReportGlobalResultsArg -> TR () diff --git a/Test/Framework/ThreadPool.hs b/Test/Framework/ThreadPool.hs --- a/Test/Framework/ThreadPool.hs +++ b/Test/Framework/ThreadPool.hs @@ -1,6 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} +{- | +Internal module providing a pool of threads. +-} -- --- Copyright (c) 2013 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -19,7 +22,7 @@ module Test.Framework.ThreadPool ( - ThreadPoolEntry, ThreadPool(..), sequentialThreadPool, parallelThreadPool + ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool , threadPoolTest ) where @@ -32,9 +35,16 @@ -- for tests import System.Random +data StopFlag + = DoStop + | DoNotStop + deriving (Eq, Show, Read) + type ThreadPoolEntry m a b = ( m a -- pre-action, must not throw exceptions , a -> IO b -- action - , Either Ex.SomeException b -> m () -- post-action, must not throw exceptions + , Either Ex.SomeException b -> m StopFlag + -- post-action, must not throw exceptions. If the result is + -- DoStop, the thread pool is terminated asap. ) data ThreadPool m a b @@ -46,19 +56,23 @@ parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) parallelThreadPool n = - do when (n < 1) $ fail ("invalid number of workers: " ++ show n) + do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) return (ThreadPool (runParallel n)) runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m () runSequentially entries = - mapM_ run entries + loop entries where + loop [] = return () + loop (e:es) = + do b <- run e + if b == DoStop then return () else loop es run (pre, action, post) = do a <- pre b <- liftIO $ Ex.try (action a) post b -data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m ()) | Done +data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m StopFlag) | Done instance Show (WorkItem m b) where show (Work _ _) = "Work" @@ -69,7 +83,7 @@ type ToWorker m b = NamedMVar (WorkItem m b) -data WorkResult m b = WorkResult (m ()) (ToWorker m b) +data WorkResult m b = WorkResult (m StopFlag) (ToWorker m b) instance Show (WorkResult m b) where show _ = "WorkResult" @@ -79,7 +93,7 @@ runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () runParallel _ [] = return () runParallel n entries = - do when (n < 1) $ fail ("invalid number of workers: " ++ show n) + do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) fromWorker <- liftIO $ newNamedChan "fromWorker" let nWorkers = min n (length entries) toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers] @@ -91,21 +105,23 @@ loop fromWorker nWorkers [] = cleanup fromWorker nWorkers loop fromWorker nWorkers (x:xs) = - do toWorker <- waitForWorkerResult fromWorker - runEntry x toWorker - loop fromWorker nWorkers xs + do (toWorker, stop) <- waitForWorkerResult fromWorker + if stop == DoStop + then return () + else do runEntry x toWorker + loop fromWorker nWorkers xs cleanup :: FromWorker m b -> Int -> m () -- n is the number of workers that will still write to fromWorker cleanup fromWorker n = do debug ("cleanup, n=" ++ show n) - toWorker <- waitForWorkerResult fromWorker + (toWorker, _) <- waitForWorkerResult fromWorker liftIO $ putNamedMVar toWorker Done when (n > 1) $ cleanup fromWorker (n - 1) - waitForWorkerResult :: FromWorker m b -> m (ToWorker m b) + waitForWorkerResult :: FromWorker m b -> m (ToWorker m b, StopFlag) waitForWorkerResult fromWorker = do WorkResult postAction toWorker <- liftIO $ readNamedChan fromWorker - postAction - return toWorker + b <- postAction + return (toWorker, b) runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m () runEntry (pre, action, post) toWorker = do a <- pre @@ -173,7 +189,7 @@ runTestParallel :: Int -> Int -> IO () runTestParallel nEntries n = - do putStrLn ("Running test " ++ show n) + do debug ("Running test " ++ show n) boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i) return (mvar, i)) [1..nEntries] @@ -182,7 +198,7 @@ debug ("Checking boxes in test " ++ show n) --runSequentially entries mapM_ assertBox boxes - putStrLn ("Test " ++ show n ++ " successful") + debug ("Test " ++ show n ++ " successful") where mkEntry (mvar, i) = let pre = myThreadId @@ -190,6 +206,7 @@ Left err -> fail ("Exception in worker thread: " ++ show err) Right y -> do tid <- myThreadId putNamedMVar mvar (y, tid) + return DoNotStop action x = do tid <- myThreadId j <- randomIO let micros = (j `mod` 50) 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 : @ @@ -54,13 +143,8 @@ prop_reverse xs = xs == (myReverse (myReverse xs)) @ -When @htfpp@ consumes the source file, it replaces the @assertEqual@ -tokens (and other @assert@-like tokens, see -"Test.Framework.HUnitWrapper") with calls to -'assertEqual_', passing -the current location in the file as the first argument. -Moreover, the -preprocessor collects all top-level definitions starting with @test_@ +When @htfpp@ consumes the source file, it +collects all top-level definitions starting with @test_@ or @prop_@ in a test suite of type 'TestSuite' and name @htf_@/M/@_thisModulesTests@, where /M/ is the name of the current module with dots @.@ replaced by underscores @_@. For your convenience, the preprocessor also defines the token @htf_thisModulesTests@ @@ -88,10 +172,11 @@ Build-type: Simple Test-Suite tutorial - Type: exitcode-stdio-1.0 - Main-is: Tutorial.hs - Build-depends: base == 4.*, HTF == 0.10.* - Default-language: Haskell2010 + Type: exitcode-stdio-1.0 + Main-is: Tutorial.hs + Build-depends: base, HTF + Build-tool-depends: HTF:htfpp + Default-language: Haskell2010 @ Compiling the program just shown (you must include the code for @@ -207,7 +292,7 @@ split the tests into several modules. For example, suppose your library contains of two modules @MyPkg.A@ and @MyPkg.B@, each containing test functions. You can find a slightly extended of this scenario in the samples directory -of the HTF source tree, see .) +of the HTF source tree, see . File @MyPkg/A.hs@ @@ -243,9 +328,9 @@ For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules' testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a -preprocessor token @thisModulesTests@ as a shorthand for this variable. +preprocessor token @htf_thisModulesTests@ as a shorthand for this variable. Thus, to expose all HTF tests defined in @MyPkg.A@, we only -need to put @thisModulesTests@ into the export list. The same holds +need to put @htf_thisModulesTests@ into the export list. The same holds analogously for module @MyPkg.B@. To execute all tests defined in these two modules, you would create @@ -263,7 +348,6 @@ module Main where import Test.Framework -import Test.Framework.BlackBoxTest import {-@ HTF_TESTS @-} MyPkg.A import {-@ HTF_TESTS @-} MyPkg.B @@ -274,10 +358,14 @@ -- * Machine-readable output +-- ** JSON + {- | For better integration with your testing environment, HTF provides the ability to produce -machine-readable output in JSON format. Here is a short example how the JSON output looks like, +machine-readable output in JSON format. The output is produced incrementally, line by line. + +Here is a short example how the JSON output looks like, for details see "Test.Framework.JsonOutput": @@ -309,62 +397,44 @@ -} --- * Backwards-compatibility with HUnit - -{- | -The types of the various @assert@-like macros of the HTF are not backwards-compatible -with the corresponding functions of HUnit. This incompatibility is intentional, of course: -with HUnit, the programmer has to provide suitable location information by explicitly -passing a string argument to the @assert@-like functions, whereas HTF provides -location information implicitly through its pre-processor @htfpp@. - -To simplify transition from HUnit to HTF, @htfpp@ provides a commandline flag -@--hunit@. This flag causes @htfpp@ to exand the assertion macros in a way compatible -with the types of the corresponding HUnit functions. For example, with the @--hunit@ -flag being present, @assertEqual@ is exanded to -@'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type -@(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with -the type of HUnit's 'Test.HUnit.Base.assertEqual' function. - --} - --- * Summary - -{- | +-- ** XML -Here is a quick summary of how to write, collect, and execute your tests. -You should also have a look at the sample project at -. +{- | 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 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 @@ -119,7 +120,11 @@ (s'',ys) <- mapAccumLM f s' xs return (s'',y:ys) +#if !(MIN_VERSION_base(4,13,0)) readM :: (Monad m, Read a) => String -> m a +#else +readM :: (MonadFail m, Read a) => String -> m a +#endif readM s | [x] <- parse = return x | otherwise = fail $ "Failed parse: " ++ show s where diff --git a/Test/Framework/XmlOutput.hs b/Test/Framework/XmlOutput.hs --- a/Test/Framework/XmlOutput.hs +++ b/Test/Framework/XmlOutput.hs @@ -1,27 +1,80 @@ {-# LANGUAGE CPP #-} +-- +-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- {- | -See -for a description of the format used. +XML-output following the JUnit output format. -The source code of this module also contains a rough specification of -the output format in terms of Haskell data types. +The data types exposed by this module give a rough specification of +the output format. +Here is a sample ouput: + +@ +\ +\ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \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 ( - mkGlobalResultsXml + JunitXmlOutput(..), Testsuites(..), Testsuite(..), Testcase(..), Result(..) + , mkGlobalResultsXml ) where import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List + +#ifndef MIN_VERSION_containers +#define MIN_VERSION_containers(a,b,c) 1 +#endif #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map #else import qualified Data.Map as Map #endif + import qualified Data.Text as T import Text.Printf @@ -30,11 +83,13 @@ import Test.Framework.TestTypes import Test.Framework.Colors --- A "specification" of the output format in terms of haskell data types --- * The name of each data type corresponds to the name of an XML element --- (lowercase first letter) --- * The name of a field with a primitive corresponds to an attribute with --- then same name as the field (without the prefix) +-- | A "specification" of the output format in terms of haskell data types: +-- The name of each data type corresponds to the name of an XML element +-- (lowercase first letter). +-- The name of a field with a primitive corresponds to an attribute with +-- then same name as the field (without the prefix up to the first @_@). +-- +-- The root element is @testsuites@ data JunitXmlOutput = JunitXmlOutput Testsuites type Seconds = Double @@ -166,29 +221,25 @@ , r_message = T.takeWhile (/= '\n') msg , r_type = elemName , r_textContent = msg } - msg = renderColorString (attachCallStack (rr_message payload) (rr_callers payload)) False + msg = renderColorString (attachCallStack (rr_message payload) (rr_stack payload)) False millisToSeconds :: Milliseconds -> Seconds millisToSeconds millis = fromInteger (toInteger millis) / 1000.0 -mkGlobalResultsXml :: Milliseconds -- ^ wall time in ms - -> [FlatTestResult] -- ^ passed tests - -> [FlatTestResult] -- ^ pending tests - -> [FlatTestResult] -- ^ failed tests - -> [FlatTestResult] -- ^ erroneous tests - -> BSL.ByteString -mkGlobalResultsXml t pass pending failed errors = - let nPassed = length pass - nPending = length pending - nFailed = length failed - nErrors = length errors - byModules = groupByModule (pass ++ pending ++ failed ++ errors) +mkGlobalResultsXml :: ReportGlobalResultsArg -> BSL.ByteString +mkGlobalResultsXml arg = + let nPassed = length (rgra_passed arg) + nPending = length (rgra_pending arg) + nFailed = length (rgra_failed arg) + nErrors = length (rgra_errors arg) + byModules = groupByModule (rgra_passed arg ++ rgra_pending arg ++ + rgra_failed arg ++ rgra_errors arg) suites = map mkTestSuite (zip [0..] byModules) root = Testsuites { tss_tests = nPassed + nPending + nFailed + nErrors , tss_failures = nFailed , tss_errors = nErrors - , tss_time = millisToSeconds t + , tss_time = millisToSeconds (rgra_timeMs arg) , tss_suites = suites } in renderAsXml (JunitXmlOutput root) 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,40 +0,0 @@ -#!/bin/bash - -compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal | tr -d ,) - -for x in $compilers -do - switch-ghc $x > /dev/null - ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g') - if [ "$x" != "$ghc_version" ] - then - echo "Could not switch to GHC version $x as requested, version is now $ghc_version" - exit 1 - fi - echo - echo - echo "============================================================" - echo "============================================================" - echo "==> Running tests for GHC version $ghc_version <==" - echo "==> Running tests for GHC version $ghc_version <==" - echo "==> Running tests for GHC version $ghc_version <==" - echo "============================================================" - echo "============================================================" - echo - ./run-all-tests.sh - ecode=$? - if [ $ecode -eq 0 ] - then - result="ok" - else - result="FAIL" - fi - RESULT="$RESULT\nResult for GHC version $ghc_version: $result" - if [ $ecode -ne 0 ] - then - exit 1 - fi -done - -echo -echo -e $RESULT diff --git a/run-all-tests.sh b/run-all-tests.sh deleted file mode 100644 --- a/run-all-tests.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -set -e -ghc-pkg unregister HTF || true - -cabal configure --enable-tests || exit 1 -cabal build || exit 1 -cabal test || exit 1 -cabal install || exit 1 - -cd sample -cabal configure --enable-tests || exit 1 -cabal build || exit 1 -cabal test || exit 1 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.11.* + build-depends: base, HTF default-language: Haskell2010 + build-tool-depends: HTF:htfpp test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.11.* + build-depends: base, HTF default-language: Haskell2010 + build-tool-depends: HTF:htfpp 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 -- @@ -23,6 +29,7 @@ import Test.Framework.Location import Test.Framework.TestManager import Test.Framework.BlackBoxTest +import Test.Framework.TestInterface import System.Environment import System.Directory @@ -33,18 +40,39 @@ import System.IO.Temp import Control.Exception import Control.Monad -import qualified Data.HashMap.Strict as M + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM +#else +import qualified Data.HashMap.Strict as KM +#endif +import qualified Data.HashSet as Set import qualified Data.Aeson as J +import qualified Data.Aeson.Encode.Pretty as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.List as List import qualified Text.Regex as R -import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible +import GHC.Stack + import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B +import FailFast +import MaxCurTime +import MaxPrevTime +import UniqTests1 +import UniqTests2 +import PrevFactor +import Repeat +import SortByPrevTime +import Quasi + import Tutorial hiding (main) data T = A | B @@ -58,41 +86,53 @@ handleExc :: a -> SomeException -> a handleExc x _ = x -test_assertFailure = - assertFailure "I'm a failure" +-- 世界不是英文的 Test for #47 -test_stringGap = assertEqual stringGap "hello world!" +-- Test for #48 +data HVect (ts :: [*]) where + HNil :: HVect '[] + HCons :: t -> HVect ts -> HVect (t ': ts) -test_assertEqual = assertEqual 1 2 +fun :: HVect '[Int, Int] -> String +fun = undefined -test_assertEqualV = assertEqualVerbose "blub" 1 2 +-- Test for #45 +foobar = [q|INSERT INTO a (name) VALUES ('')|] -test_assertEqualNoShow = withOptions (\opts -> opts { to_parallel = False }) $ - assertEqualNoShow A B +test_assertFailure_FAIL = assertFailure "I'm a failure" -test_assertListsEqualAsSets = assertListsEqualAsSets [1,2] [2] +test_stringGap_OK = assertEqual stringGap "hello world!" -test_assertSetEqualSuccess = assertListsEqualAsSets [1,2] [2,1] +test_assertEqual_FAIL = assertEqual 1 2 -test_assertNotEmpty = assertNotEmpty [] +test_assertEqualV_FAIL = assertEqualVerbose "blub" 1 2 -test_assertEmpty = assertEmpty [1] +test_assertEqualNoShow_FAIL = withOptions (\opts -> opts { to_parallel = False }) $ + assertEqualNoShow A B -test_assertElem = assertElem 1 [0,2,3] +test_assertListsEqualAsSets_FAIL = assertListsEqualAsSets [1,2] [2] -test_assertThrows = assertThrows (return () :: IO ()) (handleExc True) +test_assertSetEqualSuccess_OK = assertListsEqualAsSets [1,2] [2,1] -test_assertThrows' = assertThrows (error "ERROR") (handleExc False) +test_assertNotEmpty_FAIL = assertNotEmpty [] -test_assertThrowsIO1 = assertThrows (fail "ERROR" :: IO ()) (handleExc False) +test_assertEmpty_FAIL = assertEmpty [1] -test_assertThrowsIO2 = assertThrowsIO (fail "ERROR") (handleExc True) +test_assertElem_FAIL = assertElem 1 [0,2,3] -test_someError = error "Bart Simpson!!" :: IO () +test_assertThrows_FAIL = assertThrows (return () :: IO ()) (handleExc True) -test_pendingTest = unitTestPending "This test is pending" +test_assertThrows'_FAIL = assertThrows (error "ERROR") (handleExc False) -test_subAssert = subAssert anotherSub +test_assertThrowsIO1_FAIL = assertThrows (fail "ERROR" :: IO ()) (handleExc False) + +test_assertThrowsIO2_OK = assertThrowsIO (fail "ERROR") (handleExc True) + +test_someError_ERROR = error "Bart Simpson!!" :: IO () + +test_pendingTest_PENDING = unitTestPending "This test is pending" + +test_subAssert_FAIL = subAssert anotherSub where anotherSub = subAssertVerbose "I'm another sub" (assertNegative 42) assertNegative n = assertBool (n < 0) @@ -103,7 +143,7 @@ | Variable String deriving (Eq, Show) -test_diff = +test_diff_FAIL = assertEqual (mkExpr 1) (mkExpr 2) where mkExpr i = @@ -113,105 +153,269 @@ (Literal 581)) (Variable "egg") -prop_ok :: [Int] -> Property -prop_ok xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) +test_diff2_FAIL = + assertEqual s1 s2 + where + n = 100000 + s1 = mk [0..n] + s2 = mk ([0..4999] ++ [5001..n]) + mk :: [Int] -> String + mk [] = "" + mk (x:[]) = "line " ++ show x + mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_fail :: [Int] -> Bool -prop_fail xs = xs == (reverse xs) +test_diff3_FAIL = + assertEqual s1 s2 + where + n = 100000 + s1 = mk [0..n] + s2 = mk [0..(n+1)] + mk :: [Int] -> String + mk [] = "" + mk (x:[]) = "line " ++ show x + mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs -prop_pendingProp :: Int -> Bool -prop_pendingProp x = qcPending "This property is pending" (x == 0) +prop_ok_OK :: [Int] -> Property +prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) -prop_exhaust = False ==> True +prop_fail_FAIL :: [Int] -> Bool +prop_fail_FAIL xs = xs == (reverse xs) -prop_error :: Bool -prop_error = error "Lisa" +prop_pendingProp_PENDING :: Int -> Bool +prop_pendingProp_PENDING x = qcPending "This property is pending" (x == 0) +prop_exhaust_FAIL = False ==> True + +prop_implies :: Int -> Property +prop_implies n = n <= 10 ==> (\i -> i + n <= i + 10) + +prop_forAll = forAll (choose (0::Int, 10::Int)) (\i -> i < 11) + +prop_error_FAIL :: Bool +prop_error_FAIL = error "Lisa" + changeArgs args = args { maxSuccess = 1 } -prop_ok' = withQCArgs (\a -> a { maxSuccess = 1}) $ - \xs -> classify (null xs) "trivial" $ - (xs::[Int]) == (reverse (reverse xs)) +prop_ok'_OK = withQCArgs (\a -> a { maxSuccess = 1}) $ + \xs -> classify (null xs) "trivial" $ + (xs::[Int]) == (reverse (reverse xs)) -prop_fail' = - withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop +prop_fail'_FAIL = + prop where prop xs = xs == (reverse xs) where types = xs::[Int] -prop_error' :: WithQCArgs Bool -prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool) +prop_error'_FAIL :: WithQCArgs Bool +prop_error'_FAIL = withQCArgs changeArgs $ (error "Lisa" :: Bool) -test_genericAssertions = +test_genericAssertions_OK = case test1 of AssertOk _ -> fail "did not expect AssertOk" - AssertFailed stack -> - do assertEqual 2 (length stack) - let [se1, se2] = stack - assertNothing (ase_message se1) - loc1 <- assertJust (ase_location se1) - _ <- assertJust (ase_message se2) - loc2 <- assertJust (ase_location se2) + AssertFailed stack msg -> + do assertEqualVerbose ("stack=" ++ show stack) 2 (length (htfStackToList stack)) + let [se1, se2] = htfStackToList stack + loc1 = hse_location se1 + loc2 = hse_location se2 assertEqual (fileName loc1) (fileName loc2) - assertEqual (lineNumber loc1 + 1) (lineNumber loc2) + assertEqual (lineNumber loc1) (line - 1) + assertEqual (lineNumber loc2) (line - 3) + assertNotEqual msg "" where - test1 = gsubAssert test2 - test2 = gassertEqual 1 (2::Int) + test1 = test2 + test2 :: (HasCallStack) => AssertBool () + test2 = gassertBool False + line = __LINE__ +-- find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_PENDING" | sed 's/test_//g; s/prop_//g' | sort -u +pendingTests :: [T.Text] +pendingTests = + ["pendingProp_PENDING" + ,"pendingTest_PENDING"] + +failedTests :: [T.Text] +failedTests = +-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_FAIL" | sed 's/test_//g; s/prop_//g' | sort -u + ["a_FAIL" + ,"h_FAIL" + ,"assertElem_FAIL" + ,"assertEmpty_FAIL" + ,"assertEqualNoShow_FAIL" + ,"assertEqualV_FAIL" + ,"assertEqual_FAIL" + ,"assertFailure_FAIL" + ,"assertListsEqualAsSets_FAIL" + ,"assertNotEmpty_FAIL" + ,"assertThrows'_FAIL" + ,"assertThrowsIO1_FAIL" + ,"assertThrows_FAIL" + ,"diff_FAIL" + ,"diff2_FAIL" + ,"diff3_FAIL" + ,"error'_FAIL" + ,"error_FAIL" + ,"exhaust_FAIL" + ,"fail'_FAIL" + ,"fail_FAIL" + ,"subAssert_FAIL" +-- $ find bbt -name '*not_ok*.x' + ,"bbt/should_fail/not_ok_because_stderr1.x" + ,"bbt/should_fail/not_ok_because_stderr2.x" + ,"bbt/should_fail/not_ok_because_stdout1.x" + ,"bbt/should_fail/not_ok_because_stdout2.x" + ,"bbt/should_fail/not_ok_because_succeeds.x" + ,"bbt/should_pass/not_ok_because_fails.x" + ,"bbt/should_pass/not_ok_because_stderr1.x" + ,"bbt/should_pass/not_ok_because_stderr2.x" + ,"bbt/should_pass/not_ok_because_stdout1.x" + ,"bbt/should_pass/not_ok_because_stdout2.x" + ,"bbt/Verbose/not_ok_because_stdout1.x"] + +-- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_ERROR" | sed 's/test_//g; s/prop_//g' | sort -u +errorTests :: [T.Text] +errorTests = ["someError_ERROR"] + +passedTests :: [T.Text] +passedTests = + -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_OK" | sed 's/test_//g; s/prop_//g' | sort -u + ["assertSetEqualSuccess_OK" + ,"assertThrowsIO2_OK" + ,"b_OK" + ,"genericAssertions_OK" + ,"ok'_OK" + ,"ok_OK" + ,"stringGap_OK" + ,"implies" + ,"forAll" +-- $ find bbt -name '*ok*.x' | grep -v not_ok + ,"bbt/should_fail/ok1.x" + ,"bbt/should_fail/ok2.x" + ,"bbt/should_pass/ok1.x" + ,"bbt/should_pass/ok2.x" + ,"bbt/should_pass/stdin_ok.x"] + +timedOutTests = [] + checkOutput output = do bsl <- BSL.readFile output let jsons = map (fromJust . J.decode) (splitJson bsl) + let (pass, fail, error, pending, timedOut) = foldl checkStatus ([], [], [], [], []) jsons + checkAsSet "passed" passedTests pass + checkAsSet "failed" failedTests fail + checkAsSet "errors" errorTests error + checkAsSet "pending" pendingTests pending + checkAsSet "timed-out" timedOutTests timedOut check jsons (J.object ["type" .= J.String "test-results"]) - (J.object ["failures" .= J.toJSON (31::Int) - ,"passed" .= J.toJSON (13::Int) - ,"pending" .= J.toJSON (2::Int) - ,"errors" .= J.toJSON (1::Int)]) + (J.object ["failures" .= J.toJSON (length failedTests) + ,"passed" .= J.toJSON (length passedTests) + ,"pending" .= J.toJSON (length pendingTests) + ,"errors" .= J.toJSON (length errorTests) + ,"timedOut" .= J.toJSON (length timedOutTests)]) check jsons (J.object ["type" .= J.String "test-end" - ,"test" .= J.object ["flatName" .= J.String "Main:diff"]]) + ,"test" .= J.object ["flatName" .= J.String "Main:diff_FAIL"]]) (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs" - ,"line" .= J.toJSON (106::Int)]] + ,"line" .= J.toJSON (106+lineOffset)]] ,"location" .= J.object ["file" .= J.String "TestHTF.hs" - ,"line" .= J.toJSON (107::Int)]]) + ,"line" .= J.toJSON (107+lineOffset)]]) check jsons (J.object ["type" .= J.String "test-end" - ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]]) + ,"test" .= J.object ["flatName" .= J.String "Main:diff2_FAIL"]]) + (J.object ["message" .= J.String "NOT:No newline at end of file"]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Main:diff3_FAIL"]]) + (J.object ["message" .= J.String "NOT:No newline at end of file"]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]]) (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs" ,"line" .= J.toJSON (10::Int)]] ,"location" .= J.object ["file" .= J.String "./Foo/A.hs" ,"line" .= J.toJSON (11::Int)]]) check jsons (J.object ["type" .= J.String "test-end" - ,"test" .= J.object ["flatName" .= J.String "Main:subAssert"]]) - (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null + ,"test" .= J.object ["flatName" .= J.String "Foo.A:h_FAIL"]]) + (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/test.h" + ,"line" .= J.toJSON (8::Int)]] + ,"location" .= J.object ["file" .= J.String "./Foo/test.h" + ,"line" .= J.toJSON (9::Int)]]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Main:subAssert_FAIL"]]) + (J.object ["callers" .= J.toJSON [J.object ["message" .= J.String "I'm another sub" ,"location" .= J.object ["file" .= J.String "TestHTF.hs" - ,"line" .= J.toJSON (95::Int)]] - ,J.object ["message" .= J.String "I'm another sub" + ,"line" .= J.toJSON (97+lineOffset)]] + ,J.object ["message" .= J.Null ,"location" .= J.object ["file" .= J.String "TestHTF.hs" - ,"line" .= J.toJSON (97::Int)]]]]) + ,"line" .= J.toJSON (95+lineOffset)]]]]) where + lineOffset :: Int + lineOffset = 40 + checkStatus tuple@(pass, fail, error, pending, timedOut) json = + {- + {"location":null + ,"test":{"path":["Main","tests/bbt/should_pass/stdin_ok.x"],"sort":"blackbox-test","flatName":"Main:tests/bbt/should_pass/stdin_ok.x"} + ,"callers":[] + ,"result":"pass" + ,"timedOut":false + ,"type":"test-end" + ,"message":"" + ,"wallTime":11} + -} + case json of + J.Object objJson | Just (J.Object testObj) <- KM.lookup "test" objJson + , Just (J.String flatName) <- KM.lookup "flatName" testObj + , Just (J.String "test-end") <- KM.lookup "type" objJson + , Just (J.String result) <- KM.lookup "result" objJson + , Just (J.Bool to) <- KM.lookup "timedOut" objJson -> + let shortName = + let t = T.tail (T.dropWhile (/= ':') flatName) + in if "tests/" `T.isPrefixOf` t + then T.drop (T.length "tests/") t + else t + newTimedOut = if to then shortName : timedOut else timedOut + in case () of + _| result == "pass" -> (shortName : pass, fail, error, pending, newTimedOut) + _| result == "fail" -> (pass, shortName : fail, error, pending, newTimedOut) + _| result == "error" -> (pass, fail, shortName : error, pending, newTimedOut) + _| result == "pending" -> (pass, fail, error, shortName : pending, newTimedOut) + _ -> tuple + checkAsSet what expList givenList = + let expSet = Set.fromList expList + givenSet = Set.fromList givenList + in if expSet == givenSet + then return () + else do let unexpected = givenSet `Set.difference` expSet + notGiven = expSet `Set.difference` givenSet + fail ("Mismatch for " ++ what ++ ":" ++ + "\nExpected: " ++ show expList ++ + "\nGiven: " ++ show givenList ++ + "\nUnexpected elements: " ++ show unexpected ++ + "\nElements expected but not present: " ++ show notGiven) check jsons pred assert = case filter (\j -> matches j pred) jsons of [json] -> if not (matches json assert) - then error ("Predicate " ++ show pred ++ " match JSON " ++ show json ++ ", but assertion " ++ - show assert ++ " not satisfied") + then error ("Predicate\n" ++ ppJ pred ++ " match JSON\n" ++ ppJ json ++ ", but assertion\n" ++ + ppJ assert ++ " not satisfied") else return () l -> error ("not exactly one JSON matches predicate " ++ show pred ++ " but " ++ show l) matches :: J.Value -> J.Value -> Bool matches json pred = case (json, pred) of (J.Object objJson, J.Object objPred) -> - M.foldrWithKey (\k vPred b -> - b && case M.lookup k objJson of + KM.foldrWithKey (\k vPred b -> + b && case KM.lookup k objJson of Just vJson -> matches vJson vPred Nothing -> False) True objPred (J.String strJson, J.String strPred) -> - regexMatches (mkRegex strPred) strJson + regexMatches strPred strJson (arrJson@(J.Array _), arrPred@(J.Array _)) -> let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson J.Success (listPred :: [J.Value]) = J.fromJSON arrPred in length listJson == length listPred && all (\(x, y) -> matches x y) (zip listJson listPred) _ -> json == pred - regexMatches r s = isJust $ R.matchRegex r (T.unpack s) + regexMatches pred t = + let s = T.unpack t + in case T.unpack pred of + 'N':'O':'T':':':rest -> isNothing $ R.matchRegex (mkRegex (T.pack rest)) s + _ -> isJust $ R.matchRegex (mkRegex pred) s mkRegex s = R.mkRegexWithOpts (T.unpack s) True False splitJson bsl = if BSL.null bsl @@ -223,7 +427,22 @@ else case splitJson rest of [] -> error "invalid json output from HTF" (x:xs) -> (start `BSL.append` x : xs) + ppJ json = + T.unpack $ + T.decodeUtf8With T.lenientDecode $ + BSL.toStrict $ + J.encodePretty' J.defConfig json +runRealBlackBoxTests = + do b <- doesDirectoryExist "tests/bbt" + let dirPrefix = if b then "tests" else "" + bbts <- blackBoxTests (dirPrefix "real-bbt") ("/bin/bash") ".sh" + (defaultBBTArgs { bbtArgs_verbose = True }) + ecode <- runTest bbts + case ecode of + ExitFailure _ -> fail ("real blackbox tests failed!") + _ -> return () + main = do args <- getArgs b <- doesDirectoryExist "tests/bbt" @@ -232,10 +451,19 @@ (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests when ("--help" `elem` args || "-h" `elem` args) $ - do hPutStrLn stderr ("USGAGE: dist/build/test/test [--direct]") + do hPutStrLn stderr ("USAGE: PROG [--direct]") ecode <- runTestWithArgs ["--help"] ([] :: [Test]) exitWith ecode case args of + "FailFast.hs":rest -> failFastMain rest + "MaxCurTime.hs":rest -> maxCurTimeMain rest + "MaxPrevTime.hs":rest -> maxPrevTimeMain rest + "PrevFactor.hs":rest -> prevFactorMain rest + "Repeat.hs":rest -> repeatMain rest + "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest + "UniqTests1.hs":rest -> uniqTests1Main rest + "UniqTests2.hs":rest -> uniqTests2Main rest + x:_ | ".hs" `List.isSuffixOf` x -> fail ("Unkown real-bbt test: " ++ x) "--direct":rest -> do ecode <- runTestWithArgs rest tests case ecode of @@ -244,12 +472,11 @@ _ -> do withSystemTempFile "HTF-out" $ \outFile h -> do hClose h - ecode <- runTestWithArgs ["-j4", "--deterministic", + ecode <- runTestWithArgs ["-j4", "--shuffle=false", "--json", "--output-file=" ++ outFile] tests case ecode of ExitFailure _ -> checkOutput outFile _ -> fail ("unexpected exit code: " ++ show ecode) `onException` (do s <- readFile outFile hPutStrLn stderr s) - ecode <- system (dirPrefix "compile-errors/run-tests.sh") - exitWith ecode + runRealBlackBoxTests 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/Tutorial.hs b/tests/Tutorial.hs --- a/tests/Tutorial.hs +++ b/tests/Tutorial.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Tutorial where import System.Environment ( getArgs ) 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 base -package-conf ../../dist/package.conf.inplace -package HTF --make" lineno=7 - function check() { test="$1" - ghc $FLAGS "$test" 2>&1 | grep "$test":$lineno + echo "Running test $test ..." + command -v grep >/dev/null 2>&1 || \ + { echo >&2 "Test $0 requires ``grep'' but it's not installed. Aborting."; exit 1; } + compile_cmd="stack $HTF_TEST_STACK_ARGS ghc --package HTF -- -XPackageImports $test" + $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null grep_ecode=${PIPESTATUS[1]} if [ "$grep_ecode" != "0" ] then echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}" - ghc $FLAGS "$test" + echo "Compile command: $compile_cmd" + echo "Stack version: $(stack --version)" + echo "GHC version: $(stack $HTF_TEST_STACK_ARGS ghc -- --version)" + echo "Here is the output of the compiler:" + $compile_cmd exit 1 fi + echo "Done with test $test" } check Test1.hs 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,18 +0,0 @@ -#!/bin/bash - -if [ "$1" != "--no-clean" ] -then - cabal clean || exit 1 -fi -mkdir -p dist/build/htfpp || exit 1 -pushd .. -cabal build || exit 1 -popd -cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1 -cabal-1.16.0 configure || exit 1 -cabal-1.16.0 build || exit 1 -dist/build/test/test || exit 1 -echo "Tests ok" - -./compile-errors/run-tests.sh || exit 1 -echo "Line numbers in compile errors ok" diff --git a/tests/test-HTF.cabal b/tests/test-HTF.cabal deleted file mode 100644 --- a/tests/test-HTF.cabal +++ /dev/null @@ -1,41 +0,0 @@ -Name: test-HTF -Version: 0.1 -Cabal-Version: >= 1.10 -Build-type: Simple - -Executable test - Main-is: TestHTF.hs - Build-depends: base >= 4, - bytestring >= 0.9, - aeson >= 0.6, - unordered-containers >= 0.2, - temporary >= 1.1, - text >= 0.11, - directory >= 1.0, - filepath >= 1.1, - process >= 1.0, - regex-compat >= 0.92, - random, - mtl, - pretty, - containers, - xmlgen, - unix, - array, - old-time, - lifted-base, - monad-control, - HUnit, - QuickCheck, - Diff, - haskell-src-exts, - base64-bytestring - Default-language: Haskell2010 - Ghc-options: -threaded - Hs-source-dirs: ., .. - -Test-Suite tutorial - Type: exitcode-stdio-1.0 - Main-is: Tutorial.hs - Build-depends: base >= 4, HTF == 0.10.* - Default-language: Haskell2010