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

Resolve #3; options for hiding messages

parent d788b98d
......@@ -6,9 +6,12 @@ import StdList
import StdString
import StdTuple
import Control.Monad
import Data.Error
from Data.Func import $, seqSt
import Data.Generics.GenDefault
import Data.Generics.GenEq
import qualified Data.Map as M
import Data.Maybe
import System.CommandLine
import System.FilePath
......@@ -21,8 +24,20 @@ import Text.Language
:: Options =
{ runs :: ![Run]
, 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 =
{ name :: !String
, executable :: !FilePath
......@@ -30,7 +45,22 @@ import Text.Language
}
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
# ([prog:args],w) = getCommandLine w
......@@ -38,27 +68,46 @@ 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.runs w
# w = seqSt (run opts.hide) opts.runs w
= w
where
parseOpts :: Options [String] -> MaybeErrorString Options
parseOpts opts [] = Ok {opts & runs=reverse opts.runs}
parseOpts opts ["--run":args] = parseOpts opts ["-r":args]
parseOpts opts ["-r":exe:args] = parseOpts {opts & runs=[new:opts.runs]} args
with new = {gDefault{|*|} & executable=exe, name=exe}
parseOpts opts ["-r"] = Error "-r requires a parameter"
parseOpts opts ["--help":args] = parseOpts opts ["-h":args]
parseOpts opts ["-h":args] = parseOpts {opts & help=True} args
parseOpts opts ["--option":args] = parseOpts opts ["-O":args]
parseOpts opts ["-O":opt:args] = case opts.runs of
[] -> Error "-O used before -r"
[r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args
parseOpts opts ["-O"] = Error "-O requires a parameter"
parseOpts opts ["--name":args] = parseOpts opts ["-n":args]
parseOpts opts ["-n":name:args] = case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseOpts {opts & runs=[{Run | r & name=name}:rs]} args
parseOpts opts ["-n"] = Error "-n requires a parameter"
parseOpts opts [arg:args] | isJust ('M'.get arg long_options)
= parseOpts opts [fromJust ('M'.get arg long_options):args]
where
long_options = 'M'.fromList
[ ("-h", "--help")
, ("-H", "--hide")
, ("-n", "--name")
, ("-O", "--option")
, ("-r", "--run")
]
parseOpts opts ["--help":args] = parseOpts {opts & help=True} args
parseOpts opts ["--hide":args] = case args of
[arg:args] -> mapM parseMT (split "," arg) >>= \h -> parseOpts {opts & hide=h} args
[] -> Error "--hide requires a parameter"
where
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 +++ "'"
exit :: Bool (Maybe String) String *World -> *World
......@@ -75,59 +124,61 @@ 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"
run :: !Run !*World -> *World
run r w
run :: ![MessageType] !Run !*World -> *World
run hide r 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
| isError h
# (err,msg) = fromError h
# io = io <<< toJSON
# io = emit hide (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
}) io
= snd $ fclose io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
# w = redirect "" h pio w
# w = redirect {lines=[], rest=""} h pio w
= w
where
redirect :: String ProcessHandle ProcessIO *World -> *World
redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *World
redirect output h pio w
# (io,w) = stdio w
// Check child output
# (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w
| isError ss
# (err,msg) = fromError ss
# io = io <<< toJSON
# io = emit hide (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
}) io
= snd $ fclose io w
# [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
# output = output +++ out
// Check if child has terminated
# (t,w) = checkProcess h w
| isError t
# (err,msg) = fromError t
# io = io <<< toJSON
# io = emit hide (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
}) io
= snd $ fclose io w
# rcode = fromOk t
// Check return code
| rcode == Just 0
# results = map (fromJSON o fromString) $ filter ((<>) "") $ split "\n" output
# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
| any isNothing results
# io = io <<< toJSON
{ name = r.Run.name
......@@ -135,14 +186,14 @@ where
, message = "Failed to read child messages"
} <<< "\n"
= 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
| isJust rcode
# io = io <<< toJSON
# io = emit hide (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Child process exited with " <+ fromJust rcode
} <<< "\n"
}) io
= snd $ fclose io w
# w = snd $ fclose io w
= redirect output h pio w
......@@ -163,3 +214,8 @@ where
skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes
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"
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