Commit d788b98d authored by Camil Staps's avatar Camil Staps 🙂

Implement basic test runner

parent 2af11d0d
module CleanTest
import StdFile
from StdFunc import o
import StdList
import StdString
import StdTuple
import Data.Error
from Data.Func import $
from Data.Func import $, seqSt
import Data.Generics.GenDefault
import Data.Maybe
import System.CommandLine
import System.FilePath
import System.Process
import Testing.TestEvents
from Text import <+, class Text(split), instance Text String
import Text.JSON
import Text.Language
:: Options =
{ runs :: [Run]
, help :: Bool
{ runs :: ![Run]
, help :: !Bool
}
:: Run =
{ executable :: FilePath
, options :: [String]
{ name :: !String
, executable :: !FilePath
, options :: ![String]
}
gDefault{|Bool|} = False
......@@ -30,13 +38,14 @@ 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
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}
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
......@@ -45,7 +54,12 @@ where
[] -> 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 [arg:args] = Error $ "Unknown argument '" +++ arg +++ "'"
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] = Error $ "Unknown option '" +++ arg +++ "'"
exit :: Bool (Maybe String) String *World -> *World
exit show_help error prog w
......@@ -62,4 +76,90 @@ where
help = prog +++ ": run Clean tests\nOptions:\n" +++
" --help/-h Show this help\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"
run :: !Run !*World -> *World
run r w
# (io,w) = stdio w
# io = io <<< toJSON {StartEvent | name=r.Run.name} <<< "\n"
# (h,w) = runProcessIO r.executable r.options Nothing w
| isError h
# (err,msg) = fromError h
# io = io <<< toJSON
{ name = r.Run.name
, event = Failed
, message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
= snd $ fclose io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
# w = redirect "" h pio w
= w
where
redirect :: String 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
{ name = r.Run.name
, event = Failed
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
= snd $ fclose io w
# [out,err:_] = fromOk ss
# io = io <<< out
# 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
{ name = r.Run.name
, event = Failed
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
} <<< "\n"
= snd $ fclose io w
# rcode = fromOk t
// Check return code
| rcode == Just 0
# results = map (fromJSON o fromString) $ filter ((<>) "") $ split "\n" output
| any isNothing results
# io = io <<< toJSON
{ name = r.Run.name
, event = Failed
, message = "Failed to read child messages"
} <<< "\n"
= snd $ fclose io w
# io = io <<< toJSON (mergeResults $ map fromJust results) <<< "\n"
= snd $ fclose io w
| isJust rcode
# io = io <<< toJSON
{ name = r.Run.name
, event = Failed
, message = "Child process exited with " <+ fromJust rcode
} <<< "\n"
= snd $ fclose io w
# w = snd $ fclose io w
= redirect output h pio w
where
mergeResults :: [TestEvent] -> EndEvent
mergeResults tes =
{ name = r.Run.name
, event = if (failed + lost > 0) Failed Passed
, message =
pluralisen English passed "test" <+ " passed, " <+
pluralisen English failed "test" <+ " failed, " <+
pluralisen English skipped "test" <+ " skipped and " <+
pluralisen English lost "test" <+ " lost."
}
where
passed = length $ filter (\te -> te=:(EndEvent {event=Passed})) tes
failed = length $ filter (\te -> te=:(EndEvent {event=Failed})) tes
skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes
lost = length (filter (\te -> te=:(StartEvent _)) tes) -
length (filter (\te -> te=:(EndEvent _)) tes)
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