Permalink
Fetching contributors…
Cannot retrieve contributors at this time
393 lines (354 sloc) 10.9 KB
module Test.Chell.Main
( defaultMain
) where
import Control.Applicative
import Control.Monad (forM, forM_, when)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import Data.Char (ord)
import Data.List (isPrefixOf)
import System.Exit (exitSuccess, exitFailure)
import System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..))
import System.Random (randomIO)
import Text.Printf (printf)
import Options
import Test.Chell.Output
import Test.Chell.Types
data MainOptions = MainOptions
{ optVerbose :: Bool
, optXmlReport :: String
, optJsonReport :: String
, optTextReport :: String
, optSeed :: Maybe Int
, optTimeout :: Maybe Int
, optColor :: ColorMode
}
optionType_ColorMode :: OptionType ColorMode
optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode where
parseMode s = case s of
"always" -> Right ColorModeAlways
"never" -> Right ColorModeNever
"auto" -> Right ColorModeAuto
_ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")
showMode mode = case mode of
ColorModeAlways -> "always"
ColorModeNever -> "never"
ColorModeAuto -> "auto"
instance Options MainOptions where
defineOptions = pure MainOptions
<*> defineOption optionType_bool (\o -> o
{ optionShortFlags = ['v']
, optionLongFlags = ["verbose"]
, optionDefault = False
, optionDescription = "Print more output."
})
<*> simpleOption "xml-report" ""
"Write a parsable report to a given path, in XML."
<*> simpleOption "json-report" ""
"Write a parsable report to a given path, in JSON."
<*> simpleOption "text-report" ""
"Write a human-readable report to a given path."
<*> simpleOption "seed" Nothing
"The seed used for random numbers in (for example) quickcheck."
<*> simpleOption "timeout" Nothing
"The maximum duration of a test, in milliseconds."
<*> defineOption optionType_ColorMode (\o -> o
{ optionLongFlags = ["color"]
, optionDefault = ColorModeAuto
, optionDescription = "Whether to enable color ('always', 'auto', or 'never')."
})
-- | A simple default main function, which runs a list of tests and logs
-- statistics to stdout.
defaultMain :: [Suite] -> IO ()
defaultMain suites = runCommand $ \opts args -> do
-- validate/sanitize test options
seed <- case optSeed opts of
Just s -> return s
Nothing -> randomIO
timeout <- case optTimeout opts of
Nothing -> return Nothing
Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int)
then do
hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."
return Nothing
else return (Just t)
let testOptions = defaultTestOptions
{ testOptionSeed = seed
, testOptionTimeout = timeout
}
-- find which tests to run
let allTests = concatMap suiteTests suites
let tests = if null args
then allTests
else filter (matchesFilter args) allTests
-- output mode
output <- case optColor opts of
ColorModeNever -> return (plainOutput (optVerbose opts))
ColorModeAlways -> return (colorOutput (optVerbose opts))
ColorModeAuto -> do
isTerm <- hIsTerminalDevice stdout
return $ if isTerm
then colorOutput (optVerbose opts)
else plainOutput (optVerbose opts)
-- run tests
results <- forM tests $ \t -> do
outputStart output t
result <- runTest t testOptions
outputResult output t result
return (t, result)
-- generate reports
let reports = getReports opts
forM_ reports $ \(path, fmt, toText) ->
withBinaryFile path WriteMode $ \h -> do
when (optVerbose opts) $ do
putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)
hPutStr h (toText results)
let stats = resultStatistics results
let (_, _, failed, aborted) = stats
putStrLn (formatResultStatistics stats)
if failed == 0 && aborted == 0
then exitSuccess
else exitFailure
matchesFilter :: [String] -> Test -> Bool
matchesFilter filters = check where
check t = any (matchName (testName t)) filters
matchName name f = f == name || isPrefixOf (f ++ ".") name
type Report = [(Test, TestResult)] -> String
getReports :: MainOptions -> [(String, String, Report)]
getReports opts = concat [xml, json, text] where
xml = case optXmlReport opts of
"" -> []
path -> [(path, "XML", xmlReport)]
json = case optJsonReport opts of
"" -> []
path -> [(path, "JSON", jsonReport)]
text = case optTextReport opts of
"" -> []
path -> [(path, "text", textReport)]
jsonReport :: [(Test, TestResult)] -> String
jsonReport results = Writer.execWriter writer where
tell = Writer.tell
writer = do
tell "{\"test-runs\": ["
commas results tellResult
tell "]}"
tellResult (t, result) = case result of
TestPassed notes -> do
tell "{\"test\": \""
tell (escapeJSON (testName t))
tell "\", \"result\": \"passed\""
tellNotes notes
tell "}"
TestSkipped -> do
tell "{\"test\": \""
tell (escapeJSON (testName t))
tell "\", \"result\": \"skipped\"}"
TestFailed notes fs -> do
tell "{\"test\": \""
tell (escapeJSON (testName t))
tell "\", \"result\": \"failed\", \"failures\": ["
commas fs $ \f -> do
tell "{\"message\": \""
tell (escapeJSON (failureMessage f))
tell "\""
case failureLocation f of
Just loc -> do
tell ", \"location\": {\"module\": \""
tell (escapeJSON (locationModule loc))
tell "\", \"file\": \""
tell (escapeJSON (locationFile loc))
case locationLine loc of
Just line -> do
tell "\", \"line\": "
tell (show line)
Nothing -> tell "\""
tell "}"
Nothing -> return ()
tell "}"
tell "]"
tellNotes notes
tell "}"
TestAborted notes msg -> do
tell "{\"test\": \""
tell (escapeJSON (testName t))
tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""
tell (escapeJSON msg)
tell "\"}"
tellNotes notes
tell "}"
_ -> return ()
escapeJSON = concatMap (\c -> case c of
'"' -> "\\\""
'\\' -> "\\\\"
_ | ord c <= 0x1F -> printf "\\u%04X" (ord c)
_ -> [c])
tellNotes notes = do
tell ", \"notes\": ["
commas notes $ \(key, value) -> do
tell "{\"key\": \""
tell (escapeJSON key)
tell "\", \"value\": \""
tell (escapeJSON value)
tell "\"}"
tell "]"
commas xs block = State.evalStateT (commaState xs block) False
commaState xs block = forM_ xs $ \x -> do
let tell' = lift . Writer.tell
needComma <- State.get
if needComma
then tell' "\n, "
else tell' "\n "
State.put True
lift (block x)
xmlReport :: [(Test, TestResult)] -> String
xmlReport results = Writer.execWriter writer where
tell = Writer.tell
writer = do
tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"
tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"
mapM_ tellResult results
tell "</report>"
tellResult (t, result) = case result of
TestPassed notes -> do
tell "\t<test-run test='"
tell (escapeXML (testName t))
tell "' result='passed'>\n"
tellNotes notes
tell "\t</test-run>\n"
TestSkipped -> do
tell "\t<test-run test='"
tell (escapeXML (testName t))
tell "' result='skipped'/>\n"
TestFailed notes fs -> do
tell "\t<test-run test='"
tell (escapeXML (testName t))
tell "' result='failed'>\n"
forM_ fs $ \f -> do
tell "\t\t<failure message='"
tell (escapeXML (failureMessage f))
case failureLocation f of
Just loc -> do
tell "'>\n"
tell "\t\t\t<location module='"
tell (escapeXML (locationModule loc))
tell "' file='"
tell (escapeXML (locationFile loc))
case locationLine loc of
Just line -> do
tell "' line='"
tell (show line)
Nothing -> return ()
tell "'/>\n"
tell "\t\t</failure>\n"
Nothing -> tell "'/>\n"
tellNotes notes
tell "\t</test-run>\n"
TestAborted notes msg -> do
tell "\t<test-run test='"
tell (escapeXML (testName t))
tell "' result='aborted'>\n"
tell "\t\t<abortion message='"
tell (escapeXML msg)
tell "'/>\n"
tellNotes notes
tell "\t</test-run>\n"
_ -> return ()
escapeXML = concatMap (\c -> case c of
'&' -> "&amp;"
'<' -> "&lt;"
'>' -> "&gt;"
'"' -> "&quot;"
'\'' -> "&apos;"
_ -> [c])
tellNotes notes = forM_ notes $ \(key, value) -> do
tell "\t\t<note key=\""
tell (escapeXML key)
tell "\" value=\""
tell (escapeXML value)
tell "\"/>\n"
textReport :: [(Test, TestResult)] -> String
textReport results = Writer.execWriter writer where
tell = Writer.tell
writer = do
forM_ results tellResult
let stats = resultStatistics results
tell (formatResultStatistics stats)
tellResult (t, result) = case result of
TestPassed notes -> do
tell (replicate 70 '=')
tell "\n"
tell "PASSED: "
tell (testName t)
tell "\n"
tellNotes notes
tell "\n\n"
TestSkipped -> do
tell (replicate 70 '=')
tell "\n"
tell "SKIPPED: "
tell (testName t)
tell "\n\n"
TestFailed notes fs -> do
tell (replicate 70 '=')
tell "\n"
tell "FAILED: "
tell (testName t)
tell "\n"
tellNotes notes
tell (replicate 70 '-')
tell "\n"
forM_ fs $ \f -> do
case failureLocation f of
Just loc -> do
tell (locationFile loc)
case locationLine loc of
Just line -> do
tell ":"
tell (show line)
Nothing -> return ()
tell "\n"
Nothing -> return ()
tell (failureMessage f)
tell "\n\n"
TestAborted notes msg -> do
tell (replicate 70 '=')
tell "\n"
tell "ABORTED: "
tell (testName t)
tell "\n"
tellNotes notes
tell (replicate 70 '-')
tell "\n"
tell msg
tell "\n\n"
_ -> return ()
tellNotes notes = forM_ notes $ \(key, value) -> do
tell key
tell "="
tell value
tell "\n"
formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String
formatResultStatistics stats = Writer.execWriter writer where
writer = do
let (passed, skipped, failed, aborted) = stats
if failed == 0 && aborted == 0
then Writer.tell "PASS: "
else Writer.tell "FAIL: "
let putNum comma n what = Writer.tell $ if n == 1
then comma ++ "1 test " ++ what
else comma ++ show n ++ " tests " ++ what
let total = sum [passed, skipped, failed, aborted]
putNum "" total "run"
(putNum ", " passed "passed")
when (skipped > 0) (putNum ", " skipped "skipped")
when (failed > 0) (putNum ", " failed "failed")
when (aborted > 0) (putNum ", " aborted "aborted")
resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics results = State.execState state (0, 0, 0, 0) where
state = forM_ results $ \(_, result) -> case result of
TestPassed{} -> State.modify (\(p, s, f, a) -> (p+1, s, f, a))
TestSkipped{} -> State.modify (\(p, s, f, a) -> (p, s+1, f, a))
TestFailed{} -> State.modify (\(p, s, f, a) -> (p, s, f+1, a))
TestAborted{} -> State.modify (\(p, s, f, a) -> (p, s, f, a+1))
_ -> return ()