Permalink
Browse files

Add back basic benchmark support. Implemented via a 'benchmark' tag.

Replace --list-{tests,suites} with --list={tests,suites,benchmarks,all}.
  • Loading branch information...
1 parent 6e40d44 commit 884235eed3df002e3bb8e20de1f10c884027a3ed @cgay cgay committed Jan 29, 2014
View
@@ -6,6 +6,9 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
License: See License.txt in this distribution for details.
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+define constant $list-option-values = #["all", "suites", "tests", "benchmarks"];
+
define function parse-args
(args :: <sequence>) => (parser :: <command-line-parser>)
let parser = make(<command-line-parser>);
@@ -57,13 +60,12 @@ define function parse-args
variable: "TEST",
help: "Skip these named tests. May be repeated."));
add-option(parser,
- make(<flag-option>,
- names: #("list-suites"),
- help: "List the suites without running them."));
- add-option(parser,
- make(<flag-option>,
- names: #("list-tests"),
- help: "List the tests without running them."));
+ make(<parameter-option>,
+ names: #("list", "l"),
+ default: #f,
+ variable: "WHAT",
+ help: format-to-string("List components: %s",
+ join($list-option-values, "|"))));
add-option(parser,
make(<repeated-parameter-option>,
names: #("tag", "t"),
@@ -100,8 +102,8 @@ define method find-component
| usage-error("Suite not found: %s", suite-name);
end;
let test = if (test-name)
- find-test(test-name, search-suite: suite | root-suite())
- | usage-error("Test not found: %s", test-name);
+ find-runnable(test-name, search-suite: suite | root-suite())
+ | usage-error("Test/benchmark not found: %s", test-name);
end;
test | suite
end method find-component;
@@ -179,25 +181,9 @@ define method run-test-application
exit-application(2);
end;
- let list-suites? = get-option-value(parser, "list-suites");
- let list-tests? = get-option-value(parser, "list-tests");
- if (list-suites? | list-tests?)
- let results = list-component(start-suite, runner);
- let final-results = choose(method (c :: <component>)
- (list-suites? & instance?(c, <suite>))
- | (list-tests? & instance?(c, <test>))
- end,
- results);
- for (component :: <component> in final-results)
- format(*standard-output*, "%s %s%s\n",
- component.component-type-name, component.component-name,
- if (instance?(component, <test>) & ~empty?(component.test-tags))
- format-to-string(" (tags: %s)",
- join(component.test-tags, ", ", key: tag-name))
- else
- ""
- end)
- end;
+ let list-opt = get-option-value(parser, "list");
+ if (list-opt)
+ list-components(runner, start-suite, list-opt.as-lowercase);
#f
else
// Run the appropriate test or suite
@@ -215,3 +201,30 @@ define method run-test-application
result
end if
end method run-test-application;
+
+define function list-components
+ (runner :: <test-runner>, start-suite :: <component>, what :: <string>)
+ if (~member?(what, $list-option-values, test: \=))
+ format(*standard-error*,
+ "Invalid --list option, %=. Value must be one of %s.\n",
+ what, join($list-option-values, ", ", conjunction: ", or "));
+ exit-application(2);
+ end;
+ let components = list-component(start-suite, runner);
+ for (component :: <component> in components)
+ if (what = "all" | select (component.object-class)
+ <suite> => what = "suites";
+ <test> => what = "tests";
+ <benchmark> => what = "benchmarks";
+ end)
+ format(*standard-output*, "%s %s%s\n",
+ component.component-type-name, component.component-name,
+ if (instance?(component, <runnable>) & ~empty?(component.test-tags))
+ format-to-string(" (tags: %s)",
+ join(component.test-tags, ", ", key: tag-name))
+ else
+ ""
+ end)
+ end;
+ end;
+end function list-components;
View
@@ -10,7 +10,7 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// This is the class of objects that can be performed in a test
/// suite. Note that there are no <assertion> or <check> classes so
/// they aren't considered "components".
-define class <component> (<object>)
+define abstract class <component> (<object>)
constant slot component-name :: <string>,
required-init-keyword: name:;
end class <component>;
@@ -24,27 +24,47 @@ define class <suite> (<component>)
init-keyword: cleanup-function:;
end class <suite>;
-
-define class <test> (<component>)
+define abstract class <runnable> (<component>)
constant slot test-function :: <function>,
required-init-keyword: function:;
- constant slot test-allow-empty? :: <boolean>,
- init-value: #f, init-keyword: allow-empty:;
+ // Benchmarks don't require assertions. Needs to be an instance
+ // variable, not a bare method, because testworks-specs
+ // auto-generated tests often don't get filled in. I want to kill
+ // testworks-specs with fire.
+ constant slot test-requires-assertions? :: <boolean> = #t,
+ init-keyword: requires-assertions?:;
constant slot test-tags :: <sequence> /* of <tag> */ = #[],
init-keyword: tags:;
-end class <test>;
+end class <runnable>;
define method make
- (class :: subclass(<test>), #rest args, #key name, tags) => (test :: <test>)
+ (class :: subclass(<runnable>), #rest args, #key name, tags)
+ => (runnable :: <runnable>)
let tags = map(make-tag, tags | #[]);
let negative = choose(tag-negated?, tags);
if (~empty?(negative))
- error("Tags associated with tests may not be negated. Test: %s, Tags: %s",
+ error("Tags associated with tests or benchmarks may not be negated. Test: %s, Tags: %s",
name, negative);
end;
apply(next-method, class, tags: tags, args)
end method make;
+define class <test> (<runnable>)
+end;
+
+// Benchmarks don't require any assertions.
+// Benchmarks have the keyword "benchmark".
+define class <benchmark> (<runnable>)
+ inherited slot test-requires-assertions? = #f;
+end;
+
+define method make
+ (class :: subclass(<benchmark>), #rest args, #key tags)
+ => (test :: <benchmark>)
+ let new-tags = concatenate(#["benchmark"], tags | #[]);
+ apply(next-method, class, tags: new-tags, args)
+end;
+
define class <test-unit> (<test>)
end;
@@ -58,6 +78,11 @@ define method component-type-name
end;
define method component-type-name
+ (bench :: <benchmark>) => (type-name :: <string>)
+ "benchmark"
+end;
+
+define method component-type-name
(test-unit :: <test-unit>) => (type-name :: <string>)
"test unit"
end;
@@ -89,6 +114,11 @@ define method component-result-type
end;
define method component-result-type
+ (component :: <benchmark>) => (result-type :: subclass(<result>))
+ <benchmark-result>
+end;
+
+define method component-result-type
(component :: <suite>) => (result-type :: subclass(<result>))
<suite-result>
end;
@@ -138,6 +168,7 @@ define macro suite-definer
components:
{ } => { }
{ test ?:name; ... } => { ?name, ... }
+ { benchmark ?:name; ... } => { ?name, ... }
{ suite ?:name; ... } => { ?name, ... }
end macro suite-definer;
@@ -155,6 +186,17 @@ define macro test-definer
}
end macro test-definer;
+define macro benchmark-definer
+ { define benchmark ?test-name:name (?keyword-args:*) ?test-body:body end
+ } => {
+ define constant ?test-name :: <benchmark>
+ = make(<benchmark>,
+ name: ?"test-name",
+ function: method () ?test-body end,
+ ?keyword-args);
+ }
+end macro benchmark-definer;
+
// For backward compatibility.
define macro with-test-unit
{ with-test-unit (?name:expression, ?keyword-args:*)
@@ -186,11 +228,11 @@ define method find-suite
do-find-suite(search-suite);
end method find-suite;
-define method find-test
+define method find-runnable
(name :: <string>, #key search-suite = root-suite())
- => (test :: false-or(<test>))
+ => (test :: false-or(<runnable>))
let lowercase-name = as-lowercase(name);
- local method do-find-test (suite :: <suite>)
+ local method do-find-runnable (suite :: <suite>)
block (return)
for (object in suite-components(suite))
select (object by instance?)
@@ -199,13 +241,13 @@ define method find-test
return(object)
end if;
<suite> =>
- let test = do-find-test(object);
+ let test = do-find-runnable(object);
if (test)
return(test)
end;
end
end
end
end;
- do-find-test(search-suite);
-end method find-test;
+ do-find-runnable(search-suite);
+end method find-runnable;
@@ -362,7 +362,7 @@ Test Execution
Run a test suite or test as part of a stand-alone test executable.
:signature: run-test-application *suite-or-test* => ()
- :parameter suite-or-test: An instance of :class:`<suite>` or :class:`<test>`.
+ :parameter suite-or-test: An instance of :class:`<suite>` or :class:`<runnable>`.
This is the main entry point to run a set of tests in Testworks.
It parses the command-line and based on the specified options
View
@@ -54,13 +54,11 @@ define module testworks
assert-true,
assert-false;
- // Suites
- create
- suite-definer;
-
- // Tests
+ // Components
create
+ suite-definer,
test-definer,
+ benchmark-definer,
with-test-unit;
// Output
@@ -79,7 +77,7 @@ define module %testworks
use print, import: { print-object };
use standard-io;
use streams;
- use strings, import: { char-compare-ic, starts-with? };
+ use strings, import: { char-compare-ic, starts-with?, string-equal? };
use testworks;
use threads,
import: { dynamic-bind };
@@ -100,12 +98,15 @@ define module %testworks
component-name,
status-name;
- // Tests
+ // Tests and benchmarks
export
+ <runnable>,
+ <benchmark>,
<test>,
<test-unit>,
+ find-runnable,
test-function,
- find-test,
+ test-requires-assertions?,
test-tags;
// Suites
@@ -134,6 +135,7 @@ define module %testworks
result-subresults,
<test-result>,
+ <benchmark-result>,
<suite-result>,
<unit-result>,
result-reason,
View
@@ -148,7 +148,8 @@ define method summary-report-function
end)
end;
print-class-summary(result, "suite", <suite-result>);
- print-class-summary(result, "test", <test-result>);
+ print-class-summary(result, "test", <test-result>);
+ print-class-summary(result, "benchmark", <benchmark-result>);
print-class-summary(result, "check", <check-result>);
end method summary-report-function;
View
@@ -60,6 +60,9 @@ end class <component-result>;
define class <test-result> (<component-result>)
end;
+define class <benchmark-result> (<component-result>)
+end;
+
define class <suite-result> (<component-result>)
end;
View
@@ -163,7 +163,7 @@ define method execute-component
end method execute-component;
define method execute-component
- (test :: <test>, runner :: <test-runner>)
+ (test :: <runnable>, runner :: <test-runner>)
=> (subresults :: <sequence>, status :: <result-status>, reason :: false-or(<string>),
seconds :: <integer>, microseconds :: <integer>, bytes :: <integer>)
let subresults = make(<stretchy-vector>);
@@ -188,7 +188,7 @@ define method execute-component
case
instance?(cond, <serious-condition>) =>
values($crashed, format-to-string("%s", cond));
- empty?(subresults) & ~test.test-allow-empty? =>
+ empty?(subresults) & test.test-requires-assertions? =>
$not-implemented;
every?(method (result :: <unit-result>) => (passed? :: <boolean>)
result.result-status == $passed
@@ -203,7 +203,7 @@ define method execute-component
end method execute-component;
define method list-component
- (test :: <test>, runner :: <test-runner>)
+ (test :: <runnable>, runner :: <test-runner>)
=> (list :: <sequence>)
if (execute-component?(test, runner))
vector(test)
@@ -259,9 +259,9 @@ define method show-progress
end;
end method show-progress;
-// Tests are displayed before and after being run.
+// Tests and benchmarks are displayed before and after being run.
define method show-progress
- (runner :: <test-runner>, test :: <test>, result :: false-or(<result>))
+ (runner :: <test-runner>, test :: <runnable>, result :: false-or(<result>))
=> ()
let verbose? = runner.runner-progress = $verbose;
if (result)
@@ -272,8 +272,10 @@ define method show-progress
result.result-time);
reason & test-output(" %s\n", reason);
else
- test-output("Running test %s:%s",
- test.component-name, verbose? & "\n" | "");
+ test-output("Running %s %s:%s",
+ test.component-type-name,
+ test.component-name,
+ verbose? & "\n" | "");
end;
end method show-progress;
Oops, something went wrong.

0 comments on commit 884235e

Please sign in to comment.