Commit 5818448d authored by Camil Staps's avatar Camil Staps 🚀

Add option for test strategy (#4)

parent 6824e091
......@@ -56,10 +56,15 @@ where
= w
where
help :: String
help = prog +++ ": run Clean tests\nOptions:\n" +++
help = prog +++ ": run Clean tests\n" +++
"\nGeneral options:\n" +++
" --help/-h Show this help\n" +++
" --hide/-H TYPE Comma-separated list of types of messages to hide (start,pass,fail,skip,lost)\n" +++
" --output-format/-f FMT The output format (json,human)\n" +++
" --strategy/-S STRATEGY The test order strategy, where STRATEGY is one of\n" +++
" default Order of the --run parameters\n" +++
" failed-first First run the tests that failed last time; if they past continue with the rest\n" +++
"\nTest options:\n" +++
" --run/-r EXE Execute tests from executable EXE\n" +++
" --option/-O OPT Add OPT to the command line of the previously added run\n" +++
" --name/-n NAME Give the previously added run the name NAME\n"
......
......@@ -8,14 +8,16 @@ from System.FilePath import :: FilePath
from Testing.TestEvents import :: TestEvent
:: Options =
{ runs :: ![Run]
, help :: !Bool
, output :: !OutputFormat
, hide :: ![MessageType]
{ runs :: ![Run]
, help :: !Bool
, output :: !OutputFormat
, hide :: ![MessageType]
, strategy :: !Strategy
}
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
:: OutputFormat = OF_JSON | OF_HumanReadable
:: Strategy = S_FailedFirst | S_Default
:: Run =
{ name :: !String
......@@ -25,7 +27,7 @@ from Testing.TestEvents import :: TestEvent
instance == MessageType
derive gDefault MessageType, Options, OutputFormat, Run
derive gDefault MessageType, Options, OutputFormat, Run, Strategy
messageType :: TestEvent -> MessageType
......
......@@ -18,7 +18,7 @@ from Text import class Text(split), instance Text String
derive gEq MessageType; instance == MessageType where == a b = a === b
gDefault{|Bool|} = False
derive gDefault MessageType, Options, OutputFormat, Run
derive gDefault MessageType, Options, OutputFormat, Run, Strategy
messageType :: TestEvent -> MessageType
messageType (StartEvent _) = MT_Started
......@@ -34,6 +34,7 @@ LONG_OPTIONS =:
, ("-n", "--name")
, ("-O", "--option")
, ("-r", "--run")
, ("-S", "--strategy")
]
parseTestOpts :: Options [String] -> MaybeErrorString Options
......@@ -52,9 +53,11 @@ where
parseMT "skip" = Ok MT_Skipped
parseMT "lost" = Ok MT_Lost
parseMT s = Error $ "Unknown message type '" +++ s +++ "'"
parseTestOpts opts ["--run":args] = case args of
[exe:args] -> parseTestOpts {opts & runs=[{gDefault{|*|} & executable=exe, name=exe}:opts.runs]} args
[] -> Error "--run requires a parameter"
parseTestOpts opts ["--name":args] = case args of
[name:args] -> case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseTestOpts {opts & runs=[{Run | r & name=name}:rs]} args
[] -> Error "-n requires a parameter"
parseTestOpts opts ["--option":args] = case args of
[opt:args] -> case opts.runs of
[] -> Error "--option used before --run"
......@@ -65,9 +68,12 @@ parseTestOpts opts ["--output-format":args] = case args of
["human":args] -> parseTestOpts {opts & output=OF_HumanReadable} args
[fmt:args] -> Error $ "Unknown output format '" +++ fmt +++ "'"
[] -> Error "--output-format requires a parameter"
parseTestOpts opts ["--name":args] = case args of
[name:args] -> case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseTestOpts {opts & runs=[{Run | r & name=name}:rs]} args
[] -> Error "-n requires a parameter"
parseTestOpts opts ["--run":args] = case args of
[exe:args] -> parseTestOpts {opts & runs=[{gDefault{|*|} & executable=exe, name=exe}:opts.runs]} args
[] -> Error "--run requires a parameter"
parseTestOpts opts ["--strategy":args] = case args of
["default":args] -> parseTestOpts {opts & strategy=S_Default} args
["failed-first":args] -> parseTestOpts {opts & strategy=S_FailedFirst} args
[s:args] -> Error $ "Unknown strategy '" +++ s +++ "'"
[] -> Error "--strategy requires a parameter"
parseTestOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment