HTF 0.7.1.0 → 0.8.0.0
raw patch · 13 files changed
+633/−140 lines, 13 filesdep +Diffdep +bytestringdep +regex-compat
Dependencies added: Diff, bytestring, regex-compat, unix
Files
- ChangeLog +50/−0
- HTF.cabal +11/−3
- Test/Framework/BlackBoxTest.hs +12/−16
- Test/Framework/Colors.hs +79/−0
- Test/Framework/Diff.hs +135/−0
- Test/Framework/HUnitWrapper.hs +19/−12
- Test/Framework/QuickCheckWrapper.hs +3/−4
- Test/Framework/TestConfig.hs +64/−0
- Test/Framework/TestManager.hs +222/−80
- Test/Framework/TestManagerInternal.hs +11/−7
- Test/Framework/TestManagerInternal.hs-boot +5/−2
- Test/Framework/Tutorial.hs +1/−1
- Test/Framework/Utils.hs +21/−15
+ ChangeLog view
@@ -0,0 +1,50 @@+* 0.8.0.0 ?+ - support for `--quiet' option to report failures only+ - color support+ - diff support: if an equality assertions fails, HTF shows a diff of+ the expected and the given value+ - more uniform output+ - tests to execute are now given by a regular expression,+ tests to ignored are prefixed with `--not'++* 0.7.1.0 (2011-07-08)+ - support for pending tests and quick check properties+ - support for ignoring certain tests in the argument list of+ Test.Framework.TestManager.runTestWithArgs (simply prefix the+ test names with a '-')++* 0.7.0.1 (2011-05-21)+ - minor fix for the tutorial (thanks to Marnix)++* 0.7.0.0 (2011-01-25)+ - htfpp parses extension from pragmas+ - runTest, runTestWithArgs, runTestWithFilter return an appropriate exit+ code++* 0.6.0.1 (2010-12-05)+ - support for GHC 7, QuickCheck 2.3, containers 0.4 and directory 1.1+ (thanks to David Leuschner)++* 0.6.0.0 (2010-11-12)+ - generalized mtl dependency to accept version 1.1* and 2.0.*.++* 0.5.0.1 (2010-10-11)+ - preprocessor now parses bang patterns++* 0.5.0.0 (2010-10-05)+ - added `--hunit' flag to htfpp. (The `--hunit' flag causes assert-like+ macros to be expanded in a way that is backwards-compatible with the+ corresponding functions of the HUnit library.)+ - Some functions in Test.Framework.HUnitWrapper were renamed in a+ non-backwards compatible way. The assert*P functions are now called+ assert*Pretty, and the function assertSetEqual is now called+ assertListsEqualAsSet++* 0.4.0.0 (2010-09-02)+ - More specific version constraints in .cabal file++* 0.3.5.0 (2010-08-30)+ - Testable instance for lists++* 0.3.4.0 (2010-08-30)+ - htfpp now accepts code subject to preprocessing with cpp
HTF.cabal view
@@ -1,8 +1,8 @@ Name: HTF-Version: 0.7.1.0+Version: 0.8.0.0 License: LGPL License-File: LICENSE-Copyright: (c) 2005-2010 Stefan Wehr+Copyright: (c) 2005-2011 Stefan Wehr Author: Stefan Wehr <mail@stefanwehr.de> Maintainer: Stefan Wehr <mail@stefanwehr.de> Bug-Reports: mailto:mail@stefanwehr.de@@ -30,6 +30,7 @@ Extra-Source-Files: README TODO+ ChangeLog Source-Repository head Type: darcs@@ -53,11 +54,16 @@ process == 1.0.*, directory >= 1.0 && < 1.2, mtl >= 1.1 && < 2.1,- pretty == 1.0.*+ pretty == 1.0.*,+ Diff >= 0.1.3 && < 0.2,+ unix == 2.4.*,+ bytestring == 0.9.*,+ regex-compat == 0.93.* Exposed-Modules: Test.Framework Test.Framework.HUnitWrapper Test.Framework.TestManager+ Test.Framework.TestConfig Test.Framework.QuickCheckWrapper Test.Framework.BlackBoxTest Test.Framework.Location@@ -66,4 +72,6 @@ Other-Modules: Test.Framework.TestManagerInternal Test.Framework.Utils+ Test.Framework.Colors+ Test.Framework.Diff Test.Framework.Process
Test/Framework/BlackBoxTest.hs view
@@ -84,14 +84,16 @@ 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)- ++ ":")- hPutStrLn stderr (err ++ (endOfOutput "output"))- putStrLn $ "stdout for " ++ show (bbtCfg_cmd bbt) ++ ":"- putStrLn (out ++ (endOfOutput "output"))- blackBoxTestFail ("test is supposed to succeed but failed "- ++ "with exit code " ++ show i)+ -> do let details =+ if (bbtCfg_verbose bbt)+ then ("stderr for " ++ show (bbtCfg_cmd bbt) ++ ":\n" +++ err ++ endOfOutput "stderr" ++ "\n" +++ "stdout for " ++ show (bbtCfg_cmd bbt) ++ ":\n" +++ out ++ endOfOutput "stdout") ++ "\n"+ else ""+ blackBoxTestFail (details +++ "test is supposed to succeed but failed " +++ "with exit code " ++ show i) _ -> do cmpOut <- cmp (bbtCfg_stdoutFile bbt) (bbtCfg_stdoutCmp bbt) out "Mismatch on stdout:\n" cmpErr <- cmp (bbtCfg_stderrFile bbt) (bbtCfg_stderrCmp bbt)@@ -99,14 +101,8 @@ case (cmpOut, cmpErr) of (Nothing, Nothing) -> return () (x1, x2) ->- do when (bbtCfg_verbose bbt) $- putStrLn (x1 `concatMaybes` x2)- let mismatchOn =- case (cmpOut, cmpErr) of- (Just _, Just _) -> "stdout and stderr"- (Just _, Nothing) -> "stdout"- _ -> "stderr"- blackBoxTestFail ("Mismatch on " ++ mismatchOn)+ do let details = ensureNewline (x1 `concatMaybes` x2)+ blackBoxTestFail details where cmp expectFile cmpAction real label = do res <- cmpAction expectFile real case res of
+ Test/Framework/Colors.hs view
@@ -0,0 +1,79 @@+--+-- Copyright (c) 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.Colors (++ Color(..), PrimColor(..), startColor, withColor, colorize+ , reset+ , firstDiffColor, secondDiffColor, skipDiffColor+ , warningColor, testStartColor, testOkColor, pendingColor++) where++import Test.Framework.TestConfig++-- REVERSE = "\033[2m"++firstDiffColor = Color Magenta False+secondDiffColor = Color Blue False+skipDiffColor = Color DarkGray False+warningColor = Color Red True+testStartColor = Color NoColor True+testOkColor = Color Green False+pendingColor = Color Cyan True++data Color = Color PrimColor Bool++data PrimColor = Black | Blue | Green | Cyan | Red | Magenta+ | Brown | Gray | DarkGray | LightBlue+ | LightGreen | LightCyan | LightRed | LightMagenta+ | Yellow | White | NoColor+ deriving (Eq, Show)++startColor :: Color -> String+startColor (Color c isBold) =+ (case c of+ Black -> "\ESC[0;30m"+ Blue -> "\ESC[0;34m"+ Green -> "\ESC[0;32m"+ Cyan -> "\ESC[0;36m"+ Red -> "\ESC[0;31m"+ Magenta -> "\ESC[0;35m"+ Brown -> "\ESC[0;33m"+ Gray -> "\ESC[0;37m"+ DarkGray -> "\ESC[1;30m"+ LightBlue -> "\ESC[1;34m"+ LightGreen -> "\ESC[1;32m"+ LightCyan -> "\ESC[1;36m"+ LightRed -> "\ESC[1;31m"+ LightMagenta -> "\ESC[1;35m"+ Yellow -> "\ESC[1;33m"+ White -> "\ESC[1;37m"+ NoColor -> "") +++ (if isBold then "\ESC[1m" else "")++reset :: String+reset = "\ESC[0;0m"++withColor :: Color -> String -> String+withColor c s = startColor c ++ s ++ reset++colorize :: Color -> String -> IO String+colorize c s =+ do b <- useColors+ return $ if b then withColor c s else s
+ Test/Framework/Diff.hs view
@@ -0,0 +1,135 @@+--+-- Copyright (c) 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.Diff (++ DiffConfig(..), noColorsDiffConfig, coloredDiffConfig, showDiff+ , defaultTerminalDiffConfig, defaultNoColorsDiffConfig+ , diffWithSensibleConfig++) where++import Data.Algorithm.Diff++import Test.Framework.Colors+import Test.Framework.TestConfig++data Pos = First | Middle | Last | FirstLast+ deriving (Eq)++isLast :: Pos -> Bool+isLast Last = True+isLast FirstLast = True+isLast _ = False++isFirst :: Pos -> Bool+isFirst First = True+isFirst FirstLast = True+isFirst _ = False++isMiddle :: Pos -> Bool+isMiddle Middle = True+isMiddle _ = False++data DiffConfig = DiffConfig {+ dc_fromFirstPrefix :: String+ , dc_fromFirstSuffix :: String+ , dc_fromSecondPrefix :: String+ , dc_fromSecondSuffix :: String+ , dc_fromBothPrefix :: String+ , dc_fromBothSuffix :: String+ , dc_sep :: String+ , dc_skipPrefix :: String+ , dc_skipSuffix :: String+ }++noColorsDiffConfig :: Char -> Char -> DiffConfig+noColorsDiffConfig f s = DiffConfig {+ dc_fromFirstPrefix = f : " "+ , dc_fromFirstSuffix = ""+ , dc_fromSecondPrefix = s : " "+ , dc_fromSecondSuffix = ""+ , dc_fromBothPrefix = "C "+ , dc_fromBothSuffix = ""+ , dc_skipPrefix = "<"+ , dc_skipSuffix = ">"+ , dc_sep = "\n"+ }++coloredDiffConfig :: Color -> Color -> Color -> DiffConfig+coloredDiffConfig c1 c2 c3 = DiffConfig {+ dc_fromFirstPrefix = startColor c1+ , dc_fromFirstSuffix = reset+ , dc_fromSecondPrefix = startColor c2+ , dc_fromSecondSuffix = reset+ , dc_fromBothPrefix = ""+ , dc_fromBothSuffix = ""+ , dc_skipPrefix = startColor c3+ , dc_skipSuffix = reset+ , dc_sep = ""+ }+++defaultTerminalDiffConfig :: DiffConfig+defaultTerminalDiffConfig = coloredDiffConfig firstDiffColor secondDiffColor skipDiffColor++defaultNoColorsDiffConfig :: DiffConfig+defaultNoColorsDiffConfig = noColorsDiffConfig 'F' 'S'++contextSize :: Int+contextSize = 10++showDiff :: DiffConfig -> String -> String -> String+showDiff dc s1 s2 =+ let groups = getGroupedDiff s1 s2+ in foldr (\(group, pos) string ->+ (showDiffGroup pos group) +++ (if not (isLast pos) then dc_sep dc else "") +++ string)+ "" (addPositions groups)+ where+ showDiffGroup _ (F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc+ showDiffGroup _ (S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc+ showDiffGroup pos (B, inBoth) =+ let showStart = not $ isFirst pos+ showEnd = not $ isLast pos+ (contextStart, ignored, contextEnd) =+ let (s, rest) = splitAt contextSize inBoth+ (i, e) = splitAt (length rest - contextSize) rest+ start = if showStart then s else ""+ end = if showEnd then e else ""+ ign = (if showStart then "" else s) ++ i +++ (if showEnd then "" else e)+ in (start, ign, end)+ middle = let n = length ignored+ replText = dc_skipPrefix dc ++ "skipped " ++ show n ++ " chars" ++ dc_skipSuffix dc+ in if n <= length replText then ignored else replText+ in dc_fromBothPrefix dc ++ contextStart ++ middle ++ contextEnd ++ dc_fromBothSuffix dc+ addPositions [] = []+ addPositions (x:[]) = (x, FirstLast) : []+ addPositions (x:xs) = (x, First) : addPositions' xs+ addPositions' [] = []+ addPositions' (x:[]) = (x, Last) : []+ addPositions' (x:xs) = (x, Middle) : addPositions' xs+++diffWithSensibleConfig :: String -> String -> IO String+diffWithSensibleConfig s1 s2 =+ do b <- useColors+ let dc = if b then defaultTerminalDiffConfig else defaultNoColorsDiffConfig+ return $ showDiff dc s1 s2
Test/Framework/HUnitWrapper.hs view
@@ -70,6 +70,8 @@ import Test.Framework.TestManagerInternal import Test.Framework.Location import Test.Framework.Utils+import Test.Framework.Diff+import Test.Framework.Colors import Test.Framework.Pretty -- WARNING: do not forget to add a preprocessor macro for new assertions!!@@ -119,26 +121,32 @@ -- -- Equality Assertions --++equalityFailedMessage :: String -> String -> IO String+equalityFailedMessage exp act =+ do d <- diffWithSensibleConfig exp act+ expected_ <- colorize firstDiffColor "expected:"+ but_got_ <- colorize secondDiffColor "but got:"+ return ("\n " ++ expected_ ++ " " ++ exp +++ "\n " ++ but_got_ ++ " " ++ act +++ "\n diff:\n" ++ d)+ _assertEqual_ :: (Eq a, Show a) => String -> Location -> String -> a -> a -> HU.Assertion _assertEqual_ name loc s expected actual = if expected /= actual- then assertFailure (mkMsg name s msg)+ then do x <- equalityFailedMessage (show expected) (show actual)+ assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return ()- where msg = "failed at " ++ showLoc loc ++- "\n expected: " ++ show expected ++- "\n but got: " ++ show actual CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a) _assertEqualPretty_ :: (Eq a, Pretty a) => String -> Location -> String -> a -> a -> HU.Assertion _assertEqualPretty_ name loc s expected actual = if expected /= actual- then assertFailure (mkMsg name s msg)+ then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)+ assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x) else return ()- where msg = "assertEqual failed at " ++ showLoc loc ++- "\n expected:\n" ++ showPretty expected ++- "\n but got:\n" ++ showPretty actual CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a) _assertEqualNoShow_ :: Eq a@@ -165,10 +173,9 @@ ++ "\n expected length: " ++ show ne ++ "\n actual length: " ++ show na)) | not (unorderedEq expected actual) ->- assertFailure (mkMsg "assertSetEqual" s- ("failed at " ++ showLoc loc- ++ "\n expected: " ++ show expected- ++ "\n actual: " ++ show actual))+ do x <- equalityFailedMessage (show expected) (show actual)+ assertFailure (mkMsg "assertSetEqual" s+ ("failed at " ++ showLoc loc ++ x)) | otherwise -> return () where unorderedEq l1 l2 = null (l1 \\ l2) && null (l2 \\ l1)
Test/Framework/QuickCheckWrapper.hs view
@@ -96,15 +96,14 @@ then quickCheckTestPending err else quickCheckTestError (Just err) Right (Success { output=msg }) ->- do report (adjustOutput msg)- return ()+ quickCheckTestPass (adjustOutput msg) 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))+ 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 }) ->
+ Test/Framework/TestConfig.hs view
@@ -0,0 +1,64 @@+--+-- 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.TestConfig (++ TestConfig(..), defaultTestConfig, ReportLevel(..), report+ , useColors++) where++import Data.Char (toLower)+import Control.Monad (unless)+import System.IO++import System.Posix.Terminal+import System.Posix.IO (stdOutput)+import System.Posix.Types (Fd)+import System.Posix.Env (getEnv)++data TestConfig = TestConfig { tc_quiet :: Bool }+ deriving (Read,Show,Eq)++defaultTestConfig :: TestConfig+defaultTestConfig = TestConfig { tc_quiet = False }++data ReportLevel = Debug | Info+ deriving (Eq,Ord)++reportHandle :: Handle+reportHandle = stdout -- keep in sync with reportFd!++reportFd :: Fd+reportFd = stdOutput -- keep in sync with reportHandle!++report :: TestConfig -> ReportLevel -> String -> IO ()+report tc level msg =+ unless (tc_quiet tc && level < Info) $ do hPutStrLn reportHandle msg+ hFlush reportHandle++useColors :: IO Bool+useColors =+ do mterm <- getEnv "TERM"+ case mterm of+ Nothing -> return False+ Just s | map toLower s == "dump" -> return False+ _ -> do mx <- getEnv "HTF_NO_COLORS"+ case mx of+ Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False+ _ -> queryTerminal reportFd
Test/Framework/TestManager.hs view
@@ -1,5 +1,5 @@ ----- Copyright (c) 2009 Stefan Wehr - http://www.stefanwehr.de+-- 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@@ -25,22 +25,32 @@ makeAnonTestSuite, addToTestSuite, testSuiteAsTest, - runTest, runTestWithArgs, runTestWithFilter+ parseTestArgs, runTest, runTestWithArgs, runTestWithOptions ) where import Control.Monad-import Control.Monad.State+import Control.Monad.RWS import System.Exit (ExitCode(..)) import Data.List ( isInfixOf, isPrefixOf, partition ) import Text.PrettyPrint import qualified Data.List as List+import Data.Maybe (isJust) +import System.Directory (getTemporaryDirectory, removeFile)+import System.IO+import System.Console.GetOpt+import GHC.IO.Handle+import qualified Data.ByteString.Lazy as BSL+import qualified Text.Regex as R+ import qualified Test.HUnit.Lang as HU import Test.Framework.Location ( Location, showLoc )-import Test.Framework.Utils ( readM )+import Test.Framework.Utils ( readM, ensureNewline ) import {-# SOURCE #-} Test.Framework.TestManagerInternal+import Test.Framework.TestConfig+import Test.Framework.Colors type Assertion = IO () @@ -118,106 +128,238 @@ initTestState :: TestState initTestState = TestState [] [] [] [] -type TR = StateT TestState IO+type TR = RWST TestConfig () TestState IO +data HandleRedirection = HandleRedirection { hr_original :: Handle+ , hr_originalCopy :: Handle+ , hr_newHandle :: Handle+ , hr_newFilePath :: FilePath }++redirectHandle :: String -> Handle -> IO HandleRedirection+redirectHandle nameTmpl h =+ do tmpDir <- getTemporaryDirectory+ (path, new) <- openBinaryTempFile tmpDir nameTmpl+ copy <- hDuplicate h+ hDuplicateTo new h+ return $ HandleRedirection { hr_original = h+ , hr_originalCopy = copy+ , hr_newHandle = new+ , hr_newFilePath = path }++unredirectHandle :: HandleRedirection -> IO ()+unredirectHandle hr =+ do hClose (hr_newHandle hr)+ hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore++cleanupRedirection :: Bool -> HandleRedirection -> IO ()+cleanupRedirection printOutput hr =+ do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr)+ BSL.hPut (hr_original hr) x+ hFlush (hr_original hr)+ removeFile (hr_newFilePath hr)+ runFlatTest :: FlatTest -> TR () runFlatTest (FlatTest sort id mloc ass) = do let name = id ++ case mloc of Nothing -> "" Just loc -> " (" ++ showLoc loc ++ ")"- liftIO $ report name+ x <- atStart name res <- liftIO $ HU.performTestCase ass- case res of- Nothing -> reportSuccess name- Just (isFailure', msg') ->- let (isFailure, msg, doReport) =- if sort /= QuickCheckTest- then (isFailure', msg', True)- else case readM msg' :: Maybe (Bool, Maybe String) of- Nothing ->- error ("ERROR: " ++- "Cannot deserialize QuickCheck " ++- "error message " ++ show msg')- Just (b, ms) ->- case ms of- Nothing -> (b, "", True)- Just s -> (b, s, True)- in if isFailure- 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- liftIO $ report ""+ let (testResult, msg) =+ case res of+ Nothing -> (Pass, "")+ Just (isFailure, msg') ->+ if sort /= QuickCheckTest+ then if isFailure+ then case extractPendingMessage msg' of+ Nothing -> (Fail, msg')+ Just msg'' -> (Pending, msg'')+ else (Error, msg')+ else case readM msg' :: Maybe (TestResult, Maybe String) of+ Nothing ->+ error ("ERROR: " +++ "Cannot deserialize QuickCheck " +++ "error message " ++ show msg')+ Just (r, ms) ->+ case ms of+ Nothing -> (r, "")+ Just s -> (r, s)+ afterRunning x name testResult+ case testResult of+ Pass -> reportSuccess name msg+ Pending ->+ do modify (\s -> s { ts_pending = name : (ts_pending s) })+ reportPending msg+ Fail ->+ do modify (\s -> s { ts_failed = name : (ts_failed s) })+ reportFailure msg+ Error ->+ do modify (\s -> s { ts_error = name : (ts_error s) })+ reportError msg+ atEnd testResult where- reportSuccess name =+ testStartMessage name =+ do t <- colorize testStartColor "[TEST] "+ return $ t ++ name+ atStart name =+ do tc <- ask+ if tc_quiet tc+ then liftIO $+ do stdoutRedir <- redirectHandle "HTF.out" stdout+ stderrRedir <- redirectHandle "HTF.err" stderr+ return $ Just (stdoutRedir, stderrRedir)+ else do msg <- liftIO $ testStartMessage name+ reportTR Debug msg+ return Nothing+ afterRunning x name testResult =+ do tc <- ask+ if tc_quiet tc+ then case x of+ Just (stdoutRedir, stderrRedir) -> liftIO $+ do unredirectHandle stderrRedir+ unredirectHandle stdoutRedir+ let printOutput = needsReport testResult+ when printOutput $+ do msg <- testStartMessage name+ report tc Info msg+ cleanupRedirection printOutput stderrRedir+ cleanupRedirection printOutput stdoutRedir+ else return ()+ atEnd testResult =+ do tc <- ask+ if not (tc_quiet tc) || needsReport testResult+ then reportTR Info ""+ else return ()+ needsReport testResult = testResult `elem` [Fail, Error, Pending]+ reportSuccess name msg = do modify (\s -> s { ts_passed = name : (ts_passed s) })- liftIO $ report "+++ OK"+ pref <- okPrefix+ reportTR Debug (ensureNewline msg ++ pref) reportPending msg =- reportMessage msg pendingPrefix+ do pref <- pendingPrefix+ reportMessage Info msg pref reportFailure msg =- reportMessage msg failurePrefix+ do pref <- failurePrefix+ reportMessage Info msg pref reportError msg =- reportMessage msg errorPrefix- reportMessage msg prefix = liftIO $ report (prefix ++ msg)- failurePrefix = "*** Failed! "- errorPrefix = "@@@ Error! "- pendingPrefix = "^^^ Pending! "+ do pref <- errorPrefix+ reportMessage Info msg pref+ reportMessage isImportant msg prefix =+ reportTR isImportant (ensureNewline msg ++ prefix)+ failurePrefix = liftIO $ colorize warningColor "*** Failed! "+ errorPrefix = liftIO $ colorize warningColor "@@@ Error! "+ pendingPrefix = liftIO $ colorize pendingColor "^^^ Pending! "+ okPrefix = liftIO $ colorize testOkColor "+++ OK" runFlatTests :: [FlatTest] -> TR () runFlatTests = mapM_ runFlatTest runTest :: TestableHTF t => t -> IO ExitCode-runTest = runTestWithFilter (\_ -> True)+runTest = runTestWithOptions defaultTestOptions +optionDescriptions :: [OptDescr (TestOptions -> TestOptions)]+optionDescriptions =+ [ Option ['v'] ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output"+ , Option ['q'] ["quiet"] (NoArg (\o -> o { opts_quiet = True })) "only display errors"+ , Option ['n'] ["not"] (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })+ "TEST_PATTERN") "tests to exclude"+ , Option ['h'] ["help"] (NoArg (\o -> o { opts_help = True })) "display this message"+ ]+ runTestWithArgs :: TestableHTF t => [String] -> t -> IO ExitCode-runTestWithArgs l tests =- let (pos, neg') = partition (\x -> not $ "-" `isPrefixOf` x) l- neg = map tail neg'- in runTestWithFilter (pred pos neg) tests+runTestWithArgs args t =+ case parseTestArgs args of+ Left err ->+ do hPutStrLn stderr err+ return $ ExitFailure 1+ Right opts ->+ runTestWithOptions opts t++parseTestArgs :: [String] -> Either String TestOptions+parseTestArgs args =+ case getOpt Permute optionDescriptions args of+ (optTrans, tests, [] ) ->+ let posStrs = tests+ negStrs = opts_negated opts+ pos = map mkRegex posStrs+ neg = map mkRegex negStrs+ pred (FlatTest _ id _ _) =+ if (any (\s -> s `matches` id) neg)+ then False+ else null pos || any (\s -> s `matches` id) pos+ opts = (foldr ($) defaultTestOptions optTrans) { opts_filter = pred }+ in Right opts+ (_,_,errs) ->+ Left (concat errs ++ usageInfo usageHeader optionDescriptions) where- pred pos neg (FlatTest _ id _ _) =- if (any (\s -> s `isInfixOf` id) neg)- then False- else null pos || any (\s -> s `isInfixOf` id) pos+ matches r s = isJust $ R.matchRegex r s+ mkRegex s = R.mkRegexWithOpts s True False +usageHeader :: String+usageHeader = ("USAGE: COMMAND [OPTION ...] TEST_PATTERN ...\n\n" +++ " where TEST_PATTERN is a posix regular expression.\n")+ type Filter = FlatTest -> Bool -runTestWithFilter :: TestableHTF t => Filter -> t -> IO ExitCode-runTestWithFilter pred t =- 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 + 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)))- when (error > 0) $- reportDoc (text "\nErrors:" $$ renderTestNames- (reverse (ts_error s)))- return $ case () of- _| failed == 0 && error == 0 -> ExitSuccess- | error == 0 -> ExitFailure 1- | otherwise -> ExitFailure 2+data TestOptions = TestOptions {+ opts_quiet :: Bool+ , opts_filter :: Filter+ , opts_help :: Bool+ , opts_negated :: [String]+ }++defaultTestOptions = TestOptions {+ opts_quiet = tc_quiet defaultTestConfig+ , opts_filter = const True+ , opts_help = False+ , opts_negated = []+ }++runTestWithOptions :: TestableHTF t => TestOptions -> t -> IO ExitCode+runTestWithOptions opts t =+ if opts_help opts+ then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions)+ return $ ExitFailure 1+ else+ do let pred = opts_filter opts+ tc = optsToConfig opts+ (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc 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 + pending+ pendings <- colorize pendingColor "* Pending:"+ failures <- colorize warningColor "* Failures:"+ errors <- colorize warningColor "* Errors:"+ report tc Info ("* Tests: " ++ show total ++ "\n" +++ "* Passed: " ++ show passed ++ "\n" +++ pendings ++ " " ++ show pending ++ "\n" +++ failures ++ " " ++ show failed ++ "\n" +++ errors ++ " " ++ show error )+ when (pending > 0) $+ reportDoc tc Info+ (text ('\n' : pendings) $$ renderTestNames (reverse (ts_pending s)))+ when (failed > 0) $+ reportDoc tc Info+ (text ('\n' : failures) $$ renderTestNames (reverse (ts_failed s)))+ when (error > 0) $+ reportDoc tc Info+ (text ('\n' : errors) $$ renderTestNames (reverse (ts_error s)))+ return $ case () of+ _| failed == 0 && error == 0 -> ExitSuccess+ | error == 0 -> ExitFailure 1+ | otherwise -> ExitFailure 2 where renderTestNames l = nest 2 (vcat (map (\name -> text "*" <+> text name) l))+ optsToConfig opts =+ TestConfig { tc_quiet = opts_quiet opts } -reportDoc :: Doc -> IO ()-reportDoc doc = report (render doc)+reportDoc :: TestConfig -> ReportLevel -> Doc -> IO ()+reportDoc tc level doc = report tc level (render doc)++reportTR :: ReportLevel -> String -> TR ()+reportTR level msg =+ do tc <- ask+ liftIO $ report tc level msg
Test/Framework/TestManagerInternal.hs view
@@ -20,9 +20,10 @@ extractPendingMessage, quickCheckTestFail, quickCheckTestError, quickCheckTestPending,+ quickCheckTestPass, unitTestFail, unitTestPending, blackBoxTestFail, - report+ TestResult(..) ) where @@ -31,6 +32,9 @@ import Test.Framework.TestManager +data TestResult = Error | Fail | Pending | Pass+ deriving (Show, Read, Eq)+ -- A pending test case is treated as a failed testcase, but the error message -- starts with the given prefix. pendingPrefix :: String@@ -53,14 +57,17 @@ -- 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))+quickCheckTestError m = assertFailureHTF (show (Error, m)) quickCheckTestFail :: Maybe String -> Assertion-quickCheckTestFail m = assertFailureHTF (show (True, m))+quickCheckTestFail m = assertFailureHTF (show (Fail, m)) quickCheckTestPending :: String -> Assertion-quickCheckTestPending m = quickCheckTestFail (Just $ makePendingMessage m)+quickCheckTestPending m = assertFailureHTF (show (Pending, Just m)) +quickCheckTestPass :: String -> Assertion+quickCheckTestPass m = assertFailureHTF (show (Pass, Just m))+ unitTestFail :: String -> IO a unitTestFail s = do assertFailureHTF s@@ -71,6 +78,3 @@ blackBoxTestFail :: String -> Assertion blackBoxTestFail = assertFailureHTF--report :: String -> IO ()-report = putStrLn
Test/Framework/TestManagerInternal.hs-boot view
@@ -1,5 +1,8 @@ module Test.Framework.TestManagerInternal where -extractPendingMessage :: String -> Maybe String+data TestResult = Error | Fail | Pending | Pass+instance Read TestResult+instance Show TestResult+instance Eq TestResult -report :: String -> IO ()+extractPendingMessage :: String -> Maybe String
Test/Framework/Tutorial.hs view
@@ -66,7 +66,7 @@ @ main = do args <- getArgs- runTestWithArgs args reverseTests+ runTestWithArgs args allHTFTests @ Here is the skeleton of a @.cabal@ file which you may want to use to
Test/Framework/Utils.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE PatternGuards #-}--- +-- -- 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@@ -20,7 +20,7 @@ module Test.Framework.Utils where import System.Directory-import Data.Char +import Data.Char infixr 6 </> @@ -38,17 +38,17 @@ p' -> p' startswith :: String -> String -> Bool-startswith s pref = +startswith s pref = let n = length pref in take n s == pref endswith :: String -> String -> Bool-endswith s suf = +endswith s suf = let n = length s - length suf in drop n s == suf dropPrefix :: String -> String -> String-dropPrefix s pref = +dropPrefix s pref = if startswith s pref then drop (length pref) s else s@@ -63,11 +63,11 @@ dropSpace :: [Char] -> [Char] dropSpace = let f = reverse . dropWhile isSpace in f . f -data DirectoryEntryType = File | Directory | Other +data DirectoryEntryType = File | Directory | Other deriving (Eq, Show) directoryEntryType :: FilePath -> IO DirectoryEntryType-directoryEntryType fp = +directoryEntryType fp = do b <- doesFileExist fp if b then return File else do b <- doesDirectoryExist fp return $ if b then Directory else Other@@ -76,16 +76,16 @@ -> String -- suffix of the file names to collect -> (FilePath -> [FilePath] -> IO Bool) -- predicate that determines- -- whether files below a certain + -- whether files below a certain -- directory should be pruned. -- The first argument is the -- name of the directory, the- -- second the entries of the + -- second the entries of the -- directory -> IO [FilePath]-collectFiles root suf prune = +collectFiles root suf prune = do entries <- getDirectoryContents root- b <- prune root entries + b <- prune root entries if b then return [] else do all <- mapM (collect root) entries return $ concat all@@ -98,7 +98,7 @@ _ -> return [] maybeFile :: FilePath -> IO (Maybe FilePath)-maybeFile f = +maybeFile f = do b <- doesFileExist f return $ if b then Just f else Nothing @@ -107,11 +107,11 @@ => (acc -> x -> m (acc, y)) -- Function of elt of input list -- and accumulator, returning new -- accumulator and elt of result list- -> acc -- Initial accumulator + -> acc -- Initial accumulator -> [x] -- Input list -> m (acc, [y]) -- Final accumulator and result list mapAccumLM _ s [] = return (s, [])-mapAccumLM f s (x:xs) = do (s', y ) <- f s x +mapAccumLM f s (x:xs) = do (s', y ) <- f s x (s'',ys) <- mapAccumLM f s' xs return (s'',y:ys) @@ -121,3 +121,9 @@ where parse = [x | (x,t) <- reads s] +ensureNewline :: String -> String+ensureNewline s =+ s ++ case dropWhile (== ' ') (reverse s) of+ '\n':_ -> ""+ _ | null s -> ""+ | otherwise -> "\n"