diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,56 @@ +* 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. 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.12.2.4 -License: LGPL +Version: 0.15.0.2 +License: LGPL-2.1 License-File: LICENSE -Copyright: (c) 2005-2014 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.6.2, - GHC==7.8.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 @@ -125,8 +83,22 @@ 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 @@ -135,33 +107,36 @@ Main-Is: HTFPP.hs Build-Depends: HUnit, array, - base == 4.*, - cpphs >= 1.12, + base >= 4.10 && < 5, + cpphs >= 1.19, directory >= 1.0, - haskell-lexer, mtl >= 1.1, old-time >= 1.0, random >= 1.0, - 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: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3, - aeson >= 0.6, + aeson >= 0.11, array, - base == 4.*, + base >= 4.10 && < 5, base64-bytestring, bytestring >= 0.9, containers >= 0.5, - cpphs >= 1.12, - directory >= 1.0, - haskell-lexer, + cpphs >= 1.19, haskell-src, + directory >= 1.0, lifted-base >= 0.1, monad-control >= 0.3, mtl >= 1.1, @@ -178,31 +153,37 @@ Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework + Test.Framework.AssertM + Test.Framework.BlackBoxTest Test.Framework.HUnitWrapper - Test.Framework.TestManager - Test.Framework.TestInterface - Test.Framework.TestTypes - Test.Framework.TestReporter Test.Framework.History - Test.Framework.CmdlineOptions - Test.Framework.QuickCheckWrapper - Test.Framework.BlackBoxTest + Test.Framework.JsonOutput Test.Framework.Location - Test.Framework.Tutorial + Test.Framework.Preprocessor Test.Framework.Pretty - Test.Framework.JsonOutput - Test.Framework.XmlOutput - Test.Framework.ThreadPool - Test.Framework.AssertM - Test.Framework.Colors Test.Framework.PrettyHaskell - Test.Framework.Preprocessor + Test.Framework.QuickCheckWrapper + Test.Framework.TestInterface + Test.Framework.TestManager + Test.Framework.TestTypes + Test.Framework.ThreadPool + Test.Framework.Tutorial + Test.Framework.XmlOutput Other-Modules: - Test.Framework.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 @@ -210,9 +191,10 @@ Hs-Source-Dirs: tests Build-depends: HTF, HUnit, - base == 4.*, + base >= 4.10 && < 5, mtl, random + Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Test-Suite TestHTF @@ -220,29 +202,33 @@ Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0 Build-depends: HTF, - aeson >= 0.6, + aeson >= 0.11, aeson-pretty, - base == 4.*, + base >= 4.10 && < 5, bytestring >= 0.9, directory >= 1.0, filepath >= 1.1, process >= 1.0, random, regex-compat >= 0.92, + template-haskell, temporary >= 1.1, text >= 0.11, unordered-containers >= 0.2 + Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Other-Modules: - Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime, - MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2 + Foo.A, Foo.B, FailFast, MaxCurTime, + MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi, + Tutorial, Repeat Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests Build-depends: HTF, - base == 4.*, + base >= 4.10 && < 5, mtl, random + Build-tool-depends: HTF:htfpp Default-language: Haskell2010 diff --git a/HTFPP.hs b/HTFPP.hs --- a/HTFPP.hs +++ b/HTFPP.hs @@ -35,7 +35,7 @@ usage = hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++ - "Usage: " ++ progName ++ " [--hunit|--debug|--version] [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,9 +45,9 @@ "* 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 = @@ -73,9 +73,9 @@ when ("--version" `elem` args) $ do outputVersion exitWith ExitSuccess - let hunitBackwardsCompat = "--hunit" `elem` args - debug = "--debug" `elem` args - restArgs = flip filter args $ \x -> x /= "--hunit" && x /= "--debug" + 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 [] -> @@ -96,7 +96,7 @@ usage exitWith (ExitFailure 1) input <- hGetContents hIn - output <- transform hunitBackwardsCompat debug 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.13 -** 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, TM.htfMainWithArgs, 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,73 +24,66 @@ -} module Test.Framework.AssertM ( - AssertM(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack + AssertM(..), AssertBool(..), boolValue, eitherValue ) where -import Data.Maybe -import qualified Data.Text as T -import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) +import GHC.Stack +import qualified Data.Text as T import Test.Framework.TestInterface -import Test.Framework.Location 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 = failHTF (FullTestResult (Just loc) [] (Just s) (Just Fail)) - genericSubAssert loc mMsg action = subAssertHTF 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 = return + 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 @@ -81,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 diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs --- a/Test/Framework/CmdlineOptions.hs +++ b/Test/Framework/CmdlineOptions.hs @@ -2,7 +2,7 @@ {-# 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 @@ -89,8 +89,9 @@ , 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 previosu run. + , 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. } {- | @@ -117,6 +118,7 @@ , opts_maxCurTimeMs = Nothing , opts_prevFactor = Nothing , opts_timeoutIsSuccess = False + , opts_repeat = 1 } processorCount :: Int @@ -140,9 +142,9 @@ , 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 [] ["deterministic"] - (NoArg (\o -> Right $ o { opts_shuffle = False })) - "Do not shuffle tests when executing them in parallel." + , 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." @@ -181,6 +183,10 @@ , 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." @@ -213,7 +219,7 @@ > -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. -> --deterministic Do not shuffle tests when executing them in parallel. +> --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. @@ -235,6 +241,10 @@ case getOpt Permute optionDescriptions args of (optTrans, tests, []) -> do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans + when (opts_shuffle opts && opts_sortByPrevTime opts) $ + Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " ++ + "Can only use one of both.\n\n" ++ + usageInfo usageHeader optionDescriptions) case (opts_outputFile opts, opts_split opts) of (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions) @@ -297,6 +307,7 @@ , 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 @@ -336,9 +347,12 @@ case opts_historyFile opts of Just fp -> return fp Nothing -> - do x <- getProgName - createDirectoryIfMissing False ".HTF" - return (".HTF/" ++ x ++ ".history") + 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 @@ -347,10 +361,10 @@ case deserializeTestHistory bs of Right history -> return history Left err -> - do hPutStrLn stderr ("Error deserializing content of history file " ++ fp ++ ": " ++ err) + do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err) return emptyTestHistory `catch` (\(e::IOException) -> - do hPutStrLn stderr ("Error reading history file " ++ fp ++ ": " ++ show e) + do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e) return emptyTestHistory) mergeFilters f1 f2 t = f1 t && f2 t 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 @@ -88,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) @@ -128,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) @@ -145,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 = @@ -170,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 @@ -187,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,594 +1,915 @@ -{-# 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, - - -- * 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 -import qualified Test.HUnit.Base as HU - -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 qualified Data.Text as T - --- 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_ - -{- | -Signals that the current unit test is pending. --} -unitTestPending :: String -> IO a -unitTestPending s = - failHTF (FullTestResult Nothing [] (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 - --- --- 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 exp act) - expected_ = colorize firstDiffColor "* expected:" - but_got_ = colorize secondDiffColor "* but got:" - diff_ = colorize diffColor "* diff:" - in ("\n" +++ expected_ +++ " " +++ noColor (withNewline exp) +++ - "\n" +++ but_got_ +++ " " +++ noColor (withNewline 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) - -equalityFailedMessage :: (Show a) => a -> a -> ColorString -equalityFailedMessage exp act = - equalityFailedMessage' expP actP - where - (expP, actP) = - 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) - -_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 expected 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 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 expected 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 expected 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 = subAssertHTF 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 = subAssertHTF 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 = diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs deleted file mode 100644 --- a/Test/Framework/HaskellParser.hs +++ /dev/null @@ -1,202 +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) -#if MIN_VERSION_haskell_src_exts(1,16,0) - 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) -#else - 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) -#endif - 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 --- a/Test/Framework/History.hs +++ b/Test/Framework/History.hs @@ -1,6 +1,26 @@ {-# 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(..) @@ -103,6 +123,28 @@ _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 { @@ -139,25 +181,3 @@ mkRes id ms = HistoricTestResult id Pass False ms historyTests = [("testCreateIndex", testCreateIndex)] - -testResultStringMapping :: [(TestResult, T.Text)] -testResultStringMapping = - [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")] - -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) - -deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory -deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory -deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult 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,8 +106,7 @@ = 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 @@ -100,10 +116,11 @@ 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) @@ -192,7 +209,7 @@ 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) + in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_stack r) msg (rr_wallTimeMs r) (rr_timeout r) mkTestListObj :: [(FlatTest, String)] -> TestListObj 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,10 +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 @@ -23,20 +26,31 @@ module Test.Framework.Preprocessor ( - transform, progName, preprocessorTests + transform, progName, preprocessorTests, TransformOptions(..) ) where -- import Debug.Trace import Control.Monad import Data.Char -import "haskell-lexer" Language.Haskell.Lexer -import Language.Preprocessor.Cpphs ( runCpphs, +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 @@ -77,49 +91,6 @@ [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)), (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault 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__))" - data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition] @@ -164,10 +135,60 @@ setTestFrameworkImport name = modify $ \mi -> mi { mi_htfPrefix = name } -poorManAnalyzeTokens :: [LocToken] -> ModuleInfo -poorManAnalyzeTokens toks = - -- show toks `trace` - let revRes = +data Tok + = TokModule + | TokQname Location String + | TokName Location Bool String + | TokHtfImport Location + | TokImport Location + +transWordStyles :: [WordStyle] -> [Tok] +transWordStyles styles = loop styles True + where + 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) + +poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo +poorManAnalyzeTokens styles = + let toks = transWordStyles styles + revRes = execState (loop toks) $ ModuleInfo { mi_htfPrefix = htfModule ++ "." , mi_htfImports = [] @@ -184,33 +205,30 @@ defEqByName _ _ = False loop toks = case toks of - (Reservedid, (_, "module")) : rest -> - case rest of - (Conid, (_, name)):rest2 -> - do setModName name - loop rest2 - (Qconid, (_, name)):rest2 -> - do setModName name - loop rest2 - _ -> loop rest - (Varid, (loc, name)) : rest - | isStartOfLine loc -> + 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 (locToLocation loc) + do addTestDef shortName name loc loop rest 'p':'r':'o':'p':'_':shortName -> - do addPropDef shortName name (locToLocation loc) + do addPropDef shortName name loc loop rest _ -> loop rest | otherwise -> loop rest - (Special, (loc, "import_HTF_TESTS")) : rest -> + TokHtfImport loc : rest -> case parseImport loc rest of Just (imp, rest2) -> do addHtfImport imp loop rest2 Nothing -> loop rest - (Reservedid, (loc, "import")) : rest -> + TokImport loc : rest -> do case parseImport loc rest of Nothing -> loop rest Just (imp, rest2) -> @@ -227,181 +245,30 @@ parseImport loc toks = do let (qualified, toks2) = case toks of - (Varid, (_, "qualified")):rest -> (True, rest) + TokName _ _ "qualified" : rest -> (True, rest) _ -> (False, toks) (name, toks3) <- case toks2 of - (Conid, (_, name)):rest -> return (name, rest) - (Qconid, (_, name)):rest -> return (name, rest) + TokName _ _ name : rest -> return (name, rest) + TokQname _ name : rest -> return (name, rest) _ -> fail "no import" let (mAlias, toks4) = case toks3 of - (Varid, (_, "as")):(Conid, (_, alias)):rest -> (Just alias, rest) + TokName _ _ "as" : TokName _ _ alias : rest -> (Just alias, rest) _ -> (Nothing, toks3) decl = ImportDecl { imp_moduleName = name , imp_qualified = qualified , imp_alias = mAlias - , imp_loc = locToLocation loc } + , imp_loc = loc } return (decl, toks4) - locToLocation loc = - makeLoc (l_file loc) (l_line loc) - isStartOfLine loc = - l_column loc == 1 -cleanupTokens :: [PosToken] -> [PosToken] -cleanupTokens toks = - -- Remove whitespace tokens, remove comments, but replace - -- 'import {-@ HTF_TESTS @-}' with a single - -- token Special with value "import_HTF_TESTS" - case toks of - (Whitespace, _):rest -> cleanupTokens rest - (NestedComment, (loc, "{-@ HTF_TESTS @-}")) : rest -> - (Special, (loc, "import_HTF_TESTS")) : - cleanupTokens rest - tok:rest -> tok : cleanupTokens rest - [] -> [] - --- char -> ' (graphic<' | \> | space | escape<\&>) ' --- graphic -> small | large | symbol | digit | special | : | " | ' --- escape -> \ ( charesc | ascii | decimal | o octal | x hexadecimal ) --- charesc -> a | b | f | n | r | t | v | \ | " | ' | & --- ascii -> ^cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK --- | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE --- | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN --- | EM | SUB | ESC | FS | GS | RS | US | SP | DEL --- cntrl -> ascLarge | @ | [ | \ | ] | ^ | _ --- decimal -> digit{digit} --- octal -> octit{octit} --- hexadecimal -> hexit{hexit} --- octit -> 0 | 1 | ... | 7 --- hexit -> digit | A | ... | F | a | ... | f --- special -> ( | ) | , | ; | [ | ] | `| { | } --- Purpose of cleanupInputString: filter out template Haskell quotes -cleanupInputString :: String -> String -cleanupInputString s = - case s of - c:'\'':'\'':x:rest - | isSpace c && isUpper x -> -- TH type quote - c:x:cleanupInputString rest - c:'\'':'\'':d:rest - | not (isAlphaNum c) || not (isAlphaNum d) - -> c:'\'':'x':'\'':d:rest - '\'':rest -> - case characterLitRest rest of - Just (restLit, rest') -> - '\'':restLit ++ cleanupInputString rest' - Nothing -> - '\'':cleanupInputString rest - c:'\'':x:rest -- TH name quote - | isSpace c && isNothing (characterLitRest (x:rest)) && isLower x -> - c:x:cleanupInputString rest - c:rest - | not (isSpace c) -> - case span (== '\'') rest of - (quotes, rest') -> c : quotes ++ cleanupInputString rest' - c:rest -> c : cleanupInputString rest - [] -> [] - where - characterLitRest s = -- expects that before the s there is a ' - case s of - '\\':'\'':'\'':rest -> Just ("\\''", rest) -- '\'' - c:'\'':rest -> Just (c:"'", rest) -- regular character lit - '\\':rest -> - case span (/= '\'') rest of - (esc,'\'':rest) -> - Just (('\\':esc) ++ "'", rest) - _ -> Just (s, "") -- should not happen - _ -> Nothing - -cleanupInputStringTest = - do flip mapM_ untouched $ \s -> - let cleanedUp = cleanupInputString s - in if s /= cleanedUp - then assertFailure ("Cleanup of " ++ show s ++ " is wrong: " ++ show cleanedUp ++ - ", expected that input and output are the same") - else return () - flip mapM_ touched $ \(input, output) -> - let cleanedUp = cleanupInputString input - in if output /= cleanedUp - then assertFailure ("Cleanup of " ++ show input ++ " is wrong: " ++ show cleanedUp - ++ ", expected " ++ show output) - else return () - where - untouched = [" '0'", " '\\''", " ' '", " '\o761'", " '\BEL'", " '\^@' ", "' '", "fixed' ' '"] - touched = [(" 'foo abc", " foo abc"), (" ''T ", " T ")] - -type LocToken = (Token,(Loc,String)) - -data Loc - = Loc - { l_file :: FilePath - , l_line :: Int - , l_column :: Int - } - deriving (Eq, Show) - --- token stream should not contain whitespace -fixPositions :: FilePath -> [PosToken] -> [LocToken] -fixPositions originalFileName = loop Nothing - where - loop mPragma toks = - case toks of - [] -> [] - (Varsym, (pos, "#")) : (Varid, (_, "line")) : (IntLit, (_, lineNo)) : (StringLit,(_, fileName)) : rest - | column pos == 1 -> - map (\(tt, (pos, x)) -> (tt, (fixPos Nothing pos, x))) (take 4 toks) ++ - loop (Just (line pos, fileName, read lineNo)) rest - (tt, (pos, x)) : rest -> - (tt, (fixPos mPragma pos, x)) : loop mPragma rest - fixPos mPragma pos = - case mPragma of - Nothing -> - Loc { l_column = column pos - , l_file = originalFileName - , l_line = line pos - } - Just (lineActivated, fileName, lineNo) -> - let offset = line pos - lineActivated - 1 - in Loc { l_column = column pos - , l_file = fileName - , l_line = lineNo + offset - } - -fixPositionsTest :: IO () -fixPositionsTest = - let toks = concatMap (\(f, i) -> f i) - (zip [tok, linePragma "bar" 10, tok, tok, linePragma "foo" 99, tok] [1..]) - fixedToks = fixPositions origFileName toks - expectedToks = concat $ - [tok' origFileName 1 - ,linePragma' "bar" 10 2 - ,tok' "bar" 10 - ,tok' "bar" 11 - ,linePragma' "foo" 99 5 - ,tok' "foo" 99] - in assertEqual (show expectedToks ++ "\n\n /= \n\n" ++ show toks) expectedToks fixedToks - where - origFileName = "spam" - tok line = [(Varid, (Pos 0 line 1, "_"))] - linePragma fname line lineHere = - let pos = Pos 0 lineHere 1 - in [(Varsym, (pos, "#")) - ,(Varid, (pos, "line")) - ,(IntLit, (pos, show line)) - ,(StringLit, (pos, fname))] - tok' fname line = - let loc = Loc fname line 1 - in [(Varid, (loc, "_"))] - linePragma' fname line lineHere = - let loc = Loc origFileName lineHere 1 - in [(Varsym, (loc, "#")) - ,(Varid, (loc, "line")) - ,(IntLit, (loc, show line)) - ,(StringLit,(loc, fname))] - -analyze :: FilePath -> String -> ModuleInfo +analyze :: FilePath -> String -> IO (ModuleInfo, [WordStyle], [(Posn,String)]) analyze originalFileName input = - poorManAnalyzeTokens (fixPositions originalFileName (cleanupTokens (lexerPass0 (cleanupInputString 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" @@ -414,7 +281,7 @@ ,"deriveSafeCopy 1 'base ''T" ,"$(deriveSafeCopy 2 'extension ''T)" ,"test_blub test_foo = 1" - ,"test_blah test_foo = 1" + ,"test_blah test_foo = '\''" ,"prop_abc prop_foo = 2" ,"prop_xyz = True"] ,ModuleInfo { mi_htfPrefix = "" @@ -474,25 +341,36 @@ do mapM_ runTest (zip [1..] analyzeTests) where runTest (i, (src, mi)) = - let givenMi = analyze "" src - in if givenMi == 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) -transform :: Bool -> Bool -> FilePath -> String -> IO String -transform hunitBackwardsCompat debug originalFileName input = - let info = analyze originalFileName fixedInput - in preprocess info +cpphsOptions :: CpphsOptions +cpphsOptions = + defaultCpphsOptions { + boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell + } + +data TransformOptions = TransformOptions { debug :: Bool + , literateTex :: Bool } + +transform :: TransformOptions -> FilePath -> String -> IO String +transform (TransformOptions debug literateTex) originalFileName input = + do (info, toks, pass1) <- analyze originalFileName fixedInput + preprocess info toks pass1 where - preprocess :: ModuleInfo -> IO String - preprocess info = - do when debug $ hPutStrLn stderr ("Module info:\n" ++ show info) - 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 ' @@ -504,14 +382,15 @@ case parseCppLineInfoOut s of Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName _ -> s - cpphsOptions :: ModuleInfo -> CpphsOptions - cpphsOptions info = + 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_moduleNameWithDefault info) ++ " :: " ++ @@ -575,6 +454,4 @@ _ -> Nothing preprocessorTests = - [("testAnalyze", testAnalyze) - ,("fixPositionsTest", fixPositionsTest) - ,("cleanupInputStringTest", cleanupInputStringTest)] + [("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 --- a/Test/Framework/PrettyHaskell.hs +++ b/Test/Framework/PrettyHaskell.hs @@ -1,3 +1,23 @@ +{- | +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 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 @@ -33,6 +37,7 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs, withQCArgs, WithQCArgs, setReplayFromString, + QCAssertion, -- * Pending properties qcPending, @@ -58,9 +63,6 @@ import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef -#if MIN_VERSION_QuickCheck(2,7,0) -import System.Random -#endif import Test.QuickCheck #if !MIN_VERSION_QuickCheck(2,7,0) @@ -147,21 +149,32 @@ Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) -> case () of _| pendingPrefix `List.isPrefixOf` reason -> - let pendingMsg = let s = drop (length pendingPrefix) reason - in take (length s - length pendingSuffix) s + let pendingMsg = getPayload pendingPrefix pendingSuffix reason in quickCheckTestPending pendingMsg - | otherwise -> - let replay = "Replay argument: " ++ (show (show (Just (gen, size)))) - out = adjustOutput msg - in quickCheckTestFail (Just (out ++ "\n" ++ replay)) + | 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 @@ -184,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 @@ -221,12 +234,9 @@ 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' + -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)' case readM str of Just x -> args { replay = x } Nothing -> - case readM str of - Just (_ :: Maybe (StdGen, Int)) -> - error ("Your replay parameter has been produced with QuickCheck <= 2.6. It cannot be used with QuickCheck >= 2.7") - Nothing -> error ("Could not parse replay parameter from string " ++ show str) + error ("Could not parse replay parameter from string " ++ show str) #endif diff --git a/Test/Framework/TestInterface.hs b/Test/Framework/TestInterface.hs --- a/Test/Framework/TestInterface.hs +++ b/Test/Framework/TestInterface.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# 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 @@ -21,13 +21,19 @@ {- | -This module defines the API for HTF plugins. +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(..), failHTF, subAssertHTF + Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..) + , HtfStackEntry(..), HtfStack, emptyHtfStack, mkHtfStack, formatHtfStack + , failureLocationFromStack, failureLocation + , restCallStack, htfStackToList + , failHTF, subAssertHTF, addCallerToSubAssertStack , mkFullTestResult ) where @@ -37,6 +43,8 @@ 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 @@ -58,21 +66,87 @@ 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_location :: Maybe Location -- ^ The location of a possible failure - , ftr_callingLocations :: [(Maybe String, Location)] -- ^ 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 + { 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_location = Nothing - , ftr_callingLocations = [] + { ftr_stack = emptyHtfStack , ftr_message = fmap noColor msg , ftr_result = Just r } @@ -93,12 +167,23 @@ -- 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 :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a -subAssertHTF loc mMsg action = - action `ExcLifted.catch` - (\(HTFFailure res) -> - let newRes = res { ftr_callingLocations = (mMsg, loc) : ftr_callingLocations res } - in failHTF newRes) +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,7 +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 @@ -22,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. -} @@ -37,11 +39,16 @@ -- * Organzing tests TestableHTF, + WrappableHTF(..), makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, + flattenTest, + + -- * Tests (for internal use) + wrappableTests ) where import Control.Monad.RWS @@ -67,6 +74,7 @@ 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 @@ -100,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 @@ -218,23 +246,34 @@ pre = reportTestStart ft action _ = let run = performTestHTF (wto_payload (ft_payload ft)) - in 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) + runWithTimeout = + case maxRunTime tc ft of + Nothing -> + do (res, time) <- measure run + return (PrimTestResultNoTimeout res, time) + Just maxMs -> + do mx <- timeout (1000 * maxMs) $ measure run + case mx of + Nothing -> return (PrimTestResultTimeout, maxMs) + Just (res, time) -> + return (PrimTestResultNoTimeout res, time) + isPass primTestRes = + case primTestRes of + PrimTestResultNoTimeout fullTestRes -> + ftr_result fullTestRes == Just Pass + PrimTestResultTimeout -> False + iterRunWithTimeout i = + do (primTestRes, time) <- runWithTimeout + if isPass primTestRes && i >= 2 + then iterRunWithTimeout (i-1) + else return (primTestRes, time) + in iterRunWithTimeout (tc_repeat tc) post excOrResult = let (testResult, time) = case excOrResult of Left exc -> (FullTestResult - { ftr_location = Nothing - , ftr_callingLocations = [] + { ftr_stack = emptyHtfStack , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc) , ftr_result = Just Error } @@ -243,8 +282,7 @@ case res of PrimTestResultTimeout -> (FullTestResult - { ftr_location = Nothing - , ftr_callingLocations = [] + { ftr_stack = emptyHtfStack , ftr_message = Just $ colorize warningColor "timeout" , ftr_result = Nothing } @@ -260,12 +298,10 @@ Just x -> (x, False) Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True) rr = FlatTest - { ft_sort = ft_sort ft , ft_path = ft_path ft , ft_location = ft_location ft - , ft_payload = RunResult sumRes (ftr_location testResult) - (ftr_callingLocations testResult) + , ft_payload = RunResult sumRes (ftr_stack testResult) (fromMaybe emptyColorString (ftr_message testResult)) time isTimeout } @@ -281,31 +317,31 @@ Fail -> DoStop Error -> DoStop -runAllFlatTests :: TestConfig -> [FlatTest] -> TR () -runAllFlatTests tc tests' = - do reportGlobalStart tests - tc <- ask +runAllFlatTests :: [FlatTest] -> TR () +runAllFlatTests tests' = + do tc <- ask + tests <- orderTests tc tests' + reportGlobalStart tests case tc_threads tc of Nothing -> let entries = map (mkFlatTestRunner tc) tests in tp_run sequentialThreadPool entries Just i -> let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests - pentries' = map (mkFlatTestRunner tc) ptests + 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 - tests = sortTests tests' - sortTests ts = - if not (tc_sortByPrevTime tc) - then ts - else map snd $ List.sortBy compareTests (map (\t -> (historyKey t, t)) ts) - compareTests (t1, _) (t2, _) = + 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))) @@ -381,6 +417,8 @@ _ -> 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, @@ -406,7 +444,7 @@ startTime <- getCurrentTime ((_, s, _), time) <- measure $ - runRWST (runAllFlatTests tc activeTests) 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 @@ -457,3 +495,14 @@ 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/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 @@ -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 diff --git a/Test/Framework/TestTypes.hs b/Test/Framework/TestTypes.hs --- a/Test/Framework/TestTypes.hs +++ b/Test/Framework/TestTypes.hs @@ -1,10 +1,29 @@ {-# 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 ( @@ -148,24 +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 @@ -205,6 +218,7 @@ , 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 @@ -226,6 +240,7 @@ 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. 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 @@ -20,7 +23,7 @@ module Test.Framework.ThreadPool ( ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool - , threadPoolTest, threadPoolTestStop + , threadPoolTest ) where @@ -39,7 +42,9 @@ type ThreadPoolEntry m a b = ( m a -- pre-action, must not throw exceptions , a -> IO b -- action - , Either Ex.SomeException b -> m StopFlag -- post-action, must not throw exceptions. If the result is DoStop, the thread pool is terminated asap. + , 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 @@ -51,7 +56,7 @@ 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 () @@ -88,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] @@ -184,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] @@ -193,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 @@ -225,33 +230,3 @@ mapM (runTestParallel nEntries) [i..j] `Ex.catch` (\(e::Ex.BlockedIndefinitelyOnMVar) -> fail ("main-thread blocked " ++ show e)) - -threadPoolTestStop = - do putStrLn ("Running test to see of STOP works") - boxesAndEntries <- mapM mkEntry [1..100] - let (boxes, entries) = unzip boxesAndEntries - runParallel numberOfThreads entries - debug ("Checking boxes...") - mapM_ checkBox (zip [1..] boxes) - putStrLn ("Test for STOP successful") - where - mkEntry i = - do mvar <- newEmptyNamedMVar ("box-" ++ show i) - let pre = return () - action () = - do putNamedMVar mvar () - return () - post _exc = return (if i >= numberOfThreads then DoStop else DoNotStop) - return (mvar, (pre, action, post)) - numberOfThreads = 10 - checkBox (i, (name, box)) = - do isEmpty <- isEmptyMVar box - if isEmpty - then if i > 20 - then return () - else if i <= 10 - then fail ("Box " ++ name ++ " is still empty") - else return () - else if i > 20 - then fail ("Box " ++ name ++ " not empty") - else return () 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,17 +1,65 @@ {-# 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 @@ -35,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 @@ -171,7 +221,7 @@ , 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 = 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,31 +0,0 @@ -#!/bin/bash - -SANDBOX_FILE="cabal.sandbox.config" -SANDBOX_DIR=".cabal-sandbox" - -set -e -if [ -e "$SANDBOX_FILE" ] -then - have_sandbox=yes - cabal sandbox hc-pkg unregister HTF || true -else - have_sandbox=no - ghc-pkg unregister HTF || true -fi - -cabal configure --enable-tests || exit 1 -cabal build || exit 1 -cabal test || exit 1 -cabal install || exit 1 - -cd sample - -if [ "$have_sandbox" == "yes" ] -then - rm -f cabal.sandbox.config - cabal sandbox init --sandbox ../"$SANDBOX_DIR" -fi - -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.12.* + 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.12.* + 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 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_OK = assertEqual 1 1 +test_b_OK = HTF.assertEqual 1 1 diff --git a/tests/MiscTest.hs b/tests/MiscTest.hs --- a/tests/MiscTest.hs +++ b/tests/MiscTest.hs @@ -21,10 +21,11 @@ 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 +allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests ++ wrappableTests main :: IO () main = 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,7 +40,12 @@ 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 @@ -46,7 +58,8 @@ 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 @@ -56,7 +69,9 @@ import UniqTests1 import UniqTests2 import PrevFactor +import Repeat import SortByPrevTime +import Quasi import Tutorial hiding (main) @@ -71,6 +86,19 @@ handleExc :: a -> SomeException -> a handleExc x _ = x +-- 世界不是英文的 Test for #47 + +-- Test for #48 +data HVect (ts :: [*]) where + HNil :: HVect '[] + HCons :: t -> HVect ts -> HVect (t ': ts) + +fun :: HVect '[Int, Int] -> String +fun = undefined + +-- Test for #45 +foobar = [q|INSERT INTO a (name) VALUES ('')|] + test_assertFailure_FAIL = assertFailure "I'm a failure" test_stringGap_OK = assertEqual stringGap "hello world!" @@ -125,6 +153,28 @@ (Literal 581)) (Variable "egg") +test_diff2_FAIL = + assertEqual s1 s2 + where + n = 100000 + s1 = mk [0..n] + s2 = mk ([0..4999] ++ [5001..n]) + mk :: [Int] -> String + mk [] = "" + mk (x:[]) = "line " ++ show x + mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs + +test_diff3_FAIL = + assertEqual s1 s2 + where + n = 100000 + s1 = mk [0..n] + s2 = mk [0..(n+1)] + mk :: [Int] -> String + mk [] = "" + mk (x:[]) = "line " ++ show x + mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs + prop_ok_OK :: [Int] -> Property prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) @@ -136,6 +186,11 @@ 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" @@ -156,18 +211,20 @@ 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] @@ -178,8 +235,7 @@ 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 - ["1_FAIL" - ,"a_FAIL" + ["a_FAIL" ,"h_FAIL" ,"assertElem_FAIL" ,"assertEmpty_FAIL" @@ -193,6 +249,8 @@ ,"assertThrowsIO1_FAIL" ,"assertThrows_FAIL" ,"diff_FAIL" + ,"diff2_FAIL" + ,"diff3_FAIL" ,"error'_FAIL" ,"error_FAIL" ,"exhaust_FAIL" @@ -219,14 +277,15 @@ 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 - ["2_OK" - ,"assertSetEqualSuccess_OK" + ["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" @@ -258,6 +317,12 @@ ,"location" .= J.object ["file" .= J.String "TestHTF.hs" ,"line" .= J.toJSON (107+lineOffset)]]) check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Main:diff2_FAIL"]]) + (J.object ["message" .= J.String "NOT:No newline at end of file"]) + check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Main:diff3_FAIL"]]) + (J.object ["message" .= J.String "NOT:No newline at end of file"]) + check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]]) (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs" ,"line" .= J.toJSON (10::Int)]] @@ -271,15 +336,15 @@ ,"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.Null + (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+lineOffset)]] - ,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+lineOffset)]]]]) + ,"line" .= J.toJSON (95+lineOffset)]]]]) where lineOffset :: Int - lineOffset = 12 + lineOffset = 40 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null @@ -292,11 +357,11 @@ ,"wallTime":11} -} case json of - J.Object objJson | Just (J.Object testObj) <- M.lookup "test" objJson - , Just (J.String flatName) <- M.lookup "flatName" testObj - , Just (J.String "test-end") <- M.lookup "type" objJson - , Just (J.String result) <- M.lookup "result" objJson - , Just (J.Bool to) <- M.lookup "timedOut" objJson -> + 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 @@ -333,20 +398,24 @@ 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 @@ -362,13 +431,13 @@ T.unpack $ T.decodeUtf8With T.lenientDecode $ BSL.toStrict $ - J.encodePretty' (J.Config 2 J.compare) json + 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 = False }) + (defaultBBTArgs { bbtArgs_verbose = True }) ecode <- runTest bbts case ecode of ExitFailure _ -> fail ("real blackbox tests failed!") @@ -382,7 +451,7 @@ (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests when ("--help" `elem` args || "-h" `elem` args) $ - do hPutStrLn stderr ("USAGE: dist/build/test/test [--direct]") + do hPutStrLn stderr ("USAGE: PROG [--direct]") ecode <- runTestWithArgs ["--help"] ([] :: [Test]) exitWith ecode case args of @@ -390,6 +459,7 @@ "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 @@ -402,7 +472,7 @@ _ -> 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 @@ -410,5 +480,3 @@ `onException` (do s <- readFile outFile hPutStrLn stderr s) runRealBlackBoxTests - ecode <- system (dirPrefix "compile-errors/run-tests.sh") - exitWith ecode 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_FAIL = do assertEqual "1 == 2" 1 2 - assertEqualHTF 1 1 - -test_2_OK = do assertJust "foo" (Just 1) - assertJustHTF (Just 1) diff --git a/tests/ThreadPoolTest.hs b/tests/ThreadPoolTest.hs --- a/tests/ThreadPoolTest.hs +++ b/tests/ThreadPoolTest.hs @@ -31,7 +31,6 @@ [x] -> return (read x, 100) [x, y] -> return (read x, read y) _ -> usage - threadPoolTestStop threadPoolTest (1, i) nEntries return () where 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/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,32 +2,27 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package base -package-db ../../dist/package.conf.inplace -package HTF --make" -SANDBOX_FILE="../../cabal.sandbox.config" -SANDBOX_DIR="../../.cabal-sandbox" -GHC_VERSION=$(ghc --version | sed 's/.*version //g') - -if [ -e "$SANDBOX_FILE" ] -then - for pkg_db in $(ls -d -1 $SANDBOX_DIR/*$GHC_VERSION*-packages.conf.d) - do - FLAGS="$FLAGS -package-db $pkg_db" - done -fi -echo $FLAGS - 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 --- a/tests/real-bbt/FailFast.hs +++ b/tests/real-bbt/FailFast.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module FailFast (failFastMain) where import Test.Framework diff --git a/tests/real-bbt/MaxCurTime.hs b/tests/real-bbt/MaxCurTime.hs --- a/tests/real-bbt/MaxCurTime.hs +++ b/tests/real-bbt/MaxCurTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxCurTime (maxCurTimeMain) where import Test.Framework diff --git a/tests/real-bbt/MaxPrevTime.hs b/tests/real-bbt/MaxPrevTime.hs --- a/tests/real-bbt/MaxPrevTime.hs +++ b/tests/real-bbt/MaxPrevTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxPrevTime (maxPrevTimeMain) where import Test.Framework diff --git a/tests/real-bbt/PrevFactor.hs b/tests/real-bbt/PrevFactor.hs --- a/tests/real-bbt/PrevFactor.hs +++ b/tests/real-bbt/PrevFactor.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module PrevFactor (prevFactorMain) where import Test.Framework 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 --- a/tests/real-bbt/SortByPrevTime.hs +++ b/tests/real-bbt/SortByPrevTime.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module SortByPrevTime (sortByPrevTimeMain) where import Test.Framework diff --git a/tests/real-bbt/UniqTests1.hs b/tests/real-bbt/UniqTests1.hs --- a/tests/real-bbt/UniqTests1.hs +++ b/tests/real-bbt/UniqTests1.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests1 (uniqTests1Main) where import Test.Framework diff --git a/tests/real-bbt/UniqTests2.hs b/tests/real-bbt/UniqTests2.hs --- a/tests/real-bbt/UniqTests2.hs +++ b/tests/real-bbt/UniqTests2.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-} +{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests2 (uniqTests2Main) where import Test.Framework