Merge pull request #142 from cgay/output

Several testworks improvements / bug fixes

command-line.dylan

@@ -122,11 +122,12 @@ define function parse-args
   parser
 end function parse-args;
 
-define function do-loads(parser :: <command-line-parser>)
-  for (library-file in get-option-value(parser, "load"))
-    format(*standard-output*, "Loading library %s\n", library-file);
+define function do-loads
+    (library-files :: <collection>)
+  for (file in library-files)
+    format(*standard-output*, "Loading library %s\n", file);
     force-output(*standard-output*);
-    os/load-library(library-file);
+    os/load-library(file);
   end for;
 end function;
 
@@ -169,7 +170,8 @@ define function make-runner-from-command-line
   for (option in parser.positional-options)
     let (key, val) = apply(values, split(option, '=', count: 2));
     if (~val)
-      usage-error("%= is not a valid test run option; must be in key=value form.", option);
+      usage-error("%= is not a valid test run option; must be in key=value form.",
+                  option);
     end;
     runner.runner-options[key] := val;
   end for;
@@ -205,53 +207,82 @@ end function make-runner-from-command-line;
 // compatibility and must be a single test, benchmark, or test suite.
 //
 // TODO(cgay): update callers to pass no args, then remove `components` arg.
-define function run-test-application (#rest components)
-  // Parse command line.
+define function run-test-application
+    (#rest components) => ()
+  block ()
+    if (components.size > 1)
+      format(*standard-error*,
+             "run-test-application takes 0 or 1 test components as"
+               " arguments, (got %d)", components.size);
+      exit-application(2);
+    end;
+    let status = process-command-line(components);
+    exit-application(status);
+  exception (error :: <help-requested>)
+    format(*standard-output*, "%s", error);
+    exit-application(0);
+  exception (error :: <usage-error>)
+    // The command-line-parser library prints this error itself (which is
+    // probably a bug) so don't print it here.
+    exit-application(2);
+  exception (error :: <error>)
+    format(*standard-error*, "Error: %s", error);
+    exit-application(2);
+  end;
+end function;
+
+define function process-command-line
+    (components) => (exit-status :: <integer>)
+  // parse-args may signal <help-requested> or <usage-error>.
   let parser = parse-args(application-arguments());
-  do-loads(parser);
 
-  let top
-    = select (components.size)
-        0 =>
-          // Make a suite named after the library, containing all test
-          // components.
-          let app = locator-base(as(<file-locator>, application-name()));
-          make(<suite>,
-               name: app,
-               components: find-root-components());
-        1 =>
-          components[0];
-        otherwise =>
-          format(*standard-error*,
-                 "run-test-application takes 0 or 1 test components as"
-                   " arguments, (got %d)", components.size);
-          exit-application(2);
-      end;
+  // Load more tests, if requested. Tests share a global namespace so this will
+  // signal on duplicate names.
+  let to-load = get-option-value(parser, "load");
+  if (to-load.size > 0)
+    if (~empty?(components))
+      // We can remove this check (and the components parameter) after all
+      // libraries are updated to pass no args to run-test-application.
+      error("passing a component to run-test-application and using --load"
+              " at the same time is pointless since only the passed component"
+              " will run.");
+    end;
+    do-loads(to-load);
+  end;
 
+  let suite
+    = if (empty?(components))
+        make(<suite>,
+             name: locator-base(as(<file-locator>, application-name())),
+             components: find-root-components())
+      else
+        components[0]
+      end;
   let (start-suite, runner, report-function)
-    = make-runner-from-command-line(top, parser);
+    = make-runner-from-command-line(suite, parser);
 
-  // List tests and exit.
   let list-opt = get-option-value(parser, "list");
   if (list-opt)
     list-components(runner, start-suite, list-opt.as-lowercase);
-    exit-application(0);
-  end;
-
-  // Run the requested tests.
-  let pathname = get-option-value(parser, "report-file");
-  let result = run-tests(runner, start-suite);
-  if (pathname)
-    fs/with-open-file(stream = pathname,
-                      direction: #"output",
-                      if-exists: #"overwrite")
-      report-function(result, stream);
-    end;
+    0
   else
-    report-function(result, *standard-output*);
-  end;
-  exit-application(if (result.result-status == $passed) 0 else 1 end);
-end function run-test-application;
+    // Run the requested tests.
+    let pathname = get-option-value(parser, "report-file");
+    let result = run-tests(runner, start-suite);
+    if (pathname)
+      fs/with-open-file(stream = pathname,
+                        direction: #"output",
+                        if-exists: #"overwrite")
+        report-function(result, stream);
+      end;
+      // Always display the summary on the console.
+      print-summary-report(result, *standard-output*);
+    else
+      report-function(result, *standard-output*);
+    end;
+    if (result.result-status == $passed) 0 else 1 end
+  end
+end function;
 
 define function list-components
     (runner :: <test-runner>, start-suite :: <component>, what :: <string>)

components.dylan

@@ -280,8 +280,8 @@ define function find-root-components () => (components :: <sequence>)
   let roots = make(<stretchy-vector>);
   for (count keyed-by c in refs)
     if (count = 0)
-     add!(roots, c);
+      add!(roots, c);
     end;
   end;
   roots
-end;
+end function;

library.dylan

@@ -107,7 +107,7 @@ define module %testworks
     prefix: "fs/";
   use format;
   use json,
-    import: { encode-json };
+    import: { print-json, do-print-json };
   use locators,
     import: { <directory-locator>,
               <file-locator>,

reports.dylan

@@ -58,18 +58,26 @@ define method count-results
   values(pass, fail, crash, skip, nyi, expected-failures)
 end method;
 
+define function count-results-of-type
+    (result :: <result>, type :: subclass(<result>)) => (n :: <integer>)
+  let n = 0;
+  do-results(method (r) n := n + 1 end,
+             result,
+             test: method (r) instance?(r, type) end);
+  n
+end function;
+
 
 /// Summary generation
 
 // Output lines like these, one per call. `kind` is "suite", "test", "benchmark", or "check".
-//    Ran 10 suites: FAILED
-//    Ran 37 tests: FAILED (1 crashed, 1 failed, 3 not implemented, 1 skipped, 1 expected failure)
-//    Ran 1 benchmark: PASSED
 //    Ran 1455 checks: 22 crashed 1 failed
+//    Ran 37 tests: FAILED (1 crashed, 1 failed, 3 not implemented, 1 skipped, 1 expected failure)
 define method print-result-summary
     (result :: <result>, kind :: <string>, stream :: <stream>,
      #key test = always(#t))
  => ()
+  // Unexpected success is currently lumped in with failures.
   let (passed, failed, crashed, skipped, nyi, expected-failures)
     = count-results(result, test: test);
   let total = passed + failed + crashed + skipped + nyi + expected-failures;
@@ -225,10 +233,20 @@ define method print-summary-report
           print-result-summary(result, name, stream, test: rcurry(instance?, class))
         end;
   write(stream, "\n");
-  print-class-summary(result, "suite", <suite-result>);
-  print-class-summary(result, "test", <test-result>);
-  print-class-summary(result, "benchmark", <benchmark-result>);
   print-class-summary(result, "check", <check-result>);
+
+  // The expectation is that tests and benchmarks should be in different
+  // libraries so we try to print only one or the other here. If there are
+  // neither tests nor benchmarks something is wrong so print both.
+  let benches = count-results-of-type(result, <benchmark-result>);
+  let tests = count-results-of-type(result, <test-result>);
+  if (benches > 0 | tests = 0)
+    print-class-summary(result, "benchmark", <benchmark-result>);
+  end;
+  if (tests > 0 | benches = 0)
+    print-class-summary(result, "test", <test-result>);
+  end;
+
   let result-status = result.result-status;
   format(stream, "%=%s%= in %s seconds\n",
          result-status-to-text-attributes(result-status),
@@ -451,11 +469,11 @@ end function;
 /// JSON report
 
 define function print-json-report (result :: <result>, stream :: <stream>) => ()
-  encode-json(stream, result);
+  print-json(result, stream, indent: 2);
 end;
 
-define method encode-json (stream :: <stream>, result :: <result>)
-  encode-json(stream, result-to-table(result));
+define method do-print-json (result :: <result>, stream :: <stream>)
+  do-print-json(result-to-table(result), stream);
 end;
 
 // It's easier to convert to <table> and let the json library do the actual

tests/specification.dylan

@@ -1,7 +1,7 @@
 Module: testworks-test-suite
 
 define interface-specification-suite testworks-interface-specification-suite ()
-  function run-test-application (#"rest") => (false-or(<result>));
+  function run-test-application (#"rest") => ();
   function test-output (<string>, #"rest") => ();
   function test-temp-directory () => (false-or(<directory-locator>));
   open generic function check-equal-failure-detail (<object>, <object>) => (false-or(<string>));