Commit 22e46560 authored by Camil Staps's avatar Camil Staps 🚀

Adapt to new Platform; enhanced human-readable format (closes #1); store test results (#4)

parent 14cd74be
module CleanTest
import StdArray
import StdBool
import StdFile
from StdFunc import o
from StdFunc import flip, o
import StdList
import StdMisc
import StdString
import StdTuple
import Control.Monad => qualified join
import Data.Error
from Data.Func import $, seqSt
from Data.Func import $, mapSt, seqSt
import Data.Functor
import Data.Generics.GenDiff
import Data.List
import Data.Maybe
import Data.Tuple
import System.CommandLine
import System.FilePath
import System.Process
import Testing.Options
import Testing.TestEvents
from Text import <+, class Text(join,split), instance Text String
from Text import <+, class Text(join,replaceSubString,split), instance Text String
import Text.JSON
import Text.Language
gDiff{|JSONNode|} x y = case x of
JSONBool i -> case y of
JSONBool j -> gDiff{|*|} i j
_ -> add i ++ remove y
JSONInt i -> case y of
JSONInt j -> gDiff{|*|} i j
_ -> add i ++ remove y
JSONReal i -> case y of
JSONReal j -> gDiff{|*|} i j
_ -> add i ++ remove y
JSONString i -> case y of
JSONString j -> gDiff{|*|} i j
_ -> add i ++ remove y
JSONArray xs -> case y of
JSONArray ys -> gDiff{|*|} xs ys
_ -> add xs ++ remove y
JSONObject xs -> case y of
JSONObject ys -> [
{ status = if (all (\d -> d.status == Common) field_diffs) Common Changed
, value = "Object"
, children = field_diffs
}]
with
field_diffs =
[let ds = gDiff{|*|} (find k xs) (find k ys) in
{status=if (all (\d->d.status==Common) ds) Common Changed, value=k <+ "=", children=ds} \\ k <- both] ++
[{status=Removed, value=k <+ "=", children=[d]} \\ k <- xonly, d <- remove (find k xs)] ++
[{status=Added, value=k <+ "=", children=[d]} \\ k <- yonly, d <- add (find k ys)]
with
xkeys = map fst xs
ykeys = map fst ys
both = intersect xkeys ykeys
xonly = difference xkeys ykeys
yonly = difference ykeys xkeys
find k = fromJust o lookup k
_ -> add xs ++ remove y
_ -> abort "Unimplemented gDiff for JSONNode\n"
where
add :: a -> [Diff] | gDiff{|*|} a
add x = map (setStatus Added) (gDiff{|*|} x x)
remove :: a -> [Diff] | gDiff{|*|} a
remove x = map (setStatus Removed) (gDiff{|*|} x x)
:: ProcessOutput =
{ lines :: ![String]
, rest :: !String
......@@ -36,13 +85,45 @@ append s f out env
# out & rest = last lines
= (out, env)
:: RunResult =
{ run :: !Run
, result :: !EndEventType
}
derive JSONEncode RunResult, Run, EndEventType
derive JSONDecode RunResult, Run, EndEventType
instance <<< RunResult where <<< f rr = f <<< toJSON rr <<< "\n"
readResults :: !*File -> *(!Maybe [RunResult], !*File)
readResults f
# (e,f) = fend f
| e = (Just [], f)
# (l,f) = freadline f
# rr = fromJSON $ fromString l
| isNothing rr = (Nothing, f)
# (rrs,f) = readResults f
= ((\rrs -> [fromJust rr:rrs]) <$> rrs, f)
Start w
// Parse command line arguments
# ([prog:args],w) = getCommandLine w
# opts = parseTestOpts gDefault{|*|} args
| isError opts = exit True (Just $ fromError opts) prog w
# opts = fromOk opts
| opts.help = exit True Nothing prog w
# w = seqSt (run opts) opts.runs w
// Run tests
# (ok,f,w) = fopen ".ctest-results.json" FReadText w
# (l,f) = if ok freadline (tuple "") f
# (_,w) = fclose f w
# runs = case fromJSON (fromString l) of
Nothing -> opts.runs
Just res -> makeRuns res opts.strategy opts.runs
# (rrs,w) = mapSt (run opts) runs w
// Save results
# (_,f,w) = fopen ".ctest-results.json" FWriteText w
# f = f <<< toJSON rrs
# (_,w) = fclose f w
= w
where
exit :: Bool (Maybe String) String *World -> *World
......@@ -61,37 +142,56 @@ where
join "\n" [if (d.[0] <> ' ') "\n" "" +++ d \\ d <- optionDoc] +++
"\n"
run :: !Options !Run !*World -> *World
makeRuns :: [RunResult] Strategy [Run] -> [Run]
makeRuns _ S_Default runs = runs
makeRuns results S_FailedFirst runs =
[{r & name=r.Run.name +++ "; failed", options=prepend "--run" cs ++ r.options} \\ (r,cs) <- failed_children] ++
failed ++
[{r & name=r.Run.name +++ "; passed", options=prepend "--skip" cs ++ r.options} \\ (r,cs) <- failed_children] ++
not_failed
where
failed_children = [(run, map fst cs) \\ {run,result=Failed (FailedChildren cs)} <- results]
failed = [run \\ {run,result=Failed fr} <- results | not (fr=:(FailedChildren _))]
not_failed = [run \\ {run,result=res} <- results | not (res=:(Failed _))]
prepend :: a [a] -> [a]
prepend _ [] = []
prepend p [x:xs] = [p,x:prepend p xs]
run :: !Options !Run !*World -> *(!RunResult, !*World)
run opts r w
# (io,w) = stdio w
# io = emit (StartEvent {StartEvent | name=r.Run.name}) io
# (h,w) = runProcessIO r.executable r.options Nothing w
| isError h
# (err,msg) = fromError h
# msg = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# io = emit (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
, event = event
, message = msg
}) io
= snd $ fclose io w
= return event io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
# w = redirect {lines=[], rest=""} h pio w
= w
= redirect {lines=[], rest=""} h pio w
where
redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *World
redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *(!RunResult, !*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
# msg = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# io = emit (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
, event = event
, message = msg
}) io
= snd $ fclose io w
= return event io w
# [out,err:_] = fromOk ss
# (output,io) = append out (\s io -> case fromJSON $ fromString s of
Nothing -> io
......@@ -101,51 +201,63 @@ where
# (t,w) = checkProcess h w
| isError t
# (err,msg) = fromError t
# msg = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# io = emit (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
, event = event
, message = msg
}) io
= snd $ fclose io w
= return event io w
# rcode = fromOk t
// Check return code
| rcode == Just 0
# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
| any isNothing results
# io = io <<< toJSON
# msg = "Failed to read child messages"
# event = Failed $ OtherFailReason msg
# io = emit (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Failed to read child messages"
} <<< "\n"
= snd $ fclose io w
# io = emit (EndEvent $ mergeResults $ map fromJust results) io
= snd $ fclose io w
, event = event
, message = msg
}) io
= return event io w
# ee = mergeResults $ map fromJust results
# io = emit (EndEvent ee) io
= return ee.event io w
| isJust rcode
# msg = "Child process exited with " <+ fromJust rcode
# event = Failed $ OtherFailReason msg
# io = emit (EndEvent
{ name = r.Run.name
, event = Failed
, message = "Child process exited with " <+ fromJust rcode
, event = event
, message = msg
}) io
= snd $ fclose io w
= return event 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
, event = if (isEmpty failed && isEmpty lost) Passed
(Failed $ FailedChildren $
[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
[(l, Crashed) \\ l <- lost])
, message =
pluralisen English passed "test" <+ " passed, " <+
pluralisen English failed "test" <+ " failed, " <+
pluralisen English skipped "test" <+ " skipped and " <+
pluralisen English lost "test" <+ " lost."
pluralisen English (length passed) "test" <+ " passed, " <+
pluralisen English (length failed) "test" <+ " failed, " <+
pluralisen English (length skipped) "test" <+ " skipped and " <+
pluralisen English (length 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)
passed = filter (\te -> te=:(EndEvent {event=Passed})) tes
failed = filter (\te -> te=:(EndEvent {event=Failed _})) tes
skipped = filter (\te -> te=:(EndEvent {event=Skipped})) tes
lost = [se.StartEvent.name \\ StartEvent se <- tes
| not
$ any (\(EndEvent ee) -> se.StartEvent.name == ee.EndEvent.name)
$ passed ++ failed ++ skipped]
emit :: TestEvent *File -> *File
emit ev io
......@@ -156,11 +268,28 @@ where
where
humanReadable :: TestEvent -> String
humanReadable (StartEvent se) = "Started: " +++ se.StartEvent.name
humanReadable (EndEvent ee) = event +++ ee.EndEvent.name
humanReadable (EndEvent ee) = event +++ ee.EndEvent.name +++ diff
where
event = case ee.event of
Passed -> "Passed: "
Failed -> "Failed: "
//Failed _ -> "failed" // TODO reason
Skipped -> "Got lost: "
//Lost -> "got lost"
Failed _ -> "Failed: "
Skipped -> "Skipped: "
diff = case ee.event of
Failed (FailedAssertions fas) -> "\n Failed assumptions:\n " +++
replaceSubString "\n" "\n "
(replaceSubString "\t" " " $ join "\n" $ map printFA fas)
Failed (CounterExamples ces) -> "\n CES"
Failed (FailedChildren fcs) -> "\n Children tests failed: " +++ join ", " (map fst fcs)
Failed (OtherFailReason r) -> "\n " +++ r
Failed Crashed -> "\n Crashed"
_ -> ""
where
printFA :: FailedAssertion -> String
printFA (ExpectedRelation x rel y) = "Expected " +++ toString rel +++ " on:\n" +++ case rel of
Eq -> diffToConsole $ gDiff{|*|} x y
_ -> toString x +++ "\n" +++ toString y
return :: !EndEventType !*File !*World -> *(!RunResult, !*World)
return eet io w
# (_,w) = fclose io w
= ({run=r, result=eet}, w)
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