HTF 0.14.0.7 → 0.15.0.0

raw patch · 30 files changed

+1536/−914 lines, 30 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog +10/−0
• HTF.cabal +32/−30
• HTFPP.hs +3/−6
• README.md +7/−19
• Test/Framework.hs +5/−3
• Test/Framework/AssertM.hs +37/−39
• Test/Framework/BlackBoxTest.hs +1/−1
• Test/Framework/CmdlineOptions.hs +1/−1
• Test/Framework/Colors.hs +4/−1
• Test/Framework/Diff.hs +18/−10
• Test/Framework/HUnitWrapper.hs +905/−594
• Test/Framework/History.hs +20/−0
• Test/Framework/JsonOutput.hs +26/−9
• Test/Framework/Location.hs +2/−2
• Test/Framework/Preprocessor.hs +6/−49
• Test/Framework/Pretty.hs +17/−0
• Test/Framework/PrettyHaskell.hs +20/−0
• Test/Framework/QuickCheckWrapper.hs +1/−1
• Test/Framework/TestInterface.hs +100/−15
• Test/Framework/TestManager.hs +7/−9
• Test/Framework/TestReporter.hs +18/−1
• Test/Framework/TestTypes.hs +26/−13
• Test/Framework/ThreadPool.hs +4/−1
• Test/Framework/Tutorial.hs +136/−65
• Test/Framework/Utils.hs +1/−1
• Test/Framework/XmlOutput.hs +61/−11
• sample/sample-HTF.cabal +2/−0
• tests/Foo/B.hs +1/−1
• tests/TestHTF.hs +65/−22
• tests/TestHTFHunitBackwardsCompatible.hs +0/−10

@@ -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

@@ -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 (<http://hunit.sourceforge.net>), QuickCheck properties-    (<http://www.cs.chalmers.se/~rjmh/QuickCheck/>), and black box-    tests in an easy and convenient way. HTF uses a custom-    preprocessor that collects test definitions automatically.-    Furthermore, the preprocessor allows HTF to report failing-    test cases with exact file name and line number information.-    Additionally, HTF tries to produce highly readable output-    for failing tests: for example, it colors and pretty prints expected and-    actual results and provides a diff between the two values.+    The 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 (<http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html>)-    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 

@@ -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) <-

@@ -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 

@@ -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 (

@@ -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 "<unknown location>" $ fmap showLoc mLoc-              fmsg = fromMaybe "" $ fmap (\s -> ": " ++ s) mMsg-              pref = if pos > 0 then "  called from " else ""-          in pref ++ floc ++ fmsg+      AssertFailed stack msg -> Left (msg ++ "\n" ++ formatHtfStack stack)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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--@&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@--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 =

@@ -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(..)

@@ -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

@@ -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.  -} 

@@ -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                               }

@@ -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+--  {- | 

@@ -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

@@ -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

@@ -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)

@@ -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                      }

@@ -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

@@ -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

@@ -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

@@ -1,3 +1,20 @@+--+-- Copyright (c) 2005-2022   Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {- | This module provides a short tutorial on how to use the HTF. It assumes that you are using GHC for compiling your Haskell code. (It is@@ -5,18 +22,90 @@ taken to invoke the custom preprocessor of the HTF may differ in this case.) -We start with a simple example. Then we show how to use HTF to easily-collect test definitions from multiple modules and discuss-backwards-compatibility for projects already using `HUnit`. Finally,-we give a brief cookbook-like summary on how to setup your tests with HTF.- -}  module Test.Framework.Tutorial ( +-- * Quickstart++{- |++For the impatient, we start with a brief cookbook-like summary and then go into details.+You should also have a look at the sample project at+<https://github.com/skogsbaer/HTF/tree/master/sample>.++-}++-- ** Writing tests++{- |++You should use the following skeleton for each module defining test cases:++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+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:++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module Main ( main ) where++-- Import modules defining HTF tests like this:+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyModule++main :: IO ()+main = htfMain htf_importedTests -- all tests in modules imported via &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; 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-<https://github.com/skogsbaer/HTF/tree/master/sample>.+{- | Machine-readable output is also available as XML, following the specification of the JUnit+output format. XML-output is requested by the @--xml=OUTPUT_FILE@ flag.+See "Test.Framework.XmlOutput" for details.  -}---- ** Writing tests+-- * Commandline options  {- | -* Place @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ 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 @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ 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 &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A@.+@+USAGE: COMMAND [OPTION ...] PATTERN ... -* Use @main = htfMain htf_importedTests@ to run all imported tests.+  where PATTERN is a posix regular expression matching+  the names of the tests to run. +  -q          --quiet                     Only display errors.+  -n PATTERN  --not=PATTERN               Tests to exclude.+  -l          --list                      List all matching tests.+  -j[N]       --threads[=N]               Run N tests in parallel, default N=1.+              --shuffle=BOOL              Shuffle test order. Default: false+  -o FILE     --output-file=FILE          Name of output file.+              --json                      Output results in machine-readable JSON format (incremental).+              --xml=FILE                  Output results in junit-style XML format.+              --split                     Splits results in separate files to avoid file locking (requires -o/--output-file).+              --colors=BOOL               Use colors or not.+              --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history+              --fail-fast                 Fail and abort test run as soon as the first test fails.+              --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false+              --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.+              --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.+              --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.+              --timeout-is-success        Do not regard a test timeout as an error.+              --repeat=NUMBER             Execute the tests selected on the command line NUMBER times.+  -h          --help                      Display this message.+@ -}- ) where

@@ -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

@@ -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 <http://pzolee.blogs.balabit.com/2012/11/jenkins-vs-junit-xml-format/>-for a description of the format used.+XML-output following the JUnit output format. -The source code of this module also contains a rough specification of-the output format in terms of Haskell data types.+The data types exposed by this module give a rough specification of+the output format. +Here is a sample ouput:++@+\<?xml version="1.0" encoding="UTF-8" standalone="yes"?\>+\<testsuites tests="6" failures="2" errors="0" time="0.705"\>+  \<testsuite id="0" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.A" package="MyPkg.A"\>+    \<testcase classname="MyPkg.A" name="test_funA2" time="0.000"/\>+    \<testcase classname="MyPkg.A" name="test_funA1" time="0.000"/\>+  \</testsuite\>+  \<testsuite id="1" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.B" package="MyPkg.B"\>+    \<testcase classname="MyPkg.B" name="test_funB2" time="0.000"/\>+    \<testcase classname="MyPkg.B" name="test_funB1" time="0.000"/\>+  \</testsuite\>+  \<testsuite id="2" tests="2" failures="2" errors="0" time="0.703" name="bbts" package="bbts"\>+    \<testcase classname="bbts" name="bbt_bbt-dir/should-pass/x.num" time="0.230"\>+      \<failure type="failure" message="test is supposed to succeed but failed with exit code 255"\>test is supposed to succeed but failed with exit code 255\</failure\>+    \</testcase\>+    \<testcase classname="bbts" name="bbt_bbt-dir/should-fail/z.num" time="0.473"\>+      \<failure type="failure" message="Mismatch on stderr:"\>Mismatch on stderr:+--- bbt-dir/should-fail/z.err	2015-09-05 18:37:30.000000000 +0200++++ -	2022-03-06 09:49:55.480265000 +0100+\@\@ -1 +1 \@\@+-invalid input++sample[88331]: [fatal] unable to read input graph: The data couldn’t be read because it isn’t in the correct format.+[end of diff output]+\</failure\>+    \</testcase\>+  \</testsuite\>+\</testsuites\>+@+ -} {-# LANGUAGE OverloadedStrings #-} module Test.Framework.XmlOutput ( -    mkGlobalResultsXml+  JunitXmlOutput(..), Testsuites(..), Testsuite(..), Testcase(..), Result(..)+  , mkGlobalResultsXml  ) where @@ -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 =

@@ -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

@@ -4,4 +4,4 @@  import qualified Test.Framework as HTF -test_b_OK = assertEqual 1 1+test_b_OK = HTF.assertEqual 1 1

@@ -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

@@ -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)