diff --git a/README.md b/README.md index 5bf5f5e..ef61ae6 100644 --- a/README.md +++ b/README.md @@ -1,12 +1,12 @@ # Testworks -Testworks is a Dylan unit testing library. +Testworks is a Dylan unit testing library, also with simple benchmarking +support. -Testworks is included by -[dylan-tool](https://opendylan.org/package/dylan-tool/) as a developer -dependency in every project created. +Testworks is included as a developer dependency in every project created by +[dylan-tool](https://opendylan.org/package/dylan-tool/). -Documentation is available in -[Opendylan.org](https://opendylan.org/package/testworks/). To build -the documentation locally, you'll need the -[furo](https://sphinx-themes.org/sample-sites/furo/) theme. \ No newline at end of file +Documentation is available on +[opendylan.org](https://opendylan.org/package/testworks/). To build the +documentation locally, you'll need the +[furo](https://sphinx-themes.org/sample-sites/furo/) theme. diff --git a/components.dylan b/components.dylan index a92d891..19cb259 100644 --- a/components.dylan +++ b/components.dylan @@ -208,7 +208,7 @@ end macro suite-definer; define macro test-definer { define test ?test-name:name (?keyword-args:*) ?test-body:body end } => { - define function "%%" ## ?test-name () ?test-body end; + define function "%%" ## ?test-name () => () ?test-body end; define constant ?test-name = make(, name: ?"test-name", function: "%%" ## ?test-name, @@ -220,7 +220,7 @@ end macro test-definer; define macro benchmark-definer { define benchmark ?test-name:name (?keyword-args:*) ?test-body:body end } => { - define function "%%" ## ?test-name () ?test-body end; + define function "%%" ## ?test-name () => () ?test-body end; define constant ?test-name :: = make(, name: ?"test-name", diff --git a/library.dylan b/library.dylan index aaa7417..de7c3d6 100644 --- a/library.dylan +++ b/library.dylan @@ -175,6 +175,8 @@ define module %testworks result-microseconds, result-time, result-bytes, + result-reason, + result-passing?, , result-subresults, @@ -184,8 +186,8 @@ define module %testworks , , , - result-reason, do-results, + decide-suite-status, ; // Report functions diff --git a/run.dylan b/run.dylan index 9d38b74..1af0b00 100644 --- a/run.dylan +++ b/run.dylan @@ -10,67 +10,6 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND // test/benchmark execution and while setup/teardown code is running. define thread variable *component* :: false-or() = #f; -// Return a temporary directory unique to the current test or benchmark. The -// directory is created the first time this is called for a given test. -// The directory is _test/-//, relative -// to ${DYLAN}/, if defined, or relative to fs/working-directory() otherwise. -define function test-temp-directory () => (d :: false-or()) - if (instance?(*component*, )) - let dylan = os/environment-variable("DYLAN"); - let base = if (dylan) - as(, dylan) - else - fs/working-directory() - end; - let uniquifier - = format-to-string("%s-%s", os/login-name() | "unknown", - date/format("%Y%m%d-%H%M%S", date/now())); - let safe-name = map(method (c) - if (c == '\\' | c == '/') '_' else c end - end, - full-component-name(*component*)); - let test-directory - = subdirectory-locator(base, "_test", uniquifier, safe-name); - fs/ensure-directories-exist(test-directory); - test-directory - end -end function; - -// Create a file in the current test's temp directory with the given contents. -// If the file already exists an error is signaled. `filename` is assumed to be -// a relative pathname; if it contains the path separator, subdirectories are -// created. File contents may be provided with the `contents` parameter, -// otherwise an empty file is created. Returns the full, absolute file path as -// a ``. -define function write-test-file - (filename :: fs/, #key contents :: = "") - => (full-pathname :: ) - let locator = merge-locators(as(, filename), - test-temp-directory()); - fs/ensure-directories-exist(locator); - fs/with-open-file (stream = locator, - direction: #"output", if-exists: #"signal") - write(stream, contents); - end; - locator -end function; - -// For tests to do debugging output. -// TODO(cgay): Collect this and stdio into a log file per test run -// or per test. The Surefire report has a place for stdout, too. -define method test-output - (format-string :: , #rest format-args) => () - let stream = if (*runner*) - runner-output-stream(*runner*) - else - *standard-output* - end; - with-stream-locked (stream) - apply(format, stream, format-string, format-args); - force-output(stream); - end; -end method test-output; - define constant $progress-none = #"progress-none"; define constant $progress-minimal = #"progress-minimal"; // Hide assertions unless they fail. define constant $progress-all = #"progress-all"; // Display all assertions. @@ -220,48 +159,34 @@ define method execute-component let microseconds :: = 0; let bytes :: = 0; let indent = next-indent(); - let status - = block () - suite.suite-setup-function(); - for (component in sort-components(suite.suite-components, runner.runner-order)) - let subresult - = dynamic-bind (*indent* = indent) - maybe-execute-component(component, runner); - end; - add!(subresults, subresult); - if (instance?(subresult, ) - & subresult.result-seconds - & subresult.result-microseconds) - let (sec, usec) = add-times(seconds, microseconds, - subresult.result-seconds, - subresult.result-microseconds); - seconds := sec; - microseconds := usec; - bytes := bytes + subresult.result-bytes; - else - test-output("subresult has no profiling info: %s\n", - subresult.result-name); + block () + suite.suite-setup-function(); + for (component in sort-components(suite.suite-components, runner.runner-order)) + let subresult + = dynamic-bind (*indent* = indent) + maybe-execute-component(component, runner); end; - end for; - case - // If all subcomponents are unimplemented the suite is unimplemented. - // Note that this case matches when subresults are empty. - every?(method (subresult) - subresult.result-status = $not-implemented - end, - subresults) - => $not-implemented; - every?(result-passing?, subresults) - => $passed; - otherwise - => $failed; - end case - cleanup - suite.suite-cleanup-function(); - end block; + add!(subresults, subresult); + if (instance?(subresult, ) + & subresult.result-seconds + & subresult.result-microseconds) + let (sec, usec) = add-times(seconds, microseconds, + subresult.result-seconds, + subresult.result-microseconds); + seconds := sec; + microseconds := usec; + bytes := bytes + subresult.result-bytes; + else + test-output("subresult has no profiling info: %s\n", + subresult.result-name); + end; + end for; + cleanup + suite.suite-cleanup-function(); + end block; make(component-result-type(suite), name: suite.component-name, - status: status, + status: decide-suite-status(subresults), reason: #f, subresults: subresults, seconds: seconds, @@ -269,6 +194,27 @@ define method execute-component bytes: bytes) end method execute-component; +define function decide-suite-status + (subresults :: ) => (status :: ) + if (empty?(subresults)) + $not-implemented + else + let status0 = subresults[0].result-status; + if (every?(method (subresult) + subresult.result-status == status0 + end, + subresults)) + status0 + elseif (any?(method (r) r.result-status == $crashed end, subresults)) + $crashed + elseif (every?(result-passing?, subresults)) + $passed + else + $failed + end if + end if +end function; + define method execute-component (test :: , runner :: ) => (result :: ) @@ -309,7 +255,7 @@ define method execute-component microseconds := cpu-time-microseconds; bytes := allocation; end profiling; - decide-status(test, subresults, cond) + decide-test-status(test, subresults, cond) end dynamic-bind; make(component-result-type(test), name: test.component-name, @@ -321,7 +267,7 @@ define method execute-component bytes: bytes) end method execute-component; -define function decide-status +define function decide-test-status (test :: , subresults, condition) => (status :: , reason) let benchmark? = ~test.test-requires-assertions?; @@ -404,8 +350,7 @@ end method; define method show-progress-done (runner :: , component :: , result :: ) => () let status = result.result-status; - let bytes = result.result-bytes; - test-output("%s%s %=%s%= %=%s%= in %ss%s\n", + test-output("%s%s %=%s%= %=%s%=", *indent*, capitalize(component.component-type-name), $component-name-text-attributes, @@ -413,13 +358,16 @@ define method show-progress-done $reset-text-attributes, result-status-to-text-attributes(status), status.status-name.as-uppercase, - $reset-text-attributes, - result.result-time, - if (bytes) - format-to-string(" and %s", format-bytes(bytes)) - else - "" - end); + $reset-text-attributes); + let elapsed = result.result-time; + if (elapsed & status ~== $skipped & status ~== $not-implemented) + test-output(" in %ss", elapsed); + let bytes = result.result-bytes; + if (bytes) + test-output(" and %s", format-bytes(bytes)); + end; + end; + test-output("\n"); end method; // assertions diff --git a/tests/testworks-test-suite.dylan b/tests/testworks-test-suite.dylan index e53349f..a0c1c12 100644 --- a/tests/testworks-test-suite.dylan +++ b/tests/testworks-test-suite.dylan @@ -420,14 +420,10 @@ define constant unexpected-success-suite define test test-run-tests-expect-failure/suite () let runner = make(, progress: $progress-none); - - let suite-results = run-tests(runner, expected-to-fail-suite); - assert-equal($passed, suite-results.result-status, - "expected-to-fail-suite should pass because all of its tests" - " fail and are expected to fail"); - - let suite-results = run-tests(runner, unexpected-success-suite); - assert-equal($failed, suite-results.result-status, + assert-true(result-passing?(run-tests(runner, expected-to-fail-suite)), + "expected-to-fail-suite should pass because all of its tests" + " fail and are expected to fail"); + assert-false(result-passing?(run-tests(runner, unexpected-success-suite)), "unexpected-success-suite should fail because its tests" " pass but are expected to fail"); end test; @@ -743,6 +739,38 @@ define test test-check-equal-failure-detail () "sizes differ (4 and 5)"); end test; +define test test-decide-suite-status () + assert-equal($not-implemented, decide-suite-status(#[])); + let v = vector; + for (item in v(// First the simple one-subresult cases... + v($passed, v($passed)), + v($failed, v($failed)), + v($crashed, v($crashed)), + v($skipped, v($skipped)), + v($expected-failure, v($expected-failure)), + v($unexpected-success, v($unexpected-success)), + v($not-implemented, v($not-implemented)), + // Now a few combinations... + v($failed, v($passed, $failed)), + v($failed, v($passed, $unexpected-success)), + v($passed, v($passed, $expected-failure, $skipped, $not-implemented)), + v($crashed, v($crashed, $failed)), + v($failed, v($unexpected-success, $failed)))) + let (expected-status, subresult-statuses) + = apply(values, item); + let subresults = map(method (status) + make(, + status: status, + name: status-name(status)) + end, + subresult-statuses); + assert-equal(expected-status, + decide-suite-status(subresults), + format-to-string("%= == decide-suite-status(%=)", + expected-status, subresult-statuses)); + end for; +end test; + /* Leaving this here because actually running these failing checks makes it much easier to debug, compared to running the above test, and there's more work to be done in this area so I expect to use these more. diff --git a/utils.dylan b/utils.dylan index 0bb94a9..49f2be8 100644 --- a/utils.dylan +++ b/utils.dylan @@ -125,3 +125,64 @@ define constant $indent-step :: = " "; define function next-indent () => (indent :: ) concatenate(*indent*, $indent-step) end function; + +// Return a temporary directory unique to the current test or benchmark. The +// directory is created the first time this is called for a given test. +// The directory is _test/-//, relative +// to ${DYLAN}/, if defined, or relative to fs/working-directory() otherwise. +define function test-temp-directory () => (d :: false-or()) + if (instance?(*component*, )) + let dylan = os/environment-variable("DYLAN"); + let base = if (dylan) + as(, dylan) + else + fs/working-directory() + end; + let uniquifier + = format-to-string("%s-%s", os/login-name() | "unknown", + date/format("%Y%m%d-%H%M%S", date/now())); + let safe-name = map(method (c) + if (c == '\\' | c == '/') '_' else c end + end, + full-component-name(*component*)); + let test-directory + = subdirectory-locator(base, "_test", uniquifier, safe-name); + fs/ensure-directories-exist(test-directory); + test-directory + end +end function; + +// Create a file in the current test's temp directory with the given contents. +// If the file already exists an error is signaled. `filename` is assumed to be +// a relative pathname; if it contains the path separator, subdirectories are +// created. File contents may be provided with the `contents` parameter, +// otherwise an empty file is created. Returns the full, absolute file path as +// a ``. +define function write-test-file + (filename :: fs/, #key contents :: = "") + => (full-pathname :: ) + let locator = merge-locators(as(, filename), + test-temp-directory()); + fs/ensure-directories-exist(locator); + fs/with-open-file (stream = locator, + direction: #"output", if-exists: #"signal") + write(stream, contents); + end; + locator +end function; + +// For tests to do debugging output. +// TODO(cgay): Collect this and stdio into a log file per test run +// or per test. The Surefire report has a place for stdout, too. +define method test-output + (format-string :: , #rest format-args) => () + let stream = if (*runner*) + runner-output-stream(*runner*) + else + *standard-output* + end; + with-stream-locked (stream) + apply(format, stream, format-string, format-args); + force-output(stream); + end; +end method;