1-- | Text-based test controller for running HUnit tests and reporting 2-- results as text, usually to a terminal. 3 4module Test.HUnit.Text 5( 6 PutText(..), 7 putTextToHandle, putTextToShowS, 8 runTestText, 9 showPath, showCounts, 10 runTestTT, 11 runTestTTAndExit 12) 13where 14 15import Test.HUnit.Base 16 17import Data.CallStack 18import Control.Monad (when) 19import System.IO (Handle, stderr, hPutStr, hPutStrLn) 20import System.Exit (exitSuccess, exitFailure) 21 22 23-- | As the general text-based test controller ('runTestText') executes a 24-- test, it reports each test case start, error, and failure by 25-- constructing a string and passing it to the function embodied in a 26-- 'PutText'. A report string is known as a \"line\", although it includes 27-- no line terminator; the function in a 'PutText' is responsible for 28-- terminating lines appropriately. Besides the line, the function 29-- receives a flag indicating the intended \"persistence\" of the line: 30-- 'True' indicates that the line should be part of the final overall 31-- report; 'False' indicates that the line merely indicates progress of 32-- the test execution. Each progress line shows the current values of 33-- the cumulative test execution counts; a final, persistent line shows 34-- the final count values. 35-- 36-- The 'PutText' function is also passed, and returns, an arbitrary state 37-- value (called 'st' here). The initial state value is given in the 38-- 'PutText'; the final value is returned by 'runTestText'. 39 40data PutText st = PutText (String -> Bool -> st -> IO st) st 41 42 43-- | Two reporting schemes are defined here. @putTextToHandle@ writes 44-- report lines to a given handle. 'putTextToShowS' accumulates 45-- persistent lines for return as a whole by 'runTestText'. 46-- 47-- @putTextToHandle@ writes persistent lines to the given handle, 48-- following each by a newline character. In addition, if the given flag 49-- is @True@, it writes progress lines to the handle as well. A progress 50-- line is written with no line termination, so that it can be 51-- overwritten by the next report line. As overwriting involves writing 52-- carriage return and blank characters, its proper effect is usually 53-- only obtained on terminal devices. 54 55putTextToHandle 56 :: Handle 57 -> Bool -- ^ Write progress lines to handle? 58 -> PutText Int 59putTextToHandle handle showProgress = PutText put initCnt 60 where 61 initCnt = if showProgress then 0 else -1 62 put line pers (-1) = do when pers (hPutStrLn handle line); return (-1) 63 put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0 64 put line False _ = do hPutStr handle ('\r' : line); return (length line) 65 -- The "erasing" strategy with a single '\r' relies on the fact that the 66 -- lengths of successive summary lines are monotonically nondecreasing. 67 erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r" 68 69 70-- | Accumulates persistent lines (dropping progess lines) for return by 71-- 'runTestText'. The accumulated lines are represented by a 72-- @'ShowS' ('String' -> 'String')@ function whose first argument is the 73-- string to be appended to the accumulated report lines. 74 75putTextToShowS :: PutText ShowS 76putTextToShowS = PutText put id 77 where put line pers f = return (if pers then acc f line else f) 78 acc f line rest = f (line ++ '\n' : rest) 79 80 81-- | Executes a test, processing each report line according to the given 82-- reporting scheme. The reporting scheme's state is threaded through calls 83-- to the reporting scheme's function and finally returned, along with final 84-- count values. 85 86runTestText :: PutText st -> Test -> IO (Counts, st) 87runTestText (PutText put us0) t = do 88 (counts', us1) <- performTest reportStart reportError reportFailure us0 t 89 us2 <- put (showCounts counts') True us1 90 return (counts', us2) 91 where 92 reportStart ss us = put (showCounts (counts ss)) False us 93 reportError = reportProblem "Error:" "Error in: " 94 reportFailure = reportProblem "Failure:" "Failure in: " 95 reportProblem p0 p1 loc msg ss us = put line True us 96 where line = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg 97 kind = if null path' then p0 else p1 98 path' = showPath (path ss) 99 100formatLocation :: Maybe SrcLoc -> String 101formatLocation Nothing = "" 102formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n" 103 104-- | Converts test execution counts to a string. 105 106showCounts :: Counts -> String 107showCounts Counts{ cases = cases', tried = tried', 108 errors = errors', failures = failures' } = 109 "Cases: " ++ show cases' ++ " Tried: " ++ show tried' ++ 110 " Errors: " ++ show errors' ++ " Failures: " ++ show failures' 111 112 113-- | Converts a test case path to a string, separating adjacent elements by 114-- the colon (\':\'). An element of the path is quoted (as with 'show') when 115-- there is potential ambiguity. 116 117showPath :: Path -> String 118showPath [] = "" 119showPath nodes = foldl1 f (map showNode nodes) 120 where f b a = a ++ ":" ++ b 121 showNode (ListItem n) = show n 122 showNode (Label label) = safe label (show label) 123 safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s 124 125 126-- | Provides the \"standard\" text-based test controller. Reporting is made to 127-- standard error, and progress reports are included. For possible 128-- programmatic use, the final counts are returned. 129-- 130-- The \"TT\" in the name suggests \"Text-based reporting to the Terminal\". 131 132runTestTT :: Test -> IO Counts 133runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t 134 return counts' 135 136-- | Convenience wrapper for 'runTestTT'. 137-- Simply runs 'runTestTT' and then exits back to the OS, 138-- using 'exitSuccess' if there were no errors or failures, 139-- or 'exitFailure' if there were. For example: 140-- 141-- > tests :: Test 142-- > tests = ... 143-- > 144-- > main :: IO () 145-- > main = runTestTTAndExit tests 146 147runTestTTAndExit :: Test -> IO () 148runTestTTAndExit tests = do 149 c <- runTestTT tests 150 if (errors c == 0) && (failures c == 0) 151 then exitSuccess 152 else exitFailure 153