HTF 0.4.0.0 → 0.5.0.0

raw patch · 5 files changed

+260/−122 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• HTF.cabal +1/−1
• HTFPP.hs +22/−15
• Test/Framework/HUnitWrapper.hs +184/−82
• Test/Framework/Preprocessor.hs +33/−22
• Test/Framework/Tutorial.hs +20/−2

@@ -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

@@ -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>", 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))

@@ -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)

@@ -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 =

@@ -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