diff --git a/HUnit.cabal b/HUnit.cabal --- a/HUnit.cabal +++ b/HUnit.cabal @@ -1,10 +1,10 @@ Name: HUnit -Version: 1.2.5.2 +Version: 1.3.0.0 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE Author: Dean Herington -Maintainer: hunit@richardg.name +Maintainer: Simon Hengel Stability: stable Homepage: http://hunit.sourceforge.net/ Category: Testing @@ -12,48 +12,41 @@ Description: HUnit is a unit testing framework for Haskell, inspired by the JUnit tool for Java, see: . -Tested-With: - GHC == 7.4.1 - GHC == 7.4.2 - GHC == 7.7 Build-Type: Simple -Extra-Source-Files: - HUnit.cabal.hugs - HUnit.cabal.tests - Setup.hs.hugs - tests/HUnitTests.hs - tests/HUnitTestBase.lhs - tests/HUnitTestExtended.hs - tests/HUnitTestOptimize.hs - tests/TerminalTest.hs Data-Files: doc/Guide.html examples/Example.hs prologue.txt - README + README.md source-repository head - type: darcs - location: http://code.haskell.org/HUnit/ - -flag base4 + type: git + location: https://github.com/hspec/HUnit Library - Build-Depends: - base < 5, + Build-Depends: + base == 4.*, deepseq - if flag(base4) - Build-Depends: base >= 4 - CPP-Options: -DBASE4 - GHC-Options: -Wall - else - Build-Depends: base < 4 - if impl(ghc >= 6.10) - Build-Depends: base >= 4 Exposed-Modules: Test.HUnit.Base, Test.HUnit.Lang, Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit - Extensions: CPP + GHC-Options: -Wall + +Test-Suite tests + Type: exitcode-stdio-1.0 + Main-Is: HUnitTests.hs + HS-Source-Dirs: tests + Build-Depends: + base == 4.*, + deepseq, + filepath, + HUnit + Other-Modules: + HUnitTests + HUnitTestBase + HUnitTestExtended + TerminalTest + GHC-Options: -Wall diff --git a/HUnit.cabal.hugs b/HUnit.cabal.hugs deleted file mode 100644 --- a/HUnit.cabal.hugs +++ /dev/null @@ -1,20 +0,0 @@ -Name: HUnit -Version: 1.2.5.0 -License: BSD3 -License-File: LICENSE -Author: Dean Herington -Homepage: http://hunit.sourceforge.net/ -Category: Testing -Build-Depends: base -Synopsis: A unit testing framework for Haskell -Description: - HUnit is a unit testing framework for Haskell, inspired by the - JUnit tool for Java, see: . -Exposed-Modules: - Test.HUnit.Base, - Test.HUnit.Lang, - Test.HUnit.Terminal, - Test.HUnit.Text, - Test.HUnit -Extensions: CPP -Hugs-Options: -98 diff --git a/HUnit.cabal.tests b/HUnit.cabal.tests deleted file mode 100644 --- a/HUnit.cabal.tests +++ /dev/null @@ -1,122 +0,0 @@ --- This CABAL file is used to build and run all of the various tests for the --- project. This separate file is necessary because Hackage does not allow --- the optimization level to be specified when building executables and some --- tests require different optimization levels to be set. --- --- To use this file, simply copy it to HUnit.cabal, then build as normal. You --- may rename the existing version of HUnit.cabal first, if you like. -Name: HUnit -Version: 1.2.5.2 -Cabal-Version: >= 1.8 -License: BSD3 -License-File: LICENSE -Author: Dean Herington -Maintainer: hunit@richardg.name -Stability: stable -Homepage: http://hunit.sourceforge.net/ -Category: Testing -Synopsis: A unit testing framework for Haskell -Description: - HUnit is a unit testing framework for Haskell, inspired by the - JUnit tool for Java, see: . -Tested-With: - GHC == 7.4.1 - GHC == 7.4.2 - GHC == 7.7 -Build-Type: Simple -Extra-Source-Files: - HUnit.cabal.hugs - HUnit.cabal.tests - Setup.hs.hugs - tests/HUnitTests.hs - tests/HUnitTestBase.lhs - tests/HUnitTestExtended.hs - tests/HUnitTestOptimize.hs - tests/TerminalTest.hs -Data-Files: - doc/Guide.html - examples/Example.hs - prologue.txt - README - -source-repository head - type: darcs - location: http://code.haskell.org/HUnit/ - -flag base4 - -Library - Build-Depends: - base < 5, - deepseq - if flag(base4) - Build-Depends: base >= 4 - CPP-Options: -DBASE4 - GHC-Options: -Wall - else - Build-Depends: base < 4 - if impl(ghc >= 6.10) - Build-Depends: base >= 4 - Exposed-Modules: - Test.HUnit.Base, - Test.HUnit.Lang, - Test.HUnit.Terminal, - Test.HUnit.Text, - Test.HUnit - Extensions: CPP - -Test-Suite hunit-tests-optimize-0 - Type: exitcode-stdio-1.0 - Main-Is: HUnitTests.hs - HS-Source-Dirs: . tests - Build-Depends: - base < 5, - deepseq, - filepath - GHC-Options: -O0 - if flag(base4) - Build-Depends: base >= 4 - CPP-Options: -DBASE4 -DO0 - GHC-Options: -Wall - else - Build-Depends: base < 4 - if impl(ghc >= 6.10) - Build-Depends: base >= 4 - Extensions: CPP - -Test-Suite hunit-tests-optimize-1 - Type: exitcode-stdio-1.0 - Main-Is: HUnitTests.hs - HS-Source-Dirs: . tests - Build-Depends: - base < 5, - deepseq - GHC-Options: -O1 - if flag(base4) - Build-Depends: base >= 4 - CPP-Options: -DBASE4 -DO1 - GHC-Options: -Wall - else - Build-Depends: base < 4 - if impl(ghc >= 6.10) - Build-Depends: base >= 4 - Extensions: CPP - -Test-Suite hunit-tests-optimize-2 - Type: exitcode-stdio-1.0 - Main-Is: HUnitTests.hs - HS-Source-Dirs: . tests - Build-Depends: - base < 5, - deepseq - GHC-Options: -O2 - if flag(base4) - Build-Depends: base >= 4 - CPP-Options: -DBASE4 -DO2 - GHC-Options: -Wall - else - Build-Depends: base < 4 - if impl(ghc >= 6.10) - Build-Depends: base >= 4 - Extensions: CPP - diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,12 +0,0 @@ -HUnit is a unit testing framework for Haskell, inspired by the JUnit -tool for Java. HUnit is free software; see its "License" file for -details. HUnit is available at . - -HUnit 1.1.1 consists of a number of files. Besides Haskell source files -in Test/HUnit (whose names end in ".hs" or ".lhs"), these files include: - - * README -- this file - * doc/Guide.html -- user's guide, in HTML format - * LICENSE -- license for use of HUnit - -See the user's guide for more information. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# HUnit + +HUnit is a unit testing framework for Haskell, inspired by the JUnit +tool for Java. HUnit is free software; see its "License" file for +details. HUnit is available at . + +HUnit 1.1.1 consists of a number of files. Besides Haskell source files +in Test/HUnit (whose names end in ".hs" or ".lhs"), these files include: + +``` + * README.md -- this file + * doc/Guide.html -- user's guide, in HTML format + * LICENSE -- license for use of HUnit +``` + +See the user's guide for more information. + +## Changes + +### 1.3.0.0 + +- removed support for old compilers + +- add source locations for failing assertions (GHC >= 7.10.2 only) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.hs.hugs b/Setup.hs.hugs deleted file mode 100644 --- a/Setup.hs.hugs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runghc -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Test/HUnit.hs b/Test/HUnit.hs --- a/Test/HUnit.hs +++ b/Test/HUnit.hs @@ -1,80 +1,80 @@ --- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool --- for Java. This guide describes how to use HUnit, assuming you are familiar --- with Haskell, though not necessarily with JUnit. --- --- In the Haskell module where your tests will reside, import module --- @Test.HUnit@: --- --- @ --- import Test.HUnit --- @ --- --- Define test cases as appropriate: --- --- @ --- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3)) --- test2 = TestCase (do (x,y) <- partA 3 --- assertEqual "for the first result of partA," 5 x --- b <- partB y --- assertBool ("(partB " ++ show y ++ ") failed") b) --- @ --- --- Name the test cases and group them together: --- --- @ --- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2] --- @ --- --- Run the tests as a group. At a Haskell interpreter prompt, apply the function --- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation --- with output to the /T/erminal.) --- --- @ --- \> runTestTT tests --- Cases: 2 Tried: 2 Errors: 0 Failures: 0 --- \> --- @ --- --- If the tests are proving their worth, you might see: --- --- @ --- \> runTestTT tests --- ### Failure in: 0:test1 --- for (foo 3), --- expected: (1,2) --- but got: (1,3) --- Cases: 2 Tried: 2 Errors: 0 Failures: 1 --- \> --- @ --- --- You can specify tests even more succinctly using operators and overloaded --- functions that HUnit provides: --- --- @ --- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3), --- "test2" ~: do (x, y) <- partA 3 --- assertEqual "for the first result of partA," 5 x --- partB y \@? "(partB " ++ show y ++ ") failed" ] --- @ --- --- Assuming the same test failures as before, you would see: --- --- @ --- \> runTestTT tests --- ### Failure in: 0:test1:(foo 3) --- expected: (1,2) --- but got: (1,3) --- Cases: 2 Tried: 2 Errors: 0 Failures: 1 --- \> --- @ - -module Test.HUnit -( - module Test.HUnit.Base, - module Test.HUnit.Text -) -where - -import Test.HUnit.Base -import Test.HUnit.Text - +-- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool +-- for Java. This guide describes how to use HUnit, assuming you are familiar +-- with Haskell, though not necessarily with JUnit. +-- +-- In the Haskell module where your tests will reside, import module +-- @Test.HUnit@: +-- +-- @ +-- import Test.HUnit +-- @ +-- +-- Define test cases as appropriate: +-- +-- @ +-- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3)) +-- test2 = TestCase (do (x,y) <- partA 3 +-- assertEqual "for the first result of partA," 5 x +-- b <- partB y +-- assertBool ("(partB " ++ show y ++ ") failed") b) +-- @ +-- +-- Name the test cases and group them together: +-- +-- @ +-- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2] +-- @ +-- +-- Run the tests as a group. At a Haskell interpreter prompt, apply the function +-- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation +-- with output to the /T/erminal.) +-- +-- @ +-- \> runTestTT tests +-- Cases: 2 Tried: 2 Errors: 0 Failures: 0 +-- \> +-- @ +-- +-- If the tests are proving their worth, you might see: +-- +-- @ +-- \> runTestTT tests +-- ### Failure in: 0:test1 +-- for (foo 3), +-- expected: (1,2) +-- but got: (1,3) +-- Cases: 2 Tried: 2 Errors: 0 Failures: 1 +-- \> +-- @ +-- +-- You can specify tests even more succinctly using operators and overloaded +-- functions that HUnit provides: +-- +-- @ +-- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3), +-- "test2" ~: do (x, y) <- partA 3 +-- assertEqual "for the first result of partA," 5 x +-- partB y \@? "(partB " ++ show y ++ ") failed" ] +-- @ +-- +-- Assuming the same test failures as before, you would see: +-- +-- @ +-- \> runTestTT tests +-- ### Failure in: 0:test1:(foo 3) +-- expected: (1,2) +-- but got: (1,3) +-- Cases: 2 Tried: 2 Errors: 0 Failures: 1 +-- \> +-- @ + +module Test.HUnit +( + module Test.HUnit.Base, + module Test.HUnit.Text +) +where + +import Test.HUnit.Base +import Test.HUnit.Text + diff --git a/Test/HUnit/Base.hs b/Test/HUnit/Base.hs --- a/Test/HUnit/Base.hs +++ b/Test/HUnit/Base.hs @@ -1,11 +1,17 @@ +{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,8,1) +#define HAS_SOURCE_LOCATIONS +{-# LANGUAGE ImplicitParams #-} +#endif + -- | Basic definitions for the HUnit library. -- -- This module contains what you need to create assertions and test cases and --- combine them into test suites. +-- combine them into test suites. -- --- This module also provides infrastructure for --- implementing test controllers (which are used to execute tests). --- See "Test.HUnit.Text" for a great example of how to implement a test +-- This module also provides infrastructure for +-- implementing test controllers (which are used to execute tests). +-- See "Test.HUnit.Text" for a great example of how to implement a test -- controller. module Test.HUnit.Base @@ -13,10 +19,10 @@ -- ** Declaring tests Test(..), (~=?), (~?=), (~:), (~?), - + -- ** Making assertions assertFailure, {- from Test.HUnit.Lang: -} - assertBool, assertEqual, assertString, + assertBool, assertEqual, assertString, Assertion, {- from Test.HUnit.Lang: -} (@=?), (@?=), (@?), @@ -27,15 +33,23 @@ -- ** Test execution -- $testExecutionNote - State(..), Counts(..), - Path, Node(..), + State(..), Counts(..), + Path, Node(..), testCasePaths, testCaseCount, + Location (..), ReportStart, ReportProblem, performTest ) where +#ifdef HAS_SOURCE_LOCATIONS +import GHC.Stack +#define with_loc (?loc :: CallStack) => +#else +#define with_loc +#endif + import Control.Monad (unless, foldM) @@ -49,25 +63,28 @@ -- ------------------------------- -- | Asserts that the specified condition holds. -assertBool :: String -- ^ The message that is displayed if the assertion fails +assertBool :: with_loc + String -- ^ The message that is displayed if the assertion fails -> Bool -- ^ The condition -> Assertion assertBool msg b = unless b (assertFailure msg) -- | Signals an assertion failure if a non-empty message (i.e., a message -- other than @\"\"@) is passed. -assertString :: String -- ^ The message that is displayed with the assertion failure +assertString :: with_loc + String -- ^ The message that is displayed with the assertion failure -> Assertion assertString s = unless (null s) (assertFailure s) -- | Asserts that the specified actual value is equal to the expected value. --- The output message will contain the prefix, the expected value, and the +-- The output message will contain the prefix, the expected value, and the -- actual value. --- +-- -- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted -- and only the expected and actual values are output. -assertEqual :: (Eq a, Show a) => String -- ^ The message prefix - -> a -- ^ The expected value +assertEqual :: with_loc (Eq a, Show a) + => String -- ^ The message prefix + -> a -- ^ The expected value -> a -- ^ The actual value -> Assertion assertEqual preface expected actual = @@ -81,16 +98,16 @@ -- | Allows the extension of the assertion mechanism. -- --- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, +-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, -- there is a fair amount of flexibility of what can be achieved. As a rule, -- the resulting @Assertion@ should be the body of a 'TestCase' or part of --- a @TestCase@; it should not be used to assert multiple, independent +-- a @TestCase@; it should not be used to assert multiple, independent -- conditions. -- -- If more complex arrangements of assertions are needed, 'Test's and -- 'Testable' should be used. class Assertable t - where assert :: t -> Assertion + where assert :: with_loc t -> Assertion instance Assertable () where assert = return @@ -106,7 +123,7 @@ -- | A specialized form of 'Assertable' to handle lists. class ListAssertable t - where listAssert :: [t] -> Assertion + where listAssert :: with_loc [t] -> Assertion instance ListAssertable Char where listAssert = assertString @@ -133,13 +150,13 @@ -- 2. Read data from a file, evaluate conditions. -- -- 3. Clean up the file. --- +-- -- 4. Assert that the side effects of the read operation meet certain conditions. -- -- 5. Assert that the conditions evaluated in step 2 are met. type AssertionPredicate = IO Bool --- | Used to signify that a data type can be converted to an assertion +-- | Used to signify that a data type can be converted to an assertion -- predicate. class AssertionPredicable t where assertionPredicate :: t -> AssertionPredicate @@ -158,21 +175,24 @@ -- | Asserts that the condition obtained from the specified -- 'AssertionPredicable' holds. -(@?) :: (AssertionPredicable t) => t -- ^ A value of which the asserted condition is predicated +(@?) :: with_loc (AssertionPredicable t) + => t -- ^ A value of which the asserted condition is predicated -> String -- ^ A message that is displayed if the assertion fails -> Assertion predi @? msg = assertionPredicate predi >>= assertBool msg -- | Asserts that the specified actual value is equal to the expected value -- (with the expected value on the left-hand side). -(@=?) :: (Eq a, Show a) => a -- ^ The expected value +(@=?) :: with_loc (Eq a, Show a) + => a -- ^ The expected value -> a -- ^ The actual value -> Assertion expected @=? actual = assertEqual "" expected actual -- | Asserts that the specified actual value is equal to the expected value -- (with the actual value on the left-hand side). -(@?=) :: (Eq a, Show a) => a -- ^ The actual value +(@?=) :: with_loc (Eq a, Show a) + => a -- ^ The actual value -> a -- ^ The expected value -> Assertion actual @?= expected = assertEqual "" expected actual @@ -186,7 +206,7 @@ data Test -- | A single, independent test case composed. = TestCase Assertion - -- | A set of @Test@s sharing the same level in the hierarchy. + -- | A set of @Test@s sharing the same level in the hierarchy. | TestList [Test] -- | A name or description for a subtree of the @Test@s. | TestLabel String Test @@ -202,7 +222,7 @@ -- | Provides a way to convert data into a @Test@ or set of @Test@. class Testable t - where test :: t -> Test + where test :: with_loc t -> Test instance Testable Test where test = id @@ -220,35 +240,38 @@ infix 1 ~?, ~=?, ~?= infixr 0 ~: --- | Creates a test case resulting from asserting the condition obtained +-- | Creates a test case resulting from asserting the condition obtained -- from the specified 'AssertionPredicable'. -(~?) :: (AssertionPredicable t) => t -- ^ A value of which the asserted condition is predicated +(~?) :: with_loc (AssertionPredicable t) + => t -- ^ A value of which the asserted condition is predicated -> String -- ^ A message that is displayed on test failure -> Test predi ~? msg = TestCase (predi @? msg) --- | Shorthand for a test case that asserts equality (with the expected +-- | Shorthand for a test case that asserts equality (with the expected -- value on the left-hand side, and the actual value on the right-hand -- side). -(~=?) :: (Eq a, Show a) => a -- ^ The expected value +(~=?) :: with_loc (Eq a, Show a) + => a -- ^ The expected value -> a -- ^ The actual value -> Test expected ~=? actual = TestCase (expected @=? actual) --- | Shorthand for a test case that asserts equality (with the actual +-- | Shorthand for a test case that asserts equality (with the actual -- value on the left-hand side, and the expected value on the right-hand -- side). -(~?=) :: (Eq a, Show a) => a -- ^ The actual value - -> a -- ^ The expected value +(~?=) :: with_loc (Eq a, Show a) + => a -- ^ The actual value + -> a -- ^ The expected value -> Test actual ~?= expected = TestCase (actual @?= expected) --- | Creates a test from the specified 'Testable', with the specified +-- | Creates a test from the specified 'Testable', with the specified -- label attached to it. -- -- Since 'Test' is @Testable@, this can be used as a shorthand way of attaching --- a 'TestLabel' to one or more tests. -(~:) :: (Testable t) => String -> t -> Test +-- a 'TestLabel' to one or more tests. +(~:) :: with_loc (Testable t) => String -> t -> Test label ~: t = TestLabel label (test t) @@ -257,9 +280,9 @@ -- ============== -- $testExecutionNote --- Note: the rest of the functionality in this module is intended for +-- Note: the rest of the functionality in this module is intended for -- implementors of test controllers. If you just want to run your tests cases, --- simply use a test controller, such as the text-based controller in +-- simply use a test controller, such as the text-based controller in -- "Test.HUnit.Text". -- | A data structure that hold the results of tests that have been performed @@ -278,7 +301,7 @@ -- | Report generator for reporting problems that have occurred during -- a test run. Problems may be errors or assertion failures. -type ReportProblem us = String -> State -> us -> IO us +type ReportProblem us = Maybe Location -> String -> State -> us -> IO us -- | Uniquely describes the location of a test within a test hierarchy. -- Node order is from test case to root. @@ -302,13 +325,13 @@ testCaseCount (TestList ts) = sum (map testCaseCount ts) testCaseCount (TestLabel _ t) = testCaseCount t --- | Performs a test run with the specified report generators. +-- | Performs a test run with the specified report generators. -- --- This handles the actual running of the tests. Most developers will want --- to use @HUnit.Text.runTestTT@ instead. A developer could use this function --- to execute tests via another IO system, such as a GUI, or to output the --- results in a different manner (e.g., upload XML-formatted results to a --- webservice). +-- This handles the actual running of the tests. Most developers will want +-- to use @HUnit.Text.runTestTT@ instead. A developer could use this function +-- to execute tests via another IO system, such as a GUI, or to output the +-- results in a different manner (e.g., upload XML-formatted results to a +-- webservice). -- -- Note that the counts in a start report do not include the test case -- being started, whereas the counts in a problem report do include the @@ -316,11 +339,11 @@ -- only between test case executions. As a result, the number of test -- case successes always equals the difference of test cases tried and -- the sum of test case errors and failures. -performTest :: ReportStart us -- ^ report generator for the test run start +performTest :: ReportStart us -- ^ report generator for the test run start -> ReportProblem us -- ^ report generator for errors during the test run -> ReportProblem us -- ^ report generator for assertion failures during the test run - -> us - -> Test -- ^ the test to be executed + -> us + -> Test -- ^ the test to be executed -> IO (Counts, us) performTest reportStart reportError reportFailure initialUs initialT = do (ss', us') <- pt initState initialUs initialT @@ -334,11 +357,15 @@ pt ss us (TestCase a) = do us' <- reportStart ss us r <- performTestCase a - case r of Nothing -> do return (ss', us') - Just (True, m) -> do usF <- reportFailure m ssF us' - return (ssF, usF) - Just (False, m) -> do usE <- reportError m ssE us' - return (ssE, usE) + case r of + Success -> do + return (ss', us') + Failure loc m -> do + usF <- reportFailure loc m ssF us' + return (ssF, usF) + Error loc m -> do + usE <- reportError loc m ssE us' + return (ssE, usE) where c@Counts{ tried = n } = counts ss ss' = ss{ counts = c{ tried = n + 1 } } ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } } diff --git a/Test/HUnit/Lang.hs b/Test/HUnit/Lang.hs --- a/Test/HUnit/Lang.hs +++ b/Test/HUnit/Lang.hs @@ -1,149 +1,92 @@ --- | This module abstracts the differences between implementations of --- Haskell (e.g., GHC, Hugs, and NHC). - -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif - -module Test.HUnit.Lang -( - Assertion, - assertFailure, - performTestCase, -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) --- * Internals --- | --- /Note:/ This is not part of the public API! It is exposed so that you can --- tinker with the internals of HUnit, but do not expect it to be stable! - HUnitFailure (..) -#endif -) -where - - --- When adapting this module for other Haskell language systems, change --- the imports and the implementations but not the interfaces. - - - --- Imports --- ------- - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -import Data.Dynamic -import Control.Exception as E -#else -import Data.List (isPrefixOf) -import System.IO.Error (ioeGetErrorString, try) -#endif - -import Control.DeepSeq - - --- Interfaces --- ---------- - --- | When an assertion is evaluated, it will output a message if and only if the --- assertion fails. --- --- Test cases are composed of a sequence of one or more assertions. - -type Assertion = IO () - --- | Unconditionally signals that a failure has occured. All --- other assertions can be expressed with the form: --- --- @ --- if conditionIsMet --- then IO () --- else assertFailure msg --- @ - -assertFailure :: String -- ^ A message that is displayed with the assertion failure - -> Assertion - --- | Performs a single test case. The meaning of the result is as follows: --- --- [@Nothing@] test case success --- --- [@Just (True, msg)@] test case failure with the given message --- --- [@Just (False, msg)@] test case error with the given message - -performTestCase :: Assertion -- ^ an assertion to be made during the test case run - -> IO (Maybe (Bool, String)) - - --- Implementations --- --------------- - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -data HUnitFailure = HUnitFailure String -#if __GLASGOW_HASKELL__ >= 707 - deriving (Show, Typeable) -#else - deriving Show - -hunitFailureTc :: TyCon -#if MIN_VERSION_base(4,4,0) -hunitFailureTc = mkTyCon3 "HUnit" "Test.HUnit.Lang" "HUnitFailure" -#else -hunitFailureTc = mkTyCon "HUnitFailure" -#endif -{-# NOINLINE hunitFailureTc #-} - -instance Typeable HUnitFailure where - typeOf _ = mkTyConApp hunitFailureTc [] -#endif - -#ifdef BASE4 -instance Exception HUnitFailure - -assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure msg) - -performTestCase action = - do action - return Nothing - `E.catches` - [E.Handler (\(HUnitFailure msg) -> return $ Just (True, msg)), - - -- Re-throw AsyncException, otherwise execution will not terminate on - -- SIGINT (ctrl-c). Currently, all AsyncExceptions are being thrown - -- because it's thought that none of them will be encountered during - -- normal HUnit operation. If you encounter an example where this - -- is not the case, please email the maintainer. - E.Handler (\e -> throw (e :: E.AsyncException)), - - E.Handler (\e -> return $ Just (False, show (e :: E.SomeException)))] -#else -assertFailure msg = msg `deepseq` E.throwDyn (HUnitFailure msg) - -performTestCase action = - do r <- E.try action - case r of - Right () -> return Nothing - Left e@(E.DynException dyn) -> - case fromDynamic dyn of - Just (HUnitFailure msg) -> return $ Just (True, msg) - Nothing -> return $ Just (False, show e) - Left e -> return $ Just (False, show e) -#endif -#else -hunitPrefix = "HUnit:" - -nhc98Prefix = "I/O error (user-defined), call to function `userError':\n " - -assertFailure msg = msg `deepseq` ioError (userError (hunitPrefix ++ msg)) - -performTestCase action = do r <- try action - case r of Right () -> return Nothing - Left e -> return (Just (decode e)) - where - decode e = let s0 = ioeGetErrorString e - (_, s1) = dropPrefix nhc98Prefix s0 - in dropPrefix hunitPrefix s1 - dropPrefix pref str = if pref `isPrefixOf` str - then (True, drop (length pref) str) - else (False, str) -#endif +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,8,1) +#define HAS_SOURCE_LOCATIONS +{-# LANGUAGE ImplicitParams #-} +#endif + +module Test.HUnit.Lang ( + Assertion, + assertFailure, + + Location (..), + Result (..), + performTestCase, +-- * Internals +-- | +-- /Note:/ This is not part of the public API! It is exposed so that you can +-- tinker with the internals of HUnit, but do not expect it to be stable! + HUnitFailure (..) +) where + +import Control.DeepSeq +import Control.Exception as E +import Data.Typeable + +#ifdef HAS_SOURCE_LOCATIONS +import GHC.SrcLoc +import GHC.Stack +#endif + +-- | When an assertion is evaluated, it will output a message if and only if the +-- assertion fails. +-- +-- Test cases are composed of a sequence of one or more assertions. +type Assertion = IO () + +data Location = Location { + locationFile :: FilePath +, locationLine :: Int +, locationColumn :: Int +} deriving (Eq, Ord, Show) + +data HUnitFailure = HUnitFailure (Maybe Location) String + deriving (Eq, Ord, Show, Typeable) + +instance Exception HUnitFailure + +-- | Unconditionally signals that a failure has occured. All +-- other assertions can be expressed with the form: +-- +-- @ +-- if conditionIsMet +-- then IO () +-- else assertFailure msg +-- @ +assertFailure :: +#ifdef HAS_SOURCE_LOCATIONS + (?loc :: CallStack) => +#endif + String -- ^ A message that is displayed with the assertion failure + -> Assertion +assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location msg) + where + location :: Maybe Location +#ifdef HAS_SOURCE_LOCATIONS + location = case reverse (getCallStack ?loc) of + (_, loc) : _ -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) + [] -> Nothing +#else + location = Nothing +#endif + +data Result = Success | Failure (Maybe Location) String | Error (Maybe Location) String + deriving (Eq, Ord, Show) + +-- | Performs a single test case. +performTestCase :: Assertion -- ^ an assertion to be made during the test case run + -> IO Result +performTestCase action = + (action >> return Success) + `E.catches` + [E.Handler (\(HUnitFailure loc msg) -> return $ Failure loc msg), + + -- Re-throw AsyncException, otherwise execution will not terminate on + -- SIGINT (ctrl-c). Currently, all AsyncExceptions are being thrown + -- because it's thought that none of them will be encountered during + -- normal HUnit operation. If you encounter an example where this + -- is not the case, please email the maintainer. + E.Handler (\e -> throw (e :: E.AsyncException)), + + E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))] diff --git a/Test/HUnit/Terminal.hs b/Test/HUnit/Terminal.hs --- a/Test/HUnit/Terminal.hs +++ b/Test/HUnit/Terminal.hs @@ -1,42 +1,42 @@ --- | This module handles the complexities of writing information to the --- terminal, including modifying text in place. - -module Test.HUnit.Terminal ( - terminalAppearance - ) where - -import Data.Char (isPrint) - - --- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters --- specially so that the result string has the same final (or /terminal/, --- pun intended) appearance as would the input string when written to a --- terminal that overwrites character positions following carriage --- returns and backspaces. - -terminalAppearance :: String -> String -terminalAppearance str = ta id "" "" str - --- | The helper function @ta@ takes an accumulating @ShowS@-style function --- that holds /committed/ lines of text, a (reversed) list of characters --- on the current line /before/ the cursor, a (normal) list of characters --- on the current line /after/ the cursor, and the remaining input. - -ta - :: ([Char] -> t) -- ^ An accumulating @ShowS@-style function - -- that holds /committed/ lines of text - -> [Char] -- ^ A (reversed) list of characters - -- on the current line /before/ the cursor - -> [Char] -- ^ A (normal) list of characters - -- on the current line /after/ the cursor - -> [Char] -- ^ The remaining input - -> t -ta f bs as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs -ta f bs as ('\r':cs) = ta f "" (reverse bs ++ as) cs -ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs -ta _ "" _ ('\b': _) = error "'\\b' at beginning of line" -ta f bs as (c:cs) - | not (isPrint c) = error "invalid nonprinting character" - | null as = ta f (c:bs) "" cs - | otherwise = ta f (c:bs) (tail as) cs -ta f bs as "" = f (reverse bs ++ as) +-- | This module handles the complexities of writing information to the +-- terminal, including modifying text in place. + +module Test.HUnit.Terminal ( + terminalAppearance + ) where + +import Data.Char (isPrint) + + +-- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters +-- specially so that the result string has the same final (or /terminal/, +-- pun intended) appearance as would the input string when written to a +-- terminal that overwrites character positions following carriage +-- returns and backspaces. + +terminalAppearance :: String -> String +terminalAppearance str = ta id "" "" str + +-- | The helper function @ta@ takes an accumulating @ShowS@-style function +-- that holds /committed/ lines of text, a (reversed) list of characters +-- on the current line /before/ the cursor, a (normal) list of characters +-- on the current line /after/ the cursor, and the remaining input. + +ta + :: ([Char] -> t) -- ^ An accumulating @ShowS@-style function + -- that holds /committed/ lines of text + -> [Char] -- ^ A (reversed) list of characters + -- on the current line /before/ the cursor + -> [Char] -- ^ A (normal) list of characters + -- on the current line /after/ the cursor + -> [Char] -- ^ The remaining input + -> t +ta f bs as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs +ta f bs as ('\r':cs) = ta f "" (reverse bs ++ as) cs +ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs +ta _ "" _ ('\b': _) = error "'\\b' at beginning of line" +ta f bs as (c:cs) + | not (isPrint c) = error "invalid nonprinting character" + | null as = ta f (c:bs) "" cs + | otherwise = ta f (c:bs) (tail as) cs +ta f bs as "" = f (reverse bs ++ as) diff --git a/Test/HUnit/Text.hs b/Test/HUnit/Text.hs --- a/Test/HUnit/Text.hs +++ b/Test/HUnit/Text.hs @@ -1,128 +1,131 @@ --- | Text-based test controller for running HUnit tests and reporting --- results as text, usually to a terminal. - -module Test.HUnit.Text -( - PutText(..), - putTextToHandle, putTextToShowS, - runTestText, - showPath, showCounts, - runTestTT -) -where - -import Test.HUnit.Base - -import Control.Monad (when) -import System.IO (Handle, stderr, hPutStr, hPutStrLn) - - --- | As the general text-based test controller ('runTestText') executes a --- test, it reports each test case start, error, and failure by --- constructing a string and passing it to the function embodied in a --- 'PutText'. A report string is known as a \"line\", although it includes --- no line terminator; the function in a 'PutText' is responsible for --- terminating lines appropriately. Besides the line, the function --- receives a flag indicating the intended \"persistence\" of the line: --- 'True' indicates that the line should be part of the final overall --- report; 'False' indicates that the line merely indicates progress of --- the test execution. Each progress line shows the current values of --- the cumulative test execution counts; a final, persistent line shows --- the final count values. --- --- The 'PutText' function is also passed, and returns, an arbitrary state --- value (called 'st' here). The initial state value is given in the --- 'PutText'; the final value is returned by 'runTestText'. - -data PutText st = PutText (String -> Bool -> st -> IO st) st - - --- | Two reporting schemes are defined here. @putTextToHandle@ writes --- report lines to a given handle. 'putTextToShowS' accumulates --- persistent lines for return as a whole by 'runTestText'. --- --- @putTextToHandle@ writes persistent lines to the given handle, --- following each by a newline character. In addition, if the given flag --- is @True@, it writes progress lines to the handle as well. A progress --- line is written with no line termination, so that it can be --- overwritten by the next report line. As overwriting involves writing --- carriage return and blank characters, its proper effect is usually --- only obtained on terminal devices. - -putTextToHandle - :: Handle - -> Bool -- ^ Write progress lines to handle? - -> PutText Int -putTextToHandle handle showProgress = PutText put initCnt - where - initCnt = if showProgress then 0 else -1 - put line pers (-1) = do when pers (hPutStrLn handle line); return (-1) - put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0 - put line False _ = do hPutStr handle ('\r' : line); return (length line) - -- The "erasing" strategy with a single '\r' relies on the fact that the - -- lengths of successive summary lines are monotonically nondecreasing. - erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r" - - --- | Accumulates persistent lines (dropping progess lines) for return by --- 'runTestText'. The accumulated lines are represented by a --- @'ShowS' ('String' -> 'String')@ function whose first argument is the --- string to be appended to the accumulated report lines. - -putTextToShowS :: PutText ShowS -putTextToShowS = PutText put id - where put line pers f = return (if pers then acc f line else f) - acc f line rest = f (line ++ '\n' : rest) - - --- | Executes a test, processing each report line according to the given --- reporting scheme. The reporting scheme's state is threaded through calls --- to the reporting scheme's function and finally returned, along with final --- count values. - -runTestText :: PutText st -> Test -> IO (Counts, st) -runTestText (PutText put us0) t = do - (counts', us1) <- performTest reportStart reportError reportFailure us0 t - us2 <- put (showCounts counts') True us1 - return (counts', us2) - where - reportStart ss us = put (showCounts (counts ss)) False us - reportError = reportProblem "Error:" "Error in: " - reportFailure = reportProblem "Failure:" "Failure in: " - reportProblem p0 p1 msg ss us = put line True us - where line = "### " ++ kind ++ path' ++ '\n' : msg - kind = if null path' then p0 else p1 - path' = showPath (path ss) - - --- | Converts test execution counts to a string. - -showCounts :: Counts -> String -showCounts Counts{ cases = cases', tried = tried', - errors = errors', failures = failures' } = - "Cases: " ++ show cases' ++ " Tried: " ++ show tried' ++ - " Errors: " ++ show errors' ++ " Failures: " ++ show failures' - - --- | Converts a test case path to a string, separating adjacent elements by --- the colon (\':\'). An element of the path is quoted (as with 'show') when --- there is potential ambiguity. - -showPath :: Path -> String -showPath [] = "" -showPath nodes = foldl1 f (map showNode nodes) - where f b a = a ++ ":" ++ b - showNode (ListItem n) = show n - showNode (Label label) = safe label (show label) - safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s - - --- | Provides the \"standard\" text-based test controller. Reporting is made to --- standard error, and progress reports are included. For possible --- programmatic use, the final counts are returned. --- --- The \"TT\" in the name suggests \"Text-based reporting to the Terminal\". - -runTestTT :: Test -> IO Counts -runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t - return counts' +-- | Text-based test controller for running HUnit tests and reporting +-- results as text, usually to a terminal. + +module Test.HUnit.Text +( + PutText(..), + putTextToHandle, putTextToShowS, + runTestText, + showPath, showCounts, + runTestTT +) +where + +import Test.HUnit.Base + +import Control.Monad (when) +import System.IO (Handle, stderr, hPutStr, hPutStrLn) + + +-- | As the general text-based test controller ('runTestText') executes a +-- test, it reports each test case start, error, and failure by +-- constructing a string and passing it to the function embodied in a +-- 'PutText'. A report string is known as a \"line\", although it includes +-- no line terminator; the function in a 'PutText' is responsible for +-- terminating lines appropriately. Besides the line, the function +-- receives a flag indicating the intended \"persistence\" of the line: +-- 'True' indicates that the line should be part of the final overall +-- report; 'False' indicates that the line merely indicates progress of +-- the test execution. Each progress line shows the current values of +-- the cumulative test execution counts; a final, persistent line shows +-- the final count values. +-- +-- The 'PutText' function is also passed, and returns, an arbitrary state +-- value (called 'st' here). The initial state value is given in the +-- 'PutText'; the final value is returned by 'runTestText'. + +data PutText st = PutText (String -> Bool -> st -> IO st) st + + +-- | Two reporting schemes are defined here. @putTextToHandle@ writes +-- report lines to a given handle. 'putTextToShowS' accumulates +-- persistent lines for return as a whole by 'runTestText'. +-- +-- @putTextToHandle@ writes persistent lines to the given handle, +-- following each by a newline character. In addition, if the given flag +-- is @True@, it writes progress lines to the handle as well. A progress +-- line is written with no line termination, so that it can be +-- overwritten by the next report line. As overwriting involves writing +-- carriage return and blank characters, its proper effect is usually +-- only obtained on terminal devices. + +putTextToHandle + :: Handle + -> Bool -- ^ Write progress lines to handle? + -> PutText Int +putTextToHandle handle showProgress = PutText put initCnt + where + initCnt = if showProgress then 0 else -1 + put line pers (-1) = do when pers (hPutStrLn handle line); return (-1) + put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0 + put line False _ = do hPutStr handle ('\r' : line); return (length line) + -- The "erasing" strategy with a single '\r' relies on the fact that the + -- lengths of successive summary lines are monotonically nondecreasing. + erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r" + + +-- | Accumulates persistent lines (dropping progess lines) for return by +-- 'runTestText'. The accumulated lines are represented by a +-- @'ShowS' ('String' -> 'String')@ function whose first argument is the +-- string to be appended to the accumulated report lines. + +putTextToShowS :: PutText ShowS +putTextToShowS = PutText put id + where put line pers f = return (if pers then acc f line else f) + acc f line rest = f (line ++ '\n' : rest) + + +-- | Executes a test, processing each report line according to the given +-- reporting scheme. The reporting scheme's state is threaded through calls +-- to the reporting scheme's function and finally returned, along with final +-- count values. + +runTestText :: PutText st -> Test -> IO (Counts, st) +runTestText (PutText put us0) t = do + (counts', us1) <- performTest reportStart reportError reportFailure us0 t + us2 <- put (showCounts counts') True us1 + return (counts', us2) + where + reportStart ss us = put (showCounts (counts ss)) False us + reportError = reportProblem "Error:" "Error in: " + reportFailure = reportProblem "Failure:" "Failure in: " + reportProblem p0 p1 loc msg ss us = put line True us + where line = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg + kind = if null path' then p0 else p1 + path' = showPath (path ss) + +formatLocation :: Maybe Location -> String +formatLocation Nothing = "" +formatLocation (Just loc) = locationFile loc ++ ":" ++ show (locationLine loc) ++ "\n" + +-- | Converts test execution counts to a string. + +showCounts :: Counts -> String +showCounts Counts{ cases = cases', tried = tried', + errors = errors', failures = failures' } = + "Cases: " ++ show cases' ++ " Tried: " ++ show tried' ++ + " Errors: " ++ show errors' ++ " Failures: " ++ show failures' + + +-- | Converts a test case path to a string, separating adjacent elements by +-- the colon (\':\'). An element of the path is quoted (as with 'show') when +-- there is potential ambiguity. + +showPath :: Path -> String +showPath [] = "" +showPath nodes = foldl1 f (map showNode nodes) + where f b a = a ++ ":" ++ b + showNode (ListItem n) = show n + showNode (Label label) = safe label (show label) + safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s + + +-- | Provides the \"standard\" text-based test controller. Reporting is made to +-- standard error, and progress reports are included. For possible +-- programmatic use, the final counts are returned. +-- +-- The \"TT\" in the name suggests \"Text-based reporting to the Terminal\". + +runTestTT :: Test -> IO Counts +runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t + return counts' diff --git a/tests/HUnitTestBase.lhs b/tests/HUnitTestBase.lhs --- a/tests/HUnitTestBase.lhs +++ b/tests/HUnitTestBase.lhs @@ -1,7 +1,9 @@ HUnitTestBase.lhs -- test support and basic tests (Haskell 98 compliant) +> {-# LANGUAGE CPP #-} > module HUnitTestBase where +> import Data.List > import Test.HUnit > import Test.HUnit.Terminal (terminalAppearance) > import System.IO (IOMode(..), openFile, hClose) @@ -26,8 +28,8 @@ > expectReports :: [Report] -> Counts -> Test -> Test > expectReports reports1 counts1 t = TestCase $ do > (counts2, reports2) <- performTest (\ ss us -> return (Start ss : us)) -> (\m ss us -> return (Error m ss : us)) -> (\m ss us -> return (Failure m ss : us)) +> (\_loc m ss us -> return (Error m ss : us)) +> (\_loc m ss us -> return (Failure m ss : us)) > [] t > assertEqual "for the reports from a test," reports1 (reverse reports2) > assertEqual "for the counts from a test," counts1 counts2 @@ -88,11 +90,7 @@ > "null" ~: expectSuccess ok, > "userError" ~: -#if defined(__GLASGOW_HASKELL__) > expectError "user error (error)" (TestCase (ioError (userError "error"))), -#else -> expectError "error" (TestCase (ioError (userError "error"))), -#endif > "IO error (file missing)" ~: > expectUnspecifiedError @@ -257,12 +255,14 @@ > reportTests :: Test > reportTests = "reports" ~: expectReports suiteReports suiteCounts suite +> removeLocation :: String -> String +> removeLocation = unlines . filter (not . isInfixOf __FILE__) . lines > expectText :: Counts -> String -> Test -> Test > expectText counts1 text1 t = TestCase $ do > (counts2, text2) <- runTestText putTextToShowS t > assertEqual "for the final counts," counts1 counts2 -> assertEqual "for the failure text output," text1 (text2 "") +> assertEqual "for the failure text output," text1 (removeLocation $ text2 "") > textTests :: Test @@ -270,11 +270,7 @@ > "lone error" ~: > expectText (Counts 1 1 1 0) -#if defined(__GLASGOW_HASKELL__) > "### Error:\nuser error (xyz)\nCases: 1 Tried: 1 Errors: 1 Failures: 0\n" -#else -> "### Error:\nxyz\nCases: 1 Tried: 1 Errors: 1 Failures: 0\n" -#endif > (test (do _ <- ioError (userError "xyz"); return ())), > "lone failure" ~: @@ -295,7 +291,7 @@ > hClose handle > assertEqual "for the final counts," suiteCounts counts' > text <- readFile filename -> let text' = if flag then trim (terminalAppearance text) else text +> let text' = removeLocation $ if flag then trim (terminalAppearance text) else text > assertEqual "for the failure text output," suiteOutput text' > | flag <- [False, True] ] diff --git a/tests/HUnitTestExtended.hs b/tests/HUnitTestExtended.hs --- a/tests/HUnitTestExtended.hs +++ b/tests/HUnitTestExtended.hs @@ -5,34 +5,11 @@ import Test.HUnit import HUnitTestBase --- Notes: --- * Assertion testing is only performed on GHC. If you want this to be enabled --- for other compilers, email the HUnit maintainer. - -#ifdef __GLASGOW_HASKELL__ -import qualified Control.Exception (assert) - -#ifdef O0 -import System.FilePath - -assertionMessage :: String -assertionMessage = concat [ - "tests", - [pathSeparator], - "HUnitTestExtended.hs:27:13-36: Assertion failed\n" - ] -#endif - -assertion :: IO () -assertion = Control.Exception.assert False (return ()) -#endif - - extendedTests :: Test extendedTests = test [ -- Hugs doesn't currently catch arithmetic exceptions. - + "div by 0" ~: expectUnspecifiedError (TestCase ((3 `div` 0 :: Integer) `seq` return ())), @@ -44,20 +21,4 @@ "tail []" ~: expectUnspecifiedError (TestCase (tail [] `seq` return ())) - -#ifdef __GLASGOW_HASKELL__ -#ifdef O0 --- Run with no optimization (-O0) - , - "assert" ~: - expectError assertionMessage (TestCase assertion) -#else --- #ifdef O0 --- Run with optimization (-O1 or -O2) - , - "assert" ~: TestCase assertion --- #ifdef O0 -#endif --- #ifdef __GLASGOW_HASKELL__ -#endif ] diff --git a/tests/HUnitTestOptimize.hs b/tests/HUnitTestOptimize.hs deleted file mode 100644 --- a/tests/HUnitTestOptimize.hs +++ /dev/null @@ -1,113 +0,0 @@ --- HUnitTestOptimize.hs --- --- The purpose of this file is to test whether certain issues occur with optimization. --- It should be built and run with each level of optimization. I.e., -O0, -O1, -O2 --- --- With some versions and optimization levels of HUnit and GHC, tests were getting --- optimized out. This is a very bad thing and needs to be tested for. - -module HUnitTestOptimize ( - optimizationTests, - undefinedSwallowsTests - ) where - -import Control.Applicative -import Control.Monad -import Test.HUnit - --- Used to include the optimization level in the test results -optimizationLevel :: String -#if defined(O0) -optimizationLevel = "-O0" -#elif defined(O1) -optimizationLevel = "-O1" -#elif defined(O2) -optimizationLevel = "-O2" -#else -optimizationLevel = "unknown optimization level" -#endif - --- A test runner that doesn't print the results of the tests; it only tabulates --- the results of the tests. In this context, it's used to verify that no --- tests were optimized away or otherwise lost. -simpleTestRunner :: Test -> IO Counts -simpleTestRunner t = do - (counts', _) <- runTestText nullAccum t - return counts' - where - nullAccum = PutText (\ _ _ _ -> return ()) () - --- Some combinations of HUnit, GHC, and optimization levels cause tests to be --- optimized away. This section verifies that all tests of a type are --- performed. -optimizationTests :: IO Bool -optimizationTests = do - counts2 <- simpleTestRunner $ TestLabel "Basic Optimization Tests" $ TestList [ - True ~=? True, - False ~=? True, - TestCase $ assertEqual "both true" True True, - TestCase $ assertEqual "false true" False True, - TestCase $ assertEqual "fa" False True, - TestCase $ assertEqual "f" False True, - TestCase $ (False @?= True), - TestCase $ unless (False == True) (assertFailure "f") - ] - -- Verify results of counts2 - -- We can't use HUnit because it's possible that some tests have been - -- optimized away, so we'll just do it manually. - foldr (&&) True <$> sequence [ - caseCount counts2 optimizationLevel, - tryCount counts2 optimizationLevel, - errorCount counts2 optimizationLevel, - failureCount counts2 optimizationLevel - ] - where - caseCount cs ol = if (cases cs == 8) - then return True - else do - putStrLn $ "Failure: Basic Optimization (" ++ - ol ++ "): expected 8 test cases; only " ++ - (show $ cases cs) ++ - " found. Some may have been optimized out." - return False - tryCount cs ol = if (tried cs == 8) - then return True - else do - putStrLn $ "Failure: Basic Optimization (" ++ - ol ++ "): expected to try 8 test cases; only " ++ - (show $ tried cs) ++ - " tried. Some may have been optimized out." - return False - errorCount cs ol = if (errors cs == 0) - then return True - else do - putStrLn $ "Failure: Basic Optimization (" ++ - ol ++ "): expected 0 errors; " ++ - (show $ errors cs) ++ " found." - return False - failureCount cs ol = if (failures cs == 6) - then return True - else do - putStrLn $ "Failure: Basic Optimization (" ++ - ol ++ "): expected 6 failed cases; only " ++ - (show $ failures cs) ++ - " failed. Some may have been optimized out." - return False - --- Added in 1.4.2.3 --- When certain errors occur in a list of tests, the subsequent tests in the --- list weren't being run. This test verifies that this does not happen. -undefinedSwallowsTests :: Test -undefinedSwallowsTests = TestLabel ("Undefined Swallows Tests (" ++ optimizationLevel ++ ")") $ TestList [ - TestCase $ do - rs <- simpleTestRunner . TestList $ [ - -- Added in 1.2.4.3 because the second test case will never be run - -- (in prior versions) - TestCase $ ('f' : undefined) @?= "bar", - TestCase $ "foo" @?= "bar" - ] - assertEqual - "(cases,tried,errors,failures)" - (cases rs, tried rs, errors rs, failures rs) - (2, 2, 1, 1) - ] diff --git a/tests/HUnitTests.hs b/tests/HUnitTests.hs --- a/tests/HUnitTests.hs +++ b/tests/HUnitTests.hs @@ -9,18 +9,15 @@ import Test.HUnit import HUnitTestBase import HUnitTestExtended -import HUnitTestOptimize import TerminalTest main :: IO () main = do counts2 <- runTestTT (test [ - baseTests, + baseTests, extendedTests, - undefinedSwallowsTests, terminalTests ]) - oPassed <- optimizationTests - if (errors counts2 + failures counts2 == 0 && oPassed) + if (errors counts2 + failures counts2 == 0) then exitSuccess else exitFailure