Commit b046320d authored by Camil Staps's avatar Camil Staps 🚀

Resolve #3; options for hiding messages

parent d788b98d
...@@ -6,9 +6,12 @@ import StdList ...@@ -6,9 +6,12 @@ import StdList
import StdString import StdString
import StdTuple import StdTuple
import Control.Monad
import Data.Error import Data.Error
from Data.Func import $, seqSt from Data.Func import $, seqSt
import Data.Generics.GenDefault import Data.Generics.GenDefault
import Data.Generics.GenEq
import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import System.CommandLine import System.CommandLine
import System.FilePath import System.FilePath
...@@ -21,8 +24,20 @@ import Text.Language ...@@ -21,8 +24,20 @@ import Text.Language
:: Options = :: Options =
{ runs :: ![Run] { runs :: ![Run]
, help :: !Bool , help :: !Bool
, hide :: ![MessageType]
} }
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
messageType :: TestEvent -> MessageType
messageType (StartEvent _) = MT_Started
messageType (EndEvent ee) = case ee.event of
Passed -> MT_Passed
Failed -> MT_Failed
Skipped -> MT_Skipped
derive gEq MessageType; instance == MessageType where == a b = a === b
:: Run = :: Run =
{ name :: !String { name :: !String
, executable :: !FilePath , executable :: !FilePath
...@@ -30,7 +45,22 @@ import Text.Language ...@@ -30,7 +45,22 @@ import Text.Language
} }
gDefault{|Bool|} = False gDefault{|Bool|} = False
derive gDefault Options, Run derive gDefault MessageType, Options, Run
:: ProcessOutput =
{ lines :: ![String]
, rest :: !String
}
append :: !String !(String .e -> .e) !ProcessOutput .e -> .(ProcessOutput, .e)
append s f out env
# out & rest = out.rest +++ s
# lines = split "\n" out.rest
| length lines == 1 = (out, env)
# env = seqSt f (init lines) env
# out & lines = out.lines ++ init lines
# out & rest = last lines
= (out, env)
Start w Start w
# ([prog:args],w) = getCommandLine w # ([prog:args],w) = getCommandLine w
...@@ -38,27 +68,46 @@ Start w ...@@ -38,27 +68,46 @@ 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.runs w # w = seqSt (run opts.hide) opts.runs w
= w = w
where where
parseOpts :: Options [String] -> MaybeErrorString Options parseOpts :: Options [String] -> MaybeErrorString Options
parseOpts opts [] = Ok {opts & runs=reverse opts.runs} parseOpts opts [] = Ok {opts & runs=reverse opts.runs}
parseOpts opts ["--run":args] = parseOpts opts ["-r":args] parseOpts opts [arg:args] | isJust ('M'.get arg long_options)
parseOpts opts ["-r":exe:args] = parseOpts {opts & runs=[new:opts.runs]} args = parseOpts opts [fromJust ('M'.get arg long_options):args]
with new = {gDefault{|*|} & executable=exe, name=exe} where
parseOpts opts ["-r"] = Error "-r requires a parameter" long_options = 'M'.fromList
parseOpts opts ["--help":args] = parseOpts opts ["-h":args] [ ("-h", "--help")
parseOpts opts ["-h":args] = parseOpts {opts & help=True} args , ("-H", "--hide")
parseOpts opts ["--option":args] = parseOpts opts ["-O":args] , ("-n", "--name")
parseOpts opts ["-O":opt:args] = case opts.runs of , ("-O", "--option")
[] -> Error "-O used before -r" , ("-r", "--run")
[r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args ]
parseOpts opts ["-O"] = Error "-O requires a parameter" parseOpts opts ["--help":args] = parseOpts {opts & help=True} args
parseOpts opts ["--name":args] = parseOpts opts ["-n":args] parseOpts opts ["--hide":args] = case args of
parseOpts opts ["-n":name:args] = case opts.runs of [arg:args] -> mapM parseMT (split "," arg) >>= \h -> parseOpts {opts & hide=h} args
[] -> Error "-n used before -r" [] -> Error "--hide requires a parameter"
[r:rs] -> parseOpts {opts & runs=[{Run | r & name=name}:rs]} args where
parseOpts opts ["-n"] = Error "-n requires a parameter" parseMT :: String -> MaybeErrorString MessageType
parseMT "start" = Ok MT_Started
parseMT "pass" = Ok MT_Passed
parseMT "fail" = Ok MT_Failed
parseMT "skip" = Ok MT_Skipped
parseMT "lost" = Ok MT_Lost
parseMT s = Error $ "Unknown message type '" +++ s +++ "'"
parseOpts opts ["--run":args] = case args of
[exe:args] -> parseOpts {opts & runs=[{gDefault{|*|} & executable=exe, name=exe}:opts.runs]} args
[] -> Error "--run requires a parameter"
parseOpts opts ["--option":args] = case args of
[opt:args] -> case opts.runs of
[] -> Error "--option used before --run"
[r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args
[] -> Error "--option requires a parameter"
parseOpts opts ["--name":args] = case args of
[name:args] -> case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseOpts {opts & runs=[{Run | r & name=name}:rs]} args
[] -> Error "-n requires a parameter"
parseOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'" parseOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'"
exit :: Bool (Maybe String) String *World -> *World exit :: Bool (Maybe String) String *World -> *World
...@@ -75,59 +124,61 @@ where ...@@ -75,59 +124,61 @@ 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" +++
" --run/-r EXE Execute tests from executable EXE\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" +++ " --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" " --name/-n NAME Give the previously added run the name NAME\n"
run :: !Run !*World -> *World run :: ![MessageType] !Run !*World -> *World
run r w run hide r w
# (io,w) = stdio w # (io,w) = stdio w
# io = io <<< toJSON {StartEvent | name=r.Run.name} <<< "\n" # io = emit hide (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 = io <<< toJSON # io = emit hide (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 <+ ")"
} <<< "\n" }) io
= snd $ fclose io w = snd $ fclose io w
# (h,pio) = fromOk h # (h,pio) = fromOk h
# w = snd $ fclose io w # w = snd $ fclose io w
# w = redirect "" h pio w # w = redirect {lines=[], rest=""} h pio w
= w = w
where where
redirect :: String ProcessHandle ProcessIO *World -> *World redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *World
redirect output h pio w redirect output h pio w
# (io,w) = stdio w # (io,w) = stdio w
// Check child output // Check child output
# (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 = io <<< toJSON # io = emit hide (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 <+ ")"
} <<< "\n" }) io
= snd $ fclose io w = snd $ fclose io w
# [out,err:_] = fromOk ss # [out,err:_] = fromOk ss
# io = io <<< out # (output,io) = append out (\s io -> case fromJSON $ fromString s of
Nothing -> io
Just ev -> emit hide ev io) output io
# w = snd $ fclose (stderr <<< err) w # w = snd $ fclose (stderr <<< err) w
# output = output +++ out
// 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 = io <<< toJSON # io = emit hide (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 <+ ")"
} <<< "\n" }) io
= snd $ fclose io w = snd $ fclose io w
# rcode = fromOk t # rcode = fromOk t
// Check return code // Check return code
| rcode == Just 0 | rcode == Just 0
# results = map (fromJSON o fromString) $ filter ((<>) "") $ split "\n" output # results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
| any isNothing results | any isNothing results
# io = io <<< toJSON # io = io <<< toJSON
{ name = r.Run.name { name = r.Run.name
...@@ -135,14 +186,14 @@ where ...@@ -135,14 +186,14 @@ where
, message = "Failed to read child messages" , message = "Failed to read child messages"
} <<< "\n" } <<< "\n"
= snd $ fclose io w = snd $ fclose io w
# io = io <<< toJSON (mergeResults $ map fromJust results) <<< "\n" # io = emit hide (EndEvent $ mergeResults $ map fromJust results) io
= snd $ fclose io w = snd $ fclose io w
| isJust rcode | isJust rcode
# io = io <<< toJSON # io = emit hide (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
} <<< "\n" }) io
= snd $ fclose io w = snd $ fclose io w
# w = snd $ fclose io w # w = snd $ fclose io w
= redirect output h pio w = redirect output h pio w
...@@ -163,3 +214,8 @@ where ...@@ -163,3 +214,8 @@ where
skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes
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 hide ev io
| isMember (messageType ev) hide = io
| otherwise = io <<< toJSON ev <<< "\n"
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