diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.4.0.0 +Version: 0.5.0.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2010 Stefan Wehr diff --git a/HTFPP.hs b/HTFPP.hs --- a/HTFPP.hs +++ b/HTFPP.hs @@ -1,13 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} --- +-- -- Copyright (c) 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 @@ -28,10 +28,10 @@ import Test.Framework.Preprocessor usage :: IO () -usage = - hPutStrLn stderr +usage = + hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++ - "Usage: " ++ progName ++ " [FILE1 [FILE2 [FILE3]]]\n\n" ++ + "Usage: " ++ progName ++ " [--hunit] [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" ++ @@ -40,10 +40,13 @@ " and output is written to FILE2.\n" ++ "* 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.") + " 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.") saveOpenFile :: FilePath -> IOMode -> IO Handle -saveOpenFile path mode = +saveOpenFile path mode = openFile path mode `catch` exHandler where exHandler :: SomeException -> IO Handle @@ -51,17 +54,21 @@ do hPutStrLn stderr ("Error opening file " ++ path ++ ": " ++ show e) exitWith (ExitFailure 1) - -main = + +main = do args <- getArgs when ("-h" `elem` args || "-help" `elem` args || "--help" `elem` args) $ do usage - exitWith (ExitFailure 1) + exitWith (ExitFailure 1) + let (restArgs, hunitBackwardsCompat) = + case reverse args of + "--hunit":rrest -> (reverse rrest, True) + rrest -> (reverse rrest, False) (origInputFilename, hIn, hOut) <- - case args of - [] -> + case restArgs of + [] -> return ("", stdin, stdout) file1:[] -> do h <- saveOpenFile file1 ReadMode @@ -78,10 +85,10 @@ do usage exitWith (ExitFailure 1) input <- hGetContents hIn - output <- transform origInputFilename input `catch` + output <- transform hunitBackwardsCompat origInputFilename input `catch` (\ (e::SomeException) -> - do hPutStrLn stderr (progName ++ - ": unexpected exception: " ++ + do hPutStrLn stderr (progName ++ + ": unexpected exception: " ++ show e) return ("#line 1 " ++ show origInputFilename ++ "\n" ++ input)) diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} {-# LANGUAGE ScopedTypeVariables #-} -- -- Copyright (c) 2005, 2009 Stefan Wehr - http://www.stefanwehr.de @@ -26,21 +27,36 @@ module Test.Framework.HUnitWrapper ( - assertBool_, - - assertEqual_, assertEqualP_, assertEqualNoShow_, + -- * General failure + assertFailure, - assertNotEmpty_, assertEmpty_, + -- * Assertions on Bool values + assertBool_, assertBoolVerbose_, - assertSetEqual_, + -- * Equality assertions + assertEqual_, assertEqualVerbose_, + assertEqualPretty_, assertEqualPrettyVerbose_, + assertEqualNoShow_, assertEqualNoShowVerbose_, - assertThrows_, assertThrowsSome_, + -- * Assertions on lists + assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_, + assertNotEmpty_, assertNotEmptyVerbose_, + assertEmpty_, assertEmptyVerbose_, - assertLeft_, assertLeftNoShow_, assertRight_, assertRightNoShow_, + -- * Assertions for exceptions + assertThrows_, assertThrowsVerbose_, + assertThrowsSome_, assertThrowsSomeVerbose_, - assertJust_, + -- * Assertions on Either values + assertLeft_, assertLeftVerbose_, + assertLeftNoShow_, assertLeftNoShowVerbose_, + assertRight_, assertRightVerbose_, + assertRightNoShow_, assertRightNoShowVerbose_, - assertFailure + -- * Assertions on Just values + assertJust_, assertJustVerbose_, + assertNothing_, assertNothingVerbose_, + assertNothingNoShow_, assertNothingNoShowVerbose_ ) where @@ -49,121 +65,207 @@ import Control.Exception import Control.Monad import qualified Test.HUnit as HU hiding ( assertFailure ) --- import Data.Algorithm.Diff import Test.Framework.TestManager import Test.Framework.Location import Test.Framework.Utils import Test.Framework.Pretty --- --- Assertions --- - -- WARNING: do not forget to add a preprocessor macro for new assertions!! assertFailure :: String -> IO a assertFailure s = unitTestFail s -assertBool_ :: Location -> Bool -> HU.Assertion -assertBool_ loc False = assertFailure ("assert failed at " ++ showLoc loc) -assertBool_ loc True = return () +mkMsg :: String -> String -> String -> String +mkMsg fun extraInfo s = + if null extraInfo + then fun ++ (' ':s) + else fun ++ " (" ++ extraInfo ++ ") " ++ s -assertEqual_ :: (Eq a, Show a) => Location -> a -> a -> HU.Assertion -assertEqual_ loc expected actual = +-- +-- Dirty macro hackery (I'm too lazy ...) +-- +#define CreateAssertionsGeneric(__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 CreateAssertionsCtx(__name__, __ctx__, __type__) \ +CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, HU.Assertion) + +#define CreateAssertions(__name__, __type__) \ +CreateAssertionsGeneric(__name__, , __type__, HU.Assertion) + +#define CreateAssertionsCtxRet(__name__, __ctx__, __type__, __ret__) \ +CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, __ret__) + +#define CreateAssertionsRet(__name__, __type__, __ret__) \ +CreateAssertionsGeneric(__name__, , __type__, __ret__) + +-- +-- Boolean Assertions +-- +_assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion +_assertBool_ name loc s False = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) +_assertBool_ _ _ _ True = return () +CreateAssertions(assertBool, Bool) + +-- +-- Equality Assertions +-- +_assertEqual_ :: (Eq a, Show a) + => String -> Location -> String -> a -> a -> HU.Assertion +_assertEqual_ name loc s expected actual = if expected /= actual - then assertFailure msg + then assertFailure (mkMsg name s msg) else return () - where msg = "assertEqual failed at " ++ showLoc loc ++ + where msg = "failed at " ++ showLoc loc ++ "\n expected: " ++ show expected ++ - "\n but got: " ++ show actual + "\n but got: " ++ show actual +CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a) -assertEqualP_ :: (Eq a, Pretty a) => Location -> a -> a -> HU.Assertion -assertEqualP_ loc expected actual = +_assertEqualPretty_ :: (Eq a, Pretty a) + => String -> Location -> String -> a -> a -> HU.Assertion +_assertEqualPretty_ name loc s expected actual = if expected /= actual - then assertFailure msg + then assertFailure (mkMsg name s msg) else return () where msg = "assertEqual failed at " ++ showLoc loc ++ "\n expected:\n" ++ showPretty expected ++ - "\n but got:\n" ++ showPretty actual + "\n but got:\n" ++ showPretty actual +CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a) -assertEqualNoShow_ :: Eq a => Location -> a -> a -> HU.Assertion -assertEqualNoShow_ loc expected actual = +_assertEqualNoShow_ :: Eq a + => String -> Location -> String -> a -> a -> HU.Assertion +_assertEqualNoShow_ name loc s expected actual = if expected /= actual - then assertFailure ("assertEqualNoShow failed at " ++ showLoc loc) + then assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) else return () +CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a) -assertSetEqual_ :: (Eq a, Show a) => Location -> [a] -> [a] -> HU.Assertion -assertSetEqual_ loc expected actual = +-- +-- Assertions on Lists +-- + +_assertListsEqualAsSets_ :: (Eq a, Show a) + => String -> Location -> String -> [a] -> [a] -> HU.Assertion +_assertListsEqualAsSets_ name loc s expected actual = let ne = length expected na = length actual in case () of _| ne /= na -> - assertFailure ("assertSetEqual failed at " ++ showLoc loc - ++ "\n expected length: " ++ show ne - ++ "\n actual length: " ++ show na) + assertFailure (mkMsg name s + ("failed at " ++ showLoc loc + ++ "\n expected length: " ++ show ne + ++ "\n actual length: " ++ show na)) | not (unorderedEq expected actual) -> - assertFailure ("assertSetEqual failed at " ++ showLoc loc - ++ "\n expected: " ++ show expected - ++ "\n actual: " ++ show actual) + assertFailure (mkMsg "assertSetEqual" s + ("failed at " ++ showLoc loc + ++ "\n expected: " ++ show expected + ++ "\n actual: " ++ show actual)) | otherwise -> return () where unorderedEq l1 l2 = null (l1 \\ l2) && null (l2 \\ l1) +CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a]) +_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion +_assertNotEmpty_ name loc s [] = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) +_assertNotEmpty_ _ _ _ (_:_) = return () +CreateAssertions(assertNotEmpty, [a]) -assertNotEmpty_ :: Location -> [a] -> HU.Assertion -assertNotEmpty_ loc [] = - assertFailure ("assertNotEmpty failed at " ++ showLoc loc) -assertNotEmpty_ _ (_:_) = return () +_assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion +_assertEmpty_ name loc s (_:_) = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) +_assertEmpty_ _ _ _ [] = return () +CreateAssertions(assertEmpty, [a]) -assertEmpty_ :: Location -> [a] -> HU.Assertion -assertEmpty_ loc (_:_) = assertFailure ("assertEmpty failed at " ++ showLoc loc) -assertEmpty_ loc [] = return () +-- +-- Assertions for Exceptions +-- -assertThrows_ :: Exception e => Location -> a -> (e -> Bool) -> HU.Assertion -assertThrows_ loc x f = +_assertThrows_ :: Exception e + => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion +_assertThrows_ name loc s x f = do res <- try (evaluate x) case res of - Right _ -> assertFailure ("assertThrows failed at " ++ showLoc loc ++ - ": no exception was thrown") + Right _ -> assertFailure (mkMsg name s + ("failed at " ++ showLoc loc ++ + ": no exception was thrown")) Left e -> if f e then return () - else assertFailure ("assertThrows failed at " ++ - showLoc loc ++ - ": wrong exception was thrown: " ++ - show e) + else assertFailure (mkMsg name s + ("failed at " ++ + showLoc loc ++ + ": wrong exception was thrown: " ++ + show e)) +CreateAssertionsCtx(assertThrows, Exception e, a -> (e -> Bool)) -assertThrowsSome_ :: Location -> a -> HU.Assertion -assertThrowsSome_ loc x = - assertThrows_ loc x (\ (e::SomeException) -> True) +_assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion +_assertThrowsSome_ name loc s x = + _assertThrows_ name loc s x (\ (e::SomeException) -> True) +CreateAssertions(assertThrowsSome, a) -assertLeft_ :: forall a b . Show b => Location -> Either a b -> IO a -assertLeft_ _ (Left x) = return x -assertLeft_ loc (Right x) = - assertFailure ("assertLeft failed at " ++ showLoc loc ++ - ": expected a Left value, given " ++ - show (Right x :: Either b b)) +-- +-- Assertions on Either +-- -assertLeftNoShow_ :: Location -> Either a b -> IO a -assertLeftNoShow_ _ (Left x) = return x -assertLeftNoShow_ loc (Right x) = - assertFailure ("assertLeft failed at " ++ showLoc loc ++ - ": expected a Left value, given a Right value") +_assertLeft_ :: forall a b . Show b + => String -> Location -> String -> Either a b -> IO a +_assertLeft_ _ _ _ (Left x) = return x +_assertLeft_ name loc s (Right x) = + assertFailure (mkMsg name s + ("failed at " ++ showLoc loc ++ + ": expected a Left value, given " ++ + show (Right x :: Either b b))) +CreateAssertionsCtxRet(assertLeft, Show b, Either a b, IO a) -assertRight_ :: forall a b . Show a => Location -> Either a b -> IO b -assertRight_ _ (Right x) = return x -assertRight_ loc (Left x) = - assertFailure ("assertRight failed at " ++ showLoc loc ++ - ": expected a Right value, given " ++ - show (Left x :: Either a a)) +_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a +_assertLeftNoShow_ _ _ _ (Left x) = return x +_assertLeftNoShow_ name loc s (Right _) = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected a Left value, given a Right value")) +CreateAssertionsRet(assertLeftNoShow, Either a b, IO a) -assertRightNoShow_ :: Location -> Either a b -> IO b -assertRightNoShow_ _ (Right x) = return x -assertRightNoShow_ loc (Left x) = - assertFailure ("assertRight failed at " ++ showLoc loc ++ - ": expected a Right value, given a Left value") +_assertRight_ :: forall a b . Show a + => String -> Location -> String -> Either a b -> IO b +_assertRight_ _ _ _ (Right x) = return x +_assertRight_ name loc s (Left x) = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected a Right value, given " ++ + show (Left x :: Either a a))) +CreateAssertionsCtxRet(assertRight, Show a, Either a b, IO b) -assertJust_ :: Location -> Maybe a -> IO a -assertJust_ _ (Just x) = return x -assertJust_ loc Nothing = - assertFailure ("assertJust failed at " ++ showLoc loc ++ - ": expected a Just value, given Nothing") +_assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b +_assertRightNoShow_ _ _ _ (Right x) = return x +_assertRightNoShow_ name loc s (Left _) = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected a Right value, given a Left value")) +CreateAssertionsRet(assertRightNoShow, Either a b, IO b) + +-- +-- Assertions on Maybe +-- + +_assertJust_ :: String -> Location -> String -> Maybe a -> IO a +_assertJust_ _ _ _ (Just x) = return x +_assertJust_ name loc s Nothing = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected a Just value, given Nothing")) +CreateAssertionsRet(assertJust, Maybe a, IO a) + +_assertNothing_ :: Show a + => String -> Location -> String -> Maybe a -> HU.Assertion +_assertNothing_ _ _ _ Nothing = return () +_assertNothing_ name loc s jx = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected Nothing, given " ++ show jx)) +CreateAssertionsCtx(assertNothing, Show a, Maybe a) + +_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion +_assertNothingNoShow_ _ _ _ Nothing = return () +_assertNothingNoShow_ name loc s _ = + assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++ + ": expected Nothing, given a Just value")) +CreateAssertions(assertNothingNoShow, Maybe a) diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -39,26 +39,36 @@ testDeclName :: String testDeclName = "allHTFTests" -assertDefines :: String -> [(String, String)] -assertDefines prefix = - map (\s -> (s, "(" ++ prefix ++ s ++ "_ (" ++ - prefix ++ "makeLoc __FILE__ __LINE__))")) - ["assertBool" - ,"assertEqual" - ,"assertEqualP" - ,"assertEqualNoShow" - ,"assertSetEqual" - ,"assertEmpty" - ,"assertNotEmpty" - ,"assertThrows" - ,"assertThrowsSome" - ,"assertLeft" - ,"assertLeftNoShow" - ,"assertRight" - ,"assertRightNoShow" - ,"assertJust" - ] +allAsserts :: [String] +allAsserts = ["assertBool" + ,"assertEqual" + ,"assertEqualPretty" + ,"assertEqualNoShow" + ,"assertListsEqualAsSets" + ,"assertEmpty" + ,"assertNotEmpty" + ,"assertThrows" + ,"assertThrowsSome" + ,"assertLeft" + ,"assertLeftNoShow" + ,"assertRight" + ,"assertRightNoShow" + ,"assertJust" + ,"assertNothing" + ,"assertNothingNoShow" + ] +assertDefines :: Bool -> String -> [(String, String)] +assertDefines hunitBackwardsCompat prefix = + concatMap fun allAsserts + 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__))" + warn :: String -> IO () warn s = hPutStrLn stderr $ progName ++ " warning: " ++ s @@ -107,8 +117,8 @@ Just (PropDef rest loc name) _ -> Nothing -transform :: FilePath -> String -> IO String -transform originalFileName input = +transform :: Bool -> FilePath -> String -> IO String +transform hunitBackwardsCompat originalFileName input = do analyseResult <- analyse originalFileName input case analyseResult of ParseError loc err -> @@ -127,7 +137,8 @@ cpphsOptions info = defaultCpphsOptions { defines = defines defaultCpphsOptions ++ - assertDefines (mi_prefix info) + assertDefines hunitBackwardsCompat + (mi_prefix info) } additionalCode :: ModuleInfo -> String additionalCode info = diff --git a/Test/Framework/Tutorial.hs b/Test/Framework/Tutorial.hs --- a/Test/Framework/Tutorial.hs +++ b/Test/Framework/Tutorial.hs @@ -48,7 +48,9 @@ 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 +the current location in the file as the first argument. (Backwards-compatibility +with the HUnit library is discussed at the end of this tutorial.) +Moreover, the preprocessor collects all top-level definitions starting with @test_@ or @prop_@ in a test suite with name allHTFTests of type 'TestSuite'. @@ -78,7 +80,7 @@ Executable tutorial Main-is: Tutorial.hs - Build-depends: base, HTF + Build-depends: base >= 4 && < 5, HTF == 0.5.* @ Compiling the program just shown (you must include the code for @@ -156,7 +158,23 @@ The HTF also allows the definition of black box tests. See the documentation of the "Test.Framework.BlackBoxTest" module for further information. +/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. -} module Test.Framework.Tutorial where import Test.Framework +import qualified Test.HUnit.Base