{-# LANGUAGE CPP #-} -- -- Copyright (c) 2009-2012 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 -- {- | This module defines the commandline options of the test driver provided by HTF. -} 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 -- -- CmdlineOptions -- -- | Commandline options for running tests. data CmdlineOptions = CmdlineOptions { opts_quiet :: Bool -- ^ Be quiet or not. , opts_filter :: TestFilter -- ^ Run only tests matching this filter. , opts_help :: Bool -- ^ If 'True', display a help message and exit. , opts_negated :: [String] -- ^ Regular expressions matching test names which should /not/ run. , opts_threads :: Maybe Int -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution. , opts_shuffle :: Bool -- ^ If 'True' (the default), shuffle tests when running them in parallel. , opts_machineOutput :: Bool -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format. , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format. , opts_useColors :: Maybe Bool -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors. , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout , opts_listTests :: Bool -- ^ If 'True', lists all tests available and exits. , opts_split :: Bool -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile'). } {- | The default 'CmdlineOptions'. -} 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 {- | Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis of the format of the commandline arguments: > USAGE: COMMAND [OPTION ...] PATTERN ... > > where PATTERN is a posix regular expression matching > the names of the tests to run. > > -q --quiet only display errors > -n PATTERN --not=PATTERN tests to exclude > -l --list list all matching tests > -j[N] --threads[=N] run N tests in parallel, default N=4 > --deterministic do not shuffle tests when executing them in parallel. > -o FILE --output-file=FILE name of output file > --json output results in machine-readable JSON format (incremental) > --xml=FILE output results in junit-style XML format > --split splits results in separate files to avoid file locking (requires -o/--output-file) > --colors=BOOL use colors or not > -h --help display this message -} 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") -- | The string displayed for the @--help@ option. helpString :: String helpString = usageInfo usageHeader optionDescriptions -- -- TestConfig -- -- | Turn the 'CmdlineOptions' into a 'TestConfig'. 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