HTF 0.13.2.5 → 0.15.0.2
raw patch · 47 files changed
Files
- .travis.yml +0/−36
- ChangeLog +35/−0
- HTF.cabal +74/−46
- HTFPP.hs +8/−8
- README.md +9/−21
- Setup.hs +0/−5
- TODO.org +0/−11
- Test/Framework.hs +5/−3
- Test/Framework/AssertM.hs +40/−40
- Test/Framework/BlackBoxTest.hs +1/−1
- Test/Framework/CmdlineOptions.hs +9/−6
- Test/Framework/Colors.hs +4/−1
- Test/Framework/Diff.hs +66/−14
- Test/Framework/HUnitWrapper.hs +912/−593
- Test/Framework/History.hs +42/−22
- Test/Framework/JsonOutput.hs +26/−9
- Test/Framework/Location.hs +2/−2
- Test/Framework/Preprocessor.hs +14/−51
- Test/Framework/Pretty.hs +17/−0
- Test/Framework/PrettyHaskell.hs +20/−0
- Test/Framework/QuickCheckWrapper.hs +2/−8
- Test/Framework/TestInterface.hs +100/−15
- Test/Framework/TestManager.hs +9/−9
- Test/Framework/TestReporter.hs +19/−1
- Test/Framework/TestTypes.hs +26/−13
- Test/Framework/ThreadPool.hs +6/−3
- Test/Framework/Tutorial.hs +136/−65
- Test/Framework/Utils.hs +6/−1
- Test/Framework/XmlOutput.hs +61/−11
- sample/sample-HTF.cabal +4/−2
- scripts/check.sh +11/−4
- scripts/local-htfpp +17/−17
- scripts/prepare +6/−0
- stack-ghc-7.10.yaml +0/−5
- stack-ghc-8.0.yaml +0/−5
- stack-ghc-8.10.yaml +4/−0
- stack-ghc-8.4.yaml +1/−1
- stack-ghc-8.6.yaml +1/−1
- stack-ghc-8.8.yaml +6/−0
- stack-ghc-9.0.yaml +4/−0
- stack-ghc-9.2.yaml +4/−0
- stack-ghc-9.4.yaml +4/−0
- stack.yaml +2/−2
- tests/Foo/B.hs +1/−1
- tests/TestHTF.hs +79/−32
- tests/TestHTFHunitBackwardsCompatible.hs +0/−10
- tests/compile-errors/run-tests.sh +7/−2
− .travis.yml
@@ -1,36 +0,0 @@-# Use new container infrastructure to enable caching-sudo: false--# Choose a lightweight base image; we provide our own build tools.-language: c--# GHC depends on GMP. You can add other dependencies here as well.-addons:- apt:- packages:- - libgmp-dev--# The different configurations we want to test. You could also do things like-# change flags or use --stack-yaml to point to a different file.-env:-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.6.yaml"-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.4.yaml"-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.2.yaml"-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.0.yaml"-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-7.10.yaml"--before_install:-# Download and unpack the stack executable-- mkdir -p ~/.local/bin-- export PATH=$HOME/.local/bin:$PATH-- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'--# This line does all of the work: installs GHC if necessary, build the library,-# executables, and test suites, and runs the test suites. --no-terminal works-# around some quirks in Travis's terminal implementation.-script: stack $HTF_TRAVIS_STACK_ARGS --no-terminal --install-ghc test --haddock --cabal-verbose--# Caching so the next build will be fast too.-cache:- directories:- - $HOME/.stack
ChangeLog view
@@ -1,3 +1,38 @@+* 0.15.0.1+ - Fix build for mtl-2.3 #118++* 0.15.0.0+ - Remove macros for assertions, location information is now provided+ via HasCallStack. For most users, this change should be backwards compatible.+ However, if you imported Test.Framework qualified, then all assert macros+ where previously in scope unqualified, through macros. In this case, you need to+ import Test.Framework unqualified or qualify all uses of assert macros.+ - The modules Test.Framework.CmdlineOptions, Test.Framework.Colors,+ and Test.Framework.TestReporter are no longer exposed. I don't think that+ anyone depends on these internal modules. Let me know I am wrong.++* 0.14.0.7 (2022-03-03)+ - several upper bounds for packages+ - minor improvements++* 0.14.0.5 (2021-01-26)+ - make sure htfpp is available before running the tests++* 0.14.0.4 (2021-01-26)+ - fix #99+ - hopefully fix #97++* 0.14.0.2 (2019-11-27)+ - use haskell-src from hackage++* 0.14.0.1 (2019-11-27)+ - find cpphs++* 0.14.0.0 (2019-11-26)+ - support for GHC 8.8+ - fix for performance problem with long strings+ https://github.com/skogsbaer/HTF/issues/85+ * 0.13.2.5 (2018-11-06) - fix build problem with quickcheck: https://github.com/skogsbaer/HTF/issues/70
HTF.cabal view
@@ -1,10 +1,11 @@+Cabal-Version: 2.0 Name: HTF-Version: 0.13.2.5+Version: 0.15.0.2 License: LGPL-2.1 License-File: LICENSE-Copyright: (c) 2005-2015 Stefan Wehr-Author: Stefan Wehr <wehr@factisresearch.com>-Maintainer: Stefan Wehr <wehr@factisresearch.com>+Copyright: (c) 2005-2024 Stefan Wehr+Author: Stefan Wehr+Maintainer: Stefan Wehr Stability: Beta Category: Testing Synopsis: The Haskell Test Framework@@ -12,37 +13,41 @@ 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/ directory in+ the HTF repo provides a good starting point for+ a project using HTF. Build-Type: Simple-Cabal-Version: >= 1.10+ Extra-Source-Files: README.md- TODO.org ChangeLog- .travis.yml stack.yaml- stack-ghc-7.10.yaml- stack-ghc-8.0.yaml stack-ghc-8.2.yaml stack-ghc-8.4.yaml stack-ghc-8.6.yaml+ stack-ghc-8.8.yaml+ stack-ghc-8.10.yaml+ stack-ghc-9.0.yaml+ stack-ghc-9.2.yaml+ stack-ghc-9.4.yaml tests/bbt/should_fail/BBTArgs tests/bbt/should_fail/*.err tests/bbt/should_fail/*.out@@ -82,7 +87,18 @@ scripts/dist.sh scripts/check.sh scripts/run-sample+ scripts/prepare +tested-with:+ GHC == 9.4.4+ GHC == 9.2.6+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ Source-Repository head Type: git Location: http://github.com/skogsbaer/HTF.git@@ -91,18 +107,21 @@ Main-Is: HTFPP.hs Build-Depends: HUnit, array,- base == 4.*,+ base >= 4.10 && < 5, cpphs >= 1.19, directory >= 1.0, mtl >= 1.1, old-time >= 1.0, random >= 1.0,- text,+ text >= 0.11, HTF+ Build-tool-depends: cpphs:cpphs >= 1.19 Other-Modules: Paths_HTF Test.Framework.Location Test.Framework.Preprocessor+ Autogen-modules:+ Paths_HTF Default-language: Haskell2010 Library@@ -111,7 +130,7 @@ QuickCheck >= 2.3, aeson >= 0.11, array,- base == 4.*,+ base >= 4.10 && < 5, base64-bytestring, bytestring >= 0.9, containers >= 0.5,@@ -134,31 +153,37 @@ Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework+ Test.Framework.AssertM+ Test.Framework.BlackBoxTest Test.Framework.HUnitWrapper- Test.Framework.TestManager- Test.Framework.TestInterface- Test.Framework.TestTypes- Test.Framework.TestReporter Test.Framework.History- Test.Framework.CmdlineOptions- Test.Framework.QuickCheckWrapper- Test.Framework.BlackBoxTest+ Test.Framework.JsonOutput Test.Framework.Location- Test.Framework.Tutorial+ Test.Framework.Preprocessor Test.Framework.Pretty- Test.Framework.JsonOutput- Test.Framework.XmlOutput- Test.Framework.ThreadPool- Test.Framework.AssertM- Test.Framework.Colors Test.Framework.PrettyHaskell- Test.Framework.Preprocessor+ Test.Framework.QuickCheckWrapper+ Test.Framework.TestInterface+ Test.Framework.TestManager+ Test.Framework.TestTypes+ Test.Framework.ThreadPool+ Test.Framework.Tutorial+ Test.Framework.XmlOutput Other-Modules:- Test.Framework.Utils+ Paths_HTF+ Test.Framework.CmdlineOptions+ Test.Framework.Colors Test.Framework.Diff Test.Framework.Process+ Test.Framework.TestReporter+ Test.Framework.Utils+ Autogen-modules:+ Paths_HTF+ Build-tool-depends: cpphs:cpphs >= 1.19 Default-language: Haskell2010- Ghc-Options: -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+ Ghc-Options:+ -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+ -Wcompat Test-Suite MiscTests Main-is: MiscTest.hs@@ -166,9 +191,10 @@ Hs-Source-Dirs: tests Build-depends: HTF, HUnit,- base == 4.*,+ base >= 4.10 && < 5, mtl, random+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Test-Suite TestHTF@@ -176,9 +202,9 @@ Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0 Build-depends: HTF,- aeson >= 0.6,+ aeson >= 0.11, aeson-pretty,- base == 4.*,+ base >= 4.10 && < 5, bytestring >= 0.9, directory >= 1.0, filepath >= 1.1,@@ -189,9 +215,10 @@ temporary >= 1.1, text >= 0.11, unordered-containers >= 0.2+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Other-Modules:- Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime,+ Foo.A, Foo.B, FailFast, MaxCurTime, MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi, Tutorial, Repeat @@ -200,7 +227,8 @@ Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests Build-depends: HTF,- base == 4.*,+ base >= 4.10 && < 5, mtl, random+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010
HTFPP.hs view
@@ -35,7 +35,7 @@ usage = hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++- "Usage: " ++ progName ++ " [--hunit|--debug|--version] [FILE1 [FILE2 [FILE3]]]\n\n" +++ "Usage: " ++ progName ++ " [--debug|--version|--literate-tex] [FILE1 [FILE2 [FILE3]]]\n\n" ++ "* If no argument is given, input is read from stdin and\n" ++ " output is written to stdout.\n" ++ "* If only FILE1 is given, input is read from this file\n" ++@@ -45,9 +45,9 @@ "* If FILE1, FILE2, and FILE3 are given, input is read\n" ++ " from FILE2, output is written to FILE3, and\n" ++ " FILE1 serves as the original input filename.\n\n" ++- "The `--hunit' flag causes assert-like macros to be expanded in a way\n" ++- "that is backwards-compatible with the corresponding functions of the\n" ++- "HUnit library.")+ "The `--hunit' flag has been deprecated starting with version 0.15." +++ "The `--literate-tex` flag causes the additional generated code to be wrapped\n" +++ "in TeX-style literate code blocks.") outputVersion :: IO () outputVersion =@@ -73,9 +73,9 @@ when ("--version" `elem` args) $ do outputVersion exitWith ExitSuccess- let hunitBackwardsCompat = "--hunit" `elem` args- debug = "--debug" `elem` args- restArgs = flip filter args $ \x -> x /= "--hunit" && x /= "--debug"+ let transformOpts = TransformOptions { debug = "--debug" `elem` args+ , literateTex = "--literate-tex" `elem` args }+ restArgs = flip filter args $ \x -> not $ x `elem` ["--hunit", "--debug", "--literate-tex"] (origInputFilename, hIn, hOut) <- case restArgs of [] ->@@ -96,7 +96,7 @@ usage exitWith (ExitFailure 1) input <- hGetContents hIn- output <- transform hunitBackwardsCompat debug origInputFilename input `catch`+ output <- transform transformOpts origInputFilename input `catch` (\ (e::SomeException) -> do hPutStrLn stderr (progName ++ ": unexpected exception: " ++
README.md view
@@ -1,39 +1,27 @@ # HTF - The Haskell Test Framework -[](https://travis-ci.org/skogsbaer/HTF)+[](https://github.com/skogsbaer/HTF/actions/workflows/haskell-ci.yml) [](http://hackage.haskell.org/package/HTF) * Documentation: http://hackage.haskell.org/package/HTF * Source Repository: https://github.com/skogsbaer/HTF/ * Issue tracker: https://github.com/skogsbaer/HTF/issues?state=open * Author: Stefan Wehr (http://www.stefanwehr.de)-* License: LGPL+* License: LGPL ## Summary -The Haskell Test Framework (HTF for short) lets you define unit tests+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
− Setup.hs
@@ -1,5 +0,0 @@-#!/usr/bin/runhaskell--import Distribution.Simple--main = defaultMain
− TODO.org
@@ -1,11 +0,0 @@-* Relase 0.13-** New parser-*** Add support for MultiWayIf and LambdaCase to haskell-src-exts-*** Allow default Fixities for haskell-src-exts-** Support for timeouts (--timeout=SECS)-** External interface for integrating other test frameworks-*** Support for Smallcheck and/or Lazy Smallcheck-*** Configuration file for htfpp-**** Expansion templates (extensible!)-** Support for benchmarks-** Collect testmodules with a new preprocessor (new preprocessor runs on the main module)
Test/Framework.hs view
@@ -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 (
Test/Framework/AssertM.hs view
@@ -1,3 +1,21 @@+{-# LANGUAGE CPP #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {-| This module defines the 'AssertM' monad, which allows you either to run assertions@@ -6,73 +24,66 @@ -} module Test.Framework.AssertM ( - AssertM(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack+ AssertM(..), AssertBool(..), boolValue, eitherValue ) where -import Data.Maybe-import qualified Data.Text as T-import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap)+import GHC.Stack+import qualified Data.Text as T import Test.Framework.TestInterface-import Test.Framework.Location import Test.Framework.Colors -- | A typeclass for generic assertions. class Monad m => AssertM m where- genericAssertFailure__ :: Location -> ColorString -> m a- genericSubAssert :: Location -> Maybe String -> m a -> m a+ genericAssertFailure :: HasCallStack => ColorString -> m a+ genericSubAssert :: HasCallStack => Maybe String -> m a -> m a instance AssertM IO where- genericAssertFailure__ loc s = failHTF (FullTestResult (Just loc) [] (Just s) (Just Fail))- genericSubAssert loc mMsg action = subAssertHTF loc mMsg action---- | Stack trace element for generic assertions.-data AssertStackElem- = AssertStackElem- { ase_message :: Maybe String- , ase_location :: Maybe Location- }- deriving (Eq, Ord, Show, Read)+ genericAssertFailure s =+ failHTF (FullTestResult (mkHtfStack callStack) (Just s) (Just Fail))+ genericSubAssert mMsg action = subAssertHTF mMsg action -- | Type for evaluating a generic assertion as a pure function. data AssertBool a -- | Assertion passes successfully and yields the given value. = AssertOk a -- | Assertion fails with the given stack trace. In the stack trace, the outermost stackframe comes first.- | AssertFailed [AssertStackElem]+ | AssertFailed HtfStack String deriving (Eq, Ord, Show, Read) instance Functor AssertBool where fmap = liftM instance Applicative AssertBool where- pure = return+ pure = AssertOk (<*>) = ap instance Monad AssertBool where return = AssertOk- AssertFailed stack >>= _ = AssertFailed stack+ AssertFailed stack msg >>= _ = AssertFailed stack msg AssertOk x >>= k = k x- fail msg = AssertFailed [AssertStackElem (Just msg) Nothing]+#if !(MIN_VERSION_base(4,13,0))+ fail msg = AssertFailed emptyHtfStack msg+#endif instance AssertM AssertBool where- genericAssertFailure__ loc s =- AssertFailed [AssertStackElem (Just (T.unpack $ renderColorString s False)) (Just loc)]-- genericSubAssert loc mMsg action =+ genericAssertFailure s =+ AssertFailed (mkHtfStack callStack) (T.unpack $ renderColorString s False)+ genericSubAssert subMsg action = case action of AssertOk x -> AssertOk x- AssertFailed stack ->- AssertFailed (AssertStackElem mMsg (Just loc) : stack)+ AssertFailed stack msg ->+ let ghcStack = callStack+ in AssertFailed (addCallerToSubAssertStack ghcStack stack subMsg) msg -- | Evaluates a generic assertion to a 'Bool' value. boolValue :: AssertBool a -> Bool boolValue x = case x of AssertOk _ -> True- AssertFailed _ -> False+ AssertFailed _ _ -> False -- | Evaluates a generic assertion to an 'Either' value. The result -- is @Right x@ if the assertion passes and yields value @x@, otherwise@@ -81,15 +92,4 @@ eitherValue x = case x of AssertOk z -> Right z- AssertFailed stack -> Left (formatStack stack)---- | Formats a stack trace.-formatStack :: [AssertStackElem] -> String-formatStack stack =- unlines $ map formatStackElem $ zip [0..] $ reverse stack- where- formatStackElem (pos, AssertStackElem mMsg mLoc) =- let floc = fromMaybe "<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)
Test/Framework/BlackBoxTest.hs view
@@ -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
Test/Framework/CmdlineOptions.hs view
@@ -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@@ -347,9 +347,12 @@ case opts_historyFile opts of Just fp -> return fp Nothing ->- do x <- getProgName- createDirectoryIfMissing False ".HTF"- return (".HTF/" ++ x ++ ".history")+ do progName <- getProgName+ let x = if progName == "<interactive>" then "interactive" else progName+ curDir <- getCurrentDirectory+ let dir = curDir </> ".HTF"+ createDirectoryIfMissing False dir+ return $ dir </> (x ++ ".history") getHistory fp = do b <- doesFileExist fp if not b@@ -358,10 +361,10 @@ case deserializeTestHistory bs of Right history -> return history Left err ->- do hPutStrLn stderr ("Error deserializing content of history file " ++ fp ++ ": " ++ err)+ do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err) return emptyTestHistory `catch` (\(e::IOException) ->- do hPutStrLn stderr ("Error reading history file " ++ fp ++ ": " ++ show e)+ do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e) return emptyTestHistory) mergeFilters f1 f2 t = f1 t && f2 t
Test/Framework/Colors.hs view
@@ -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
Test/Framework/Diff.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} ----- Copyright (c) 2011, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -88,12 +88,50 @@ contextSize :: Int contextSize = 10 +prepareStringsForDiff :: String -> String -> (String, String, Maybe (String, String))+prepareStringsForDiff s1 s2 =+ case (List.splitAt 1024 s1, List.splitAt 1024 s2) of+ ((start1, rest1@(_:_)), (start2, rest2@(_:_))) -> (start1, start2, Just (rest1, rest2))+ ((start1, []), (start2, _)) -> (start1, start2, Nothing)+ ((start1, _), (start2, [])) -> (start1, start2, Nothing)+ singleLineDiff :: DiffConfig -> String -> String -> ColorString-singleLineDiff dc s1 s2- | s1 == s2 = emptyColorString+singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2)+ where+ loop :: (Int, Int) -> (String, String) -> ColorString+ loop (skipped1, skipped2) (s1, s2) =+ let (start1, start2, cont) = prepareStringsForDiff s1 s2+ in case singleLineDiff' dc start1 start2 of+ Just cs ->+ let prefix =+ if skipped1 == 0 && skipped1 == 0+ then emptyColorString+ else dc_skip dc+ ("skipped " ++ show skipped1 +++ " chars from first string, "+ ++ show skipped2 ++ " chars from second string")+ suffix =+ case cont of+ Nothing -> emptyColorString+ Just (r1, r2) ->+ dc_skip dc+ ("skipped " ++ show (length r1) +++ " chars from first string, " +++ show (length r2) ++ " chars from second string")+ in prefix +++ cs +++ suffix+ Nothing ->+ case cont of+ Just (r1, r2) ->+ loop (skipped1 + length start1, skipped2 + length start2) (r1, r2)+ Nothing -> emptyColorString++singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString+singleLineDiff' dc s1 s2+ | s1 == s2 = Nothing | otherwise = let groups = D.getGroupedDiff s1 s2- in foldr (\(group, pos) string ->+ in Just $+ foldr (\(group, pos) string -> (showDiffGroup pos group) +++ (if not (isLast pos) then dc_sep dc else emptyColorString) +++ string)@@ -128,12 +166,20 @@ multiLineDiff :: DiffConfig -> String -> String -> IO ColorString multiLineDiff cfg left right = withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) ->- do write hLeft left- write hRight right+ do write hLeft leftForFile+ write hRight rightForFile doDiff fpLeft fpRight where+ (leftForFile, rightForFile) =+ if lastChar left /= Just '\n' && lastChar right /= Just '\n'+ then (left ++ "\n", right ++ "\n") -- avoid "No newline at end of file" error messages+ else (left, right)+ lastChar s =+ case reverse s of+ [] -> Nothing+ (c:_) -> Just c doDiff leftFile rightFile =- (do (ecode, out, _err) <- readProcessWithExitCode "diff" [leftFile, rightFile] ""+ (do (ecode, out, _err) <- readProcessWithExitCode "diff" ["-u", leftFile, rightFile] "" case ecode of ExitSuccess -> return (format out) ExitFailure 1 -> return (format out)@@ -145,8 +191,8 @@ removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException))) withTempFiles action = do dir <- getTemporaryDirectory- left@(fpLeft, _) <- openTempFile dir "HTF-diff-left.txt"- (do right@(fpRight, _) <- openTempFile dir "HTF-diff-right.txt"+ left@(fpLeft, _) <- openTempFile dir "HTF-diff-EXPECTED_.txt"+ (do right@(fpRight, _) <- openTempFile dir "HTF-diff-ACTUAL_.txt" action left right `finally` saveRemove fpRight `finally` saveRemove fpLeft) write h s =@@ -170,12 +216,12 @@ fromSecond s = dc_fromSecond cfg s diff :: DiffConfig -> String -> String -> IO ColorString-diff cfg left right =+diff cfg left right = do case (lines left, lines right) of ([], []) -> return emptyColorString- ([], [_]) -> return $ singleLineDiff cfg left right- ([_], []) -> return $ singleLineDiff cfg left right- ([_], [_]) -> return $ singleLineDiff cfg left right+ ([], [_]) -> return (singleLineDiff cfg left right)+ ([_], []) -> return (singleLineDiff cfg left right)+ ([_], [_]) -> return (singleLineDiff cfg left right) _ -> multiLineDiff cfg left right diffWithSensibleConfig :: String -> String -> IO ColorString@@ -187,7 +233,13 @@ -} multiLineDiffHaskell :: String -> String -> ColorString multiLineDiffHaskell left right =- noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) -- this code is now part of the Diff library (hence the >0.3 in Cabal)+ if length left > maxLen || length right > maxLen+ then noColor+ ("Refusing to compute a multiline diff for strings with more than " ++ show maxLen +++ " chars. Please install the 'diff' tool to get a diff ouput.")+ else noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right)+ where+ maxLen = 10000 main = do args <- getArgs
Test/Framework/HUnitWrapper.hs view
@@ -1,596 +1,915 @@-{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}------- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----{-|--This module provides assert-like functions for writing unit tests.--/Hint:/ Do not use the @assertXXX_@ functions-directly. Instead, for each function @assertXXX_@,-there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically. Use these macros, which-are available automatically if you add--@{-# OPTIONS_GHC -F -pgmF htfpp #-}@--at the top of your source file (see the 'Test.Framework.Tutorial').---}--module Test.Framework.HUnitWrapper (-- -- * Assertions on Bool values- assertBool_, assertBoolVerbose_,- gassertBool_, gassertBoolVerbose_,-- -- * Equality assertions- assertEqual_, assertEqualVerbose_,- gassertEqual_, gassertEqualVerbose_,- assertEqualPretty_, assertEqualPrettyVerbose_,- gassertEqualPretty_, gassertEqualPrettyVerbose_,- assertEqualNoShow_, assertEqualNoShowVerbose_,- gassertEqualNoShow_, gassertEqualNoShowVerbose_,- assertNotEqual_, assertNotEqualVerbose_,- gassertNotEqual_, gassertNotEqualVerbose_,- assertNotEqualPretty_, assertNotEqualPrettyVerbose_,- gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_,- assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,- gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_,-- -- * Assertions on lists- assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,- gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_,- assertNotEmpty_, assertNotEmptyVerbose_,- gassertNotEmpty_, gassertNotEmptyVerbose_,- assertEmpty_, assertEmptyVerbose_,- gassertEmpty_, gassertEmptyVerbose_,- assertElem_, assertElemVerbose_,- gassertElem_, gassertElemVerbose_,-- -- * Assertions for exceptions- assertThrows_, assertThrowsVerbose_,- assertThrowsSome_, assertThrowsSomeVerbose_,- assertThrowsIO_, assertThrowsIOVerbose_,- assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,- assertThrowsM_, assertThrowsMVerbose_,- assertThrowsSomeM_, assertThrowsSomeMVerbose_,-- -- * Assertions on Either values- assertLeft_, assertLeftVerbose_,- gassertLeft_, gassertLeftVerbose_,- assertLeftNoShow_, assertLeftNoShowVerbose_,- gassertLeftNoShow_, gassertLeftNoShowVerbose_,- assertRight_, assertRightVerbose_,- gassertRight_, gassertRightVerbose_,- assertRightNoShow_, assertRightNoShowVerbose_,- gassertRightNoShow_, gassertRightNoShowVerbose_,-- -- * Assertions on Just values- assertJust_, assertJustVerbose_,- gassertJust_, gassertJustVerbose_,- assertNothing_, assertNothingVerbose_,- gassertNothing_, gassertNothingVerbose_,- assertNothingNoShow_, assertNothingNoShowVerbose_,- gassertNothingNoShow_, gassertNothingNoShowVerbose_,-- -- * General failure- assertFailure_,- gassertFailure_,-- -- * Pending unit tests- unitTestPending, unitTestPending',-- -- * Sub assertions- subAssert_, subAssertVerbose_,- gsubAssert_, gsubAssertVerbose_,-- -- * HUnit re-exports- HU.HUnitFailure,-- -- * Tests (for internal use)- hunitWrapperTests--) where--import Control.Exception-import qualified Control.Exception.Lifted as ExL-import Control.Monad.Trans.Control-import Control.Monad.Trans-import qualified Test.HUnit.Lang as HU-#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---- WARNING: do not forget to add a preprocessor macro for new assertions!!--{- |-Fail with the given reason, supplying the error location and the error message.--}-gassertFailure_ :: AssertM m => Location -> String -> m a-gassertFailure_ loc s =- genericAssertFailure__ loc (mkMsg "assertFailure" ""- ("failed at " ++ showLoc loc ++ ": " ++ s))---- | Specialization of 'gassertFailure'.-assertFailure_ :: Location -> String -> IO a-assertFailure_ = gassertFailure_--{- |-Signals that the current unit test is pending.--}-unitTestPending :: String -> IO a-unitTestPending s =- failHTF (FullTestResult Nothing [] (Just $ noColor s) (Just Pending))--{- |-Use @unitTestPending' msg test@ to mark the given test as pending-without removing it from the test suite and without deleting or commenting out the test code.--}-unitTestPending' :: String -> IO a -> IO a-unitTestPending' msg _ = unitTestPending msg--mkMsg :: String -> String -> String -> ColorString-mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)--mkColorMsg :: String -> String -> ColorString -> ColorString-mkColorMsg fun extraInfo s =- let pref = if null extraInfo- then fun ++ " "- else fun ++ " (" ++ extraInfo ++ ") "- in noColor pref +++ s------- Dirty macro hackery (I'm too lazy ...)----#define CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, __ret__) \-__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \-__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \-__name__##_ loc = _##__name__##_ #__name__ loc ""-#define CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \-g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \-g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \-g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \-CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__)--#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ())-#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ())--#define CreateAssertions(__name__, __type__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ())-#define CreateAssertionsNoGVariant(__name__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ())--#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__)-#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__)--#define CreateAssertionsRet(__name__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__)-#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __ret__)--#define DocAssertion(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variants can be used to provide extra information about the error. The \- variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \- they run in the IO monad and can be evaluated to a 'Bool' value. \- Do not use the \- @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \- functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \- @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}-#define DocAssertionNoGVariant(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variant can be used to provide extra information about the error. \- Do not use the \- @__name__##_@ and @__name__##Verbose_@ \- functions directly, use the macros @__name__@ and @__name__##Verbose@ \- instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}------ Boolean Assertions-----_assertBool_ :: AssertM m => String -> Location -> String -> Bool -> m ()-_assertBool_ name loc s False =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertBool_ _ _ _ True = return ()--DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)-CreateAssertions(assertBool, Bool)------- Equality Assertions-----equalityFailedMessage' :: String -> String -> ColorString-equalityFailedMessage' exp act =- let !diff = unsafePerformIO (diffWithSensibleConfig exp act)- expected_ = colorize firstDiffColor "* expected:"- but_got_ = colorize secondDiffColor "* but got:"- diff_ = colorize diffColor "* diff:"- in ("\n" +++ expected_ +++ " " +++ noColor (withNewline exp) +++- "\n" +++ but_got_ +++ " " +++ noColor (withNewline act) +++- "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff +++- (if (exp == act)- then "\nWARNING: strings are equal but actual values differ!"- else ""))- where- withNewline s =- case lines s of- [] -> s- [_] -> s- _ -> '\n':s- newlineBeforeDiff d =- let f b = case colorStringFind (\c -> c == '\n') d b of- Just _ -> "\n"- Nothing -> ""- in noColor' (f True) (f False)--equalityFailedMessage :: (Show a) => a -> a -> ColorString-equalityFailedMessage exp act =- equalityFailedMessage' expP actP- where- (expP, actP) =- case (prettyHaskell' exp, prettyHaskell' act) of- (Nothing, _) -> (show exp, show act)- (_, Nothing) -> (show exp, show act)- (Just expP, Just actP)- | expP == actP ->- (show exp, show act)- | otherwise -> (expP, actP)--notEqualityFailedMessage :: Show a => a -> String-notEqualityFailedMessage exp =- notEqualityFailedMessage' (prettyHaskell exp)--notEqualityFailedMessage' :: String -> String-notEqualityFailedMessage' exp =- (": Objects are equal\n" ++ exp)--_assertEqual_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqual_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg name s $- noColor ("failed at " ++ showLoc loc) +++ x)- else return ()--DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertNotEqual_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqual_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage expected- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()--DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualPretty_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)- genericAssertFailure__ loc (mkColorMsg name s- (noColor ("failed at " ++ showLoc loc) +++ x))- else return ()--DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualPretty_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage' (showPretty expected)- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()-DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualNoShow_ name loc s expected actual =- if expected /= actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)--_assertNotEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualNoShow_ name loc s expected actual =- if expected == actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertNotEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)------- Assertions on Lists-----_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> [a] -> [a] -> m ()-_assertListsEqualAsSets_ name loc s expected actual =- let ne = length expected- na = length actual- in case () of- _| ne /= na ->- do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg name s- (noColor- ("failed at " ++ showLoc loc- ++ "\n expected length: " ++ show ne- ++ "\n actual length: " ++ show na) +++- (if maxLength x < 5000- then x else emptyColorString)))- | not (unorderedEq expected actual) ->- do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s- (noColor ("failed at " ++ showLoc loc) +++ x))- | otherwise -> return ()- where unorderedEq l1 l2 =- null (l1 \\ l2) && null (l2 \\ l1)-DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal- when considered as sets. The first list parameter- denotes the expected value.)-CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), (Eq a, Show a, AssertM m), [a] -> [a])--_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertNotEmpty_ name loc s [] =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertNotEmpty_ _ _ _ (_:_) = return ()-DocAssertion(assertNotEmpty, Fail if the given list is empty.)-CreateAssertions(assertNotEmpty, [a])--_assertEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertEmpty_ name loc s (_:_) =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertEmpty_ _ _ _ [] = return ()-DocAssertion(assertEmpty, Fail if the given list is a non-empty list.)-CreateAssertions(assertEmpty, [a])--_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m ()-_assertElem_ name loc s x l =- if x `elem` l- then return ()- else genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- "\n element: " ++ show x ++- "\n list: " ++ show l))-DocAssertion(assertElem, Fail if the given element is not in the list.)-CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a])------- Assertions for Exceptions-----_assertThrowsIO_ :: Exception e- => String -> Location -> String -> IO a -> (e -> Bool) -> IO ()-_assertThrowsIO_ name loc s x f =- _assertThrowsM_ name loc s x f-DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool))--_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO ()-_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a)--_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e)- => String -> Location -> String -> m a -> (e -> Bool) -> m ()-_assertThrowsM_ name loc s x f =- do res <- ExL.try x- case res of- Right _ -> liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": no exception was thrown"))- Left e -> if f e then return ()- else liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++- showLoc loc ++- ": wrong exception was thrown: " ++- show e))-DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,- m a -> (e -> Bool), m ())--_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m)- => String -> Location -> String -> m a -> m ()-_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not- throw an exception.)-CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ())--_assertThrows_ :: Exception e- => String -> Location -> String -> a -> (e -> Bool) -> IO ()-_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f-DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool))--_assertThrowsSome_ :: String -> Location -> String -> a -> IO ()-_assertThrowsSome_ name loc s x =- _assertThrows_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSome, a)------- Assertions on Either-----_assertLeft_ :: forall a b m . (AssertM m, Show b)- => String -> Location -> String -> Either a b -> m a-_assertLeft_ _ _ _ (Left x) = return x-_assertLeft_ name loc s (Right x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given " ++- show (Right x :: Either b b)))-DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.- Use this function if @b@ is an instance of 'Show')-CreateAssertionsCtxRet(assertLeft, Show b, (Show b, AssertM m), Either a b, a)--_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a-_assertLeftNoShow_ _ _ _ (Left x) = return x-_assertLeftNoShow_ name loc s (Right _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given a Right value"))-DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.)-CreateAssertionsRet(assertLeftNoShow, Either a b, a)--_assertRight_ :: forall a b m . (Show a, AssertM m)- => String -> Location -> String -> Either a b -> m b-_assertRight_ _ _ _ (Right x) = return x-_assertRight_ name loc s (Left x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given " ++- show (Left x :: Either a a)))-DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.- Use this function if @a@ is an instance of 'Show')-CreateAssertionsCtxRet(assertRight, Show a, (Show a, AssertM m), Either a b, b)--_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b-_assertRightNoShow_ _ _ _ (Right x) = return x-_assertRightNoShow_ name loc s (Left _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given a Left value"))-DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.)-CreateAssertionsRet(assertRightNoShow, Either a b, b)------- Assertions on Maybe-----_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a-_assertJust_ _ _ _ (Just x) = return x-_assertJust_ name loc s Nothing =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Just value, given Nothing"))-DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.)-CreateAssertionsRet(assertJust, Maybe a, a)--_assertNothing_ :: (Show a, AssertM m)- => String -> Location -> String -> Maybe a -> m ()-_assertNothing_ _ _ _ Nothing = return ()-_assertNothing_ name loc s jx =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given " ++ show jx))-DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.- Use this function if @a@ is an instance of 'Show'.)-CreateAssertionsCtx(assertNothing, Show a, (Show a, AssertM m), Maybe a)--_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m ()-_assertNothingNoShow_ _ _ _ Nothing = return ()-_assertNothingNoShow_ name loc s _ =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given a Just value"))-DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.)-CreateAssertions(assertNothingNoShow, Maybe a)------- Sub assertions------- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location--- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write------ > assertIsPositive :: Int -> Assertion--- > assertIsPositive n = assertBool (n > 0)------ You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly--- you will lose location information: if @assertIsPositive i@ fails you will only get the location where--- @assertIsPositive@ is defined but not from where it has been called.------ To recover the location information you simply use @subAssert (assertIsPositive i)@.--- In this case, if @i@ is not positive, you will get the location of the caller.------ /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@.-subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a-subAssert_ loc ass = subAssertHTF loc Nothing ass---- | Generic variant of 'subAssert_'.-gsubAssert_ :: AssertM m => Location -> m a -> m a-gsubAssert_ loc ass = genericSubAssert loc Nothing ass---- | Same as 'subAssert_' but with an additional error message.-subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a-subAssertVerbose_ loc msg ass = subAssertHTF loc (Just msg) ass---- | Generic variant of 'subAssertVerbose_'.-gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a-gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{-|++This module provides assert-like functions for writing unit tests.++-}++module Test.Framework.HUnitWrapper (++ -- * Assertions on Bool values+ assertBool, assertBoolVerbose,++ -- * Equality assertions+ assertEqual, assertEqualVerbose,+ assertEqualPretty, assertEqualPrettyVerbose,+ assertEqualNoShow, assertEqualNoShowVerbose,++ -- * Inequality assertions+ assertNotEqual, assertNotEqualVerbose,+ assertNotEqualPretty, assertNotEqualPrettyVerbose,+ assertNotEqualNoShow, assertNotEqualNoShowVerbose,++ -- * Assertions on lists+ assertListsEqualAsSets, assertListsEqualAsSetsVerbose,+ assertNotEmpty, assertNotEmptyVerbose,+ assertEmpty, assertEmptyVerbose,+ assertElem, assertElemVerbose,++ -- * Assertions for exceptions+ assertThrows, assertThrowsVerbose,+ assertThrowsSome, assertThrowsSomeVerbose,+ assertThrowsIO, assertThrowsIOVerbose,+ assertThrowsSomeIO, assertThrowsSomeIOVerbose,+ assertThrowsM, assertThrowsMVerbose,+ assertThrowsSomeM, assertThrowsSomeMVerbose,++ -- * Assertions on Either values+ assertLeft, assertLeftVerbose,+ assertLeftNoShow, assertLeftNoShowVerbose,+ assertRight, assertRightVerbose,+ assertRightNoShow, assertRightNoShowVerbose,++ -- * Assertions on Just values+ assertJust, assertJustVerbose,+ assertNothing, assertNothingVerbose,+ assertNothingNoShow, assertNothingNoShowVerbose,++ -- * General failure+ assertFailure,++ -- * Pending unit tests+ unitTestPending, unitTestPending',++ -- * Sub assertions+ subAssert, subAssertVerbose,++ -- * Generalized assertions and failures in AssertM+ {- |+ The following definitions generalize the the monad in which assertions are executed.+ Usually, assertions are executed in the @IO@ monad. The @AssertM@ monad+ (see "Test.Framework.AssertM") allows you to evaluate assertions also as pure functions.+ -}+ -- ** Assertions on Bool values+ gassertBool, gassertBoolVerbose,++ -- ** Equality assertions+ gassertEqual, gassertEqualVerbose,+ gassertEqualPretty, gassertEqualPrettyVerbose,+ gassertEqualNoShow, gassertEqualNoShowVerbose,++ -- ** Inequality assertions+ gassertNotEqual, gassertNotEqualVerbose,+ gassertNotEqualPretty, gassertNotEqualPrettyVerbose,+ gassertNotEqualNoShow, gassertNotEqualNoShowVerbose,++ -- ** Assertions on lists+ gassertListsEqualAsSets, gassertListsEqualAsSetsVerbose,+ gassertNotEmpty, gassertNotEmptyVerbose,+ gassertEmpty, gassertEmptyVerbose,+ gassertElem, gassertElemVerbose,++ -- ** Assertions on Either values+ gassertLeft, gassertLeftVerbose,+ gassertLeftNoShow, gassertLeftNoShowVerbose,+ gassertRight, gassertRightVerbose,+ gassertRightNoShow, gassertRightNoShowVerbose,++ -- ** Assertions on Just values+ gassertJust, gassertJustVerbose,+ gassertNothing, gassertNothingVerbose,+ gassertNothingNoShow, gassertNothingNoShowVerbose,++ -- ** General failure+ gassertFailure,++ -- ** Sub assertions+ gsubAssert, gsubAssertVerbose,++ -- * HUnit re-exports+ HU.HUnitFailure,++ -- * Tests (for internal use)+ hunitWrapperTests++) where++import Control.Exception+import qualified Control.Exception.Lifted as ExL+import Control.Monad.Trans.Control+import Control.Monad.Trans+import qualified Test.HUnit.Lang as HU+#if !MIN_VERSION_HUnit(1,4,0)+import qualified Test.HUnit.Base as HU+#endif++import GHC.Stack++import Data.List ( (\\) )+import System.IO.Unsafe (unsafePerformIO)++import Test.Framework.TestInterface+import Test.Framework.Location+import Test.Framework.Diff+import Test.Framework.Colors+import Test.Framework.Pretty+import Test.Framework.AssertM+import Test.Framework.PrettyHaskell+import Test.Framework.Utils++import qualified Data.Text as T+import qualified Data.List as List++-- WARNING: do not forget to add a preprocessor macro for new assertions!!++{- |+Fail with the given reason in some 'AssertM' monad.+-}+gassertFailure :: (HasCallStack, AssertM m) => String -> m a+gassertFailure s =+ genericAssertFailure (mkMsg "assertFailure" "" s)++-- | Specialization of 'gassertFailure' to @IO@.+assertFailure :: HasCallStack => String -> IO a+assertFailure = gassertFailure++{- |+Signals that the current unit test is pending.+-}+unitTestPending :: String -> IO a+unitTestPending s =+ failHTF (FullTestResult emptyHtfStack (Just $ noColor s) (Just Pending))++{- |+Use @unitTestPending' msg test@ to mark the given test as pending+without removing it from the test suite and without deleting or commenting out the test code.+-}+unitTestPending' :: String -> IO a -> IO a+unitTestPending' msg _ = unitTestPending msg++mkMsg :: String -> String -> String -> ColorString+mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)++mkColorMsg :: String -> String -> ColorString -> ColorString+mkColorMsg fun extraInfo s =+ let pref = if null extraInfo+ then fun ++ " "+ else fun ++ " (" ++ extraInfo ++ ") "+ in noColor pref +++ s++--+-- Boolean Assertions+--++assertBool_ :: (HasCallStack, AssertM m) => String -> String -> Bool -> m ()+assertBool_ name s False = genericAssertFailure (mkMsg name s "failed")+assertBool_ _ _ True = return ()++-- | Fail if the 'Bool' value is 'False'.+assertBool :: HasCallStack => Bool -> IO ()+assertBool = assertBool_ "assertBool" ""++assertBoolVerbose :: HasCallStack => String -> Bool -> IO ()+assertBoolVerbose = assertBool_ "assertBoolVerbose"++gassertBool :: (HasCallStack, AssertM m) => Bool -> m ()+gassertBool = assertBool_ "gassertBool" ""++gassertBoolVerbose :: (HasCallStack, AssertM m) => String -> Bool -> m ()+gassertBoolVerbose = assertBool_ "gassertBoolVerbose"++--+-- Equality Assertions+--++equalityFailedMessage' :: String -> String -> ColorString+equalityFailedMessage' exp act =+ let !diff = unsafePerformIO (diffWithSensibleConfig exp act)+ expected_ = colorize firstDiffColor "* expected:"+ but_got_ = colorize secondDiffColor "* but got:"+ diff_ = colorize diffColor "* diff:"+ in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) ++++ "\n" +++ but_got_ +++ " " +++ noColor (withNewline (trim act)) ++++ "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff ++++ (if (exp == act)+ then "\nWARNING: strings are equal but actual values differ!"+ else ""))+ where+ withNewline s =+ case lines s of+ [] -> s+ [_] -> s+ _ -> '\n':s+ newlineBeforeDiff d =+ let f b = case colorStringFind (\c -> c == '\n') d b of+ Just _ -> "\n"+ Nothing -> ""+ in noColor' (f True) (f False)+ trim s =+ case List.splitAt maxLen s of+ (_, []) -> s+ (prefix, rest) ->+ prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)"+ maxLen = 10000++asString :: Show a => a -> Maybe String+asString x = readM (show x)++equalityFailedMessage :: (Show a) => a -> a -> ColorString+equalityFailedMessage exp act =+ equalityFailedMessage' expP actP+ where+ (expP, actP) =+ case (asString exp, asString act) of+ (Just expS, Just actS)+ | expS /= actS -> (expS, actS)+ _ ->+ case (prettyHaskell' exp, prettyHaskell' act) of+ (Nothing, _) -> (show exp, show act)+ (_, Nothing) -> (show exp, show act)+ (Just expP, Just actP)+ | expP == actP ->+ (show exp, show act)+ | otherwise -> (expP, actP)++notEqualityFailedMessage :: Show a => a -> String+notEqualityFailedMessage exp =+ notEqualityFailedMessage' (prettyHaskell exp)++notEqualityFailedMessage' :: String -> String+notEqualityFailedMessage' exp =+ (": Objects are equal\n" ++ exp)++failedAt :: HasCallStack => String+failedAt =+ case failureLocation of+ Nothing -> "failed"+ Just loc -> "failed at " ++ showLoc loc++assertEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqual_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s $+ noColor failedAt +++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualVerbose = assertEqual_ "gassertEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqual = assertEqual_ "gassertEqual" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertEqualVerbose = assertEqual_ "assertEqualVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertEqual = assertEqual_ "assertEqual" ""++assertNotEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqual_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage expected+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualVerbose = assertNotEqual_ "gassertNotEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqual = assertNotEqual_ "gassertNotEqual" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualVerbose = assertNotEqual_ "assertNotEqualVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertNotEqual = assertNotEqual_ "assertNotEqual" ""++assertEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualPretty_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)+ genericAssertFailure (mkColorMsg name s+ (noColor failedAt +++ x))+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualPrettyVerbose = assertEqualPretty_ "gassertEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualPretty = assertEqualPretty_ "gassertEqualPretty" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertEqualPrettyVerbose = assertEqualPretty_ "assertEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertEqualPretty = assertEqualPretty_ "assertEqualPretty" ""++assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualPretty_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage' (showPretty expected)+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualPrettyVerbose = assertNotEqualPretty_ "gassertNotEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualPretty = assertNotEqualPretty_ "gassertNotEqualPretty" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualPrettyVerbose = assertNotEqualPretty_ "assertNotEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertNotEqualPretty = assertNotEqualPretty_ "assertNotEqualPretty" ""++assertEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualNoShow_ name s expected actual =+ if expected /= actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualNoShowVerbose = assertEqualNoShow_ "gassertEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualNoShow = assertEqualNoShow_ "gassertEqualNoShow" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertEqualNoShowVerbose = assertEqualNoShow_ "assertEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertEqualNoShow = assertEqualNoShow_ "assertEqualNoShow" ""++assertNotEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualNoShow_ name s expected actual =+ if expected == actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualNoShowVerbose = assertNotEqualNoShow_ "gassertNotEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualNoShow = assertNotEqualNoShow_ "gassertNotEqualNoShow" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualNoShowVerbose = assertNotEqualNoShow_ "assertNotEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertNotEqualNoShow = assertNotEqualNoShow_ "assertNotEqualNoShow" ""++--+-- Assertions on Lists+--++assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> [a] -> [a] -> m ()+assertListsEqualAsSets_ name s expected actual =+ let ne = length expected+ na = length actual+ in case () of+ _| ne /= na ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s+ (noColor+ (failedAt+ ++ "\n expected length: " ++ show ne+ ++ "\n actual length: " ++ show na) ++++ (if maxLength x < 5000+ then x else emptyColorString)))+ | not (unorderedEq expected actual) ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg "assertSetEqual" s+ (noColor failedAt +++ x))+ | otherwise -> return ()+ where unorderedEq l1 l2 =+ null (l1 \\ l2) && null (l2 \\ l1)++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+gassertListsEqualAsSetsVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> [a] -> [a] -> m ()+gassertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "gassertListsEqualAsSetsVerbose"++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets.+gassertListsEqualAsSets :: (Eq a, Show a, AssertM m, HasCallStack) => [a] -> [a] -> m ()+gassertListsEqualAsSets= assertListsEqualAsSets_ "gassertListsEqualAsSets" ""++-- | Fail if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+assertListsEqualAsSetsVerbose :: (Eq a, Show a, HasCallStack) => String -> [a] -> [a] -> IO ()+assertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "assertListsEqualAsSetsVerbose"++-- | Fail if the two given lists are not equal when considered as sets.+assertListsEqualAsSets :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> IO ()+assertListsEqualAsSets = assertListsEqualAsSets_ "assertListsEqualAsSets" ""++assertNotEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertNotEmpty_ name s [] =+ genericAssertFailure (mkMsg name s failedAt)+assertNotEmpty_ _ _ (_:_) = return ()++-- | Fail in some 'AssertM' monad if the given list is empty, supplying an+-- additional error message.+gassertNotEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertNotEmptyVerbose = assertNotEmpty_ "gassertNotEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is empty.+gassertNotEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertNotEmpty = assertNotEmpty_ "gassertNotEmpty" ""++-- | Fail if the given list is empty, supplying an+-- additional error message.+assertNotEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertNotEmptyVerbose = assertNotEmpty_ "assertNotEmptyVerbose"++-- | Fail if the given list is empty.+assertNotEmpty :: HasCallStack => [a] -> IO ()+assertNotEmpty = assertNotEmpty_ "assertNotEmpty" ""++assertEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertEmpty_ name s (_:_) =+ genericAssertFailure (mkMsg name s failedAt)+assertEmpty_ _ _ [] = return ()++-- | Fail in some 'AssertM' monad if the given list is not empty, supplying an+-- additional error message.+gassertEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertEmptyVerbose = assertEmpty_ "gassertEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is not empty.+gassertEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertEmpty = assertEmpty_ "gassertEmpty" ""++-- | Fail if the given list is not empty, supplying an+-- additional error message.+assertEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertEmptyVerbose = assertEmpty_ "assertEmptyVerbose"++-- | Fail if the given list is not empty.+assertEmpty :: HasCallStack => [a] -> IO ()+assertEmpty = assertEmpty_ "assertEmpty" ""++assertElem_ :: (Eq a, Show a, AssertM m, HasCallStack) => String -> String -> a -> [a] -> m ()+assertElem_ name s x l =+ if x `elem` l+ then return ()+ else genericAssertFailure (mkMsg name s+ (failedAt +++ "\n element: " ++ show x +++ "\n list: " ++ show l))++-- | Fail in some 'AssertM' monad if the element given is not contained in the list, supplying+-- an additional error message.+gassertElemVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> [a] -> m ()+gassertElemVerbose = assertElem_ "gassertElemVerbose"++-- | Fail in some 'AssertM' monad if the element given is not contained in the list.+gassertElem :: (Eq a, Show a, AssertM m, HasCallStack) => a -> [a] -> m ()+gassertElem = assertElem_ "gassertElem" ""++-- | Fail if the element given is not contained in the list, supplying+-- an additional error message.+assertElemVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> [a] -> IO ()+assertElemVerbose = assertElem_ "assertElemVerbose"++-- | Fail if the element given is not contained in the list.+assertElem :: (Eq a, Show a, HasCallStack) => a -> [a] -> IO ()+assertElem = assertElem_ "assertElem" ""++--+-- Assertions for Exceptions+--++assertThrowsIO_ :: (HasCallStack, Exception e)+ => String -> String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIO_ name s x f =+ assertThrowsM_ name s x f++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsIOVerbose :: (HasCallStack, Exception e) => String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIOVerbose = assertThrowsIO_ "assertThrowsIOVerbose"++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsIO :: (HasCallStack, Exception e) => IO a -> (e -> Bool) -> IO ()+assertThrowsIO = assertThrowsIO_ "assertThrowsIO" ""++assertThrowsSomeIO_ :: HasCallStack => String -> String -> IO a -> IO ()+assertThrowsSomeIO_ name s x = assertThrowsIO_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the 'IO' action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeIOVerbose :: HasCallStack => String -> IO a -> IO ()+assertThrowsSomeIOVerbose = assertThrowsSomeIO_ "assertThrowsSomeIOVerbose"++-- | Fail if executing the 'IO' action does not throw any exception.+assertThrowsSomeIO :: HasCallStack => IO a -> IO ()+assertThrowsSomeIO = assertThrowsSomeIO_ "assertThrowsSomeIO" ""++assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> String -> m a -> (e -> Bool) -> m ()+assertThrowsM_ name s x f =+ do res <- ExL.try x+ case res of+ Right _ -> liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": no exception was thrown"))+ Left e -> if f e then return ()+ else liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": wrong exception was thrown: " +++ show e))+-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsMVerbose ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> m a -> (e -> Bool) -> m ()+assertThrowsMVerbose = assertThrowsM_ "assertThrowsMVerbose"++-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsM ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => m a -> (e -> Bool) -> m ()+assertThrowsM = assertThrowsM_ "assertThrowsM" ""++assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> String -> m a -> m ()+assertThrowsSomeM_ name s x = assertThrowsM_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the @m@ action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeMVerbose ::+ (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> m a -> m ()+assertThrowsSomeMVerbose = assertThrowsSomeM_ "assertThrowsSomeMVerbose"++-- | Fail if executing the @m@ action does not throw any exception.+assertThrowsSomeM :: (MonadBaseControl IO m, MonadIO m, HasCallStack) => m a -> m ()+assertThrowsSomeM = assertThrowsSomeM_ "assertThrowsSomeM" ""++assertThrows_ :: (HasCallStack, Exception e)+ => String -> String -> a -> (e -> Bool) -> IO ()+assertThrows_ name s x f = assertThrowsIO_ name s (evaluate x) f++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@,+-- supplying an additional error message.+assertThrowsVerbose :: (HasCallStack, Exception e) => String -> a -> (e -> Bool) -> IO ()+assertThrowsVerbose = assertThrows_ "assertThrowsVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@.+assertThrows :: (HasCallStack, Exception e) => a -> (e -> Bool) -> IO ()+assertThrows = assertThrows_ "assertThrows" ""++assertThrowsSome_ :: HasCallStack => String -> String -> a -> IO ()+assertThrowsSome_ name s x =+ assertThrows_ name s x (\ (_e::SomeException) -> True)++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception, supplying an additional error message.+assertThrowsSomeVerbose :: HasCallStack => String -> a -> IO ()+assertThrowsSomeVerbose = assertThrowsSome_ "assertThrowsSomeVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception.+assertThrowsSome :: HasCallStack => a -> IO ()+assertThrowsSome = assertThrowsSome_ "assertThrowsSome" ""++--+-- Assertions on Either+--++assertLeft_ :: forall a b m . (AssertM m, Show b, HasCallStack)+ => String -> String -> Either a b -> m a+assertLeft_ _ _ (Left x) = return x+assertLeft_ name s (Right x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given " +++ show (Right x :: Either b b)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeftVerbose :: (Show b, AssertM m, HasCallStack) => String -> Either a b -> m a+gassertLeftVerbose = assertLeft_ "gassertLeftVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeft :: (Show b, AssertM m, HasCallStack) => Either a b -> m a+gassertLeft = assertLeft_ "gassertLeft" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+assertLeftVerbose :: (Show b, HasCallStack) => String -> Either a b -> IO a+assertLeftVerbose = assertLeft_ "assertLeftVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+assertLeft :: (HasCallStack, Show b) => Either a b -> IO a+assertLeft = assertLeft_ "assertLeft" ""++assertLeftNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m a+assertLeftNoShow_ _ _ (Left x) = return x+assertLeftNoShow_ name s (Right _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given a Right value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m a+gassertLeftNoShowVerbose = assertLeftNoShow_ "gassertLeftNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShow :: (HasCallStack, AssertM m) => Either a b -> m a+gassertLeftNoShow = assertLeftNoShow_ "gassertLeftNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShowVerbose :: HasCallStack => String -> Either a b -> IO a+assertLeftNoShowVerbose = assertLeftNoShow_ "assertLeftNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShow :: HasCallStack => Either a b -> IO a+assertLeftNoShow = assertLeftNoShow_ "assertLeftNoShow" ""++assertRight_ :: forall a b m . (AssertM m, Show a, HasCallStack)+ => String -> String -> Either a b -> m b+assertRight_ _ _ (Right x) = return x+assertRight_ name s (Left x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given " +++ show (Left x :: Either a a)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertRightVerbose :: (Show a, AssertM m, HasCallStack) => String -> Either a b -> m b+gassertRightVerbose = assertRight_ "gassertRightVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+gassertRight :: (Show a, AssertM m, HasCallStack) => Either a b -> m b+gassertRight = assertRight_ "gassertRight" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+assertRightVerbose :: (Show a, HasCallStack) => String -> Either a b -> IO b+assertRightVerbose = assertRight_ "assertRightVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+assertRight :: (HasCallStack, Show a) => Either a b -> IO b+assertRight = assertRight_ "assertRight" ""++assertRightNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m b+assertRightNoShow_ _ _ (Right x) = return x+assertRightNoShow_ name s (Left _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given a Left value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m b+gassertRightNoShowVerbose = assertRightNoShow_ "gassertRightNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShow :: (HasCallStack, AssertM m) => Either a b -> m b+gassertRightNoShow = assertRightNoShow_ "gassertRightNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShowVerbose :: HasCallStack => String -> Either a b -> IO b+assertRightNoShowVerbose = assertRightNoShow_ "assertRightNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShow :: HasCallStack => Either a b -> IO b+assertRightNoShow = assertRightNoShow_ "assertRightNoShow" ""++--+-- Assertions on Maybe+--++assertJust_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m a+assertJust_ _ _ (Just x) = return x+assertJust_ name s Nothing =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Just value, given Nothing"))++-- | Fail in some 'AssertM' monad if the given value is a Nothing, supplying an additional+-- error message.+gassertJustVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m a+gassertJustVerbose = assertJust_ "gassertJustVerbose"++-- | Fail in some 'AssertM' monad if the given value is a Nothing.+gassertJust :: (HasCallStack, AssertM m) => Maybe a -> m a+gassertJust = assertJust_ "gassertJust" ""++-- | Fail if the given value is a Nothing, supplying an additional+-- error message.+assertJustVerbose :: HasCallStack => String -> Maybe a -> IO a+assertJustVerbose = assertJust_ "assertJustVerbose"++-- | Fail if the given value is a Nothing.+assertJust :: HasCallStack => Maybe a -> IO a+assertJust = assertJust_ "assertJust" ""++assertNothing_ :: (Show a, AssertM m, HasCallStack)+ => String -> String -> Maybe a -> m ()+assertNothing_ _ _ Nothing = return ()+assertNothing_ name s jx =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given " ++ show jx))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothingVerbose :: (Show a, AssertM m, HasCallStack) => String -> Maybe a -> m ()+gassertNothingVerbose = assertNothing_ "gassertNothingVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothing :: (Show a, AssertM m, HasCallStack) => Maybe a -> m ()+gassertNothing = assertNothing_ "gassertNothing" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+assertNothingVerbose :: (Show a, HasCallStack) => String -> Maybe a -> IO ()+assertNothingVerbose = assertNothing_ "assertNothingVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+assertNothing :: (HasCallStack, Show a) => Maybe a -> IO ()+assertNothing = assertNothing_ "assertNothing" ""++assertNothingNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m ()+assertNothingNoShow_ _ _ Nothing = return ()+assertNothingNoShow_ name s _ =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given a Just value"))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShowVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m ()+gassertNothingNoShowVerbose = assertNothingNoShow_ "gassertNothingNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShow :: (HasCallStack, AssertM m) => Maybe a -> m ()+gassertNothingNoShow = assertNothingNoShow_ "gassertNothingNoShow" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShowVerbose :: HasCallStack => String -> Maybe a -> IO ()+assertNothingNoShowVerbose = assertNothingNoShow_ "assertNothingNoShowVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShow :: HasCallStack => Maybe a -> IO ()+assertNothingNoShow = assertNothingNoShow_ "assertNothingNoShow" ""++--+-- Sub assertions+--++-- | Use 'subAssert' if you want location information for the call site but the function+-- being called does not carry a 'HasCallStack' constraint.+subAssert :: (HasCallStack, MonadBaseControl IO m) => m a -> m a+subAssert = subAssertHTF Nothing++gsubAssert :: (HasCallStack, AssertM m) => m a -> m a+gsubAssert = genericSubAssert Nothing++subAssertVerbose :: (HasCallStack, MonadBaseControl IO m) => String -> m a -> m a+subAssertVerbose msg = subAssertHTF (Just msg)++gsubAssertVerbose :: (HasCallStack, AssertM m) => String -> m a -> m a+gsubAssertVerbose msg = genericSubAssert (Just msg) testEqualityFailedMessage1 :: IO () testEqualityFailedMessage1 =
Test/Framework/History.hs view
@@ -1,6 +1,26 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--+{- |+Internal module for retaining a history of test runs.+-} module Test.Framework.History ( TestHistory, HistoricTestResult(..), emptyTestHistory, Milliseconds, TestResult(..)@@ -103,6 +123,28 @@ _CURRENT_VERSION_ :: Int _CURRENT_VERSION_ = 0 +instance ToJSON TestResult where+ toJSON r = String $+ case L.lookup r testResultStringMapping of+ Just s -> s+ Nothing -> error ("TestResult " ++ show r ++ " not defined in testResultStringMapping")++instance FromJSON TestResult where+ parseJSON v =+ case v of+ String s+ | Just r <- L.lookup s (map (\(x, y) -> (y, x)) testResultStringMapping)+ -> return r+ _ -> fail ("could not parse JSON value as a test result: " ++ show v)++testResultStringMapping :: [(TestResult, T.Text)]+testResultStringMapping =+ [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")]++deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory+deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory+ serializeTestHistory :: TestHistory -> BS.ByteString serializeTestHistory hist = let serHist = SerializableTestHistory {@@ -139,25 +181,3 @@ mkRes id ms = HistoricTestResult id Pass False ms historyTests = [("testCreateIndex", testCreateIndex)]--testResultStringMapping :: [(TestResult, T.Text)]-testResultStringMapping =- [(Pass, "pass"), (Pending, "pending"), (Fail, "fail"), (Error, "error")]--instance ToJSON TestResult where- toJSON r = String $- case L.lookup r testResultStringMapping of- Just s -> s- Nothing -> error ("TestResult " ++ show r ++ " not defined in testResultStringMapping")--instance FromJSON TestResult where- parseJSON v =- case v of- String s- | Just r <- L.lookup s (map (\(x, y) -> (y, x)) testResultStringMapping)- -> return r- _ -> fail ("could not parse JSON value as a test result: " ++ show v)--deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory-deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory-deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult
Test/Framework/JsonOutput.hs view
@@ -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
Test/Framework/Location.hs view
@@ -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. -}
Test/Framework/Preprocessor.hs view
@@ -1,11 +1,13 @@-{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PackageImports #-}-+{- |+Internal module providing access to some functionality of cpphs.+-} ----- Copyright (c) 2009-2014 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -24,7 +26,7 @@ module Test.Framework.Preprocessor ( - transform, progName, preprocessorTests+ transform, progName, preprocessorTests, TransformOptions(..) ) where @@ -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,8 +355,11 @@ boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell } -transform :: Bool -> Bool -> FilePath -> String -> IO String-transform hunitBackwardsCompat debug originalFileName input =+data TransformOptions = TransformOptions { debug :: Bool+ , literateTex :: Bool }++transform :: TransformOptions -> FilePath -> String -> IO String+transform (TransformOptions debug literateTex) originalFileName input = do (info, toks, pass1) <- analyze originalFileName fixedInput preprocess info toks pass1 where@@ -408,7 +370,7 @@ let opts = mkOptionsForModule info preProcessedInput <- runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1- return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+ return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n" -- fixedInput serves two purposes: -- 1. add a trailing \n -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'@@ -424,10 +386,11 @@ mkOptionsForModule info = defaultCpphsOptions { defines = defines defaultCpphsOptions ++- assertDefines hunitBackwardsCompat (mi_htfPrefix info) ++ nameDefines info , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell }+ possiblyWrap :: Bool -> String -> String+ possiblyWrap b s = if b then "\\begin{code}\n" ++ s ++ "\\end{code}" else s additionalCode :: ModuleInfo -> String additionalCode info = thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++
Test/Framework/Pretty.hs view
@@ -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+-- {- |
Test/Framework/PrettyHaskell.hs view
@@ -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
Test/Framework/QuickCheckWrapper.hs view
@@ -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@@ -63,9 +63,6 @@ import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef-#if MIN_VERSION_QuickCheck(2,7,0)-import System.Random-#endif import Test.QuickCheck #if !MIN_VERSION_QuickCheck(2,7,0)@@ -241,8 +238,5 @@ case readM str of Just x -> args { replay = x } Nothing ->- case readM str of- Just (_ :: Maybe (StdGen, Int)) ->- error ("Your replay parameter has been produced with QuickCheck <= 2.6. It cannot be used with QuickCheck >= 2.7")- Nothing -> error ("Could not parse replay parameter from string " ++ show str)+ error ("Could not parse replay parameter from string " ++ show str) #endif
Test/Framework/TestInterface.hs view
@@ -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)
Test/Framework/TestManager.hs view
@@ -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 }@@ -419,6 +417,8 @@ _ -> return () storeHistory file history = BS.writeFile file (serializeTestHistory history)+ `Exc.catch` (\(e::Exc.IOException) ->+ hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e)) -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,
Test/Framework/TestReporter.hs view
@@ -1,4 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {-| This module defines functions for notifying all test reporters registered about@@ -22,6 +39,7 @@ import Test.Framework.XmlOutput import System.IO+import Control.Monad import Control.Monad.RWS import Text.PrettyPrint @@ -144,7 +162,7 @@ reportTestResultHS :: ReportTestResult reportTestResultHS ftr = let res = rr_result (ft_payload ftr)- msg = attachCallStack (rr_message (ft_payload ftr)) (rr_callers (ft_payload ftr))+ msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr)) in case res of Pass -> reportMessage Debug msg okSuffix
Test/Framework/TestTypes.hs view
@@ -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
Test/Framework/ThreadPool.hs view
@@ -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@@ -53,7 +56,7 @@ parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) parallelThreadPool n =- do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+ do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) return (ThreadPool (runParallel n)) runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m ()@@ -90,7 +93,7 @@ runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () runParallel _ [] = return () runParallel n entries =- do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+ do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) fromWorker <- liftIO $ newNamedChan "fromWorker" let nWorkers = min n (length entries) toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers]
Test/Framework/Tutorial.hs view
@@ -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:++@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module MyModule (+ -- some more exports here++ htf_thisModulesTests -- all test cases are automatically collected in htf_thisModulesTests++) where++import Test.Framework++-- Each top-level definition whose name starts with 'test_' defines a unit test.+test_nonEmpty :: Assertion+test_nonEmpty = do+ assertEqual [1] (reverse [1])+ assertEqual [3,2,1] (reverse [1,2,3])+++-- Each top-level definition whose name starts with 'prop_' defines a quickcheck property.+prop_reverse :: [Int] -> Bool+prop_reverse xs = xs == (reverse (reverse xs))+@++For unit tests, see "Test.Framework.HUnitWrapper" for the assertions provided.++-}++-- ** Collecting and executing tests++{- |++Your main module collecting all tests should look like this:++@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main ( main ) where++-- Import modules defining HTF tests like this:+import {-@ HTF_TESTS @-} MyModule++main :: IO ()+main = htfMain htf_importedTests -- all tests in modules imported via {-@ HTF_TESTS @-} are available in htf_importedTests+@++Tests are then executed via @cabal test@ or @stack test@. You only need to add+the following snippet to your @.cabal@ file:++@+Test-Suite example+ Type: exitcode-stdio-1.0+ Main-is: Main.hs+ Build-depends: base, HTF+ Build-tool-depends: HTF:htfpp+ Default-language: Haskell2010+@++Several commandline options are available for HTF tests. Use+@stack test --ta --help@ or @cabal test --test-options --help@ to see the list of options.+-}+ -- * A simple example {- | +We now explain everything in more detail. Suppose you are trying to write a function for reversing lists : @@@ -54,13 +143,8 @@ prop_reverse xs = xs == (myReverse (myReverse xs)) @ -When @htfpp@ consumes the source file, it replaces the @assertEqual@-tokens (and other @assert@-like tokens, see-"Test.Framework.HUnitWrapper") with calls to-'assertEqual_', passing-the current location in the file as the first argument.-Moreover, the-preprocessor collects all top-level definitions starting with @test_@+When @htfpp@ consumes the source file, it+collects all top-level definitions starting with @test_@ or @prop_@ in a test suite of type 'TestSuite' and name @htf_@/M/@_thisModulesTests@, where /M/ is the name of the current module with dots @.@ replaced by underscores @_@. For your convenience, the preprocessor also defines the token @htf_thisModulesTests@@@ -88,10 +172,11 @@ Build-type: Simple Test-Suite tutorial- Type: exitcode-stdio-1.0- Main-is: Tutorial.hs- Build-depends: base, HTF- Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-is: Tutorial.hs+ Build-depends: base, HTF+ Build-tool-depends: HTF:htfpp+ Default-language: Haskell2010 @ Compiling the program just shown (you must include the code for@@ -273,10 +358,14 @@ -- * Machine-readable output +-- ** JSON+ {- | For better integration with your testing environment, HTF provides the ability to produce-machine-readable output in JSON format. Here is a short example how the JSON output looks like,+machine-readable output in JSON format. The output is produced incrementally, line by line.++Here is a short example how the JSON output looks like, for details see "Test.Framework.JsonOutput": @@ -308,62 +397,44 @@ -} --- * Backwards-compatibility with HUnit--{- |-The types of the various @assert@-like macros of the HTF are not backwards-compatible-with the corresponding functions of HUnit. This incompatibility is intentional, of course:-with HUnit, the programmer has to provide suitable location information by explicitly-passing a string argument to the @assert@-like functions, whereas HTF provides-location information implicitly through its pre-processor @htfpp@.--To simplify transition from HUnit to HTF, @htfpp@ provides a commandline flag-@--hunit@. This flag causes @htfpp@ to exand the assertion macros in a way compatible-with the types of the corresponding HUnit functions. For example, with the @--hunit@-flag being present, @assertEqual@ is exanded to-@'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type-@(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with-the type of HUnit's 'Test.HUnit.Base.assertEqual' function.---}---- * Summary--{- |+-- ** XML -Here is a quick summary of how to write, collect, and execute your tests.-You should also have a look at the sample project at-<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 @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ at the top of your module.--* Put @htf_thisModulesTests@ into the export list of your module.--* Import @Test.Framework@.--* Prefix your unit tests with @test_@, see "Test.Framework.HUnitWrapper" for the assertions provided.--* Prefix your QuickCheck properties with @prop_@.---}---- ** Collecting and executing tests--{- |-* Place @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ at the top of your module.--* Import @Test.Framework@.+Here is the list of commandline options for programs using @htfMain@: -* Import modules defining HTF tests with @import {-@ HTF_TESTS @-} MyPkg.A@.+@+USAGE: COMMAND [OPTION ...] PATTERN ... -* Use @main = htfMain htf_importedTests@ to run all imported tests.+ where PATTERN is a posix regular expression matching+ the names of the tests to run. + -q --quiet Only display errors.+ -n PATTERN --not=PATTERN Tests to exclude.+ -l --list List all matching tests.+ -j[N] --threads[=N] Run N tests in parallel, default N=1.+ --shuffle=BOOL Shuffle test order. Default: false+ -o FILE --output-file=FILE Name of output file.+ --json Output results in machine-readable JSON format (incremental).+ --xml=FILE Output results in junit-style XML format.+ --split Splits results in separate files to avoid file locking (requires -o/--output-file).+ --colors=BOOL Use colors or not.+ --history=FILE Path to the history file. Default: ./.HTF/<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
Test/Framework/Utils.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----- Copyright (c) 2005, 2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -119,7 +120,11 @@ (s'',ys) <- mapAccumLM f s' xs return (s'',y:ys) +#if !(MIN_VERSION_base(4,13,0)) readM :: (Monad m, Read a) => String -> m a+#else+readM :: (MonadFail m, Read a) => String -> m a+#endif readM s | [x] <- parse = return x | otherwise = fail $ "Failed parse: " ++ show s where
Test/Framework/XmlOutput.hs view
@@ -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 =
sample/sample-HTF.cabal view
@@ -14,12 +14,14 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B- build-depends: base == 4.*, HTF == 0.13.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B- build-depends: base == 4.*, HTF == 0.13.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp
scripts/check.sh view
@@ -14,20 +14,27 @@ exit 1 fi -YAMLS=$(grep '^- HTF_TRAVIS_STACK_ARGS' "$TRAVIS" | sed 's/^.*="--stack-yaml //g; s/"$//g')+YAMLS=$(grep '^- HTF_TEST_STACK_ARGS' "$TRAVIS" | sed 's/^.*="--stack-yaml //g; s/"$//g') if [ -z "$TRAVIS_BUILD_DIR" ]; then export TRAVIS_BUILD_DIR="$TOP" fi for yaml in $YAMLS; do+ echo >&2 eval yaml="$yaml" # evaluate variables contained in $yaml echo >&2 "Checking with $yaml ..."- export HTF_TRAVIS_STACK_ARGS="--stack-yaml $yaml"- stack $HTF_TRAVIS_STACK_ARGS test+ export HTF_TEST_STACK_ARGS="--stack-yaml $yaml"+ stack $HTF_TEST_STACK_ARGS build ecode=$? if [ $ecode -ne 0 ]; then- echo >&2 "Check for $yaml failed!"+ echo >&2 "Build for $yaml failed!"+ exit 1+ fi+ stack $HTF_TEST_STACK_ARGS test+ ecode=$?+ if [ $ecode -ne 0 ]; then+ echo >&2 "Test for $yaml failed!" exit 1 fi done
scripts/local-htfpp view
@@ -1,8 +1,15 @@ #!/bin/bash -DEBUG=no TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)-dist=$(stack $HTF_TRAVIS_STACK_ARGS path --dist-dir 2> /dev/null)++if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_TEST_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_TEST_STACK_YAML"+fi+if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_STACK_YAML"+fi++dist=$(stack $HTF_TEST_STACK_ARGS path --dist-dir 2> /dev/null) find=find if [ "$(uname)" == "Darwin" ]; then find=gfind@@ -10,27 +17,20 @@ function find_bin() {- bin=$($find "$TOP/$dist" -name htfpp -type f -executable -printf "%T+\t%p\n" | sort -r | head -1 | gawk '{print $2}')+ local d="$TOP/$dist"+ if [ ! -d "$d" ]; then+ d="$(dirname $d)"+ fi+ bin=$($find "$d" -name htfpp -type f -executable -printf "%T+\t%p\n" | sort -r | head -1 | cut -f 2) } find_bin -if [ "$DEBUG" == "yes" ]; then+if [ -z "$bin" ]; then echo "TOP=$TOP" >&2 echo "dist=$dist" >&2 echo "bin=$bin" >&2-fi--if [ -z "$bin" ]; then- echo "No executable named htfpp found in $TOP/$dist, trying to build it" >&2- stack $HTF_TRAVIS_STACK_ARGS build 2> /dev/null > /dev/null- find_bin- if [ -z "$bin" ]; then- echo "Still no executable named htfpp found in $TOP/$dist (even after trying to build it)" >&2- echo "TOP=$TOP" >&2- echo "dist=$dist" >&2- find "$TOP/$dist" -type f >&2- exit 1- fi+ echo "No executable named htfpp found in $TOP/$dist. Aborting!" >&2+ exit 1 fi "$bin" "$@"
+ scripts/prepare view
@@ -0,0 +1,6 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+echo "Preparing everything for building ..."+chmod 755 "$TOP/scripts/local-htfpp"+echo "Done with preparing!"
− stack-ghc-7.10.yaml
@@ -1,5 +0,0 @@-resolver: lts-6.35-flags: {}-packages:-- '.'-extra-deps: []
− stack-ghc-8.0.yaml
@@ -1,5 +0,0 @@-resolver: lts-9.21-flags: {}-packages:-- '.'-extra-deps: []
+ stack-ghc-8.10.yaml view
@@ -0,0 +1,4 @@+resolver: lts-18.28+flags: {}+packages:+- '.'
stack-ghc-8.4.yaml view
@@ -1,4 +1,4 @@-resolver: lts-12.17+resolver: lts-12.26 flags: {} packages: - '.'
stack-ghc-8.6.yaml view
@@ -1,4 +1,4 @@-resolver: nightly-2018-11-06+resolver: lts-14.27 flags: {} packages: - '.'
+ stack-ghc-8.8.yaml view
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
+ stack-ghc-9.0.yaml view
@@ -0,0 +1,4 @@+resolver: lts-19.33+flags: {}+packages:+- '.'
+ stack-ghc-9.2.yaml view
@@ -0,0 +1,4 @@+resolver: lts-20.12+flags: {}+packages:+- '.'
+ stack-ghc-9.4.yaml view
@@ -0,0 +1,4 @@+resolver: lts-21.25+flags: {}+packages:+- '.'
stack.yaml view
@@ -1,6 +1,6 @@-resolver: lts-12.17+resolver: lts-16.31 flags: {} packages: - '.' extra-deps:-- haskell-src-1.0.3.0+- haskell-src-1.0.3.1
tests/Foo/B.hs view
@@ -4,4 +4,4 @@ import qualified Test.Framework as HTF -test_b_OK = assertEqual 1 1+test_b_OK = HTF.assertEqual 1 1
tests/TestHTF.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} -- -- Copyright (c) 2005,2010 Stefan Wehr - http://www.stefanwehr.de@@ -28,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@@ -38,7 +40,12 @@ import System.IO.Temp import Control.Exception import Control.Monad-import qualified Data.HashMap.Strict as M++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif import qualified Data.HashSet as Set import qualified Data.Aeson as J import qualified Data.Aeson.Encode.Pretty as J@@ -51,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 @@ -145,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)) @@ -156,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" @@ -176,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]@@ -198,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"@@ -213,6 +249,8 @@ ,"assertThrowsIO1_FAIL" ,"assertThrows_FAIL" ,"diff_FAIL"+ ,"diff2_FAIL"+ ,"diff3_FAIL" ,"error'_FAIL" ,"error_FAIL" ,"exhaust_FAIL"@@ -239,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"@@ -278,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)]]@@ -291,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 = 32+ lineOffset = 40 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null@@ -312,11 +357,11 @@ ,"wallTime":11} -} case json of- J.Object objJson | Just (J.Object testObj) <- M.lookup "test" objJson- , Just (J.String flatName) <- M.lookup "flatName" testObj- , Just (J.String "test-end") <- M.lookup "type" objJson- , Just (J.String result) <- M.lookup "result" objJson- , Just (J.Bool to) <- M.lookup "timedOut" objJson ->+ J.Object objJson | Just (J.Object testObj) <- KM.lookup "test" objJson+ , Just (J.String flatName) <- KM.lookup "flatName" testObj+ , Just (J.String "test-end") <- KM.lookup "type" objJson+ , Just (J.String result) <- KM.lookup "result" objJson+ , Just (J.Bool to) <- KM.lookup "timedOut" objJson -> let shortName = let t = T.tail (T.dropWhile (/= ':') flatName) in if "tests/" `T.isPrefixOf` t@@ -353,20 +398,24 @@ matches json pred = case (json, pred) of (J.Object objJson, J.Object objPred) ->- M.foldrWithKey (\k vPred b ->- b && case M.lookup k objJson of+ KM.foldrWithKey (\k vPred b ->+ b && case KM.lookup k objJson of Just vJson -> matches vJson vPred Nothing -> False) True objPred (J.String strJson, J.String strPred) ->- regexMatches (mkRegex strPred) strJson+ regexMatches strPred strJson (arrJson@(J.Array _), arrPred@(J.Array _)) -> let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson J.Success (listPred :: [J.Value]) = J.fromJSON arrPred in length listJson == length listPred && all (\(x, y) -> matches x y) (zip listJson listPred) _ -> json == pred- regexMatches r s = isJust $ R.matchRegex r (T.unpack s)+ regexMatches pred t =+ let s = T.unpack t+ in case T.unpack pred of+ 'N':'O':'T':':':rest -> isNothing $ R.matchRegex (mkRegex (T.pack rest)) s+ _ -> isJust $ R.matchRegex (mkRegex pred) s mkRegex s = R.mkRegexWithOpts (T.unpack s) True False splitJson bsl = if BSL.null bsl@@ -431,5 +480,3 @@ `onException` (do s <- readFile outFile hPutStrLn stderr s) runRealBlackBoxTests- ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")- exitWith ecode
− tests/TestHTFHunitBackwardsCompatible.hs
@@ -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)
tests/compile-errors/run-tests.sh view
@@ -6,18 +6,23 @@ function check() { test="$1"+ echo "Running test $test ..." command -v grep >/dev/null 2>&1 || \ { echo >&2 "Test $0 requires ``grep'' but it's not installed. Aborting."; exit 1; }- compile_cmd="stack $HTF_TRAVIS_STACK_ARGS ghc -- -XPackageImports $test"- $compile_cmd 2>&1 | grep "$test":$lineno+ compile_cmd="stack $HTF_TEST_STACK_ARGS ghc --package HTF -- -XPackageImports $test"+ $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null grep_ecode=${PIPESTATUS[1]} if [ "$grep_ecode" != "0" ] then echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"+ echo "Compile command: $compile_cmd"+ echo "Stack version: $(stack --version)"+ echo "GHC version: $(stack $HTF_TEST_STACK_ARGS ghc -- --version)" echo "Here is the output of the compiler:" $compile_cmd exit 1 fi+ echo "Done with test $test" } check Test1.hs