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