HTF 0.12.2.4 → 0.15.0.2
raw patch · 68 files changed
Files
- ChangeLog +53/−0
- HTF.cabal +92/−106
- HTFPP.hs +8/−8
- README.md +13/−22
- Setup.hs +0/−5
- TODO.org +0/−11
- Test/Framework.hs +7/−4
- Test/Framework/AssertM.hs +40/−40
- Test/Framework/BlackBoxTest.hs +1/−1
- Test/Framework/CmdlineOptions.hs +25/−11
- Test/Framework/Colors.hs +4/−1
- Test/Framework/Diff.hs +66/−14
- Test/Framework/HUnitWrapper.hs +912/−591
- Test/Framework/HaskellParser.hs +0/−202
- Test/Framework/History.hs +42/−22
- Test/Framework/JsonOutput.hs +26/−9
- Test/Framework/Location.hs +2/−2
- Test/Framework/Preprocessor.hs +126/−249
- Test/Framework/Pretty.hs +23/−1
- Test/Framework/PrettyHaskell.hs +20/−0
- Test/Framework/QuickCheckWrapper.hs +29/−19
- Test/Framework/TestInterface.hs +100/−15
- Test/Framework/TestManager.hs +83/−34
- Test/Framework/TestReporter.hs +19/−1
- Test/Framework/TestTypes.hs +28/−13
- Test/Framework/ThreadPool.hs +12/−37
- Test/Framework/Tutorial.hs +139/−69
- Test/Framework/Utils.hs +6/−1
- Test/Framework/XmlOutput.hs +61/−11
- run-all-tests-for-all-compilers.sh +0/−40
- run-all-tests.sh +0/−31
- sample/TestMain.hs +1/−1
- sample/sample-HTF.cabal +5/−2
- scripts/check.sh +40/−0
- scripts/dist.sh +50/−0
- scripts/local-htfpp +36/−0
- scripts/prepare +6/−0
- scripts/run-sample +3/−0
- stack-ghc-8.10.yaml +4/−0
- stack-ghc-8.2.yaml +5/−0
- stack-ghc-8.4.yaml +6/−0
- stack-ghc-8.6.yaml +6/−0
- 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 +6/−0
- tests/Foo/A.hs +1/−1
- tests/Foo/B.hs +2/−2
- tests/MiscTest.hs +2/−1
- tests/Quasi.hs +11/−0
- tests/TestHTF.hs +105/−37
- tests/TestHTFHunitBackwardsCompatible.hs +0/−10
- tests/ThreadPoolTest.hs +0/−1
- tests/Tutorial.hs +1/−1
- tests/compile-errors/Test1.hs +2/−2
- tests/compile-errors/Test2.hs +2/−2
- tests/compile-errors/Test3.hs +2/−2
- tests/compile-errors/Test4.hs +2/−2
- tests/compile-errors/run-tests.sh +11/−16
- tests/real-bbt/FailFast.hs +1/−1
- tests/real-bbt/MaxCurTime.hs +1/−1
- tests/real-bbt/MaxPrevTime.hs +1/−1
- tests/real-bbt/PrevFactor.hs +1/−1
- tests/real-bbt/Repeat.hs +23/−0
- tests/real-bbt/SortByPrevTime.hs +1/−1
- tests/real-bbt/UniqTests1.hs +1/−1
- tests/real-bbt/UniqTests2.hs +1/−1
ChangeLog view
@@ -1,3 +1,56 @@+* 0.15.0.1+ - Fix build for mtl-2.3 #118++* 0.15.0.0+ - Remove macros for assertions, location information is now provided+ via HasCallStack. For most users, this change should be backwards compatible.+ However, if you imported Test.Framework qualified, then all assert macros+ where previously in scope unqualified, through macros. In this case, you need to+ import Test.Framework unqualified or qualify all uses of assert macros.+ - The modules Test.Framework.CmdlineOptions, Test.Framework.Colors,+ and Test.Framework.TestReporter are no longer exposed. I don't think that+ anyone depends on these internal modules. Let me know I am wrong.++* 0.14.0.7 (2022-03-03)+ - several upper bounds for packages+ - minor improvements++* 0.14.0.5 (2021-01-26)+ - make sure htfpp is available before running the tests++* 0.14.0.4 (2021-01-26)+ - fix #99+ - hopefully fix #97++* 0.14.0.2 (2019-11-27)+ - use haskell-src from hackage++* 0.14.0.1 (2019-11-27)+ - find cpphs++* 0.14.0.0 (2019-11-26)+ - support for GHC 8.8+ - fix for performance problem with long strings+ https://github.com/skogsbaer/HTF/issues/85++* 0.13.2.5 (2018-11-06)+ - fix build problem with quickcheck:+ https://github.com/skogsbaer/HTF/issues/70+ - fix some compiler warnings+ - support for GHC 8.6++* 0.13.2.4 (2018-03-31)+ - fix build for ghc 8.4++* 0.13.2.{0,1,2} (2017-08-06)+ - various build and documentation fixes and improvements++* 0.13.1.0 (2015-08-21)+ - resolved compile error with HUnit == 1.3.0.0++* 0.13.0.0 (2015-08-21)+ - use cpphs for lexing (fixes many bugs related to lexing)+ * 0.12.2.4 (2015-03-22) - fixed bug that caused double quoted strings to appear in the output of error messages produced by assertEqual and co.
HTF.cabal view
@@ -1,10 +1,11 @@+Cabal-Version: 2.0 Name: HTF-Version: 0.12.2.4-License: LGPL+Version: 0.15.0.2+License: LGPL-2.1 License-File: LICENSE-Copyright: (c) 2005-2014 Stefan Wehr-Author: Stefan Wehr <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,85 +13,42 @@ 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 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.-- .-- /HEADS UP, backwards incomatibility with prior versions:/-- .-- In version 0.10.0.0, the following changes could break code compiled against version 0.9.*:-- .-- * "Test.Framework" now longer exports all of "Test.Framework.TestManager" and- "Test.Framework.BlackBoxTest". For modules that only define tests, no changes- should be necessary. However, you likely need to adjust your test runner- module by importing "Test.Framework.TestManager" and possibly "Test.Framework.BlackBoxTest".-- .-- * Some reorganization in "Test.Framework.TestManager" and related modules, introduction- of "Test.Framework.TestTypes". Usually, your code should not be affected- by these changes.-- .- Starting with version 0.9.0.0, HTF uses a new strategy- for collecting the testcases defined in your project- (see "Test.Framework.Tutorial" for a description of this strategy).- If you used version 0.8.* or earlier of HTF, this /will break your build!/- However, it's rather easy to bring you project in line with the new HTF- version. Here are the steps that will most likely resolve- your backwards incompatibility problems:-- .-- * If a module exports the @allHTFTests@ symbol, this export must- be changed to @htf_thisModulesTests@.+ The Haskell Test Framework (/HTF/ for short) lets you define and organize unit tests,+ QuickCheck properties,+ and black box tests in an+ easy and convenient way. HTF uses a custom preprocessor that collects+ test definitions automatically. . - * If an import declaration of some module hides the @allHTFTests@- symbol, you can simply remove the hiding clause for @allHTFTests@.+ HTF produces highly readable output+ for failing test cases: it provides exact file name and line number+ information,+ it colors and pretty prints expected and+ actual results, and it displays a diff highlighting the mismatching parts. . - * If a module collects and executes tests from several other modules,- the collecting module has to be changed as follows: add- @{-# OPTIONS_GHC -F -pgmF htfpp #-}@ to the top- of the collecting module, import- the other modules with the @{-@ HTF_TESTS @-}@- annotation, use the symbol @htf_importedTests@ for referencing- the imported tests. See "Test.Framework.Tutorial" for details.+ The documentation of the "Test.Framework.Tutorial" module+ provides a tutorial for HTF. The /sample/ directory in+ the HTF repo provides a good starting point for+ a project using HTF. -Tested-With:- GHC==7.6.2,- GHC==7.8.2 Build-Type: Simple-Cabal-Version: >= 1.10+ Extra-Source-Files: README.md- TODO.org ChangeLog+ stack.yaml+ stack-ghc-8.2.yaml+ stack-ghc-8.4.yaml+ stack-ghc-8.6.yaml+ stack-ghc-8.8.yaml+ stack-ghc-8.10.yaml+ stack-ghc-9.0.yaml+ stack-ghc-9.2.yaml+ stack-ghc-9.4.yaml tests/bbt/should_fail/BBTArgs- -- tests/bbt/should_fail/*.in tests/bbt/should_fail/*.err tests/bbt/should_fail/*.out tests/bbt/should_fail/*.x@@ -125,8 +83,22 @@ sample/bbt-dir/should-fail/z.num sample/bbt-dir/should-pass/x.num sample/bbt-dir/should-pass/x.out- run-all-tests-for-all-compilers.sh- run-all-tests.sh+ scripts/local-htfpp+ scripts/dist.sh+ scripts/check.sh+ scripts/run-sample+ scripts/prepare++tested-with:+ GHC == 9.4.4+ GHC == 9.2.6+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ Source-Repository head Type: git Location: http://github.com/skogsbaer/HTF.git@@ -135,33 +107,36 @@ Main-Is: HTFPP.hs Build-Depends: HUnit, array,- base == 4.*,- cpphs >= 1.12,+ base >= 4.10 && < 5,+ cpphs >= 1.19, directory >= 1.0,- haskell-lexer, mtl >= 1.1, old-time >= 1.0, random >= 1.0,- text+ text >= 0.11,+ HTF+ Build-tool-depends: cpphs:cpphs >= 1.19 Other-Modules:+ Paths_HTF+ Test.Framework.Location Test.Framework.Preprocessor- Test.Framework.HaskellParser+ Autogen-modules:+ Paths_HTF Default-language: Haskell2010 Library Build-Depends: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3,- aeson >= 0.6,+ aeson >= 0.11, array,- base == 4.*,+ base >= 4.10 && < 5, base64-bytestring, bytestring >= 0.9, containers >= 0.5,- cpphs >= 1.12,- directory >= 1.0,- haskell-lexer,+ cpphs >= 1.19, haskell-src,+ directory >= 1.0, lifted-base >= 0.1, monad-control >= 0.3, mtl >= 1.1,@@ -178,31 +153,37 @@ Build-Depends: unix >= 2.4 Exposed-Modules: Test.Framework+ Test.Framework.AssertM+ Test.Framework.BlackBoxTest Test.Framework.HUnitWrapper- Test.Framework.TestManager- Test.Framework.TestInterface- Test.Framework.TestTypes- Test.Framework.TestReporter Test.Framework.History- Test.Framework.CmdlineOptions- Test.Framework.QuickCheckWrapper- Test.Framework.BlackBoxTest+ Test.Framework.JsonOutput Test.Framework.Location- Test.Framework.Tutorial+ Test.Framework.Preprocessor Test.Framework.Pretty- Test.Framework.JsonOutput- Test.Framework.XmlOutput- Test.Framework.ThreadPool- Test.Framework.AssertM- Test.Framework.Colors Test.Framework.PrettyHaskell- Test.Framework.Preprocessor+ Test.Framework.QuickCheckWrapper+ Test.Framework.TestInterface+ Test.Framework.TestManager+ Test.Framework.TestTypes+ Test.Framework.ThreadPool+ Test.Framework.Tutorial+ Test.Framework.XmlOutput Other-Modules:- Test.Framework.Utils+ Paths_HTF+ Test.Framework.CmdlineOptions+ Test.Framework.Colors Test.Framework.Diff Test.Framework.Process+ Test.Framework.TestReporter+ Test.Framework.Utils+ Autogen-modules:+ Paths_HTF+ Build-tool-depends: cpphs:cpphs >= 1.19 Default-language: Haskell2010- Ghc-Options: -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+ Ghc-Options:+ -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind+ -Wcompat Test-Suite MiscTests Main-is: MiscTest.hs@@ -210,9 +191,10 @@ Hs-Source-Dirs: tests Build-depends: HTF, HUnit,- base == 4.*,+ base >= 4.10 && < 5, mtl, random+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Test-Suite TestHTF@@ -220,29 +202,33 @@ Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0 Build-depends: HTF,- aeson >= 0.6,+ aeson >= 0.11, aeson-pretty,- base == 4.*,+ base >= 4.10 && < 5, bytestring >= 0.9, directory >= 1.0, filepath >= 1.1, process >= 1.0, random, regex-compat >= 0.92,+ template-haskell, temporary >= 1.1, text >= 0.11, unordered-containers >= 0.2+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010 Other-Modules:- Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime,- MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2+ Foo.A, Foo.B, FailFast, MaxCurTime,+ MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2, Quasi,+ Tutorial, Repeat Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests Build-depends: HTF,- base == 4.*,+ base >= 4.10 && < 5, mtl, random+ Build-tool-depends: HTF:htfpp Default-language: Haskell2010
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,36 +1,27 @@ # HTF - The Haskell Test Framework +[](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-(http://hunit.sourceforge.net), QuickCheck properties-(http://www.cs.chalmers.se/~rjmh/QuickCheck/), and black box tests in an+The Haskell Test Framework (HTF for short) lets you define and organize unit tests+(http://hackage.haskell.org/package/HUnit), QuickCheck properties+(https://hackage.haskell.org/package/QuickCheck), and black box tests in an easy and convenient way. HTF uses a custom preprocessor that collects-test definitions automatically. Furthermore, the preprocessor allows-HTF to report failing test cases with exact file name and line number-information. Additionally, HTF tries to produce highly readable output-for failing tests: for example, it colors and pretty prints expected and-actual results and provides a diff between the two values.--Look [here](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html)-for a short tutorial on HTF. The following slightly out-dated-[blog article](http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html)-demonstrates HTF's coloring, pretty-printing and diff functionality.--## Installation instructions--* Install from http://hackage.haskell.org/ using `cabal install HTF`-* Install from source:+test definitions automatically. - $ git clone git@github.com:skogsbaer/HTF.git- $ cd HTF- $ cabal install+HTF produces highly readable output+for failing test cases: it provides exact file name and line number+information,+it colors and pretty prints expected and+actual results, and it displays a diff highlighting the mismatching parts. ## Getting started
− 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,9 +21,11 @@ Top-level module that re-exports functionality from sub-modules. Modules that only define unit tests and quickcheck properties typically only need to import this module.-Your test driver should additionally import 'Test.Framework.TestManager' and,+Test drivers should additionally import 'Test.Framework.TestManager' and, if needed, 'Test.Framework.BlackBoxTest'. +See "Test.Framework.Tutorial" for a description how to use HTF.+ -} module Test.Framework ( @@ -37,7 +39,8 @@ module Test.Framework.AssertM, -- * Organizing tests- TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc+ TM.makeTestSuite, TM.TestSuite, TM.htfMain, TM.htfMainWithArgs, Loc.makeLoc, TM.runTest,+ TM.WrappableHTF(..) ) where
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@@ -89,8 +89,9 @@ , opts_sortByPrevTime :: Bool -- ^ Sort tests by their previous run times (ascending). Default: 'False' , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run. , opts_maxCurTimeMs :: Maybe Milliseconds -- ^ Abort tests that run more than the given milliseconds.- , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previosu run.+ , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run. , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error.+ , opts_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } {- |@@ -117,6 +118,7 @@ , opts_maxCurTimeMs = Nothing , opts_prevFactor = Nothing , opts_timeoutIsSuccess = False+ , opts_repeat = 1 } processorCount :: Int@@ -140,9 +142,9 @@ , Option ['j'] ["threads"] (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N") ("Run N tests in parallel, default N=" ++ show processorCount ++ ".")- , Option [] ["deterministic"]- (NoArg (\o -> Right $ o { opts_shuffle = False }))- "Do not shuffle tests when executing them in parallel."+ , Option [] ["shuffle"]+ (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL")+ "Shuffle test order. Default: false" , Option ['o'] ["output-file"] (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE") "Name of output file."@@ -181,6 +183,10 @@ , Option [] ["timeout-is-success"] (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True })) "Do not regard a test timeout as an error."+ , Option [] ["repeat"]+ (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) ->+ Right $ o { opts_repeat = i}) "NUMBER")+ "Execute the tests selected on the command line NUMBER times." , Option ['h'] ["help"] (NoArg (\o -> Right $ o { opts_help = True })) "Display this message."@@ -213,7 +219,7 @@ > -n PATTERN --not=PATTERN Tests to exclude. > -l --list List all matching tests. > -j[N] --threads[=N] Run N tests in parallel, default N=1.-> --deterministic Do not shuffle tests when executing them in parallel.+> --shuffle=BOOL Shuffle test order. Default: false > -o FILE --output-file=FILE Name of output file. > --json Output results in machine-readable JSON format (incremental). > --xml=FILE Output results in junit-style XML format.@@ -235,6 +241,10 @@ case getOpt Permute optionDescriptions args of (optTrans, tests, []) -> do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans+ when (opts_shuffle opts && opts_sortByPrevTime opts) $+ Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " +++ "Can only use one of both.\n\n" +++ usageInfo usageHeader optionDescriptions) case (opts_outputFile opts, opts_split opts) of (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++ usageInfo usageHeader optionDescriptions)@@ -297,6 +307,7 @@ , tc_maxSingleTestTime = opts_maxCurTimeMs opts , tc_prevFactor = opts_prevFactor opts , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts+ , tc_repeat = opts_repeat opts } where #ifdef mingw32_HOST_OS@@ -336,9 +347,12 @@ case opts_historyFile opts of Just fp -> return fp Nothing ->- do x <- getProgName- createDirectoryIfMissing False ".HTF"- return (".HTF/" ++ x ++ ".history")+ do progName <- getProgName+ let x = if progName == "<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@@ -347,10 +361,10 @@ case deserializeTestHistory bs of Right history -> return history Left err ->- do hPutStrLn stderr ("Error deserializing content of history file " ++ fp ++ ": " ++ err)+ do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err) return emptyTestHistory `catch` (\(e::IOException) ->- do hPutStrLn stderr ("Error reading history file " ++ fp ++ ": " ++ show e)+ do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e) return emptyTestHistory) mergeFilters f1 f2 t = f1 t && f2 t
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,594 +1,915 @@-{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}------- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----{-|--This module provides assert-like functions for writing unit tests.--/Hint:/ Do not use the @assertXXX_@ functions-directly. Instead, for each function @assertXXX_@,-there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically. Use these macros, which-are available automatically if you add--@{-# OPTIONS_GHC -F -pgmF htfpp #-}@--at the top of your source file (see the 'Test.Framework.Tutorial').---}--module Test.Framework.HUnitWrapper (-- -- * Assertions on Bool values- assertBool_, assertBoolVerbose_,- gassertBool_, gassertBoolVerbose_,-- -- * Equality assertions- assertEqual_, assertEqualVerbose_,- gassertEqual_, gassertEqualVerbose_,- assertEqualPretty_, assertEqualPrettyVerbose_,- gassertEqualPretty_, gassertEqualPrettyVerbose_,- assertEqualNoShow_, assertEqualNoShowVerbose_,- gassertEqualNoShow_, gassertEqualNoShowVerbose_,- assertNotEqual_, assertNotEqualVerbose_,- gassertNotEqual_, gassertNotEqualVerbose_,- assertNotEqualPretty_, assertNotEqualPrettyVerbose_,- gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_,- assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,- gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_,-- -- * Assertions on lists- assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,- gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_,- assertNotEmpty_, assertNotEmptyVerbose_,- gassertNotEmpty_, gassertNotEmptyVerbose_,- assertEmpty_, assertEmptyVerbose_,- gassertEmpty_, gassertEmptyVerbose_,- assertElem_, assertElemVerbose_,- gassertElem_, gassertElemVerbose_,-- -- * Assertions for exceptions- assertThrows_, assertThrowsVerbose_,- assertThrowsSome_, assertThrowsSomeVerbose_,- assertThrowsIO_, assertThrowsIOVerbose_,- assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,- assertThrowsM_, assertThrowsMVerbose_,- assertThrowsSomeM_, assertThrowsSomeMVerbose_,-- -- * Assertions on Either values- assertLeft_, assertLeftVerbose_,- gassertLeft_, gassertLeftVerbose_,- assertLeftNoShow_, assertLeftNoShowVerbose_,- gassertLeftNoShow_, gassertLeftNoShowVerbose_,- assertRight_, assertRightVerbose_,- gassertRight_, gassertRightVerbose_,- assertRightNoShow_, assertRightNoShowVerbose_,- gassertRightNoShow_, gassertRightNoShowVerbose_,-- -- * Assertions on Just values- assertJust_, assertJustVerbose_,- gassertJust_, gassertJustVerbose_,- assertNothing_, assertNothingVerbose_,- gassertNothing_, gassertNothingVerbose_,- assertNothingNoShow_, assertNothingNoShowVerbose_,- gassertNothingNoShow_, gassertNothingNoShowVerbose_,-- -- * General failure- assertFailure_,- gassertFailure_,-- -- * Pending unit tests- unitTestPending, unitTestPending',-- -- * Sub assertions- subAssert_, subAssertVerbose_,- gsubAssert_, gsubAssertVerbose_,-- -- * HUnit re-exports- HU.HUnitFailure,-- -- * Tests (for internal use)- hunitWrapperTests--) where--import Control.Exception-import qualified Control.Exception.Lifted as ExL-import Control.Monad.Trans.Control-import Control.Monad.Trans-import qualified Test.HUnit.Lang as HU-import qualified Test.HUnit.Base as HU--import Data.List ( (\\) )-import System.IO.Unsafe (unsafePerformIO)--import Test.Framework.TestInterface-import Test.Framework.Location-import Test.Framework.Diff-import Test.Framework.Colors-import Test.Framework.Pretty-import Test.Framework.AssertM-import Test.Framework.PrettyHaskell--import qualified Data.Text as T---- WARNING: do not forget to add a preprocessor macro for new assertions!!--{- |-Fail with the given reason, supplying the error location and the error message.--}-gassertFailure_ :: AssertM m => Location -> String -> m a-gassertFailure_ loc s =- genericAssertFailure__ loc (mkMsg "assertFailure" ""- ("failed at " ++ showLoc loc ++ ": " ++ s))---- | Specialization of 'gassertFailure'.-assertFailure_ :: Location -> String -> IO a-assertFailure_ = gassertFailure_--{- |-Signals that the current unit test is pending.--}-unitTestPending :: String -> IO a-unitTestPending s =- failHTF (FullTestResult Nothing [] (Just $ noColor s) (Just Pending))--{- |-Use @unitTestPending' msg test@ to mark the given test as pending-without removing it from the test suite and without deleting or commenting out the test code.--}-unitTestPending' :: String -> IO a -> IO a-unitTestPending' msg _ = unitTestPending msg--mkMsg :: String -> String -> String -> ColorString-mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)--mkColorMsg :: String -> String -> ColorString -> ColorString-mkColorMsg fun extraInfo s =- let pref = if null extraInfo- then fun ++ " "- else fun ++ " (" ++ extraInfo ++ ") "- in noColor pref +++ s------- Dirty macro hackery (I'm too lazy ...)----#define CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, __ret__) \-__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \-__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \-__name__##_ loc = _##__name__##_ #__name__ loc ""-#define CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \-g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \-g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \-g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \-g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \-CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__)--#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ())-#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ())--#define CreateAssertions(__name__, __type__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ())-#define CreateAssertionsNoGVariant(__name__, __type__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ())--#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__)-#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__)--#define CreateAssertionsRet(__name__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__)-#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \-CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __ret__)--#define DocAssertion(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variants can be used to provide extra information about the error. The \- variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \- they run in the IO monad and can be evaluated to a 'Bool' value. \- Do not use the \- @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \- functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \- @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}-#define DocAssertionNoGVariant(__name__, __text__) \- {- | __text__ The 'String' parameter in the @Verbose@ \- variant can be used to provide extra information about the error. \- Do not use the \- @__name__##_@ and @__name__##Verbose_@ \- functions directly, use the macros @__name__@ and @__name__##Verbose@ \- instead. These macros, provided by the @htfpp@ preprocessor, \- insert the 'Location' parameter automatically. -}------ Boolean Assertions-----_assertBool_ :: AssertM m => String -> Location -> String -> Bool -> m ()-_assertBool_ name loc s False =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertBool_ _ _ _ True = return ()--DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)-CreateAssertions(assertBool, Bool)------- Equality Assertions-----equalityFailedMessage' :: String -> String -> ColorString-equalityFailedMessage' exp act =- let !diff = unsafePerformIO (diffWithSensibleConfig exp act)- expected_ = colorize firstDiffColor "* expected:"- but_got_ = colorize secondDiffColor "* but got:"- diff_ = colorize diffColor "* diff:"- in ("\n" +++ expected_ +++ " " +++ noColor (withNewline exp) +++- "\n" +++ but_got_ +++ " " +++ noColor (withNewline act) +++- "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff +++- (if (exp == act)- then "\nWARNING: strings are equal but actual values differ!"- else ""))- where- withNewline s =- case lines s of- [] -> s- [_] -> s- _ -> '\n':s- newlineBeforeDiff d =- let f b = case colorStringFind (\c -> c == '\n') d b of- Just _ -> "\n"- Nothing -> ""- in noColor' (f True) (f False)--equalityFailedMessage :: (Show a) => a -> a -> ColorString-equalityFailedMessage exp act =- equalityFailedMessage' expP actP- where- (expP, actP) =- case (prettyHaskell' exp, prettyHaskell' act) of- (Nothing, _) -> (show exp, show act)- (_, Nothing) -> (show exp, show act)- (Just expP, Just actP)- | expP == actP ->- (show exp, show act)- | otherwise -> (expP, actP)--notEqualityFailedMessage :: Show a => a -> String-notEqualityFailedMessage exp =- notEqualityFailedMessage' (prettyHaskell exp)--notEqualityFailedMessage' :: String -> String-notEqualityFailedMessage' exp =- (": Objects are equal\n" ++ exp)--_assertEqual_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqual_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg name s $- noColor ("failed at " ++ showLoc loc) +++ x)- else return ()--DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertNotEqual_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqual_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage expected- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()--DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Show' but not of 'Pretty'.)-CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a)--_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualPretty_ name loc s expected actual =- if expected /= actual- then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)- genericAssertFailure__ loc (mkColorMsg name s- (noColor ("failed at " ++ showLoc loc) +++ x))- else return ()--DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualPretty_ name loc s expected actual =- if expected == actual- then do let x = notEqualityFailedMessage' (showPretty expected)- genericAssertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)- else return ()-DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is an instance of 'Pretty'.)-CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a)--_assertEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertEqualNoShow_ name loc s expected actual =- if expected /= actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)--_assertNotEqualNoShow_ :: (Eq a, AssertM m)- => String -> Location -> String -> a -> a -> m ()-_assertNotEqualNoShow_ name loc s expected actual =- if expected == actual- then genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()-DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.- The first parameter denotes the expected value. Use these two functions- of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this- case the generated error message might not be very helpful.)-CreateAssertionsCtx(assertNotEqualNoShow, Eq a, (Eq a, AssertM m), a -> a)------- Assertions on Lists-----_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m)- => String -> Location -> String -> [a] -> [a] -> m ()-_assertListsEqualAsSets_ name loc s expected actual =- let ne = length expected- na = length actual- in case () of- _| ne /= na ->- do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg name s- (noColor- ("failed at " ++ showLoc loc- ++ "\n expected length: " ++ show ne- ++ "\n actual length: " ++ show na) +++- (if maxLength x < 5000- then x else emptyColorString)))- | not (unorderedEq expected actual) ->- do let x = equalityFailedMessage expected actual- genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s- (noColor ("failed at " ++ showLoc loc) +++ x))- | otherwise -> return ()- where unorderedEq l1 l2 =- null (l1 \\ l2) && null (l2 \\ l1)-DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal- when considered as sets. The first list parameter- denotes the expected value.)-CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), (Eq a, Show a, AssertM m), [a] -> [a])--_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertNotEmpty_ name loc s [] =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertNotEmpty_ _ _ _ (_:_) = return ()-DocAssertion(assertNotEmpty, Fail if the given list is empty.)-CreateAssertions(assertNotEmpty, [a])--_assertEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()-_assertEmpty_ name loc s (_:_) =- genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))-_assertEmpty_ _ _ _ [] = return ()-DocAssertion(assertEmpty, Fail if the given list is a non-empty list.)-CreateAssertions(assertEmpty, [a])--_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m ()-_assertElem_ name loc s x l =- if x `elem` l- then return ()- else genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- "\n element: " ++ show x ++- "\n list: " ++ show l))-DocAssertion(assertElem, Fail if the given element is not in the list.)-CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a])------- Assertions for Exceptions-----_assertThrowsIO_ :: Exception e- => String -> Location -> String -> IO a -> (e -> Bool) -> IO ()-_assertThrowsIO_ name loc s x f =- _assertThrowsM_ name loc s x f-DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool))--_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO ()-_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a)--_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e)- => String -> Location -> String -> m a -> (e -> Bool) -> m ()-_assertThrowsM_ name loc s x f =- do res <- ExL.try x- case res of- Right _ -> liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": no exception was thrown"))- Left e -> if f e then return ()- else liftIO $- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++- showLoc loc ++- ": wrong exception was thrown: " ++- show e))-DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,- m a -> (e -> Bool), m ())--_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m)- => String -> Location -> String -> m a -> m ()-_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not- throw an exception.)-CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ())--_assertThrows_ :: Exception e- => String -> Location -> String -> a -> (e -> Bool) -> IO ()-_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f-DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool))--_assertThrowsSome_ :: String -> Location -> String -> a -> IO ()-_assertThrowsSome_ name loc s x =- _assertThrows_ name loc s x (\ (_e::SomeException) -> True)-DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not- throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSome, a)------- Assertions on Either-----_assertLeft_ :: forall a b m . (AssertM m, Show b)- => String -> Location -> String -> Either a b -> m a-_assertLeft_ _ _ _ (Left x) = return x-_assertLeft_ name loc s (Right x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given " ++- show (Right x :: Either b b)))-DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.- Use this function if @b@ is an instance of 'Show')-CreateAssertionsCtxRet(assertLeft, Show b, (Show b, AssertM m), Either a b, a)--_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a-_assertLeftNoShow_ _ _ _ (Left x) = return x-_assertLeftNoShow_ name loc s (Right _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given a Right value"))-DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.)-CreateAssertionsRet(assertLeftNoShow, Either a b, a)--_assertRight_ :: forall a b m . (Show a, AssertM m)- => String -> Location -> String -> Either a b -> m b-_assertRight_ _ _ _ (Right x) = return x-_assertRight_ name loc s (Left x) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given " ++- show (Left x :: Either a a)))-DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.- Use this function if @a@ is an instance of 'Show')-CreateAssertionsCtxRet(assertRight, Show a, (Show a, AssertM m), Either a b, b)--_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b-_assertRightNoShow_ _ _ _ (Right x) = return x-_assertRightNoShow_ name loc s (Left _) =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Right value, given a Left value"))-DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.)-CreateAssertionsRet(assertRightNoShow, Either a b, b)------- Assertions on Maybe-----_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a-_assertJust_ _ _ _ (Just x) = return x-_assertJust_ name loc s Nothing =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Just value, given Nothing"))-DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.)-CreateAssertionsRet(assertJust, Maybe a, a)--_assertNothing_ :: (Show a, AssertM m)- => String -> Location -> String -> Maybe a -> m ()-_assertNothing_ _ _ _ Nothing = return ()-_assertNothing_ name loc s jx =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given " ++ show jx))-DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.- Use this function if @a@ is an instance of 'Show'.)-CreateAssertionsCtx(assertNothing, Show a, (Show a, AssertM m), Maybe a)--_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m ()-_assertNothingNoShow_ _ _ _ Nothing = return ()-_assertNothingNoShow_ name loc s _ =- genericAssertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected Nothing, given a Just value"))-DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.)-CreateAssertions(assertNothingNoShow, Maybe a)------- Sub assertions------- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location--- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write------ > assertIsPositive :: Int -> Assertion--- > assertIsPositive n = assertBool (n > 0)------ You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly--- you will lose location information: if @assertIsPositive i@ fails you will only get the location where--- @assertIsPositive@ is defined but not from where it has been called.------ To recover the location information you simply use @subAssert (assertIsPositive i)@.--- In this case, if @i@ is not positive, you will get the location of the caller.------ /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@.-subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a-subAssert_ loc ass = subAssertHTF loc Nothing ass---- | Generic variant of 'subAssert_'.-gsubAssert_ :: AssertM m => Location -> m a -> m a-gsubAssert_ loc ass = genericSubAssert loc Nothing ass---- | Same as 'subAssert_' but with an additional error message.-subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a-subAssertVerbose_ loc msg ass = subAssertHTF loc (Just msg) ass---- | Generic variant of 'subAssertVerbose_'.-gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a-gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+--++{-|++This module provides assert-like functions for writing unit tests.++-}++module Test.Framework.HUnitWrapper (++ -- * Assertions on Bool values+ assertBool, assertBoolVerbose,++ -- * Equality assertions+ assertEqual, assertEqualVerbose,+ assertEqualPretty, assertEqualPrettyVerbose,+ assertEqualNoShow, assertEqualNoShowVerbose,++ -- * Inequality assertions+ assertNotEqual, assertNotEqualVerbose,+ assertNotEqualPretty, assertNotEqualPrettyVerbose,+ assertNotEqualNoShow, assertNotEqualNoShowVerbose,++ -- * Assertions on lists+ assertListsEqualAsSets, assertListsEqualAsSetsVerbose,+ assertNotEmpty, assertNotEmptyVerbose,+ assertEmpty, assertEmptyVerbose,+ assertElem, assertElemVerbose,++ -- * Assertions for exceptions+ assertThrows, assertThrowsVerbose,+ assertThrowsSome, assertThrowsSomeVerbose,+ assertThrowsIO, assertThrowsIOVerbose,+ assertThrowsSomeIO, assertThrowsSomeIOVerbose,+ assertThrowsM, assertThrowsMVerbose,+ assertThrowsSomeM, assertThrowsSomeMVerbose,++ -- * Assertions on Either values+ assertLeft, assertLeftVerbose,+ assertLeftNoShow, assertLeftNoShowVerbose,+ assertRight, assertRightVerbose,+ assertRightNoShow, assertRightNoShowVerbose,++ -- * Assertions on Just values+ assertJust, assertJustVerbose,+ assertNothing, assertNothingVerbose,+ assertNothingNoShow, assertNothingNoShowVerbose,++ -- * General failure+ assertFailure,++ -- * Pending unit tests+ unitTestPending, unitTestPending',++ -- * Sub assertions+ subAssert, subAssertVerbose,++ -- * Generalized assertions and failures in AssertM+ {- |+ The following definitions generalize the the monad in which assertions are executed.+ Usually, assertions are executed in the @IO@ monad. The @AssertM@ monad+ (see "Test.Framework.AssertM") allows you to evaluate assertions also as pure functions.+ -}+ -- ** Assertions on Bool values+ gassertBool, gassertBoolVerbose,++ -- ** Equality assertions+ gassertEqual, gassertEqualVerbose,+ gassertEqualPretty, gassertEqualPrettyVerbose,+ gassertEqualNoShow, gassertEqualNoShowVerbose,++ -- ** Inequality assertions+ gassertNotEqual, gassertNotEqualVerbose,+ gassertNotEqualPretty, gassertNotEqualPrettyVerbose,+ gassertNotEqualNoShow, gassertNotEqualNoShowVerbose,++ -- ** Assertions on lists+ gassertListsEqualAsSets, gassertListsEqualAsSetsVerbose,+ gassertNotEmpty, gassertNotEmptyVerbose,+ gassertEmpty, gassertEmptyVerbose,+ gassertElem, gassertElemVerbose,++ -- ** Assertions on Either values+ gassertLeft, gassertLeftVerbose,+ gassertLeftNoShow, gassertLeftNoShowVerbose,+ gassertRight, gassertRightVerbose,+ gassertRightNoShow, gassertRightNoShowVerbose,++ -- ** Assertions on Just values+ gassertJust, gassertJustVerbose,+ gassertNothing, gassertNothingVerbose,+ gassertNothingNoShow, gassertNothingNoShowVerbose,++ -- ** General failure+ gassertFailure,++ -- ** Sub assertions+ gsubAssert, gsubAssertVerbose,++ -- * HUnit re-exports+ HU.HUnitFailure,++ -- * Tests (for internal use)+ hunitWrapperTests++) where++import Control.Exception+import qualified Control.Exception.Lifted as ExL+import Control.Monad.Trans.Control+import Control.Monad.Trans+import qualified Test.HUnit.Lang as HU+#if !MIN_VERSION_HUnit(1,4,0)+import qualified Test.HUnit.Base as HU+#endif++import GHC.Stack++import Data.List ( (\\) )+import System.IO.Unsafe (unsafePerformIO)++import Test.Framework.TestInterface+import Test.Framework.Location+import Test.Framework.Diff+import Test.Framework.Colors+import Test.Framework.Pretty+import Test.Framework.AssertM+import Test.Framework.PrettyHaskell+import Test.Framework.Utils++import qualified Data.Text as T+import qualified Data.List as List++-- WARNING: do not forget to add a preprocessor macro for new assertions!!++{- |+Fail with the given reason in some 'AssertM' monad.+-}+gassertFailure :: (HasCallStack, AssertM m) => String -> m a+gassertFailure s =+ genericAssertFailure (mkMsg "assertFailure" "" s)++-- | Specialization of 'gassertFailure' to @IO@.+assertFailure :: HasCallStack => String -> IO a+assertFailure = gassertFailure++{- |+Signals that the current unit test is pending.+-}+unitTestPending :: String -> IO a+unitTestPending s =+ failHTF (FullTestResult emptyHtfStack (Just $ noColor s) (Just Pending))++{- |+Use @unitTestPending' msg test@ to mark the given test as pending+without removing it from the test suite and without deleting or commenting out the test code.+-}+unitTestPending' :: String -> IO a -> IO a+unitTestPending' msg _ = unitTestPending msg++mkMsg :: String -> String -> String -> ColorString+mkMsg s1 s2 s3 = mkColorMsg s1 s2 (noColor s3)++mkColorMsg :: String -> String -> ColorString -> ColorString+mkColorMsg fun extraInfo s =+ let pref = if null extraInfo+ then fun ++ " "+ else fun ++ " (" ++ extraInfo ++ ") "+ in noColor pref +++ s++--+-- Boolean Assertions+--++assertBool_ :: (HasCallStack, AssertM m) => String -> String -> Bool -> m ()+assertBool_ name s False = genericAssertFailure (mkMsg name s "failed")+assertBool_ _ _ True = return ()++-- | Fail if the 'Bool' value is 'False'.+assertBool :: HasCallStack => Bool -> IO ()+assertBool = assertBool_ "assertBool" ""++assertBoolVerbose :: HasCallStack => String -> Bool -> IO ()+assertBoolVerbose = assertBool_ "assertBoolVerbose"++gassertBool :: (HasCallStack, AssertM m) => Bool -> m ()+gassertBool = assertBool_ "gassertBool" ""++gassertBoolVerbose :: (HasCallStack, AssertM m) => String -> Bool -> m ()+gassertBoolVerbose = assertBool_ "gassertBoolVerbose"++--+-- Equality Assertions+--++equalityFailedMessage' :: String -> String -> ColorString+equalityFailedMessage' exp act =+ let !diff = unsafePerformIO (diffWithSensibleConfig exp act)+ expected_ = colorize firstDiffColor "* expected:"+ but_got_ = colorize secondDiffColor "* but got:"+ diff_ = colorize diffColor "* diff:"+ in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) ++++ "\n" +++ but_got_ +++ " " +++ noColor (withNewline (trim act)) ++++ "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff ++++ (if (exp == act)+ then "\nWARNING: strings are equal but actual values differ!"+ else ""))+ where+ withNewline s =+ case lines s of+ [] -> s+ [_] -> s+ _ -> '\n':s+ newlineBeforeDiff d =+ let f b = case colorStringFind (\c -> c == '\n') d b of+ Just _ -> "\n"+ Nothing -> ""+ in noColor' (f True) (f False)+ trim s =+ case List.splitAt maxLen s of+ (_, []) -> s+ (prefix, rest) ->+ prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)"+ maxLen = 10000++asString :: Show a => a -> Maybe String+asString x = readM (show x)++equalityFailedMessage :: (Show a) => a -> a -> ColorString+equalityFailedMessage exp act =+ equalityFailedMessage' expP actP+ where+ (expP, actP) =+ case (asString exp, asString act) of+ (Just expS, Just actS)+ | expS /= actS -> (expS, actS)+ _ ->+ case (prettyHaskell' exp, prettyHaskell' act) of+ (Nothing, _) -> (show exp, show act)+ (_, Nothing) -> (show exp, show act)+ (Just expP, Just actP)+ | expP == actP ->+ (show exp, show act)+ | otherwise -> (expP, actP)++notEqualityFailedMessage :: Show a => a -> String+notEqualityFailedMessage exp =+ notEqualityFailedMessage' (prettyHaskell exp)++notEqualityFailedMessage' :: String -> String+notEqualityFailedMessage' exp =+ (": Objects are equal\n" ++ exp)++failedAt :: HasCallStack => String+failedAt =+ case failureLocation of+ Nothing -> "failed"+ Just loc -> "failed at " ++ showLoc loc++assertEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqual_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s $+ noColor failedAt +++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualVerbose = assertEqual_ "gassertEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqual = assertEqual_ "gassertEqual" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertEqualVerbose = assertEqual_ "assertEqualVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertEqual = assertEqual_ "assertEqual" ""++assertNotEqual_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqual_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage expected+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqualVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualVerbose = assertNotEqual_ "gassertNotEqualVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+gassertNotEqual :: (Eq a, Show a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqual = assertNotEqual_ "gassertNotEqual" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqualVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualVerbose = assertNotEqual_ "assertNotEqualVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Show' but not of 'Pretty'.+assertNotEqual :: (Eq a, Show a, HasCallStack) => a -> a -> IO ()+assertNotEqual = assertNotEqual_ "assertNotEqual" ""++assertEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualPretty_ name s expected actual =+ if expected /= actual+ then do let x = equalityFailedMessage' (showPretty expected) (showPretty actual)+ genericAssertFailure (mkColorMsg name s+ (noColor failedAt +++ x))+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualPrettyVerbose = assertEqualPretty_ "gassertEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualPretty = assertEqualPretty_ "gassertEqualPretty" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertEqualPrettyVerbose = assertEqualPretty_ "assertEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is an instance of 'Pretty'.+assertEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertEqualPretty = assertEqualPretty_ "assertEqualPretty" ""++assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualPretty_ name s expected actual =+ if expected == actual+ then do let x = notEqualityFailedMessage' (showPretty expected)+ genericAssertFailure (mkMsg name s $ failedAt ++ x)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPrettyVerbose :: (Eq a, Pretty a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualPrettyVerbose = assertNotEqualPretty_ "gassertNotEqualPrettyVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+gassertNotEqualPretty :: (Eq a, Pretty a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualPretty = assertNotEqualPretty_ "gassertNotEqualPretty" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPrettyVerbose :: (Eq a, Pretty a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualPrettyVerbose = assertNotEqualPretty_ "assertNotEqualPrettyVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is an instance of 'Pretty'.+assertNotEqualPretty :: (Eq a, Pretty a, HasCallStack) => a -> a -> IO ()+assertNotEqualPretty = assertNotEqualPretty_ "assertNotEqualPretty" ""++assertEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertEqualNoShow_ name s expected actual =+ if expected /= actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertEqualNoShowVerbose = assertEqualNoShow_ "gassertEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertEqualNoShow = assertEqualNoShow_ "gassertEqualNoShow" ""++-- | Fail if the two values of type @a@ are not equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertEqualNoShowVerbose = assertEqualNoShow_ "assertEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are not equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertEqualNoShow = assertEqualNoShow_ "assertEqualNoShow" ""++assertNotEqualNoShow_ :: (Eq a, AssertM m, HasCallStack)+ => String -> String -> a -> a -> m ()+assertNotEqualNoShow_ name s expected actual =+ if expected == actual+ then genericAssertFailure (mkMsg name s failedAt)+ else return ()++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShowVerbose :: (Eq a, AssertM m, HasCallStack) => String -> a -> a -> m ()+gassertNotEqualNoShowVerbose = assertNotEqualNoShow_ "gassertNotEqualNoShowVerbose"++-- | Fail in some 'AssertM' monad if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+gassertNotEqualNoShow :: (Eq a, AssertM m, HasCallStack) => a -> a -> m ()+gassertNotEqualNoShow = assertNotEqualNoShow_ "gassertNotEqualNoShow" ""++-- | Fail if the two values of type @a@ are equal, supplying+-- an additional message.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShowVerbose :: (Eq a, HasCallStack) => String -> a -> a -> IO ()+assertNotEqualNoShowVerbose = assertNotEqualNoShow_ "assertNotEqualNoShowVerbose"++-- | Fail if the two values of type @a@ are equal.+-- Use if @a@ is neither an instance of 'Show' nor of 'Pretty'.+assertNotEqualNoShow :: (Eq a, HasCallStack) => a -> a -> IO ()+assertNotEqualNoShow = assertNotEqualNoShow_ "assertNotEqualNoShow" ""++--+-- Assertions on Lists+--++assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m, HasCallStack)+ => String -> String -> [a] -> [a] -> m ()+assertListsEqualAsSets_ name s expected actual =+ let ne = length expected+ na = length actual+ in case () of+ _| ne /= na ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg name s+ (noColor+ (failedAt+ ++ "\n expected length: " ++ show ne+ ++ "\n actual length: " ++ show na) ++++ (if maxLength x < 5000+ then x else emptyColorString)))+ | not (unorderedEq expected actual) ->+ do let x = equalityFailedMessage expected actual+ genericAssertFailure (mkColorMsg "assertSetEqual" s+ (noColor failedAt +++ x))+ | otherwise -> return ()+ where unorderedEq l1 l2 =+ null (l1 \\ l2) && null (l2 \\ l1)++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+gassertListsEqualAsSetsVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> [a] -> [a] -> m ()+gassertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "gassertListsEqualAsSetsVerbose"++-- | Fail in some 'AssertM' monad if the two given lists are not equal when considered as sets.+gassertListsEqualAsSets :: (Eq a, Show a, AssertM m, HasCallStack) => [a] -> [a] -> m ()+gassertListsEqualAsSets= assertListsEqualAsSets_ "gassertListsEqualAsSets" ""++-- | Fail if the two given lists are not equal when considered as sets,+-- supplying an additional error message.+assertListsEqualAsSetsVerbose :: (Eq a, Show a, HasCallStack) => String -> [a] -> [a] -> IO ()+assertListsEqualAsSetsVerbose = assertListsEqualAsSets_ "assertListsEqualAsSetsVerbose"++-- | Fail if the two given lists are not equal when considered as sets.+assertListsEqualAsSets :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> IO ()+assertListsEqualAsSets = assertListsEqualAsSets_ "assertListsEqualAsSets" ""++assertNotEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertNotEmpty_ name s [] =+ genericAssertFailure (mkMsg name s failedAt)+assertNotEmpty_ _ _ (_:_) = return ()++-- | Fail in some 'AssertM' monad if the given list is empty, supplying an+-- additional error message.+gassertNotEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertNotEmptyVerbose = assertNotEmpty_ "gassertNotEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is empty.+gassertNotEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertNotEmpty = assertNotEmpty_ "gassertNotEmpty" ""++-- | Fail if the given list is empty, supplying an+-- additional error message.+assertNotEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertNotEmptyVerbose = assertNotEmpty_ "assertNotEmptyVerbose"++-- | Fail if the given list is empty.+assertNotEmpty :: HasCallStack => [a] -> IO ()+assertNotEmpty = assertNotEmpty_ "assertNotEmpty" ""++assertEmpty_ :: (AssertM m, HasCallStack) => String -> String -> [a] -> m ()+assertEmpty_ name s (_:_) =+ genericAssertFailure (mkMsg name s failedAt)+assertEmpty_ _ _ [] = return ()++-- | Fail in some 'AssertM' monad if the given list is not empty, supplying an+-- additional error message.+gassertEmptyVerbose :: (AssertM m, HasCallStack) => String -> [a] -> m ()+gassertEmptyVerbose = assertEmpty_ "gassertEmptyVerbose"++-- | Fail in some 'AssertM' monad if the given list is not empty.+gassertEmpty :: (HasCallStack, AssertM m) => [a] -> m ()+gassertEmpty = assertEmpty_ "gassertEmpty" ""++-- | Fail if the given list is not empty, supplying an+-- additional error message.+assertEmptyVerbose :: HasCallStack => String -> [a] -> IO ()+assertEmptyVerbose = assertEmpty_ "assertEmptyVerbose"++-- | Fail if the given list is not empty.+assertEmpty :: HasCallStack => [a] -> IO ()+assertEmpty = assertEmpty_ "assertEmpty" ""++assertElem_ :: (Eq a, Show a, AssertM m, HasCallStack) => String -> String -> a -> [a] -> m ()+assertElem_ name s x l =+ if x `elem` l+ then return ()+ else genericAssertFailure (mkMsg name s+ (failedAt +++ "\n element: " ++ show x +++ "\n list: " ++ show l))++-- | Fail in some 'AssertM' monad if the element given is not contained in the list, supplying+-- an additional error message.+gassertElemVerbose :: (Eq a, Show a, AssertM m, HasCallStack) => String -> a -> [a] -> m ()+gassertElemVerbose = assertElem_ "gassertElemVerbose"++-- | Fail in some 'AssertM' monad if the element given is not contained in the list.+gassertElem :: (Eq a, Show a, AssertM m, HasCallStack) => a -> [a] -> m ()+gassertElem = assertElem_ "gassertElem" ""++-- | Fail if the element given is not contained in the list, supplying+-- an additional error message.+assertElemVerbose :: (Eq a, Show a, HasCallStack) => String -> a -> [a] -> IO ()+assertElemVerbose = assertElem_ "assertElemVerbose"++-- | Fail if the element given is not contained in the list.+assertElem :: (Eq a, Show a, HasCallStack) => a -> [a] -> IO ()+assertElem = assertElem_ "assertElem" ""++--+-- Assertions for Exceptions+--++assertThrowsIO_ :: (HasCallStack, Exception e)+ => String -> String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIO_ name s x f =+ assertThrowsM_ name s x f++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsIOVerbose :: (HasCallStack, Exception e) => String -> IO a -> (e -> Bool) -> IO ()+assertThrowsIOVerbose = assertThrowsIO_ "assertThrowsIOVerbose"++-- | Fail if executing the 'IO' action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsIO :: (HasCallStack, Exception e) => IO a -> (e -> Bool) -> IO ()+assertThrowsIO = assertThrowsIO_ "assertThrowsIO" ""++assertThrowsSomeIO_ :: HasCallStack => String -> String -> IO a -> IO ()+assertThrowsSomeIO_ name s x = assertThrowsIO_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the 'IO' action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeIOVerbose :: HasCallStack => String -> IO a -> IO ()+assertThrowsSomeIOVerbose = assertThrowsSomeIO_ "assertThrowsSomeIOVerbose"++-- | Fail if executing the 'IO' action does not throw any exception.+assertThrowsSomeIO :: HasCallStack => IO a -> IO ()+assertThrowsSomeIO = assertThrowsSomeIO_ "assertThrowsSomeIO" ""++assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> String -> m a -> (e -> Bool) -> m ()+assertThrowsM_ name s x f =+ do res <- ExL.try x+ case res of+ Right _ -> liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": no exception was thrown"))+ Left e -> if f e then return ()+ else liftIO $+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": wrong exception was thrown: " +++ show e))+-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@, supplying an additional error message.+assertThrowsMVerbose ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => String -> m a -> (e -> Bool) -> m ()+assertThrowsMVerbose = assertThrowsM_ "assertThrowsMVerbose"++-- | Fail if executing the @m@ action does not throw an exception satisfying the given predicate+-- @(e -> Bool)@.+assertThrowsM ::+ (MonadBaseControl IO m, MonadIO m, Exception e, HasCallStack)+ => m a -> (e -> Bool) -> m ()+assertThrowsM = assertThrowsM_ "assertThrowsM" ""++assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> String -> m a -> m ()+assertThrowsSomeM_ name s x = assertThrowsM_ name s x (\ (_e::SomeException) -> True)++-- | Fail if executing the @m@ action does not throw any exception,+-- supplying an additional error message.+assertThrowsSomeMVerbose ::+ (MonadBaseControl IO m, MonadIO m, HasCallStack)+ => String -> m a -> m ()+assertThrowsSomeMVerbose = assertThrowsSomeM_ "assertThrowsSomeMVerbose"++-- | Fail if executing the @m@ action does not throw any exception.+assertThrowsSomeM :: (MonadBaseControl IO m, MonadIO m, HasCallStack) => m a -> m ()+assertThrowsSomeM = assertThrowsSomeM_ "assertThrowsSomeM" ""++assertThrows_ :: (HasCallStack, Exception e)+ => String -> String -> a -> (e -> Bool) -> IO ()+assertThrows_ name s x f = assertThrowsIO_ name s (evaluate x) f++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@,+-- supplying an additional error message.+assertThrowsVerbose :: (HasCallStack, Exception e) => String -> a -> (e -> Bool) -> IO ()+assertThrowsVerbose = assertThrows_ "assertThrowsVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw an exception satisfying the given predicate @(e -> Bool)@.+assertThrows :: (HasCallStack, Exception e) => a -> (e -> Bool) -> IO ()+assertThrows = assertThrows_ "assertThrows" ""++assertThrowsSome_ :: HasCallStack => String -> String -> a -> IO ()+assertThrowsSome_ name s x =+ assertThrows_ name s x (\ (_e::SomeException) -> True)++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception, supplying an additional error message.+assertThrowsSomeVerbose :: HasCallStack => String -> a -> IO ()+assertThrowsSomeVerbose = assertThrowsSome_ "assertThrowsSomeVerbose"++-- | Fail if evaluating the expression of type @a@ does not+-- throw any exception.+assertThrowsSome :: HasCallStack => a -> IO ()+assertThrowsSome = assertThrowsSome_ "assertThrowsSome" ""++--+-- Assertions on Either+--++assertLeft_ :: forall a b m . (AssertM m, Show b, HasCallStack)+ => String -> String -> Either a b -> m a+assertLeft_ _ _ (Left x) = return x+assertLeft_ name s (Right x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given " +++ show (Right x :: Either b b)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeftVerbose :: (Show b, AssertM m, HasCallStack) => String -> Either a b -> m a+gassertLeftVerbose = assertLeft_ "gassertLeftVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+gassertLeft :: (Show b, AssertM m, HasCallStack) => Either a b -> m a+gassertLeft = assertLeft_ "gassertLeft" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is an instance of 'Show'.+assertLeftVerbose :: (Show b, HasCallStack) => String -> Either a b -> IO a+assertLeftVerbose = assertLeft_ "assertLeftVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is an instance of 'Show'.+assertLeft :: (HasCallStack, Show b) => Either a b -> IO a+assertLeft = assertLeft_ "assertLeft" ""++assertLeftNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m a+assertLeftNoShow_ _ _ (Left x) = return x+assertLeftNoShow_ name s (Right _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Left value, given a Right value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m a+gassertLeftNoShowVerbose = assertLeftNoShow_ "gassertLeftNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+gassertLeftNoShow :: (HasCallStack, AssertM m) => Either a b -> m a+gassertLeftNoShow = assertLeftNoShow_ "gassertLeftNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Right',+-- supplying an additional error message.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShowVerbose :: HasCallStack => String -> Either a b -> IO a+assertLeftNoShowVerbose = assertLeftNoShow_ "assertLeftNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Right'.+-- Use this function if @b@ is not an instance of 'Show'.+assertLeftNoShow :: HasCallStack => Either a b -> IO a+assertLeftNoShow = assertLeftNoShow_ "assertLeftNoShow" ""++assertRight_ :: forall a b m . (AssertM m, Show a, HasCallStack)+ => String -> String -> Either a b -> m b+assertRight_ _ _ (Right x) = return x+assertRight_ name s (Left x) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given " +++ show (Left x :: Either a a)))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertRightVerbose :: (Show a, AssertM m, HasCallStack) => String -> Either a b -> m b+gassertRightVerbose = assertRight_ "gassertRightVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+gassertRight :: (Show a, AssertM m, HasCallStack) => Either a b -> m b+gassertRight = assertRight_ "gassertRight" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is an instance of 'Show'.+assertRightVerbose :: (Show a, HasCallStack) => String -> Either a b -> IO b+assertRightVerbose = assertRight_ "assertRightVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is an instance of 'Show'.+assertRight :: (HasCallStack, Show a) => Either a b -> IO b+assertRight = assertRight_ "assertRight" ""++assertRightNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Either a b -> m b+assertRightNoShow_ _ _ (Right x) = return x+assertRightNoShow_ name s (Left _) =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Right value, given a Left value"))++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShowVerbose :: (HasCallStack, AssertM m) => String -> Either a b -> m b+gassertRightNoShowVerbose = assertRightNoShow_ "gassertRightNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertRightNoShow :: (HasCallStack, AssertM m) => Either a b -> m b+gassertRightNoShow = assertRightNoShow_ "gassertRightNoShow" ""++-- | Fail if the given @Either a b@ value is a 'Left',+-- supplying an additional error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShowVerbose :: HasCallStack => String -> Either a b -> IO b+assertRightNoShowVerbose = assertRightNoShow_ "assertRightNoShowVerbose"++-- | Fail if the given @Either a b@ value is a 'Left'.+-- Use this function if @a@ is not an instance of 'Show'.+assertRightNoShow :: HasCallStack => Either a b -> IO b+assertRightNoShow = assertRightNoShow_ "assertRightNoShow" ""++--+-- Assertions on Maybe+--++assertJust_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m a+assertJust_ _ _ (Just x) = return x+assertJust_ name s Nothing =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected a Just value, given Nothing"))++-- | Fail in some 'AssertM' monad if the given value is a Nothing, supplying an additional+-- error message.+gassertJustVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m a+gassertJustVerbose = assertJust_ "gassertJustVerbose"++-- | Fail in some 'AssertM' monad if the given value is a Nothing.+gassertJust :: (HasCallStack, AssertM m) => Maybe a -> m a+gassertJust = assertJust_ "gassertJust" ""++-- | Fail if the given value is a Nothing, supplying an additional+-- error message.+assertJustVerbose :: HasCallStack => String -> Maybe a -> IO a+assertJustVerbose = assertJust_ "assertJustVerbose"++-- | Fail if the given value is a Nothing.+assertJust :: HasCallStack => Maybe a -> IO a+assertJust = assertJust_ "assertJust" ""++assertNothing_ :: (Show a, AssertM m, HasCallStack)+ => String -> String -> Maybe a -> m ()+assertNothing_ _ _ Nothing = return ()+assertNothing_ name s jx =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given " ++ show jx))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothingVerbose :: (Show a, AssertM m, HasCallStack) => String -> Maybe a -> m ()+gassertNothingVerbose = assertNothing_ "gassertNothingVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+gassertNothing :: (Show a, AssertM m, HasCallStack) => Maybe a -> m ()+gassertNothing = assertNothing_ "gassertNothing" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is an instance of 'Show'.+assertNothingVerbose :: (Show a, HasCallStack) => String -> Maybe a -> IO ()+assertNothingVerbose = assertNothing_ "assertNothingVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is an instance of 'Show'.+assertNothing :: (HasCallStack, Show a) => Maybe a -> IO ()+assertNothing = assertNothing_ "assertNothing" ""++assertNothingNoShow_ :: (HasCallStack, AssertM m) => String -> String -> Maybe a -> m ()+assertNothingNoShow_ _ _ Nothing = return ()+assertNothingNoShow_ name s _ =+ genericAssertFailure (mkMsg name s+ (failedAt +++ ": expected Nothing, given a Just value"))++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShowVerbose :: (HasCallStack, AssertM m) => String -> Maybe a -> m ()+gassertNothingNoShowVerbose = assertNothingNoShow_ "gassertNothingNoShowVerbose"++-- | Fail in some 'AssertM' monad if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+gassertNothingNoShow :: (HasCallStack, AssertM m) => Maybe a -> m ()+gassertNothingNoShow = assertNothingNoShow_ "gassertNothingNoShow" ""++-- | Fail if the given @Maybe a@ value is a 'Just', supplying an additional+-- error message.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShowVerbose :: HasCallStack => String -> Maybe a -> IO ()+assertNothingNoShowVerbose = assertNothingNoShow_ "assertNothingNoShowVerbose"++-- | Fail if the given @Maybe a@ value is a 'Just'.+-- Use this function if @a@ is not an instance of 'Show'.+assertNothingNoShow :: HasCallStack => Maybe a -> IO ()+assertNothingNoShow = assertNothingNoShow_ "assertNothingNoShow" ""++--+-- Sub assertions+--++-- | Use 'subAssert' if you want location information for the call site but the function+-- being called does not carry a 'HasCallStack' constraint.+subAssert :: (HasCallStack, MonadBaseControl IO m) => m a -> m a+subAssert = subAssertHTF Nothing++gsubAssert :: (HasCallStack, AssertM m) => m a -> m a+gsubAssert = genericSubAssert Nothing++subAssertVerbose :: (HasCallStack, MonadBaseControl IO m) => String -> m a -> m a+subAssertVerbose msg = subAssertHTF (Just msg)++gsubAssertVerbose :: (HasCallStack, AssertM m) => String -> m a -> m a+gsubAssertVerbose msg = genericSubAssert (Just msg) testEqualityFailedMessage1 :: IO () testEqualityFailedMessage1 =
− Test/Framework/HaskellParser.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE ScopedTypeVariables,CPP #-}---- This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Lesser General Public--- License as published by the Free Software Foundation; either--- version 2.1 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Lesser General Public License for more details.------ You should have received a copy of the GNU Lesser General Public--- License along with this library; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA-----module Test.Framework.HaskellParser where--import Data.Maybe-import Data.Char ( isSpace, isDigit )-import qualified Data.List as List-import Control.Exception ( evaluate, catch, SomeException )-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding ( catch )-#endif--import qualified Language.Haskell.Exts as Exts-import qualified Language.Haskell.Exts.Parser as Parser-import qualified Language.Haskell.Exts.Syntax as Syn-import qualified Language.Haskell.Exts.Extension as Ext-import qualified Language.Haskell.Exts.Fixity as Fix-import qualified Language.Haskell.Exts.SrcLoc as Src--import Test.Framework.Location-import Test.Framework.Utils--type Name = String--data Decl = Decl { decl_loc :: Location- , decl_name :: Name }- deriving (Show)--data Pragma = Pragma { pr_name :: String- , pr_args :: String- , pr_loc :: Location }- deriving (Show)--data ParseResult a = ParseOK a | ParseError Location String--data Module = Module { mod_name :: Name- , mod_imports :: [ImportDecl]- , mod_decls :: [Decl]- , mod_htfPragmas :: [Pragma] }- deriving (Show)--data ImportDecl = ImportDecl { imp_moduleName :: Name- , imp_qualified :: Bool- , imp_alias :: Maybe Name- , imp_loc :: Location }- deriving (Show)---- Returns for lines of the form '# <number> "<filename>"'--- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)--- the value 'Just <number> "<filename>"'-parseCppLineInfoOut :: String -> Maybe (String, String)-parseCppLineInfoOut line =- case line of- '#':' ':c:rest- | isDigit c ->- case List.span isDigit rest of- (restDigits, ' ' : '"' : rest) ->- case dropWhile (/= '"') (reverse rest) of- '"' : fileNameRev ->- let line = (c:restDigits)- file = "\"" ++ reverse fileNameRev ++ "\""- in Just (line, file)- _ -> Nothing- _ -> Nothing- _ -> Nothing--parse :: FilePath -> String -> IO (ParseResult Module)-parse originalFileName input =- do r <- (evaluate $ Exts.parseFileContentsWithComments parseMode fixedInput)- `catch` (\(e::SomeException) ->- return $ Parser.ParseFailed unknownLoc (show e))- case r of- Parser.ParseFailed loc err -> return (ParseError (transformLoc loc) err)- Parser.ParseOk (m, comments) -> return $ ParseOK (transformModule m comments)- where- -- fixedInput serves two purposes:- -- 1. add a trailing \n- -- 2. turn lines of the form '# <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'- -- 2. turn lines of the form '#line <number> "<filename>"' into GHC line pragmas '{-# LINE <number> <filename> #-}'- -- 3. comment out lines starting with #- fixedInput :: String- fixedInput = (unlines . map fixLine . lines) input- where- fixLine s =- case parseCppLineInfoOut s of- Just (line, file) -> "{-# LINE " ++ line ++ " " ++ file ++ " #-}"- Nothing ->- case dropWhile isSpace s of- '#':'l':'i':'n':'e':rest -> "{-# LINE " ++ rest ++ " #-}"- '#':_ -> "-- " ++ s- _ -> s- {- FIXME: fixities needed for all operators. Heuristic:- all operators are considered to be any sequence- of the symbols _:"'>!#$%&*+./<=>?@\^|-~ with at most length 8 -}- parseMode :: Parser.ParseMode- parseMode = Parser.ParseMode { Parser.parseFilename = originalFileName- , Parser.baseLanguage = Ext.Haskell2010- , Parser.ignoreLanguagePragmas = False- , Parser.ignoreLinePragmas = False- , Parser.extensions = (map Ext.EnableExtension- extensions)- , Parser.fixities = Nothing- }- extensions =- [ Ext.ForeignFunctionInterface- , Ext.UnliftedFFITypes- , Ext.GADTs- , Ext.ScopedTypeVariables- , Ext.UnboxedTuples- , Ext.TypeSynonymInstances- , Ext.StandaloneDeriving- , Ext.DeriveDataTypeable- , Ext.FlexibleContexts- , Ext.FlexibleInstances- , Ext.ConstrainedClassMethods- , Ext.MultiParamTypeClasses- , Ext.FunctionalDependencies- , Ext.MagicHash- , Ext.PolymorphicComponents- , Ext.ExistentialQuantification- , Ext.UnicodeSyntax- , Ext.PostfixOperators- , Ext.PatternGuards- , Ext.LiberalTypeSynonyms- , Ext.RankNTypes- , Ext.ImpredicativeTypes- , Ext.TypeOperators- , Ext.RecursiveDo- , Ext.ParallelListComp- , Ext.EmptyDataDecls- , Ext.KindSignatures- , Ext.GeneralizedNewtypeDeriving- , Ext.TypeFamilies- , Ext.NamedFieldPuns- , Ext.RecordWildCards- , Ext.PackageImports- , Ext.ViewPatterns- , Ext.TupleSections- , Ext.NondecreasingIndentation- , Ext.DoAndIfThenElse- ]- unknownLoc :: Syn.SrcLoc- unknownLoc = Syn.SrcLoc originalFileName 0 0- transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls)- comments =- Module moduleName (map transformImport imports)- (mapMaybe transformDecl decls)- (mapMaybe transformComment comments)-#if MIN_VERSION_haskell_src_exts(1,16,0) - transformImport (Syn.ImportDecl loc (Syn.ModuleName s)- qualified _ _ _ alias _) =- let alias' = case alias of- Nothing -> Nothing- Just (Syn.ModuleName s) -> Just s- in ImportDecl s qualified alias' (transformLoc loc)- transformDecl (Syn.PatBind loc (Syn.PVar name) _ _) =- Just $ Decl (transformLoc loc) (transformName name)-#else- transformImport (Syn.ImportDecl loc (Syn.ModuleName s)- qualified _ _ alias _) =- let alias' = case alias of- Nothing -> Nothing- Just (Syn.ModuleName s) -> Just s- in ImportDecl s qualified alias' (transformLoc loc)- transformDecl (Syn.PatBind loc (Syn.PVar name) _ _ _) =- Just $ Decl (transformLoc loc) (transformName name)-#endif- transformDecl (Syn.FunBind (Syn.Match loc name _ _ _ _ : _)) =- Just $ Decl (transformLoc loc) (transformName name)- transformDecl _ = Nothing- transformSpan span = makeLoc (Src.srcSpanFilename span) (Src.srcSpanStartLine span)- transformLoc (Syn.SrcLoc f n _) = makeLoc f n- transformName :: Syn.Name -> String- transformName (Syn.Ident s) = s- transformName (Syn.Symbol s) = s- transformComment (Exts.Comment True span ('@':s)) =- case reverse s of- '@':r ->- let stripped = strip (reverse r)- in if "HTF_" `List.isPrefixOf` stripped- then let (name, args) = List.span (not . isSpace) stripped- argsStripped = dropWhile isSpace args- loc = transformSpan span- in Just $ Pragma name argsStripped loc- else Nothing- _ -> Nothing- transformComment _ = Nothing
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,10 +1,13 @@+{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PackageImports #-}-+{- |+Internal module providing access to some functionality of cpphs.+-} ----- Copyright (c) 2009-2014 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -23,20 +26,31 @@ module Test.Framework.Preprocessor ( - transform, progName, preprocessorTests+ transform, progName, preprocessorTests, TransformOptions(..) ) where -- import Debug.Trace import Control.Monad import Data.Char-import "haskell-lexer" Language.Haskell.Lexer-import Language.Preprocessor.Cpphs ( runCpphs,+import Language.Preprocessor.Cpphs ( runCpphsPass1,+ runCpphsPass2, CpphsOptions(..), BoolOptions(..),- defaultCpphsOptions)+ defaultCpphsOptions,+ WordStyle(..),+ Posn,+ filename,+ lineno,+ newfile,+ tokenise+ ) import System.IO ( hPutStrLn, stderr )+#if MIN_VERSION_HUnit(1,4,0) import Test.HUnit hiding (State)+#else+import Test.HUnit hiding (State, Location)+#endif import Control.Monad.State.Strict import qualified Data.List as List import Data.Maybe@@ -77,49 +91,6 @@ [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)), (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault info))] -allAsserts :: [String]-allAsserts =- withGs ["assertBool"- ,"assertEqual"- ,"assertEqualPretty"- ,"assertEqualNoShow"- ,"assertNotEqual"- ,"assertNotEqualPretty"- ,"assertNotEqualNoShow"- ,"assertListsEqualAsSets"- ,"assertElem"- ,"assertEmpty"- ,"assertNotEmpty"- ,"assertLeft"- ,"assertLeftNoShow"- ,"assertRight"- ,"assertRightNoShow"- ,"assertJust"- ,"assertNothing"- ,"assertNothingNoShow"- ,"subAssert"- ,"subAssertVerbose"- ] ++ ["assertThrows"- ,"assertThrowsSome"- ,"assertThrowsIO"- ,"assertThrowsSomeIO"- ,"assertThrowsM"- ,"assertThrowsSomeM"]- where- withGs l =- concatMap (\s -> [s, 'g':s]) l--assertDefines :: Bool -> String -> [(String, String)]-assertDefines hunitBackwardsCompat prefix =- concatMap fun allAsserts ++ [("assertFailure", expansion "assertFailure" "_")]- where- fun a =- if hunitBackwardsCompat- then [(a, expansion a "Verbose_"), (a ++ "HTF", expansion a "_")]- else [(a, expansion a "_"), (a ++ "Verbose", expansion a "Verbose_")]- expansion a suffix = "(" ++ prefix ++ a ++ suffix ++ " (" ++- prefix ++ "makeLoc __FILE__ __LINE__))"- data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition]@@ -164,10 +135,60 @@ setTestFrameworkImport name = modify $ \mi -> mi { mi_htfPrefix = name } -poorManAnalyzeTokens :: [LocToken] -> ModuleInfo-poorManAnalyzeTokens toks =- -- show toks `trace`- let revRes =+data Tok+ = TokModule+ | TokQname Location String+ | TokName Location Bool String+ | TokHtfImport Location+ | TokImport Location++transWordStyles :: [WordStyle] -> [Tok]+transWordStyles styles = loop styles True+ where+ loop styles startOfLine =+ case styles of+ [] -> []+ Ident pos name : rest ->+ case name of+ "module" -> TokModule : loop rest False+ "import" ->+ case dropWhite rest of+ Other "{-@ HTF_TESTS @-}" : rest2 ->+ TokHtfImport (posToLocation pos) : loop rest2 False+ _ ->+ TokImport (posToLocation pos) : loop rest False+ _ ->+ case parseQname rest of+ ([], rest2) ->+ TokName (posToLocation pos) startOfLine name : loop rest2 False+ (nameParts, rest2) ->+ TokQname (posToLocation pos) (List.intercalate "." (name:nameParts)) : loop rest2 False+ Other str : rest ->+ let startOfLine =+ case reverse str of+ '\n':_ -> True+ _ -> False+ in loop rest startOfLine+ Cmd _ : rest -> loop rest False+ dropWhite styles =+ case styles of+ Other str : rest ->+ case dropWhile isSpace str of+ [] -> dropWhite rest+ str' -> Other str' : rest+ _ -> styles+ parseQname styles =+ case styles of+ Other "." : Ident _ name : rest ->+ let (restParts, rest2) = parseQname rest+ in (name:restParts, rest2)+ _ -> ([], styles)+ posToLocation pos = makeLoc (filename pos) (lineno pos)++poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo+poorManAnalyzeTokens styles =+ let toks = transWordStyles styles+ revRes = execState (loop toks) $ ModuleInfo { mi_htfPrefix = htfModule ++ "." , mi_htfImports = []@@ -184,33 +205,30 @@ defEqByName _ _ = False loop toks = case toks of- (Reservedid, (_, "module")) : rest ->- case rest of- (Conid, (_, name)):rest2 ->- do setModName name- loop rest2- (Qconid, (_, name)):rest2 ->- do setModName name- loop rest2- _ -> loop rest- (Varid, (loc, name)) : rest- | isStartOfLine loc ->+ TokModule : TokQname _ name : rest ->+ do setModName name+ loop rest+ TokModule : TokName _ _ name : rest ->+ do setModName name+ loop rest+ TokName loc startOfLine name : rest+ | startOfLine -> case name of 't':'e':'s':'t':'_':shortName ->- do addTestDef shortName name (locToLocation loc)+ do addTestDef shortName name loc loop rest 'p':'r':'o':'p':'_':shortName ->- do addPropDef shortName name (locToLocation loc)+ do addPropDef shortName name loc loop rest _ -> loop rest | otherwise -> loop rest- (Special, (loc, "import_HTF_TESTS")) : rest ->+ TokHtfImport loc : rest -> case parseImport loc rest of Just (imp, rest2) -> do addHtfImport imp loop rest2 Nothing -> loop rest- (Reservedid, (loc, "import")) : rest ->+ TokImport loc : rest -> do case parseImport loc rest of Nothing -> loop rest Just (imp, rest2) ->@@ -227,181 +245,30 @@ parseImport loc toks = do let (qualified, toks2) = case toks of- (Varid, (_, "qualified")):rest -> (True, rest)+ TokName _ _ "qualified" : rest -> (True, rest) _ -> (False, toks) (name, toks3) <- case toks2 of- (Conid, (_, name)):rest -> return (name, rest)- (Qconid, (_, name)):rest -> return (name, rest)+ TokName _ _ name : rest -> return (name, rest)+ TokQname _ name : rest -> return (name, rest) _ -> fail "no import" let (mAlias, toks4) = case toks3 of- (Varid, (_, "as")):(Conid, (_, alias)):rest -> (Just alias, rest)+ TokName _ _ "as" : TokName _ _ alias : rest -> (Just alias, rest) _ -> (Nothing, toks3) decl = ImportDecl { imp_moduleName = name , imp_qualified = qualified , imp_alias = mAlias- , imp_loc = locToLocation loc }+ , imp_loc = loc } return (decl, toks4)- locToLocation loc =- makeLoc (l_file loc) (l_line loc)- isStartOfLine loc =- l_column loc == 1 -cleanupTokens :: [PosToken] -> [PosToken]-cleanupTokens toks =- -- Remove whitespace tokens, remove comments, but replace- -- 'import {-@ HTF_TESTS @-}' with a single- -- token Special with value "import_HTF_TESTS"- case toks of- (Whitespace, _):rest -> cleanupTokens rest- (NestedComment, (loc, "{-@ HTF_TESTS @-}")) : rest ->- (Special, (loc, "import_HTF_TESTS")) :- cleanupTokens rest- tok:rest -> tok : cleanupTokens rest- [] -> []---- char -> ' (graphic<' | \> | space | escape<\&>) '--- graphic -> small | large | symbol | digit | special | : | " | '--- escape -> \ ( charesc | ascii | decimal | o octal | x hexadecimal )--- charesc -> a | b | f | n | r | t | v | \ | " | ' | &--- ascii -> ^cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK--- | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE--- | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN--- | EM | SUB | ESC | FS | GS | RS | US | SP | DEL--- cntrl -> ascLarge | @ | [ | \ | ] | ^ | _--- decimal -> digit{digit}--- octal -> octit{octit}--- hexadecimal -> hexit{hexit}--- octit -> 0 | 1 | ... | 7--- hexit -> digit | A | ... | F | a | ... | f--- special -> ( | ) | , | ; | [ | ] | `| { | }--- Purpose of cleanupInputString: filter out template Haskell quotes-cleanupInputString :: String -> String-cleanupInputString s =- case s of- c:'\'':'\'':x:rest- | isSpace c && isUpper x -> -- TH type quote- c:x:cleanupInputString rest- c:'\'':'\'':d:rest- | not (isAlphaNum c) || not (isAlphaNum d)- -> c:'\'':'x':'\'':d:rest- '\'':rest ->- case characterLitRest rest of- Just (restLit, rest') ->- '\'':restLit ++ cleanupInputString rest'- Nothing ->- '\'':cleanupInputString rest- c:'\'':x:rest -- TH name quote- | isSpace c && isNothing (characterLitRest (x:rest)) && isLower x ->- c:x:cleanupInputString rest- c:rest- | not (isSpace c) ->- case span (== '\'') rest of- (quotes, rest') -> c : quotes ++ cleanupInputString rest'- c:rest -> c : cleanupInputString rest- [] -> []- where- characterLitRest s = -- expects that before the s there is a '- case s of- '\\':'\'':'\'':rest -> Just ("\\''", rest) -- '\''- c:'\'':rest -> Just (c:"'", rest) -- regular character lit- '\\':rest ->- case span (/= '\'') rest of- (esc,'\'':rest) ->- Just (('\\':esc) ++ "'", rest)- _ -> Just (s, "") -- should not happen- _ -> Nothing--cleanupInputStringTest =- do flip mapM_ untouched $ \s ->- let cleanedUp = cleanupInputString s- in if s /= cleanedUp- then assertFailure ("Cleanup of " ++ show s ++ " is wrong: " ++ show cleanedUp ++- ", expected that input and output are the same")- else return ()- flip mapM_ touched $ \(input, output) ->- let cleanedUp = cleanupInputString input- in if output /= cleanedUp- then assertFailure ("Cleanup of " ++ show input ++ " is wrong: " ++ show cleanedUp- ++ ", expected " ++ show output)- else return ()- where- untouched = [" '0'", " '\\''", " ' '", " '\o761'", " '\BEL'", " '\^@' ", "' '", "fixed' ' '"]- touched = [(" 'foo abc", " foo abc"), (" ''T ", " T ")]--type LocToken = (Token,(Loc,String))--data Loc- = Loc- { l_file :: FilePath- , l_line :: Int- , l_column :: Int- }- deriving (Eq, Show)---- token stream should not contain whitespace-fixPositions :: FilePath -> [PosToken] -> [LocToken]-fixPositions originalFileName = loop Nothing- where- loop mPragma toks =- case toks of- [] -> []- (Varsym, (pos, "#")) : (Varid, (_, "line")) : (IntLit, (_, lineNo)) : (StringLit,(_, fileName)) : rest- | column pos == 1 ->- map (\(tt, (pos, x)) -> (tt, (fixPos Nothing pos, x))) (take 4 toks) ++- loop (Just (line pos, fileName, read lineNo)) rest- (tt, (pos, x)) : rest ->- (tt, (fixPos mPragma pos, x)) : loop mPragma rest- fixPos mPragma pos =- case mPragma of- Nothing ->- Loc { l_column = column pos- , l_file = originalFileName- , l_line = line pos- }- Just (lineActivated, fileName, lineNo) ->- let offset = line pos - lineActivated - 1- in Loc { l_column = column pos- , l_file = fileName- , l_line = lineNo + offset- }--fixPositionsTest :: IO ()-fixPositionsTest =- let toks = concatMap (\(f, i) -> f i)- (zip [tok, linePragma "bar" 10, tok, tok, linePragma "foo" 99, tok] [1..])- fixedToks = fixPositions origFileName toks- expectedToks = concat $- [tok' origFileName 1- ,linePragma' "bar" 10 2- ,tok' "bar" 10- ,tok' "bar" 11- ,linePragma' "foo" 99 5- ,tok' "foo" 99]- in assertEqual (show expectedToks ++ "\n\n /= \n\n" ++ show toks) expectedToks fixedToks- where- origFileName = "spam"- tok line = [(Varid, (Pos 0 line 1, "_"))]- linePragma fname line lineHere =- let pos = Pos 0 lineHere 1- in [(Varsym, (pos, "#"))- ,(Varid, (pos, "line"))- ,(IntLit, (pos, show line))- ,(StringLit, (pos, fname))]- tok' fname line =- let loc = Loc fname line 1- in [(Varid, (loc, "_"))]- linePragma' fname line lineHere =- let loc = Loc origFileName lineHere 1- in [(Varsym, (loc, "#"))- ,(Varid, (loc, "line"))- ,(IntLit, (loc, show line))- ,(StringLit,(loc, fname))]--analyze :: FilePath -> String -> ModuleInfo+analyze :: FilePath -> String -> IO (ModuleInfo, [WordStyle], [(Posn,String)]) analyze originalFileName input =- poorManAnalyzeTokens (fixPositions originalFileName (cleanupTokens (lexerPass0 (cleanupInputString input))))+ do xs <- runCpphsPass1 cpphsOptions originalFileName input+ let bopts = boolopts cpphsOptions+ toks = tokenise (stripEol bopts) (stripC89 bopts) (ansi bopts) (lang bopts) ((newfile "preDefined",""):xs)+ mi = poorManAnalyzeTokens toks+ return (mi, toks, xs) analyzeTests = [(unlines ["module FOO where"@@ -414,7 +281,7 @@ ,"deriveSafeCopy 1 'base ''T" ,"$(deriveSafeCopy 2 'extension ''T)" ,"test_blub test_foo = 1"- ,"test_blah test_foo = 1"+ ,"test_blah test_foo = '\''" ,"prop_abc prop_foo = 2" ,"prop_xyz = True"] ,ModuleInfo { mi_htfPrefix = ""@@ -474,25 +341,36 @@ do mapM_ runTest (zip [1..] analyzeTests) where runTest (i, (src, mi)) =- let givenMi = analyze "<input>" src- in if givenMi == mi+ do (givenMi, _, _) <- analyze "<input>" src+ if givenMi == mi then return () else assertFailure ("Error in test " ++ show i ++ ", expected:\n" ++ show mi ++ "\nGiven:\n" ++ show givenMi ++ "\nSrc:\n" ++ src) -transform :: Bool -> Bool -> FilePath -> String -> IO String-transform hunitBackwardsCompat debug originalFileName input =- let info = analyze originalFileName fixedInput- in preprocess info+cpphsOptions :: CpphsOptions+cpphsOptions =+ defaultCpphsOptions {+ boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell+ }++data TransformOptions = TransformOptions { debug :: Bool+ , literateTex :: Bool }++transform :: TransformOptions -> FilePath -> String -> IO String+transform (TransformOptions debug literateTex) originalFileName input =+ do (info, toks, pass1) <- analyze originalFileName fixedInput+ preprocess info toks pass1 where- preprocess :: ModuleInfo -> IO String- preprocess info =- do when debug $ hPutStrLn stderr ("Module info:\n" ++ show info)- preProcessedInput <- runCpphs (cpphsOptions info) originalFileName- fixedInput- return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+ preprocess info toks pass1 =+ do when debug $+ do hPutStrLn stderr ("Tokens: " ++ show toks)+ hPutStrLn stderr ("Module info:\n" ++ show info)+ let opts = mkOptionsForModule info+ preProcessedInput <-+ runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1+ return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n" -- fixedInput serves two purposes: -- 1. add a trailing \n -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'@@ -504,14 +382,15 @@ case parseCppLineInfoOut s of Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName _ -> s- cpphsOptions :: ModuleInfo -> CpphsOptions- cpphsOptions info =+ mkOptionsForModule :: ModuleInfo -> CpphsOptions+ mkOptionsForModule info = defaultCpphsOptions { defines = defines defaultCpphsOptions ++- assertDefines hunitBackwardsCompat (mi_htfPrefix info) ++ nameDefines info , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell }+ possiblyWrap :: Bool -> String -> String+ possiblyWrap b s = if b then "\\begin{code}\n" ++ s ++ "\\end{code}" else s additionalCode :: ModuleInfo -> String additionalCode info = thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++@@ -575,6 +454,4 @@ _ -> Nothing preprocessorTests =- [("testAnalyze", testAnalyze)- ,("fixPositionsTest", fixPositionsTest)- ,("cleanupInputStringTest", cleanupInputStringTest)]+ [("testAnalyze", testAnalyze)]
Test/Framework/Pretty.hs view
@@ -1,4 +1,21 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}+--+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA+-- {- | @@ -19,7 +36,12 @@ where +#if MIN_VERSION_base(4,11,0)+-- Text.PrettyPrint exports (<>) conflicting with newer Prelude.+import Text.PrettyPrint hiding ((<>))+#else import Text.PrettyPrint+#endif -- | A type class for pretty-printable things. -- Minimal complete definition: @pretty@.
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
@@ -1,8 +1,12 @@-{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances,- ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -33,6 +37,7 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs, withQCArgs, WithQCArgs, setReplayFromString,+ QCAssertion, -- * Pending properties qcPending,@@ -58,9 +63,6 @@ import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef-#if MIN_VERSION_QuickCheck(2,7,0)-import System.Random-#endif import Test.QuickCheck #if !MIN_VERSION_QuickCheck(2,7,0)@@ -147,21 +149,32 @@ Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) -> case () of _| pendingPrefix `List.isPrefixOf` reason ->- let pendingMsg = let s = drop (length pendingPrefix) reason- in take (length s - length pendingSuffix) s+ let pendingMsg = getPayload pendingPrefix pendingSuffix reason in quickCheckTestPending pendingMsg- | otherwise ->- let replay = "Replay argument: " ++ (show (show (Just (gen, size))))- out = adjustOutput msg- in quickCheckTestFail (Just (out ++ "\n" ++ replay))+ | failurePrefix `List.isPrefixOf` reason+ , Just result <- readM (getPayload failurePrefix failureSuffix reason)+ -> failHTF result+ | otherwise ->+ let replay = "Replay argument: " ++ (show (show (Just (gen, size))))+ out = adjustOutput msg+ in quickCheckTestFail (Just (out ++ "\n" ++ replay)) Right (GaveUp { output=msg }) -> quickCheckTestFail (Just (adjustOutput msg)) Right (NoExpectedFailure { output=msg }) -> quickCheckTestFail (Just (adjustOutput msg))+#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)+ Right (InsufficientCoverage { output=msg }) ->+ quickCheckTestFail (Just (adjustOutput msg))+#endif return () where pendingPrefix = "Exception: 'QCPendingException \"" pendingSuffix = "\"'"+ failurePrefix = "Exception: 'HTFFailure "+ failureSuffix = "'"+ getPayload pref suf reason =+ let s = drop (length pref) reason+ in take (length s - length suf) s adjustOutput s = trimTrailing $ case s of '+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest@@ -184,11 +197,11 @@ argsModifier :: a -> (Args -> Args) testable :: a -> AnyTestable -instance Testable a => QCAssertion a where+instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where argsModifier _ = id testable = AnyTestable -instance Testable a => QCAssertion (WithQCArgs a) where+instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where argsModifier (WithQCArgs f _) = f testable (WithQCArgs _ x) = AnyTestable x @@ -221,12 +234,9 @@ Nothing -> error ("Could not parse replay parameter from string " ++ show str) #else -- Starting with QC 2.7 the type of the replay field changed from- -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int'+ -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)' case readM str of Just x -> args { replay = x } Nothing ->- case readM str of- Just (_ :: Maybe (StdGen, Int)) ->- error ("Your replay parameter has been produced with QuickCheck <= 2.6. It cannot be used with QuickCheck >= 2.7")- Nothing -> error ("Could not parse replay parameter from string " ++ show str)+ error ("Could not parse replay parameter from string " ++ show str) #endif
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. -} @@ -37,11 +39,16 @@ -- * Organzing tests TestableHTF,+ WrappableHTF(..), makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, + flattenTest,++ -- * Tests (for internal use)+ wrappableTests ) where import Control.Monad.RWS@@ -67,6 +74,7 @@ import Test.Framework.ThreadPool import Test.Framework.History +import qualified Test.HUnit as HU -- | Construct a test where the given 'Assertion' checks a quick check property. -- Mainly used internally by the htfpp preprocessor. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test@@ -100,6 +108,26 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') +-- | Kind of specialised 'Functor' type class for tests, which allows you to+-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any+-- test code.+--+-- E.g. if you want to add timeouts to all tests of a module, you could write:+--+-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded"+-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests+class WrappableHTF t where+ wrap :: (Assertion -> Assertion) -> t -> t++instance WrappableHTF TestSuite where+ wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests+ wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests++instance WrappableHTF Test where+ wrap wrapper (BaseTest ts tid loc topt assertion) =+ BaseTest ts tid loc topt (wrapper assertion)+ wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite+ -- | A type class for things that can be run as tests. -- Mainly used internally. class TestableHTF t where@@ -218,23 +246,34 @@ pre = reportTestStart ft action _ = let run = performTestHTF (wto_payload (ft_payload ft))- in case maxRunTime tc ft of- Nothing ->- do (res, time) <- measure run- return (PrimTestResultNoTimeout res, time)- Just maxMs ->- do mx <- timeout (1000 * maxMs) $ measure run- case mx of- Nothing -> return (PrimTestResultTimeout, maxMs)- Just (res, time) ->- return (PrimTestResultNoTimeout res, time)+ runWithTimeout =+ case maxRunTime tc ft of+ Nothing ->+ do (res, time) <- measure run+ return (PrimTestResultNoTimeout res, time)+ Just maxMs ->+ do mx <- timeout (1000 * maxMs) $ measure run+ case mx of+ Nothing -> return (PrimTestResultTimeout, maxMs)+ Just (res, time) ->+ return (PrimTestResultNoTimeout res, time)+ isPass primTestRes =+ case primTestRes of+ PrimTestResultNoTimeout fullTestRes ->+ ftr_result fullTestRes == Just Pass+ PrimTestResultTimeout -> False+ iterRunWithTimeout i =+ do (primTestRes, time) <- runWithTimeout+ if isPass primTestRes && i >= 2+ then iterRunWithTimeout (i-1)+ else return (primTestRes, time)+ in iterRunWithTimeout (tc_repeat tc) post excOrResult = let (testResult, time) = case excOrResult of Left exc -> (FullTestResult- { ftr_location = Nothing- , ftr_callingLocations = []+ { ftr_stack = emptyHtfStack , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc) , ftr_result = Just Error }@@ -243,8 +282,7 @@ case res of PrimTestResultTimeout -> (FullTestResult- { ftr_location = Nothing- , ftr_callingLocations = []+ { ftr_stack = emptyHtfStack , ftr_message = Just $ colorize warningColor "timeout" , ftr_result = Nothing }@@ -260,12 +298,10 @@ Just x -> (x, False) Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True) rr = FlatTest- { ft_sort = ft_sort ft , ft_path = ft_path ft , ft_location = ft_location ft- , ft_payload = RunResult sumRes (ftr_location testResult)- (ftr_callingLocations testResult)+ , ft_payload = RunResult sumRes (ftr_stack testResult) (fromMaybe emptyColorString (ftr_message testResult)) time isTimeout }@@ -281,31 +317,31 @@ Fail -> DoStop Error -> DoStop -runAllFlatTests :: TestConfig -> [FlatTest] -> TR ()-runAllFlatTests tc tests' =- do reportGlobalStart tests- tc <- ask+runAllFlatTests :: [FlatTest] -> TR ()+runAllFlatTests tests' =+ do tc <- ask+ tests <- orderTests tc tests'+ reportGlobalStart tests case tc_threads tc of Nothing -> let entries = map (mkFlatTestRunner tc) tests in tp_run sequentialThreadPool entries Just i -> let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests- pentries' = map (mkFlatTestRunner tc) ptests+ pentries = map (mkFlatTestRunner tc) ptests sentries = map (mkFlatTestRunner tc) stests in do tp <- parallelThreadPool i- pentries <- if tc_shuffle tc- then liftIO (shuffleIO pentries')- else return pentries' tp_run tp pentries tp_run sequentialThreadPool sentries where- tests = sortTests tests'- sortTests ts =- if not (tc_sortByPrevTime tc)- then ts- else map snd $ List.sortBy compareTests (map (\t -> (historyKey t, t)) ts)- compareTests (t1, _) (t2, _) =+ orderTests tc ts+ | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts+ | tc_shuffle tc = shuffleTests ts+ | otherwise = return ts+ shuffleTests = liftIO . shuffleIO+ sortByPrevTime tc ts =+ map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts)+ compareTests tc (t1, _) (t2, _) = case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc))) (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc))) ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc)))@@ -381,6 +417,8 @@ _ -> return () storeHistory file history = BS.writeFile file (serializeTestHistory history)+ `Exc.catch` (\(e::Exc.IOException) ->+ hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e)) -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,@@ -406,7 +444,7 @@ startTime <- getCurrentTime ((_, s, _), time) <- measure $- runRWST (runAllFlatTests tc activeTests) tc initTestState+ runRWST (runAllFlatTests activeTests) tc initTestState let results = reverse (ts_results s) passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results@@ -457,3 +495,14 @@ htfMainWithArgs args tests = do ecode <- runTestWithArgs args tests exitWith ecode++testWrapCanCauseFailure :: IO ()+testWrapCanCauseFailure =+ do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest+ HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest+ where+ unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ())+ wrappedUnitTest = wrap wrapper unitTest+ wrapper test = HU.assertFailure "Fail" >> test++wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)]
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@@ -205,6 +218,7 @@ , tc_timeoutIsSuccess :: Bool -- ^ Do not regard timeout as an error , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run , tc_prevFactor :: Maybe Double -- ^ Maximum factor a single test is allowed to run slower than its previous execution+ , tc_repeat :: Int -- ^ Number of times to repeat tests selected on the command line before reporting them as a success. } instance Show TestConfig where@@ -226,6 +240,7 @@ showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) . showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) . showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) .+ showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) . showString " }" -- | A 'TestReporter' provides hooks to customize the output of HTF.
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@@ -20,7 +23,7 @@ module Test.Framework.ThreadPool ( ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool- , threadPoolTest, threadPoolTestStop+ , threadPoolTest ) where @@ -39,7 +42,9 @@ type ThreadPoolEntry m a b = ( m a -- pre-action, must not throw exceptions , a -> IO b -- action- , Either Ex.SomeException b -> m StopFlag -- post-action, must not throw exceptions. If the result is DoStop, the thread pool is terminated asap.+ , Either Ex.SomeException b -> m StopFlag+ -- post-action, must not throw exceptions. If the result is+ -- DoStop, the thread pool is terminated asap. ) data ThreadPool m a b@@ -51,7 +56,7 @@ parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) parallelThreadPool n =- do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+ do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) return (ThreadPool (runParallel n)) runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m ()@@ -88,7 +93,7 @@ runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () runParallel _ [] = return () runParallel n entries =- do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+ do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n)) fromWorker <- liftIO $ newNamedChan "fromWorker" let nWorkers = min n (length entries) toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers]@@ -184,7 +189,7 @@ runTestParallel :: Int -> Int -> IO () runTestParallel nEntries n =- do putStrLn ("Running test " ++ show n)+ do debug ("Running test " ++ show n) boxes <- mapM (\i -> do mvar <- newEmptyNamedMVar ("testbox" ++ show i) return (mvar, i)) [1..nEntries]@@ -193,7 +198,7 @@ debug ("Checking boxes in test " ++ show n) --runSequentially entries mapM_ assertBox boxes- putStrLn ("Test " ++ show n ++ " successful")+ debug ("Test " ++ show n ++ " successful") where mkEntry (mvar, i) = let pre = myThreadId@@ -225,33 +230,3 @@ mapM (runTestParallel nEntries) [i..j] `Ex.catch` (\(e::Ex.BlockedIndefinitelyOnMVar) -> fail ("main-thread blocked " ++ show e))--threadPoolTestStop =- do putStrLn ("Running test to see of STOP works")- boxesAndEntries <- mapM mkEntry [1..100]- let (boxes, entries) = unzip boxesAndEntries- runParallel numberOfThreads entries- debug ("Checking boxes...")- mapM_ checkBox (zip [1..] boxes)- putStrLn ("Test for STOP successful")- where- mkEntry i =- do mvar <- newEmptyNamedMVar ("box-" ++ show i)- let pre = return ()- action () =- do putNamedMVar mvar ()- return ()- post _exc = return (if i >= numberOfThreads then DoStop else DoNotStop)- return (mvar, (pre, action, post))- numberOfThreads = 10- checkBox (i, (name, box)) =- do isEmpty <- isEmptyMVar box- if isEmpty- then if i > 20- then return ()- else if i <= 10- then fail ("Box " ++ name ++ " is still empty")- else return ()- else if i > 20- then fail ("Box " ++ name ++ " not empty")- else return ()
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 == 4.*, HTF == 0.10.*- Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-is: Tutorial.hs+ Build-depends: base, HTF+ Build-tool-depends: HTF:htfpp+ Default-language: Haskell2010 @ Compiling the program just shown (you must include the code for@@ -207,7 +292,7 @@ split the tests into several modules. For example, suppose your library contains of two modules @MyPkg.A@ and @MyPkg.B@, each containing test functions. You can find a slightly extended of this scenario in the samples directory-of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>.)+of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>. File @MyPkg/A.hs@ @@ -243,9 +328,9 @@ For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules' testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a-preprocessor token @thisModulesTests@ as a shorthand for this variable.+preprocessor token @htf_thisModulesTests@ as a shorthand for this variable. Thus, to expose all HTF tests defined in @MyPkg.A@, we only-need to put @thisModulesTests@ into the export list. The same holds+need to put @htf_thisModulesTests@ into the export list. The same holds analogously for module @MyPkg.B@. To execute all tests defined in these two modules, you would create@@ -263,7 +348,6 @@ module Main where import Test.Framework-import Test.Framework.BlackBoxTest import {-@ HTF_TESTS @-} MyPkg.A import {-@ HTF_TESTS @-} MyPkg.B @@ -274,10 +358,14 @@ -- * Machine-readable output +-- ** JSON+ {- | For better integration with your testing environment, HTF provides the ability to produce-machine-readable output in JSON format. Here is a short example how the JSON output looks like,+machine-readable output in JSON format. The output is produced incrementally, line by line.++Here is a short example how the JSON output looks like, for details see "Test.Framework.JsonOutput": @@ -309,62 +397,44 @@ -} --- * Backwards-compatibility with HUnit--{- |-The types of the various @assert@-like macros of the HTF are not backwards-compatible-with the corresponding functions of HUnit. This incompatibility is intentional, of course:-with HUnit, the programmer has to provide suitable location information by explicitly-passing a string argument to the @assert@-like functions, whereas HTF provides-location information implicitly through its pre-processor @htfpp@.--To simplify transition from HUnit to HTF, @htfpp@ provides a commandline flag-@--hunit@. This flag causes @htfpp@ to exand the assertion macros in a way compatible-with the types of the corresponding HUnit functions. For example, with the @--hunit@-flag being present, @assertEqual@ is exanded to-@'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type-@(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with-the type of HUnit's 'Test.HUnit.Base.assertEqual' function.---}---- * Summary--{- |+-- ** XML -Here is a quick summary of how to write, collect, and execute your tests.-You should also have a look at the sample project at-<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 =
− run-all-tests-for-all-compilers.sh
@@ -1,40 +0,0 @@-#!/bin/bash--compilers=$(gawk -F == '/GHC==/ {print $2}' HTF.cabal | tr -d ,)--for x in $compilers-do- switch-ghc $x > /dev/null- ghc_version=$(ghc --version | sed -E 's/.*version ([.0-9]*)/\1/g')- if [ "$x" != "$ghc_version" ]- then- echo "Could not switch to GHC version $x as requested, version is now $ghc_version"- exit 1- fi- echo- echo- echo "============================================================"- echo "============================================================"- echo "==> Running tests for GHC version $ghc_version <=="- echo "==> Running tests for GHC version $ghc_version <=="- echo "==> Running tests for GHC version $ghc_version <=="- echo "============================================================"- echo "============================================================"- echo- ./run-all-tests.sh- ecode=$?- if [ $ecode -eq 0 ]- then- result="ok"- else- result="FAIL"- fi- RESULT="$RESULT\nResult for GHC version $ghc_version: $result"- if [ $ecode -ne 0 ]- then- exit 1- fi-done--echo-echo -e $RESULT
− run-all-tests.sh
@@ -1,31 +0,0 @@-#!/bin/bash--SANDBOX_FILE="cabal.sandbox.config"-SANDBOX_DIR=".cabal-sandbox"--set -e-if [ -e "$SANDBOX_FILE" ]-then- have_sandbox=yes- cabal sandbox hc-pkg unregister HTF || true-else- have_sandbox=no- ghc-pkg unregister HTF || true-fi--cabal configure --enable-tests || exit 1-cabal build || exit 1-cabal test || exit 1-cabal install || exit 1--cd sample--if [ "$have_sandbox" == "yes" ]-then- rm -f cabal.sandbox.config- cabal sandbox init --sandbox ../"$SANDBOX_DIR"-fi--cabal configure --enable-tests || exit 1-cabal build || exit 1-cabal test || exit 1
sample/TestMain.hs view
@@ -9,5 +9,5 @@ import {-@ HTF_TESTS @-} MyPkg.B main =- do bbts <- blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs+ do bbts <- blackBoxTests "bbt-dir" "../scripts/run-sample" ".num" defaultBBTArgs htfMain (htf_importedTests ++ [makeTestSuite "bbts" bbts])
sample/sample-HTF.cabal view
@@ -1,6 +1,7 @@ name: sample-HTF version: 0.1.0.0 synopsis: Sample project showing how to use HTF+description: Sample project showing how to use HTF homepage: https://github.com/skogsbaer/HTF/ license: BSD3 license-file: LICENSE@@ -13,12 +14,14 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B- build-depends: base, HTF == 0.12.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B- build-depends: base, HTF == 0.12.*+ build-depends: base, HTF default-language: Haskell2010+ build-tool-depends: HTF:htfpp
+ scripts/check.sh view
@@ -0,0 +1,40 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+ echo "Checks that HTF compiles against all resolvers mentioned in .travis.yml"+ exit 1+fi++set -e++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)+TRAVIS="$TOP/.travis.yml"+if [ ! -e "$TRAVIS" ]; then+ echo "$TRAVIS does not exist!"+ exit 1+fi++YAMLS=$(grep '^- HTF_TEST_STACK_ARGS' "$TRAVIS" | sed 's/^.*="--stack-yaml //g; s/"$//g')++if [ -z "$TRAVIS_BUILD_DIR" ]; then+ export TRAVIS_BUILD_DIR="$TOP"+fi++for yaml in $YAMLS; do+ echo >&2+ eval yaml="$yaml" # evaluate variables contained in $yaml+ echo >&2 "Checking with $yaml ..."+ export HTF_TEST_STACK_ARGS="--stack-yaml $yaml"+ stack $HTF_TEST_STACK_ARGS build+ ecode=$?+ if [ $ecode -ne 0 ]; then+ echo >&2 "Build for $yaml failed!"+ exit 1+ fi+ stack $HTF_TEST_STACK_ARGS test+ ecode=$?+ if [ $ecode -ne 0 ]; then+ echo >&2 "Test for $yaml failed!"+ exit 1+ fi+done
+ scripts/dist.sh view
@@ -0,0 +1,50 @@+#!/bin/bash++if [ "$1" == "--help" ]; then+ echo "USAGE: $0 [--no-check]"+ echo "Creates an dist tarball and checks that it builds."+ exit 1+fi++no_check=no+if [ "$1" == "--no-check" ]; then+ no_check=yes+fi++version=$(gawk -F: '/^Version:/ { print $2 }' HTF.cabal | sed 's/ //g')++echo "Building version $version"++# Somehow, --test-tarball always because of a strange permission error. That's why+# we do the checks here by hand.++stack sdist . --no-test-tarball || exit 1+tarball=$(find $(pwd)/.stack-work/dist -name "*${version}.tar.gz" | xargs ls -t | head -1)++echo "Distribution tarball is $tarball"++tmp=$(mktemp -d)+tar -C "$tmp" -x -z -f "$tarball" || exit 1++if [ "$no_check" == "yes" ]; then+ echo "Skipping tests as requested"+else+ pushd "${tmp}/HTF-${version}" > /dev/null+ echo "Running checks in directory $(pwd)"+ scripts/check.sh || exit 1+ popd > /dev/null+fi++git_tag="release/${version}"+if ! git tag --points-at HEAD | grep -E "^$git_tag$" > /dev/null; then+ git tag "$git_tag" || exit 1+ echo "Tagged HEAD with $git_tag"+fi++echo+echo+echo 'All checks succeeded, now upload to archive using the following command:'+echo '$ stack upload . --no-test-tarball'+echo+echo 'And do not forget to push all tags:'+echo '$ git push --tags'
+ scripts/local-htfpp view
@@ -0,0 +1,36 @@+#!/bin/bash++TOP=$(cd $(dirname ${BASH_SOURCE[0]})/.. > /dev/null && pwd -P)++if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_TEST_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_TEST_STACK_YAML"+fi+if [ -z "$HTF_TEST_STACK_ARGS" -a ! -z "$HTF_STACK_YAML" ]; then+ HTF_TEST_STACK_ARGS="--stack-yaml $HTF_STACK_YAML"+fi++dist=$(stack $HTF_TEST_STACK_ARGS path --dist-dir 2> /dev/null)+find=find+if [ "$(uname)" == "Darwin" ]; then+ find=gfind+fi++function find_bin()+{+ local d="$TOP/$dist"+ if [ ! -d "$d" ]; then+ d="$(dirname $d)"+ fi+ bin=$($find "$d" -name htfpp -type f -executable -printf "%T+\t%p\n" | sort -r | head -1 | cut -f 2)+}++find_bin++if [ -z "$bin" ]; then+ echo "TOP=$TOP" >&2+ echo "dist=$dist" >&2+ echo "bin=$bin" >&2+ echo "No executable named htfpp found in $TOP/$dist. Aborting!" >&2+ exit 1+fi+"$bin" "$@"
+ 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!"
+ scripts/run-sample view
@@ -0,0 +1,3 @@+#!/bin/bash++stack exec sample -- "$@"
+ stack-ghc-8.10.yaml view
@@ -0,0 +1,4 @@+resolver: lts-18.28+flags: {}+packages:+- '.'
+ stack-ghc-8.2.yaml view
@@ -0,0 +1,5 @@+resolver: lts-11.22+flags: {}+packages:+- '.'+extra-deps: []
+ stack-ghc-8.4.yaml view
@@ -0,0 +1,6 @@+resolver: lts-12.26+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ stack-ghc-8.6.yaml view
@@ -0,0 +1,6 @@+resolver: lts-14.27+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.0
+ 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
@@ -0,0 +1,6 @@+resolver: lts-16.31+flags: {}+packages:+- '.'+extra-deps:+- haskell-src-1.0.3.1
tests/Foo/A.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} {-# LANGUAGE CPP #-} module Foo.A where
tests/Foo/B.hs view
@@ -1,7 +1,7 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Foo.B (htf_thisModulesTests) where import qualified Test.Framework as HTF -test_b_OK = assertEqual 1 1+test_b_OK = HTF.assertEqual 1 1
tests/MiscTest.hs view
@@ -21,10 +21,11 @@ import Test.Framework.Preprocessor import Test.Framework.PrettyHaskell import Test.Framework.HUnitWrapper+import Test.Framework.TestManager import System.Exit import Test.HUnit -allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests+allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests ++ hunitWrapperTests ++ wrappableTests main :: IO () main =
+ tests/Quasi.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+module Quasi where++import Language.Haskell.TH.Quote+import GHC.Exts (IsString(..))++q :: QuasiQuoter+q = QuasiQuoter exprQ undefined undefined undefined+ where+ exprQ =+ (\a -> [|fromString a|]) . filter (/= '\r')
tests/TestHTF.hs view
@@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} -- -- Copyright (c) 2005,2010 Stefan Wehr - http://www.stefanwehr.de --@@ -23,6 +29,7 @@ import Test.Framework.Location import Test.Framework.TestManager import Test.Framework.BlackBoxTest+import Test.Framework.TestInterface import System.Environment import System.Directory@@ -33,7 +40,12 @@ import System.IO.Temp import Control.Exception import Control.Monad-import qualified Data.HashMap.Strict as M++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif import qualified Data.HashSet as Set import qualified Data.Aeson as J import qualified Data.Aeson.Encode.Pretty as J@@ -46,7 +58,8 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.List as List import qualified Text.Regex as R-import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible+import GHC.Stack+ import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B @@ -56,7 +69,9 @@ import UniqTests1 import UniqTests2 import PrevFactor+import Repeat import SortByPrevTime+import Quasi import Tutorial hiding (main) @@ -71,6 +86,19 @@ handleExc :: a -> SomeException -> a handleExc x _ = x +-- 世界不是英文的 Test for #47++-- Test for #48+data HVect (ts :: [*]) where+ HNil :: HVect '[]+ HCons :: t -> HVect ts -> HVect (t ': ts)++fun :: HVect '[Int, Int] -> String+fun = undefined++-- Test for #45+foobar = [q|INSERT INTO a (name) VALUES ('')|]+ test_assertFailure_FAIL = assertFailure "I'm a failure" test_stringGap_OK = assertEqual stringGap "hello world!"@@ -125,6 +153,28 @@ (Literal 581)) (Variable "egg") +test_diff2_FAIL =+ assertEqual s1 s2+ where+ n = 100000+ s1 = mk [0..n]+ s2 = mk ([0..4999] ++ [5001..n])+ mk :: [Int] -> String+ mk [] = ""+ mk (x:[]) = "line " ++ show x+ mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs++test_diff3_FAIL =+ assertEqual s1 s2+ where+ n = 100000+ s1 = mk [0..n]+ s2 = mk [0..(n+1)]+ mk :: [Int] -> String+ mk [] = ""+ mk (x:[]) = "line " ++ show x+ mk (x:xs) = "line " ++ show x ++ "\n" ++ mk xs+ prop_ok_OK :: [Int] -> Property prop_ok_OK xs = classify (null xs) "trivial" $ xs == (reverse (reverse xs)) @@ -136,6 +186,11 @@ prop_exhaust_FAIL = False ==> True +prop_implies :: Int -> Property+prop_implies n = n <= 10 ==> (\i -> i + n <= i + 10)++prop_forAll = forAll (choose (0::Int, 10::Int)) (\i -> i < 11)+ prop_error_FAIL :: Bool prop_error_FAIL = error "Lisa" @@ -156,18 +211,20 @@ test_genericAssertions_OK = case test1 of AssertOk _ -> fail "did not expect AssertOk"- AssertFailed stack ->- do assertEqual 2 (length stack)- let [se1, se2] = stack- assertNothing (ase_message se1)- loc1 <- assertJust (ase_location se1)- _ <- assertJust (ase_message se2)- loc2 <- assertJust (ase_location se2)+ AssertFailed stack msg ->+ do assertEqualVerbose ("stack=" ++ show stack) 2 (length (htfStackToList stack))+ let [se1, se2] = htfStackToList stack+ loc1 = hse_location se1+ loc2 = hse_location se2 assertEqual (fileName loc1) (fileName loc2)- assertEqual (lineNumber loc1 + 1) (lineNumber loc2)+ assertEqual (lineNumber loc1) (line - 1)+ assertEqual (lineNumber loc2) (line - 3)+ assertNotEqual msg "" where- test1 = gsubAssert test2- test2 = gassertEqual 1 (2::Int)+ test1 = test2+ test2 :: (HasCallStack) => AssertBool ()+ test2 = gassertBool False+ line = __LINE__ -- find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_PENDING" | sed 's/test_//g; s/prop_//g' | sort -u pendingTests :: [T.Text]@@ -178,8 +235,7 @@ failedTests :: [T.Text] failedTests = -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_FAIL" | sed 's/test_//g; s/prop_//g' | sort -u- ["1_FAIL"- ,"a_FAIL"+ ["a_FAIL" ,"h_FAIL" ,"assertElem_FAIL" ,"assertEmpty_FAIL"@@ -193,6 +249,8 @@ ,"assertThrowsIO1_FAIL" ,"assertThrows_FAIL" ,"diff_FAIL"+ ,"diff2_FAIL"+ ,"diff3_FAIL" ,"error'_FAIL" ,"error_FAIL" ,"exhaust_FAIL"@@ -219,14 +277,15 @@ passedTests :: [T.Text] passedTests = -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_OK" | sed 's/test_//g; s/prop_//g' | sort -u- ["2_OK"- ,"assertSetEqualSuccess_OK"+ ["assertSetEqualSuccess_OK" ,"assertThrowsIO2_OK" ,"b_OK" ,"genericAssertions_OK" ,"ok'_OK" ,"ok_OK" ,"stringGap_OK"+ ,"implies"+ ,"forAll" -- $ find bbt -name '*ok*.x' | grep -v not_ok ,"bbt/should_fail/ok1.x" ,"bbt/should_fail/ok2.x"@@ -258,6 +317,12 @@ ,"location" .= J.object ["file" .= J.String "TestHTF.hs" ,"line" .= J.toJSON (107+lineOffset)]]) check jsons (J.object ["type" .= J.String "test-end"+ ,"test" .= J.object ["flatName" .= J.String "Main:diff2_FAIL"]])+ (J.object ["message" .= J.String "NOT:No newline at end of file"])+ check jsons (J.object ["type" .= J.String "test-end"+ ,"test" .= J.object ["flatName" .= J.String "Main:diff3_FAIL"]])+ (J.object ["message" .= J.String "NOT:No newline at end of file"])+ check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Foo.A:a_FAIL"]]) (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs" ,"line" .= J.toJSON (10::Int)]]@@ -271,15 +336,15 @@ ,"line" .= J.toJSON (9::Int)]]) check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Main:subAssert_FAIL"]])- (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null+ (J.object ["callers" .= J.toJSON [J.object ["message" .= J.String "I'm another sub" ,"location" .= J.object ["file" .= J.String "TestHTF.hs"- ,"line" .= J.toJSON (95+lineOffset)]]- ,J.object ["message" .= J.String "I'm another sub"+ ,"line" .= J.toJSON (97+lineOffset)]]+ ,J.object ["message" .= J.Null ,"location" .= J.object ["file" .= J.String "TestHTF.hs"- ,"line" .= J.toJSON (97+lineOffset)]]]])+ ,"line" .= J.toJSON (95+lineOffset)]]]]) where lineOffset :: Int- lineOffset = 12+ lineOffset = 40 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null@@ -292,11 +357,11 @@ ,"wallTime":11} -} case json of- J.Object objJson | Just (J.Object testObj) <- M.lookup "test" objJson- , Just (J.String flatName) <- M.lookup "flatName" testObj- , Just (J.String "test-end") <- M.lookup "type" objJson- , Just (J.String result) <- M.lookup "result" objJson- , Just (J.Bool to) <- M.lookup "timedOut" objJson ->+ J.Object objJson | Just (J.Object testObj) <- KM.lookup "test" objJson+ , Just (J.String flatName) <- KM.lookup "flatName" testObj+ , Just (J.String "test-end") <- KM.lookup "type" objJson+ , Just (J.String result) <- KM.lookup "result" objJson+ , Just (J.Bool to) <- KM.lookup "timedOut" objJson -> let shortName = let t = T.tail (T.dropWhile (/= ':') flatName) in if "tests/" `T.isPrefixOf` t@@ -333,20 +398,24 @@ matches json pred = case (json, pred) of (J.Object objJson, J.Object objPred) ->- M.foldrWithKey (\k vPred b ->- b && case M.lookup k objJson of+ KM.foldrWithKey (\k vPred b ->+ b && case KM.lookup k objJson of Just vJson -> matches vJson vPred Nothing -> False) True objPred (J.String strJson, J.String strPred) ->- regexMatches (mkRegex strPred) strJson+ regexMatches strPred strJson (arrJson@(J.Array _), arrPred@(J.Array _)) -> let J.Success (listJson :: [J.Value]) = J.fromJSON arrJson J.Success (listPred :: [J.Value]) = J.fromJSON arrPred in length listJson == length listPred && all (\(x, y) -> matches x y) (zip listJson listPred) _ -> json == pred- regexMatches r s = isJust $ R.matchRegex r (T.unpack s)+ regexMatches pred t =+ let s = T.unpack t+ in case T.unpack pred of+ 'N':'O':'T':':':rest -> isNothing $ R.matchRegex (mkRegex (T.pack rest)) s+ _ -> isJust $ R.matchRegex (mkRegex pred) s mkRegex s = R.mkRegexWithOpts (T.unpack s) True False splitJson bsl = if BSL.null bsl@@ -362,13 +431,13 @@ T.unpack $ T.decodeUtf8With T.lenientDecode $ BSL.toStrict $- J.encodePretty' (J.Config 2 J.compare) json+ J.encodePretty' J.defConfig json runRealBlackBoxTests = do b <- doesDirectoryExist "tests/bbt" let dirPrefix = if b then "tests" else "" bbts <- blackBoxTests (dirPrefix </> "real-bbt") ("/bin/bash") ".sh"- (defaultBBTArgs { bbtArgs_verbose = False })+ (defaultBBTArgs { bbtArgs_verbose = True }) ecode <- runTest bbts case ecode of ExitFailure _ -> fail ("real blackbox tests failed!")@@ -382,7 +451,7 @@ (defaultBBTArgs { bbtArgs_verbose = False }) let tests = [addToTestSuite htf_thisModulesTests bbts] ++ htf_importedTests when ("--help" `elem` args || "-h" `elem` args) $- do hPutStrLn stderr ("USAGE: dist/build/test/test [--direct]")+ do hPutStrLn stderr ("USAGE: PROG [--direct]") ecode <- runTestWithArgs ["--help"] ([] :: [Test]) exitWith ecode case args of@@ -390,6 +459,7 @@ "MaxCurTime.hs":rest -> maxCurTimeMain rest "MaxPrevTime.hs":rest -> maxPrevTimeMain rest "PrevFactor.hs":rest -> prevFactorMain rest+ "Repeat.hs":rest -> repeatMain rest "SortByPrevTime.hs":rest -> sortByPrevTimeMain rest "UniqTests1.hs":rest -> uniqTests1Main rest "UniqTests2.hs":rest -> uniqTests2Main rest@@ -402,7 +472,7 @@ _ -> do withSystemTempFile "HTF-out" $ \outFile h -> do hClose h- ecode <- runTestWithArgs ["-j4", "--deterministic",+ ecode <- runTestWithArgs ["-j4", "--shuffle=false", "--json", "--output-file=" ++ outFile] tests case ecode of ExitFailure _ -> checkOutput outFile@@ -410,5 +480,3 @@ `onException` (do s <- readFile outFile hPutStrLn stderr s) runRealBlackBoxTests- ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")- exitWith ecode
− tests/TestHTFHunitBackwardsCompatible.hs
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp -optF --hunit #-}-module TestHTFHunitBackwardsCompatible where--import Test.Framework--test_1_FAIL = do assertEqual "1 == 2" 1 2- assertEqualHTF 1 1--test_2_OK = do assertJust "foo" (Just 1)- assertJustHTF (Just 1)
tests/ThreadPoolTest.hs view
@@ -31,7 +31,6 @@ [x] -> return (read x, 100) [x, y] -> return (read x, read y) _ -> usage- threadPoolTestStop threadPoolTest (1, i) nEntries return () where
tests/Tutorial.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module Tutorial where import System.Environment ( getArgs )
tests/compile-errors/Test1.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int
tests/compile-errors/Test2.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework #include "Foo.h" foo :: Int -> Int foo i = i + "Stefan"
tests/compile-errors/Test3.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework -- error must be in line 7 test_foo :: Int
tests/compile-errors/Test4.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -F -pgmF ../../dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ../../scripts/local-htfpp #-} -import Test.Framework+import "HTF" Test.Framework data D = D -- error must be in line 7 prop_foo :: D -> Bool
tests/compile-errors/run-tests.sh view
@@ -2,32 +2,27 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package base -package-db ../../dist/package.conf.inplace -package HTF --make"-SANDBOX_FILE="../../cabal.sandbox.config"-SANDBOX_DIR="../../.cabal-sandbox"-GHC_VERSION=$(ghc --version | sed 's/.*version //g')--if [ -e "$SANDBOX_FILE" ]-then- for pkg_db in $(ls -d -1 $SANDBOX_DIR/*$GHC_VERSION*-packages.conf.d)- do- FLAGS="$FLAGS -package-db $pkg_db"- done-fi-echo $FLAGS- lineno=7 function check() { test="$1"- ghc $FLAGS "$test" 2>&1 | grep "$test":$lineno+ echo "Running test $test ..."+ command -v grep >/dev/null 2>&1 || \+ { echo >&2 "Test $0 requires ``grep'' but it's not installed. Aborting."; exit 1; }+ compile_cmd="stack $HTF_TEST_STACK_ARGS ghc --package HTF -- -XPackageImports $test"+ $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null grep_ecode=${PIPESTATUS[1]} if [ "$grep_ecode" != "0" ] then echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"- ghc $FLAGS "$test"+ echo "Compile command: $compile_cmd"+ echo "Stack version: $(stack --version)"+ echo "GHC version: $(stack $HTF_TEST_STACK_ARGS ghc -- --version)"+ echo "Here is the output of the compiler:"+ $compile_cmd exit 1 fi+ echo "Done with test $test" } check Test1.hs
tests/real-bbt/FailFast.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-} module FailFast (failFastMain) where import Test.Framework
tests/real-bbt/MaxCurTime.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxCurTime (maxCurTimeMain) where import Test.Framework
tests/real-bbt/MaxPrevTime.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module MaxPrevTime (maxPrevTimeMain) where import Test.Framework
tests/real-bbt/PrevFactor.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module PrevFactor (prevFactorMain) where import Test.Framework
+ tests/real-bbt/Repeat.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -F -pgmF ./scripts/local-htfpp #-}+module Repeat (repeatMain) where++import Test.Framework++import Data.IORef+import System.IO.Unsafe++globalBool :: IORef Bool+globalBool = unsafePerformIO (newIORef True)+{-# NOINLINE globalBool #-}++readGlobalBool :: IO Bool+readGlobalBool =+ do b <- readIORef globalBool+ writeIORef globalBool False+ return b++test_globalMVarIsTrue =+ do b <- readGlobalBool+ assertEqual b True++repeatMain args = htfMainWithArgs args htf_thisModulesTests
tests/real-bbt/SortByPrevTime.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module SortByPrevTime (sortByPrevTimeMain) where import Test.Framework
tests/real-bbt/UniqTests1.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests1 (uniqTests1Main) where import Test.Framework
tests/real-bbt/UniqTests2.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+{-# OPTIONS_GHC -F -pgmF scripts/local-htfpp #-} module UniqTests2 (uniqTests2Main) where import Test.Framework