diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +* 0.8.2.0 (2012-01-30) + - Assertions can be run via runTest + - Support for assertNotEqual + - Bugfixes + +* 0.8.1.1 (2011-11-07) + - Bugfixes + * 0.8.1.0 (2011-11-07) - fixed build dependencies to include process 1.1.* diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.8.1.1 +Version: 0.8.2.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2011 Stefan Wehr diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -37,6 +37,9 @@ assertEqual_, assertEqualVerbose_, assertEqualPretty_, assertEqualPrettyVerbose_, assertEqualNoShow_, assertEqualNoShowVerbose_, + assertNotEqual_, assertNotEqualVerbose_, + assertNotEqualPretty_, assertNotEqualPrettyVerbose_, + assertNotEqualNoShow_, assertNotEqualNoShowVerbose_, -- * Assertions on lists assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_, @@ -157,6 +160,15 @@ HE.ParseOk x -> Just $ HE.prettyPrint x HE.ParseFailed{} -> Nothing +notEqualityFailedMessage :: String -> IO String +notEqualityFailedMessage exp = + do return (": Objects are equal\n" ++ pp exp) + where + pp s = + case HE.parseExp s of + HE.ParseOk x -> HE.prettyPrint x + HE.ParseFailed{} -> s + _assertEqual_ :: (Eq a, Show a) => String -> Location -> String -> a -> a -> HU.Assertion _assertEqual_ name loc s expected actual = @@ -166,6 +178,15 @@ else return () CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a) +_assertNotEqual_ :: (Eq a, Show a) + => String -> Location -> String -> a -> a -> HU.Assertion +_assertNotEqual_ name loc s expected actual = + if expected == actual + then do x <- notEqualityFailedMessage (show expected) + assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + else return () +CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), a -> a) + _assertEqualPretty_ :: (Eq a, Pretty a) => String -> Location -> String -> a -> a -> HU.Assertion _assertEqualPretty_ name loc s expected actual = @@ -175,6 +196,15 @@ else return () CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a) +_assertNotEqualPretty_ :: (Eq a, Pretty a) + => String -> Location -> String -> a -> a -> HU.Assertion +_assertNotEqualPretty_ name loc s expected actual = + if expected == actual + then do x <- notEqualityFailedMessage (showPretty expected) + assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) + else return () +CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), a -> a) + _assertEqualNoShow_ :: Eq a => String -> Location -> String -> a -> a -> HU.Assertion _assertEqualNoShow_ name loc s expected actual = @@ -182,6 +212,14 @@ then assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) else return () CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a) + +_assertNotEqualNoShow_ :: Eq a + => String -> Location -> String -> a -> a -> HU.Assertion +_assertNotEqualNoShow_ name loc s expected actual = + if expected == actual + then assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) + else return () +CreateAssertionsCtx(assertNotEqualNoShow, Eq a, a -> a) -- -- Assertions on Lists diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs --- a/Test/Framework/HaskellParser.hs +++ b/Test/Framework/HaskellParser.hs @@ -71,7 +71,9 @@ parseMode = Parser.ParseMode { Parser.parseFilename = originalFileName , Parser.ignoreLanguagePragmas = False , Parser.ignoreLinePragmas = False - , Parser.extensions = Ext.glasgowExts + , Parser.extensions = + Ext.glasgowExts ++ + [Ext.BangPatterns, Ext.TemplateHaskell] , Parser.fixities = Just (Fix.baseFixities ++ Fix.infixr_ 0 ["==>"]) diff --git a/Test/Framework/Location.hs b/Test/Framework/Location.hs --- a/Test/Framework/Location.hs +++ b/Test/Framework/Location.hs @@ -1,11 +1,11 @@ --- +-- -- Copyright (c) 2005 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 @@ -16,13 +16,13 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Location ( +module Test.Framework.Location ( - Location, + Location, unknownLocation, fileName, lineNumber, - showLoc, makeLoc + showLoc, makeLoc ) where @@ -44,3 +44,6 @@ -> Int -- ^ The line number -> Location makeLoc = Location + +unknownLocation :: Location +unknownLocation = Location "?" 0 diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -44,6 +44,9 @@ ,"assertEqual" ,"assertEqualPretty" ,"assertEqualNoShow" + ,"assertNotEqual" + ,"assertNotEqualPretty" + ,"assertNotEqualNoShow" ,"assertListsEqualAsSets" ,"assertEmpty" ,"assertNotEmpty" diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -85,7 +85,8 @@ (Just ("Cannot evaluate custom arguments: " ++ err)) Right args -> - do res <- do x <- t `seq` quickCheckWithResult args t + do res <- do t' <- evaluate t + x <- quickCheckWithResult args t' return (Right x) `catches` [Handler $ \(QCPendingException msg) -> return $ Left (True, msg) diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -46,7 +46,7 @@ import qualified Test.HUnit.Lang as HU -import Test.Framework.Location ( Location, showLoc ) +import Test.Framework.Location import Test.Framework.Utils ( readM, ensureNewline ) import {-# SOURCE #-} Test.Framework.TestManagerInternal import Test.Framework.TestConfig @@ -101,6 +101,9 @@ instance TestableHTF t => TestableHTF [t] where flatten = concatMap flatten +instance TestableHTF (IO a) where + flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action) + type Path = Maybe String flattenTest :: Path -> Test -> [FlatTest] @@ -179,7 +182,8 @@ Nothing -> error ("ERROR: " ++ "Cannot deserialize QuickCheck " ++ - "error message " ++ show msg') + "error message.\n[BEGIN]\n" ++ + show msg' ++ "\n[END]\n") Just (r, ms) -> case ms of Nothing -> (r, "")