Commit 9305beb3 authored by Camil Staps's avatar Camil Staps 🙂

Start with #1: different output options

parent b046320d
......@@ -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"
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