diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,8 +1,8 @@ Name: HTF -Version: 0.7.0.1 +Version: 0.7.1.0 License: LGPL License-File: LICENSE -Copyright: (c) 2005-2011 Stefan Wehr +Copyright: (c) 2005-2010 Stefan Wehr Author: Stefan Wehr Maintainer: Stefan Wehr Bug-Reports: mailto:mail@stefanwehr.de @@ -46,7 +46,7 @@ Library Build-Depends: HUnit == 1.2.*, - QuickCheck >= 2.1 && < 2.4, + QuickCheck >= 2.3 && < 2.4, base >= 4 && < 5, random == 1.0.*, containers >= 0.3 && < 0.5, @@ -64,5 +64,6 @@ Test.Framework.Tutorial Test.Framework.Pretty Other-Modules: + Test.Framework.TestManagerInternal Test.Framework.Utils Test.Framework.Process diff --git a/Test/Framework/BlackBoxTest.hs b/Test/Framework/BlackBoxTest.hs --- a/Test/Framework/BlackBoxTest.hs +++ b/Test/Framework/BlackBoxTest.hs @@ -1,11 +1,11 @@ --- +-- -- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU @@ -24,10 +24,10 @@ correct exit code and that it produces the expected output. -} -module Test.Framework.BlackBoxTest ( - - BBTArgs(..), defaultBBTArgs, +module Test.Framework.BlackBoxTest ( + BBTArgs(..), defaultBBTArgs, + blackBoxTests, Diff, defaultDiff @@ -39,22 +39,23 @@ import System.IO import System.Exit import Control.Exception -import System.Directory +import System.Directory import Data.List ( mapAccumL ) import qualified Data.Map as Map import Control.Monad import Test.Framework.Process import Test.Framework.TestManager +import Test.Framework.TestManagerInternal import Test.Framework.Utils -{- | +{- | The type of a function comparing the content of a file against a string, similar to the unix tool @diff@. -The first parameter is the name of the file containing the +The first parameter is the name of the file containing the expected output. If this parameter is 'Nothing', then no output is expected. The second parameter is the actual output produced. -If the result is 'Nothing' then no difference was found. +If the result is 'Nothing' then no difference was found. Otherwise, a 'Just' value contains a string explaining the different. -} @@ -73,18 +74,18 @@ } runBlackBoxTest :: BlackBoxTestCfg -> Assertion -runBlackBoxTest bbt = +runBlackBoxTest bbt = do inp <- case bbtCfg_stdinFile bbt of Nothing -> return Nothing Just f -> do s <- readFile f return $ Just s (out,err,exit) <- popenShell (bbtCfg_cmd bbt) inp case exit of - ExitSuccess | bbtCfg_shouldFail bbt + ExitSuccess | bbtCfg_shouldFail bbt -> blackBoxTestFail ("test is supposed to fail but succeeded") ExitFailure i | not $ bbtCfg_shouldFail bbt -> do when (bbtCfg_verbose bbt) $ - do hPutStrLn stderr ("stderr for " ++ show (bbtCfg_cmd bbt) + do hPutStrLn stderr ("stderr for " ++ show (bbtCfg_cmd bbt) ++ ":") hPutStrLn stderr (err ++ (endOfOutput "output")) putStrLn $ "stdout for " ++ show (bbtCfg_cmd bbt) ++ ":" @@ -97,16 +98,16 @@ err "Mismatch on stderr:\n" case (cmpOut, cmpErr) of (Nothing, Nothing) -> return () - (x1, x2) -> - do when (bbtCfg_verbose bbt) $ + (x1, x2) -> + do when (bbtCfg_verbose bbt) $ putStrLn (x1 `concatMaybes` x2) - let mismatchOn = + let mismatchOn = case (cmpOut, cmpErr) of (Just _, Just _) -> "stdout and stderr" (Just _, Nothing) -> "stdout" _ -> "stderr" blackBoxTestFail ("Mismatch on " ++ mismatchOn) - where cmp expectFile cmpAction real label = + where cmp expectFile cmpAction real label = do res <- cmpAction expectFile real case res of Nothing -> return Nothing @@ -137,7 +138,7 @@ , bbtArgs_verbose = False } defaultDiff :: Diff -defaultDiff expectFile real = +defaultDiff expectFile real = do mexe <- findExecutable "diff" let exe = case mexe of Just p -> p @@ -148,7 +149,7 @@ "given:\n" ++ real ++ (endOfOutput "given output")) Just expect -> - do (out, err, exitCode) <- popen exe ["-u", expect, "-"] + do (out, err, exitCode) <- popen exe ["-u", expect, "-"] (Just real) case exitCode of ExitSuccess -> return Nothing -- no difference @@ -162,26 +163,26 @@ -> String -- filename suffix for input file -> BBTArgs -- configuration -> IO [Test] -blackBoxTests root exe suf cfg = +blackBoxTests root exe suf cfg = do let prune root _ = do dynCfg <- readDynCfg Map.empty - (root + (root bbtArgs_dynArgsName cfg) return $ dyn_skip dynCfg inputFiles <- collectFiles root suf prune (_, tests) <- mapAccumLM genTest Map.empty inputFiles return tests - where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap, + where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap, Test) genTest map fname = - do stdinf <- maybeFile $ replaceSuffix fname + do stdinf <- maybeFile $ replaceSuffix fname (bbtArgs_stdinSuffix cfg) - stdoutf <- maybeFile $ replaceSuffix fname + stdoutf <- maybeFile $ replaceSuffix fname (bbtArgs_stdoutSuffix cfg) - stderrf <- maybeFile $ replaceSuffix fname + stderrf <- maybeFile $ replaceSuffix fname (bbtArgs_stderrSuffix cfg) let configFile = dirname fname bbtArgs_dynArgsName cfg dynCfg <- readDynCfg map configFile - let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++ + let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++ fname shouldFail = dyn_shouldFail dynCfg verbose = bbtArgs_verbose cfg || dyn_verbose dynCfg @@ -211,15 +212,15 @@ , dyn_verbose = False } readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig -readDynCfg m f = +readDynCfg m f = do case Map.lookup f m of Just dynCfg -> return dynCfg Nothing -> do b <- doesFileExist f if not b then return $ defaultDynCfg else do s <- readFile f - return $ foldl (parse f) defaultDynCfg $ - filter (not . isUseless) (map dropSpace + return $ foldl (parse f) defaultDynCfg $ + filter (not . isUseless) (map dropSpace (lines s)) where isUseless :: String -> Bool isUseless [] = True @@ -232,4 +233,3 @@ parse _ cfg ('F':'l':'a':'g':'s':':':flags) = cfg { dyn_flags = flags } parse f _ l = error ("invalid line in dynamic configuration file `" ++ f ++ "': " ++ show l) - diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -28,7 +28,7 @@ module Test.Framework.HUnitWrapper ( -- * General failure - assertFailure, + assertFailure, unitTestPending, unitTestPending', -- * Assertions on Bool values assertBool_, assertBoolVerbose_, @@ -67,6 +67,7 @@ import qualified Test.HUnit as HU hiding ( assertFailure ) import Test.Framework.TestManager +import Test.Framework.TestManagerInternal import Test.Framework.Location import Test.Framework.Utils import Test.Framework.Pretty @@ -75,6 +76,9 @@ assertFailure :: String -> IO a assertFailure s = unitTestFail s + +unitTestPending' :: String -> IO a -> IO a +unitTestPending' msg _ = unitTestPending msg mkMsg :: String -> String -> String -> String mkMsg fun extraInfo s = diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification, + DeriveDataTypeable,ScopedTypeVariables #-} --- +-- -- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU @@ -24,47 +25,56 @@ module Test.QuickCheck, - TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs + TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs, + qcPending ) where import qualified Data.Map as Map import Control.Concurrent.MVar import Prelude hiding ( catch ) -import Control.Exception ( throw, catch, SomeException, evaluate ) +import Control.Exception ( SomeException, Exception, Handler(..), + throw, catch, catches, evaluate ) import System.IO import System.IO.Unsafe import System.Random -import Data.List( group, sort, intersperse ) +import Data.List( group, sort, intersperse, isPrefixOf ) import Data.Char +import Data.Typeable (Typeable) import Test.QuickCheck -import Test.QuickCheck.Property +import Test.QuickCheck.Property hiding (reason) import Test.Framework.TestManager +import Test.Framework.TestManagerInternal data QCState = QCState { qc_args :: Args } - + qcState :: MVar QCState qcState = unsafePerformIO (newMVar (QCState defaultArgs)) {-# NOINLINE qcState #-} defaultArgs :: Args -defaultArgs = stdArgs +defaultArgs = stdArgs { chatty = False } setDefaultArgs :: Args -> IO () -setDefaultArgs args = +setDefaultArgs args = do withMVar qcState $ \state -> return (state { qc_args = args }) return () getCurrentArgs :: IO Args -getCurrentArgs = +getCurrentArgs = withMVar qcState $ \state -> return (qc_args state) +data QCPendingException = QCPendingException String + deriving (Show,Read,Eq,Typeable) + +instance Exception QCPendingException + testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion -testableAsAssertion t = +testableAsAssertion t = withMVar qcState $ \state -> - do eitherArgs <- + do eitherArgs <- (let a = (argsModifier t) (qc_args state) in do evaluate (length (show a)) return (Right a)) @@ -72,24 +82,46 @@ (\e -> return $ Left (show (e :: SomeException))) case eitherArgs of Left err -> quickCheckTestError - (Just ("Cannot evaluate custom arguments: " + (Just ("Cannot evaluate custom arguments: " ++ err)) Right args -> - do res <- do x <- quickCheckWithResult args t + do res <- do x <- t `seq` quickCheckWithResult args t return (Right x) - `catch` - (\e -> return $ Left (show (e::SomeException))) + `catches` + [Handler $ \(QCPendingException msg) -> return $ Left (True, msg) + ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))] case res of - Left err -> quickCheckTestError (Just err) - Right (Success {}) -> return () - Right (Failure { usedSize=size, usedSeed=gen }) -> - do putStrLn ("Replay argument: " ++ - (show (show (Just (gen, size))))) - quickCheckTestFail Nothing - _ -> quickCheckTestFail Nothing + Left (isPending, err) -> + if isPending + then quickCheckTestPending err + else quickCheckTestError (Just err) + Right (Success { output=msg }) -> + do report (adjustOutput msg) + return () + Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) -> + if pendingPrefix `isPrefixOf` reason + then let pendingMsg = let s = drop (length pendingPrefix) reason + in take (length s - length pendingSuffix) s + in quickCheckTestPending pendingMsg + else do let replay = "Replay argument: " ++ (show (show (Just (gen, size)))) + quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay)) + Right (GaveUp { output=msg }) -> + quickCheckTestFail (Just (adjustOutput msg)) + Right (NoExpectedFailure { output=msg }) -> + quickCheckTestFail (Just (adjustOutput msg)) return () + where + pendingPrefix = "Exception: 'QCPendingException \"" + pendingSuffix = "\"'" + adjustOutput s = trimTrailing $ + case s of + '+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest + '*':'*':'*':' ':'F':'a':'i':'l':'e':'d':'!':' ':rest -> rest + '*':'*':'*':' ':rest -> rest + _ -> s + trimTrailing = reverse . dropWhile isSpace . reverse -data TestableWithQCArgs = forall a . Testable a => +data TestableWithQCArgs = forall a . Testable a => TestableWithQCArgs (Args -> Args) a instance Testable TestableWithQCArgs where @@ -107,12 +139,15 @@ argsModifier (TestableWithQCArgs f _) = f original a = Just a -withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a +withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a -> TestableWithQCArgs withQCArgs = TestableWithQCArgs asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs -asTestableWithQCArgs a = +asTestableWithQCArgs a = case original a of Just a' -> a' Nothing -> TestableWithQCArgs id a + +qcPending :: Testable t => String -> t -> t +qcPending msg _ = throw (QCPendingException msg) diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -21,9 +21,6 @@ TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..), TestableHTF, - quickCheckTestFail, quickCheckTestError, - unitTestFail, blackBoxTestFail, - makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, makeAnonTestSuite, addToTestSuite, testSuiteAsTest, @@ -35,40 +32,20 @@ import Control.Monad import Control.Monad.State import System.Exit (ExitCode(..)) -import Data.List ( isInfixOf ) +import Data.List ( isInfixOf, isPrefixOf, partition ) import Text.PrettyPrint +import qualified Data.List as List import qualified Test.HUnit.Lang as HU import Test.Framework.Location ( Location, showLoc ) import Test.Framework.Utils ( readM ) +import {-# SOURCE #-} Test.Framework.TestManagerInternal type Assertion = IO () type TestID = String -assertFailureHTF :: String -> Assertion --- Important: force the string argument, otherwise an error embedded --- lazily inside the string might escape. -assertFailureHTF s = length s `seq` HU.assertFailure s - --- This is a HACK: we encode a custom error message for QuickCheck --- failures and errors in a string, which is later parsed using read! - -quickCheckTestError :: Maybe String -> Assertion -quickCheckTestError m = assertFailureHTF (show (False, m)) - -quickCheckTestFail :: Maybe String -> Assertion -quickCheckTestFail m = assertFailureHTF (show (True, m)) - -unitTestFail :: String -> IO a -unitTestFail s = - do assertFailureHTF s - error "unitTestFail: UNREACHABLE" - -blackBoxTestFail :: String -> Assertion -blackBoxTestFail = assertFailureHTF - makeQuickCheckTest :: TestID -> Location -> Assertion -> Test makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass @@ -133,12 +110,13 @@ concatPath (Just s1) s2 = s1 ++ pathSep ++ s2 where pathSep = ":" -data TestState = TestState { ts_passed :: [String] - , ts_failed :: [String] - , ts_error :: [String] } +data TestState = TestState { ts_passed :: [String] + , ts_failed :: [String] + , ts_error :: [String] + , ts_pending :: [String] } initTestState :: TestState -initTestState = TestState [] [] [] +initTestState = TestState [] [] [] [] type TR = StateT TestState IO @@ -162,12 +140,16 @@ "error message " ++ show msg') Just (b, ms) -> case ms of - Nothing -> (b, "", False) + Nothing -> (b, "", True) Just s -> (b, s, True) in if isFailure - then do modify (\s -> s { ts_failed = - name : (ts_failed s) }) - when doReport $ reportFailure msg + then case extractPendingMessage msg of + Nothing -> do modify (\s -> s { ts_failed = + name : (ts_failed s) }) + when doReport $ reportFailure msg + Just msg -> do modify (\s -> s { ts_pending = + name : (ts_pending s) }) + when doReport $ reportPending msg else do modify (\s -> s { ts_error = name : (ts_error s) }) when doReport $ reportError msg @@ -175,8 +157,9 @@ where reportSuccess name = do modify (\s -> s { ts_passed = name : (ts_passed s) }) - when (sort /= QuickCheckTest) $ - liftIO $ report "+++ OK" + liftIO $ report "+++ OK" + reportPending msg = + reportMessage msg pendingPrefix reportFailure msg = reportMessage msg failurePrefix reportError msg = @@ -184,6 +167,7 @@ reportMessage msg prefix = liftIO $ report (prefix ++ msg) failurePrefix = "*** Failed! " errorPrefix = "@@@ Error! " + pendingPrefix = "^^^ Pending! " runFlatTests :: [FlatTest] -> TR () runFlatTests = mapM_ runFlatTest @@ -192,9 +176,15 @@ runTest = runTestWithFilter (\_ -> True) runTestWithArgs :: TestableHTF t => [String] -> t -> IO ExitCode -runTestWithArgs [] = runTest -runTestWithArgs l = runTestWithFilter pred - where pred (FlatTest _ id _ _) = any (\s -> s `isInfixOf` id) l +runTestWithArgs l tests = + let (pos, neg') = partition (\x -> not $ "-" `isPrefixOf` x) l + neg = map tail neg' + in runTestWithFilter (pred pos neg) tests + where + pred pos neg (FlatTest _ id _ _) = + if (any (\s -> s `isInfixOf` id) neg) + then False + else null pos || any (\s -> s `isInfixOf` id) pos type Filter = FlatTest -> Bool @@ -203,13 +193,18 @@ do s <- execStateT (runFlatTests (filter pred (flatten t))) initTestState let passed = length (ts_passed s) + pending = length (ts_pending s) failed = length (ts_failed s) error = length (ts_error s) - total = passed + failed + error + total = passed + failed + error + pending report ("* Tests: " ++ show total ++ "\n" ++ "* Passed: " ++ show passed ++ "\n" ++ + "* Pending: " ++ show pending ++ "\n" ++ "* Failures: " ++ show failed ++ "\n" ++ "* Errors: " ++ show error ) + when (pending > 0) $ + reportDoc (text "\nPending:" $$ renderTestNames + (reverse (ts_pending s))) when (failed > 0) $ reportDoc (text "\nFailures:" $$ renderTestNames (reverse (ts_failed s))) @@ -223,10 +218,6 @@ where renderTestNames l = nest 2 (vcat (map (\name -> text "*" <+> text name) l)) - - -report :: String -> IO () -report = putStrLn reportDoc :: Doc -> IO () reportDoc doc = report (render doc) diff --git a/Test/Framework/TestManagerInternal.hs b/Test/Framework/TestManagerInternal.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TestManagerInternal.hs @@ -0,0 +1,76 @@ +-- +-- Copyright (c) 2009-2011 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +module Test.Framework.TestManagerInternal ( + + extractPendingMessage, + quickCheckTestFail, quickCheckTestError, quickCheckTestPending, + unitTestFail, unitTestPending, blackBoxTestFail, + + report + +) where + +import Data.List ( isPrefixOf ) +import qualified Test.HUnit.Lang as HU + +import Test.Framework.TestManager + +-- A pending test case is treated as a failed testcase, but the error message +-- starts with the given prefix. +pendingPrefix :: String +pendingPrefix = "__PENDING__" + +makePendingMessage :: String -> String +makePendingMessage = (++) pendingPrefix + +extractPendingMessage :: String -> Maybe String +extractPendingMessage msg = + if pendingPrefix `isPrefixOf` msg + then Just $ drop (length pendingPrefix) msg + else Nothing + +assertFailureHTF :: String -> Assertion +-- Important: force the string argument, otherwise an error embedded +-- lazily inside the string might escape. +assertFailureHTF s = length s `seq` HU.assertFailure s + +-- This is a HACK: we encode a custom error message for QuickCheck +-- failures and errors in a string, which is later parsed using read! +quickCheckTestError :: Maybe String -> Assertion +quickCheckTestError m = assertFailureHTF (show (False, m)) + +quickCheckTestFail :: Maybe String -> Assertion +quickCheckTestFail m = assertFailureHTF (show (True, m)) + +quickCheckTestPending :: String -> Assertion +quickCheckTestPending m = quickCheckTestFail (Just $ makePendingMessage m) + +unitTestFail :: String -> IO a +unitTestFail s = + do assertFailureHTF s + error "unitTestFail: UNREACHABLE" + +unitTestPending :: String -> IO a +unitTestPending s = unitTestFail (makePendingMessage s) + +blackBoxTestFail :: String -> Assertion +blackBoxTestFail = assertFailureHTF + +report :: String -> IO () +report = putStrLn diff --git a/Test/Framework/TestManagerInternal.hs-boot b/Test/Framework/TestManagerInternal.hs-boot new file mode 100644 --- /dev/null +++ b/Test/Framework/TestManagerInternal.hs-boot @@ -0,0 +1,5 @@ +module Test.Framework.TestManagerInternal where + +extractPendingMessage :: String -> Maybe String + +report :: String -> IO () diff --git a/Test/Framework/Tutorial.hs b/Test/Framework/Tutorial.hs --- a/Test/Framework/Tutorial.hs +++ b/Test/Framework/Tutorial.hs @@ -66,7 +66,7 @@ @ main = do args <- getArgs - runTestWithArgs args allHTFTests + runTestWithArgs args reverseTests @ Here is the skeleton of a @.cabal@ file which you may want to use to