diff --git a/Tools/CleanTest.icl b/Tools/CleanTest.icl index 707d074a27cc98db26ef0079639b00850e62b27e..8ab60cf31924b48eea7d6325f1653cd911dc8a63 100644 --- a/Tools/CleanTest.icl +++ b/Tools/CleanTest.icl @@ -22,12 +22,14 @@ import Text.JSON import Text.Language :: Options = - { runs :: ![Run] - , help :: !Bool - , hide :: ![MessageType] + { runs :: ![Run] + , help :: !Bool + , output :: !OutputFormat + , hide :: ![MessageType] } :: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost +:: OutputFormat = OF_JSON | OF_HumanReadable messageType :: TestEvent -> MessageType messageType (StartEvent _) = MT_Started @@ -45,7 +47,7 @@ derive gEq MessageType; instance == MessageType where == a b = a === b } gDefault{|Bool|} = False -derive gDefault MessageType, Options, Run +derive gDefault MessageType, Options, OutputFormat, Run :: ProcessOutput = { lines :: ![String] @@ -68,7 +70,7 @@ Start w | isError opts = exit True (Just $ fromError opts) prog w # opts = fromOk opts | opts.help = exit True Nothing prog w -# w = seqSt (run opts.hide) opts.runs w +# w = seqSt (run opts) opts.runs w = w where parseOpts :: Options [String] -> MaybeErrorString Options @@ -77,7 +79,8 @@ where = parseOpts opts [fromJust ('M'.get arg long_options):args] where long_options = 'M'.fromList - [ ("-h", "--help") + [ ("-f", "--output-format") + , ("-h", "--help") , ("-H", "--hide") , ("-n", "--name") , ("-O", "--option") @@ -103,6 +106,11 @@ where [] -> Error "--option used before --run" [r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args [] -> Error "--option requires a parameter" + parseOpts opts ["--output-format":args] = case args of + ["json":args] -> parseOpts {opts & output=OF_JSON} args + ["human":args] -> parseOpts {opts & output=OF_HumanReadable} args + [fmt:args] -> Error $ "Unknown output format '" +++ fmt +++ "'" + [] -> Error "--output-format requires a parameter" parseOpts opts ["--name":args] = case args of [name:args] -> case opts.runs of [] -> Error "-n used before -r" @@ -123,20 +131,21 @@ where where help :: String help = prog +++ ": run Clean tests\nOptions:\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" +++ - " --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" + " --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" +++ + " --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" -run :: ![MessageType] !Run !*World -> *World -run hide r w +run :: !Options !Run !*World -> *World +run opts r w # (io,w) = stdio w -# io = emit hide (StartEvent {StartEvent | name=r.Run.name}) io +# io = emit (StartEvent {StartEvent | name=r.Run.name}) io # (h,w) = runProcessIO r.executable r.options Nothing w | isError h # (err,msg) = fromError h - # io = emit hide (EndEvent + # io = emit (EndEvent { name = r.Run.name , event = Failed , message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")" @@ -154,7 +163,7 @@ where # (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w | isError ss # (err,msg) = fromError ss - # io = emit hide (EndEvent + # io = emit (EndEvent { name = r.Run.name , event = Failed , message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")" @@ -163,13 +172,13 @@ where # [out,err:_] = fromOk ss # (output,io) = append out (\s io -> case fromJSON $ fromString s of Nothing -> io - Just ev -> emit hide ev io) output io + Just ev -> emit ev io) output io # w = snd $ fclose (stderr <<< err) w // Check if child has terminated # (t,w) = checkProcess h w | isError t # (err,msg) = fromError t - # io = emit hide (EndEvent + # io = emit (EndEvent { name = r.Run.name , event = Failed , message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")" @@ -186,10 +195,10 @@ where , message = "Failed to read child messages" } <<< "\n" = snd $ fclose io w - # io = emit hide (EndEvent $ mergeResults $ map fromJust results) io + # io = emit (EndEvent $ mergeResults $ map fromJust results) io = snd $ fclose io w | isJust rcode - # io = emit hide (EndEvent + # io = emit (EndEvent { name = r.Run.name , event = Failed , message = "Child process exited with " <+ fromJust rcode @@ -215,7 +224,20 @@ where lost = length (filter (\te -> te=:(StartEvent _)) tes) - length (filter (\te -> te=:(EndEvent _)) tes) - emit :: [MessageType] TestEvent *File -> *File - emit hide ev io - | isMember (messageType ev) hide = io - | otherwise = io <<< toJSON ev <<< "\n" + emit :: TestEvent *File -> *File + emit ev io + | isMember (messageType ev) opts.hide = io + | otherwise = case opts.output of + OF_JSON -> io <<< toJSON ev <<< "\n" + OF_HumanReadable -> io <<< humanReadable ev <<< "\n" + where + humanReadable :: TestEvent -> String + humanReadable (StartEvent se) = "Started: " +++ se.StartEvent.name + humanReadable (EndEvent ee) = event +++ ee.EndEvent.name + where + event = case ee.event of + Passed -> "Passed: " + Failed -> "Failed: " + //Failed _ -> "failed" // TODO reason + Skipped -> "Got lost: " + //Lost -> "got lost"