module Test.Chell.Main
( defaultMain
) where
import Control.Monad (forM, forM_, unless, when)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import qualified Data.ByteString
import Data.Char (ord)
import qualified Data.Text
import Data.Text (Text, pack)
import qualified Data.Text.Encoding
import qualified Data.Text.IO
import qualified System.Console.GetOpt as GetOpt
import System.Environment (getArgs, getProgName)
import System.Exit (exitSuccess, exitFailure)
import qualified System.IO as IO
import System.Random (randomIO)
import Text.Printf (printf)
import Test.Chell.Types
data Option
= OptionHelp
| OptionVerbose
| OptionXmlReport FilePath
| OptionJsonReport FilePath
| OptionTextReport FilePath
| OptionSeed Int
| OptionTimeout Int
deriving (Show, Eq)
optionInfo :: [GetOpt.OptDescr Option]
optionInfo =
[ GetOpt.Option ['h'] ["help"]
(GetOpt.NoArg OptionHelp)
"show this help"
, GetOpt.Option ['v'] ["verbose"]
(GetOpt.NoArg OptionVerbose)
"print more output"
, GetOpt.Option [] ["xml-report"]
(GetOpt.ReqArg OptionXmlReport "PATH")
"write a parsable report to a file, in XML"
, GetOpt.Option [] ["json-report"]
(GetOpt.ReqArg OptionJsonReport "PATH")
"write a parsable report to a file, in JSON"
, GetOpt.Option [] ["text-report"]
(GetOpt.ReqArg OptionTextReport "PATH")
"write a human-readable report"
, GetOpt.Option [] ["seed"]
(GetOpt.ReqArg (\s -> case parseInt s of
Just x -> OptionSeed x
Nothing -> error ("Failed to parse --seed value " ++ show s)) "SEED")
"the seed used for random numbers in (for example) quickcheck"
, GetOpt.Option [] ["timeout"]
(GetOpt.ReqArg (\s -> case parseTimeout s of
Just x -> OptionTimeout x
Nothing -> error ("Failed to parse --timeout value " ++ show s)) "TIMEOUT")
"the maximum duration of a test, in milliseconds"
]
parseInt :: String -> Maybe Int
parseInt s = case [x | (x, "") <- reads s] of
[x] -> Just x
_ -> Nothing
parseTimeout :: String -> Maybe Int
parseTimeout s = do
msec <- parseInt s
if (toInteger msec) * 1000 > toInteger (maxBound :: Int)
then Nothing
else return msec
getSeedOpt :: [Option] -> Maybe Int
getSeedOpt [] = Nothing
getSeedOpt ((OptionSeed s) : _) = Just s
getSeedOpt (_:os) = getSeedOpt os
getTimeoutOpt :: [Option] -> Maybe Int
getTimeoutOpt [] = Nothing
getTimeoutOpt ((OptionTimeout s) : _) = Just s
getTimeoutOpt (_:os) = getTimeoutOpt os
usage :: String -> String
usage name = "Usage: " ++ name ++ " [OPTION...]"
defaultMain :: [Suite] -> IO ()
defaultMain suites = do
args <- getArgs
let (options, filters, optionErrors) = GetOpt.getOpt GetOpt.Permute optionInfo args
unless (null optionErrors) $ do
name <- getProgName
IO.hPutStrLn IO.stderr (concat optionErrors)
IO.hPutStrLn IO.stderr (GetOpt.usageInfo (usage name) optionInfo)
exitFailure
when (OptionHelp `elem` options) $ do
name <- getProgName
putStrLn (GetOpt.usageInfo (usage name) optionInfo)
exitSuccess
let allTests = concatMap suiteTests suites
let tests = if null filters
then allTests
else filter (matchesFilter filters) allTests
seed <- case getSeedOpt options of
Just s -> return s
Nothing -> randomIO
let testOptions = TestOptions
{ testOptionSeed_ = seed
, testOptionTimeout_ = getTimeoutOpt options
}
let verbose = elem OptionVerbose options
results <- forM tests $ \t -> do
result <- runTest t testOptions
printResult verbose t result
return (t, result)
let reports = getReports options
forM_ reports $ \(path, fmt, toText) ->
IO.withBinaryFile path IO.WriteMode $ \h -> do
let text = toText results
let bytes = Data.Text.Encoding.encodeUtf8 text
when verbose $ do
putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)
Data.ByteString.hPut h bytes
let stats = resultStatistics results
let (_, _, failed, aborted) = stats
Data.Text.IO.putStrLn (formatResultStatistics stats)
if failed == 0 && aborted == 0
then exitSuccess
else exitFailure
matchesFilter :: [String] -> Test -> Bool
matchesFilter strFilters = check where
filters = map Data.Text.pack strFilters
check t = any (matchName (testName t)) filters
matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name
printResult :: Bool -> Test -> TestResult -> IO ()
printResult verbose t result = case result of
TestPassed _ -> when verbose $ do
Data.Text.IO.putStr (testName t)
putStrLn ": PASS"
TestSkipped -> when verbose $ do
Data.Text.IO.putStr (testName t)
putStrLn ": SKIPPED"
TestFailed notes fs -> do
putStrLn (replicate 70 '=')
Data.Text.IO.putStr (testName t)
putStrLn ": FAILED"
forM_ notes $ \(key, value) -> do
putStr "\t"
Data.Text.IO.putStr key
putStr "="
Data.Text.IO.putStrLn value
putStrLn (replicate 70 '=')
forM_ fs $ \(Failure loc msg) -> do
case loc of
Just loc' -> do
Data.Text.IO.putStr (locationFile loc')
putStr ":"
putStrLn (show (locationLine loc'))
Nothing -> return ()
Data.Text.IO.putStr msg
putStr "\n\n"
TestAborted notes msg -> do
putStrLn (replicate 70 '=')
Data.Text.IO.putStr (testName t)
putStrLn ": ABORTED"
forM_ notes $ \(key, value) -> do
putStr "\t"
Data.Text.IO.putStr key
putStr "="
Data.Text.IO.putStrLn value
putStrLn (replicate 70 '=')
Data.Text.IO.putStr msg
putStr "\n\n"
type Report = [(Test, TestResult)] -> Text
getReports :: [Option] -> [(FilePath, String, Report)]
getReports = concatMap step where
step (OptionXmlReport path) = [(path, "XML", xmlReport)]
step (OptionJsonReport path) = [(path, "JSON", jsonReport)]
step (OptionTextReport path) = [(path, "text", textReport)]
step _ = []
jsonReport :: [(Test, TestResult)] -> Text
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 $ \(Failure loc msg) -> do
tell "{\"message\": \""
tell (escapeJSON msg)
tell "\""
case loc of
Just loc' -> do
tell ", \"location\": {\"module\": \""
tell (escapeJSON (locationModule loc'))
tell "\", \"file\": \""
tell (escapeJSON (locationFile loc'))
tell "\", \"line\": "
tell (pack (show (locationLine loc')))
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 "}"
escapeJSON = Data.Text.concatMap (\c -> case c of
'"' -> "\\\""
'\\' -> "\\\\"
_ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c))
_ -> Data.Text.singleton 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)] -> Text
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 $ \(Failure loc msg) -> do
tell "\t\t<failure message='"
tell (escapeXML msg)
case loc of
Just loc' -> do
tell "'>\n"
tell "\t\t\t<location module='"
tell (escapeXML (locationModule loc'))
tell "' file='"
tell (escapeXML (locationFile loc'))
tell "' line='"
tell (pack (show (locationLine loc')))
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"
escapeXML = Data.Text.concatMap (\c -> case c of
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> Data.Text.singleton 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)] -> Text
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 (Data.Text.replicate 70 "=")
tell "\n"
tell "PASSED: "
tell (testName t)
tell "\n"
tellNotes notes
tell "\n\n"
TestSkipped -> do
tell (Data.Text.replicate 70 "=")
tell "\n"
tell "SKIPPED: "
tell (testName t)
tell "\n\n"
TestFailed notes fs -> do
tell (Data.Text.replicate 70 "=")
tell "\n"
tell "FAILED: "
tell (testName t)
tell "\n"
tellNotes notes
tell (Data.Text.replicate 70 "-")
tell "\n"
forM_ fs $ \(Failure loc msg) -> do
case loc of
Just loc' -> do
tell (locationFile loc')
tell ":"
tell (pack (show (locationLine loc')))
tell "\n"
Nothing -> return ()
tell msg
tell "\n\n"
TestAborted notes msg -> do
tell (Data.Text.replicate 70 "=")
tell "\n"
tell "ABORTED: "
tell (testName t)
tell "\n"
tellNotes notes
tell (Data.Text.replicate 70 "-")
tell "\n"
tell msg
tell "\n\n"
tellNotes notes = forM_ notes $ \(key, value) -> do
tell key
tell "="
tell value
tell "\n"
formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text
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 pack (comma ++ "1 test " ++ what)
else pack (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))