HTF 0.7.0.1 → 0.7.1.0

raw patch · 8 files changed

+217/−105 lines, 8 filesdep ~QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• HTF.cabal +4/−3
• Test/Framework/BlackBoxTest.hs +29/−29
• Test/Framework/HUnitWrapper.hs +5/−1
• Test/Framework/QuickCheckWrapper.hs +62/−27
• Test/Framework/TestManager.hs +35/−44
• Test/Framework/TestManagerInternal.hs +76/−0
• Test/Framework/TestManagerInternal.hs-boot +5/−0
• Test/Framework/Tutorial.hs +1/−1

@@ -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 <mail@stefanwehr.de> Maintainer:       Stefan Wehr <mail@stefanwehr.de> 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

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

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

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

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

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

@@ -0,0 +1,5 @@+module Test.Framework.TestManagerInternal where++extractPendingMessage :: String -> Maybe String++report :: String -> IO ()

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