diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +* 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 diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.0 Name: HTF -Version: 0.14.0.7 +Version: 0.15.0.0 License: LGPL-2.1 License-File: LICENSE Copyright: (c) 2005-2015 Stefan Wehr @@ -13,23 +13,25 @@ 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 Haskell Test Framework (/HTF/ for short) lets you define and organize unit tests, + QuickCheck properties, + and black box tests in an + easy and convenient way. HTF uses a custom preprocessor that collects + test definitions automatically. . + HTF produces highly readable output + for failing test cases: it provides exact file name and line number + information, + it colors and pretty prints expected and + actual results, and it displays a diff highlighting the mismatching parts. + + . + The documentation of the "Test.Framework.Tutorial" module - provides a tutorial for HTF. There is also a slightly out-dated - blog article () - demonstrating HTF's coloring, pretty-printing and diff functionality. + provides a tutorial for HTF. The /sample/ provides a good starting point for + a project using HTF. Build-Type: Custom @@ -153,30 +155,30 @@ 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: Paths_HTF - Test.Framework.Utils + 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 @@ -218,7 +220,7 @@ Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Other-Modules: - Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime, + Foo.A, Foo.B, FailFast, MaxCurTime, MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi, Tutorial, Repeat 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|--literate-tex] [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,7 @@ "* 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.\n" ++ + "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.") @@ -75,8 +73,7 @@ when ("--version" `elem` args) $ do outputVersion exitWith ExitSuccess - let transformOpts = TransformOptions { hunitBackwardsCompat = "--hunit" `elem` args - , debug = "--debug" `elem` args + 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) <- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,29 +11,17 @@ ## Summary -The Haskell Test Framework (HTF for short) lets you define unit tests +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/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,8 +21,10 @@ 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 ( diff --git a/Test/Framework/AssertM.hs b/Test/Framework/AssertM.hs --- a/Test/Framework/AssertM.hs +++ b/Test/Framework/AssertM.hs @@ -1,4 +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 @@ -7,41 +24,33 @@ -} 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.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 @@ -52,29 +61,29 @@ (<*>) = ap instance Monad AssertBool where - return = pure - AssertFailed stack >>= _ = AssertFailed stack + return = AssertOk + AssertFailed stack msg >>= _ = AssertFailed stack msg AssertOk x >>= k = k x #if !(MIN_VERSION_base(4,13,0)) - fail msg = AssertFailed [AssertStackElem (Just msg) Nothing] + 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 @@ -83,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 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 @@ -166,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) @@ -183,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 = @@ -208,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 diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -5,600 +5,911 @@ {-# 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 -#if !MIN_VERSION_HUnit(1,4,0) -import qualified Test.HUnit.Base as HU -#endif - -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 -import qualified Data.List as List - --- 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 (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 = 100000 - - -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 +-- 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/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(..) 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 @@ -3,9 +3,11 @@ {-# 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 @@ -89,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] @@ -396,12 +355,11 @@ boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell } -data TransformOptions = TransformOptions { hunitBackwardsCompat :: Bool - , debug :: Bool +data TransformOptions = TransformOptions { debug :: Bool , literateTex :: Bool } transform :: TransformOptions -> FilePath -> String -> IO String -transform (TransformOptions hunitBackwardsCompat debug literateTex) originalFileName input = +transform (TransformOptions debug literateTex) originalFileName input = do (info, toks, pass1) <- analyze originalFileName fixedInput preprocess info toks pass1 where @@ -428,7 +386,6 @@ mkOptionsForModule info = defaultCpphsOptions { defines = defines defaultCpphsOptions ++ - assertDefines hunitBackwardsCompat (mi_htfPrefix info) ++ nameDefines info , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell } 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 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 +-- {- | 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 @@ -6,7 +6,7 @@ {-# 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 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. -} @@ -271,8 +273,7 @@ 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 } @@ -281,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 } @@ -298,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 } 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 @@ -144,7 +161,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 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 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, HTF - 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 @@ -273,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": @@ -308,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,7 +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 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/sample/sample-HTF.cabal b/sample/sample-HTF.cabal --- a/sample/sample-HTF.cabal +++ b/sample/sample-HTF.cabal @@ -16,6 +16,7 @@ other-modules: MyPkg.A MyPkg.B build-depends: base, HTF default-language: Haskell2010 + build-tool-depends: HTF:htfpp test-suite sample-tests type: exitcode-stdio-1.0 @@ -23,3 +24,4 @@ other-modules: MyPkg.A MyPkg.B build-depends: base, HTF default-language: Haskell2010 + build-tool-depends: HTF:htfpp diff --git a/tests/Foo/B.hs b/tests/Foo/B.hs --- a/tests/Foo/B.hs +++ b/tests/Foo/B.hs @@ -4,4 +4,4 @@ import qualified Test.Framework as HTF -test_b_OK = assertEqual 1 1 +test_b_OK = HTF.assertEqual 1 1 diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -29,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 @@ -57,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 @@ -151,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)) @@ -162,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" @@ -182,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] @@ -204,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" @@ -219,6 +249,8 @@ ,"assertThrowsIO1_FAIL" ,"assertThrows_FAIL" ,"diff_FAIL" + ,"diff2_FAIL" + ,"diff3_FAIL" ,"error'_FAIL" ,"error_FAIL" ,"exhaust_FAIL" @@ -245,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" @@ -284,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)]] @@ -297,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 = 38 + lineOffset = 40 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null @@ -365,14 +404,18 @@ 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 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 ./scripts/local-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)