module Test.Framework.CmdlineOptions (
CmdlineOptions(..), defaultCmdlineOptions, parseTestArgs, helpString,
testConfigFromCmdlineOptions
) where
import Test.Framework.TestReporter
import Test.Framework.TestTypes
import Test.Framework.Utils
import Data.Char (toLower)
import Data.Maybe
import System.IO
import System.Console.GetOpt
import qualified Text.Regex as R
#ifndef mingw32_HOST_OS
import System.Posix.Terminal
import System.Posix.IO (stdOutput)
import System.Posix.Env (getEnv)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Conc ( numCapabilities )
#endif
data CmdlineOptions = CmdlineOptions {
opts_quiet :: Bool
, opts_filter :: TestFilter
, opts_help :: Bool
, opts_negated :: [String]
, opts_threads :: Maybe Int
, opts_shuffle :: Bool
, opts_machineOutput :: Bool
, opts_machineOutputXml :: Maybe FilePath
, opts_useColors :: Maybe Bool
, opts_outputFile :: Maybe FilePath
, opts_listTests :: Bool
, opts_split :: Bool
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions {
opts_quiet = False
, opts_filter = const True
, opts_help = False
, opts_negated = []
, opts_threads = Nothing
, opts_shuffle = True
, opts_machineOutput = False
, opts_machineOutputXml = Nothing
, opts_useColors = Nothing
, opts_outputFile = Nothing
, opts_listTests = False
, opts_split = False
}
processorCount :: Int
#ifdef __GLASGOW_HASKELL__
processorCount = numCapabilities
#else
processorCount = 1
#endif
optionDescriptions :: [OptDescr (CmdlineOptions -> CmdlineOptions)]
optionDescriptions =
[ 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) })
"PATTERN") "tests to exclude"
, Option ['l'] ["list"] (NoArg (\o -> o { opts_listTests = True })) "list all matching tests"
, Option ['j'] ["threads"] (OptArg (\ms o -> o { opts_threads = Just (parseThreads ms) }) "N")
("run N tests in parallel, default N=" ++ show processorCount)
, Option [] ["deterministic"] (NoArg (\o -> o { opts_shuffle = False })) "do not shuffle tests when executing them in parallel."
, Option ['o'] ["output-file"] (ReqArg (\s o -> o { opts_outputFile = Just s })
"FILE") "name of output file"
, Option [] ["json"] (NoArg (\o -> o { opts_machineOutput = True }))
"output results in machine-readable JSON format (incremental)"
, Option [] ["xml"] (ReqArg (\s o -> o { opts_machineOutputXml = Just s }) "FILE")
"output results in junit-style XML format"
, Option [] ["split"] (NoArg (\o -> o { opts_split = True }))
"splits results in separate files to avoid file locking (requires -o/--output-file)"
, Option [] ["colors"] (ReqArg (\s o -> o { opts_useColors = Just (parseBool s) })
"BOOL") "use colors or not"
, Option ['h'] ["help"] (NoArg (\o -> o { opts_help = True })) "display this message"
]
where
parseThreads Nothing = processorCount
parseThreads (Just s) =
case readM s of
Just i -> i
Nothing -> error ("invalid number of threads: " ++ s)
parseBool s =
if map toLower s `elem` ["1", "true", "yes", "on"] then True else False
parseTestArgs :: [String] -> Either String CmdlineOptions
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 _ path _ _) =
let flat = flatName path
in if (any (\s -> s `matches` flat) neg)
then False
else null pos || any (\s -> s `matches` flat) pos
opts = (foldr ($) defaultCmdlineOptions optTrans) { opts_filter = pred }
in case (opts_outputFile opts, opts_split opts) of
(Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++
usageInfo usageHeader optionDescriptions)
_ -> Right opts
(_,_,errs) ->
Left (concat errs ++ usageInfo usageHeader optionDescriptions)
where
matches r s = isJust $ R.matchRegex r s
mkRegex s = R.mkRegexWithOpts s True False
usageHeader :: String
usageHeader = ("USAGE: COMMAND [OPTION ...] PATTERN ...\n\n" ++
" where PATTERN is a posix regular expression matching\n" ++
" the names of the tests to run.\n")
helpString :: String
helpString = usageInfo usageHeader optionDescriptions
testConfigFromCmdlineOptions :: CmdlineOptions -> IO TestConfig
testConfigFromCmdlineOptions opts =
do (output, colors) <-
case (opts_outputFile opts, opts_split opts) of
(Just fname, True) -> return (TestOutputSplitted fname, False)
_ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile
colors <- checkColors mOutputFd
return (TestOutputHandle outputHandle closeOutput, colors)
let threads = opts_threads opts
reporters = defaultTestReporters (isParallelFromBool $ isJust threads)
(if opts_machineOutput opts then JsonOutput else NoJsonOutput)
(if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput)
return $ TestConfig { tc_quiet = opts_quiet opts
, tc_threads = threads
, tc_shuffle = opts_shuffle opts
, tc_output = output
, tc_outputXml = opts_machineOutputXml opts
, tc_reporters = reporters
, tc_filter = opts_filter opts
, tc_useColors = colors }
where
#ifdef mingw32_HOST_OS
openOutputFile =
case opts_outputFile opts of
Nothing -> return (stdout, False, Nothing)
Just fname ->
do f <- openFile fname WriteMode
return (f, True, Nothing)
checkColors mOutputFd =
case opts_useColors opts of
Just b -> return b
Nothing -> return False
#else
openOutputFile =
case opts_outputFile opts of
Nothing -> return (stdout, False, Just stdOutput)
Just fname ->
do f <- openFile fname WriteMode
return (f, True, Nothing)
checkColors mOutputFd =
case opts_useColors opts of
Just b -> return b
Nothing ->
do mterm <- getEnv "TERM"
case mterm of
Nothing -> return False
Just s | map toLower s == "dumb" -> return False
_ -> do mx <- getEnv "HTF_NO_COLORS"
case mx of
Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False
_ -> case mOutputFd of
Just fd -> queryTerminal fd
_ -> return False
#endif