From f2ffc727b25fc1acdc12068a251cee734eebf2db Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sat, 13 Sep 2025 18:23:48 -0400 Subject: [PATCH 1/2] Improve exception handling (for --debug option) Fixes #182 Fixes #183 --- assertions.dylan | 36 +++++--- command-line.dylan | 13 +-- library.dylan | 11 ++- run.dylan | 46 +++++++---- tests/testworks-test-suite.dylan | 137 +++++++++++++++++++------------ 5 files changed, 154 insertions(+), 89 deletions(-) diff --git a/assertions.dylan b/assertions.dylan index 3afaf88..e2941ab 100644 --- a/assertions.dylan +++ b/assertions.dylan @@ -8,8 +8,15 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND define constant $invalid-description = "*** invalid description ***"; -// This is used to do a non-local exit to the end of a test and skip remaining assertions. -define class () end; +// This is used to do a non-local exit to the end of a test and skip remaining +// assertions. It's a subclass of so that the debugger will be +// invoked if we don't handle it, e.g., for '--debug failures'. +define class () +end class; + +define method condition-to-string (c :: ) => (s :: ) + apply(format-to-string, c.condition-format-string, c.condition-format-arguments) +end method; /// Assertion macros @@ -100,6 +107,10 @@ define macro expect-equal terminate?: #f) } end macro; +define function handle-assertion-condition? (c :: ) + ~instance?(c, ) & handle-condition?(*runner*, c) +end function; + define function do-check-equal (description-thunk :: , arguments-thunk :: , caller :: , #key terminate? :: ) @@ -128,7 +139,7 @@ define function do-check-equal want, *indent*, $indent-step, got, detail)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); @@ -183,7 +194,7 @@ define function do-check-not-equal format-to-string("%= and %= are =.", val1, val2)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); @@ -324,7 +335,7 @@ define function do-check-instance? description := eval-check-description(description-thunk); phase := format-to-string("evaluating %s expressions", caller); let (type :: , value, value-expr :: ) = get-arguments(); - phase := format-to-string("checking if expression %s is %=an instance of %s", + phase := format-to-string("checking if expression %s is %san instance of %s", value-expr, if (negate?) "not " else "" end, type); if (instance?(value, type) ~= negate?) record-check(description, $passed, #f); @@ -334,7 +345,7 @@ define function do-check-instance? value, value-expr, type)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); @@ -381,7 +392,7 @@ define function do-check-true format-to-string("expression %s is false.", value-expr)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); @@ -443,7 +454,7 @@ define function do-check-false value-expr, value)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); @@ -515,9 +526,10 @@ define function do-check-condition terminate? & signal(make()); exception (ex :: condition-class) record-check(description, $passed, #f); - // Not really sure if this should catch something broader, like - // , but leaving it this way for compat with old code. - exception (ex :: ) + exception (ex :: , + test: method (c) + ~instance?(c, ) + end) record-check(description, $failed, format-to-string("condition of class %s signaled; " "expected a condition of class %s. " @@ -525,7 +537,7 @@ define function do-check-condition ex.object-class, condition-class, ex)); terminate? & signal(make()); end; - exception (err :: , test: method (cond) ~debug?() end) + exception (err :: , test: handle-assertion-condition?) record-check(description | $invalid-description, $crashed, format-to-string("Error %s: %s", phase, err)); diff --git a/command-line.dylan b/command-line.dylan index e5eeaac..2a311e9 100644 --- a/command-line.dylan +++ b/command-line.dylan @@ -31,11 +31,11 @@ define function parse-args add-option(parser, make(, names: "debug", - choices: #("none", "crashes", "all"), + choices: #("none", "crashes", "failures", "all"), default: "none", variable: "WHAT", - help: "Enter the debugger? None, crashes, or all" - " (crashes and failures). [%default%]")); + help: "Enter the debugger? none, crashes, failures, or all." + " [%default%]")); add-option(parser, make(, names: #("progress", "p"), @@ -132,9 +132,10 @@ define function make-runner-from-command-line get-option-value(parser, "run"), get-option-value(parser, "skip")); let debug = select (as-lowercase(get-option-value(parser, "debug")) by \=) - "none" => $debug-none; - "crashes" => $debug-crashes; - "all" => $debug-all; + "none" => $debug-none; + "crashes" => $debug-crashes; + "failures" => $debug-failures; + "all" => $debug-all; end; let progress = select (as-lowercase(get-option-value(parser, "progress")) by \=) "none" => $progress-none; diff --git a/library.dylan b/library.dylan index 44bfd3a..c6976ef 100644 --- a/library.dylan +++ b/library.dylan @@ -139,9 +139,8 @@ define module %testworks , $debug-none, $debug-crashes, - $debug-all, - debug-failures?, - debug?; + $debug-failures, + $debug-all; // Components export @@ -238,6 +237,10 @@ define module %testworks // Specs accessors export spec-name, - spec-title; + spec-title; + + // Conditions + export + ; end module %testworks; diff --git a/run.dylan b/run.dylan index a11bba5..aa977d3 100644 --- a/run.dylan +++ b/run.dylan @@ -17,20 +17,11 @@ define constant = one-of($progress-none, $progress-minimal, $progress-all); define constant $debug-none = #"debug-none"; +define constant $debug-failures = #"debug-failures"; define constant $debug-crashes = #"debug-crashes"; define constant $debug-all = #"debug-all"; define constant - = one-of($debug-none, $debug-crashes, $debug-all); - -define inline function debug-failures? - () => (debug-failures? :: ) - runner-debug(*runner*) == $debug-all -end function; - -define inline function debug? - () => (debug? :: ) - runner-debug(*runner*) ~= $debug-none -end function; + = one-of($debug-none, $debug-crashes, $debug-failures, $debug-all); define constant $source-order = #"source"; // order they appear in the source code. define constant $lexical-order = #"lexical"; @@ -167,7 +158,8 @@ define method execute-component skip-result := $skipped; skip-reason := reason | format-to-string("disabled by when: option"); end - exception (err :: , test: method (c) ~debug?() end) + exception (err :: , + test: curry(handle-condition?, runner)) skip-result := $crashed; skip-reason := format-to-string("Error in %s for suite %s: %s", context, suite.component-name, err); @@ -267,16 +259,16 @@ define method execute-component block () test.test-function(); exception (err :: , - test: method (c) ~debug?() end) + test: curry(handle-condition?, runner)) // An assertion failure causes the remainder of a test to be // skipped (by jumping here) to prevent cascading failures. // The failure has already been recorded so nothing to do. #f exception (err :: , - test: method (c) ~debug?() end) + test: curry(handle-condition?, runner)) err end; - results + results seconds := cpu-time-seconds; microseconds := cpu-time-microseconds; bytes := allocation; @@ -294,6 +286,30 @@ define method execute-component end if end method execute-component; +define generic handle-condition? + (runner :: , cond :: ) => (b :: ); + +define method handle-condition? + (runner :: , cond :: ) => (b :: ) + #f +end method; + +define method handle-condition? + (runner :: , cond :: ) => (b :: ) + select (runner.runner-debug) + $debug-failures, $debug-all => #f; + otherwise => #t; + end +end method; + +define method handle-condition? + (runner :: , cond :: ) => (b :: ) + select (runner.runner-debug) + $debug-crashes, $debug-all => #f; + otherwise => #t; + end +end method; + define function make-skip-result (component, reason) make(component-result-type(component), name: component.component-name, diff --git a/tests/testworks-test-suite.dylan b/tests/testworks-test-suite.dylan index 70a0fa1..d54b554 100644 --- a/tests/testworks-test-suite.dylan +++ b/tests/testworks-test-suite.dylan @@ -8,11 +8,6 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// Some utilities for testing TestWorks -// TODO: anything that calls run-tests should turn off debug?() so that running -// testworks-test-suite with --debug=crashes doesn't cause unwanted debugger entry. -// Probably can change without-recording to be with-standard-test-environment or -// something. Can test this with test-expect-failure-continues. - define function run-component (comp, #key components) if (~components) components := make(); @@ -346,23 +341,11 @@ define test test-assert-not-instance? () end test; define test testworks-check-condition-test () - begin - let success? = #f; - assert-equal($passed, - with-result-status () - check-condition($internal-check-name, - , - begin - // default-handler for returns #f - test-warning(); - success? := #t; - test-error() - end) - end, - "check-condition catches "); - assert-true(success?, - "check-condition for doesn't catch "); - end; + assert-equal($passed, + with-result-status () + check-condition($internal-check-name, , test-error()) + end, + "check-condition catches "); assert-equal($failed, with-result-status () check-condition($internal-check-name, , #f) @@ -376,22 +359,11 @@ define test testworks-check-condition-test () end test; define test test-expect-condition () - begin - let success? = #f; - assert-equal($passed, - with-result-status () - expect-condition(, - begin - // default-handler for returns #f - test-warning(); - success? := #t; - test-error() - end) - end, - "expect-condition catches "); - assert-true(success?, - "expect-condition for doesn't catch "); - end; + assert-equal($passed, + with-result-status () + expect-condition(, test-error()) + end, + "expect-condition catches "); assert-equal($failed, with-result-status () expect-condition(, #f) @@ -407,20 +379,10 @@ end test; define test testworks-assert-condition-test () assert-condition(, error("foo")); assert-condition(, error("foo"), "error signals error w/ description"); - begin - let success? = #f; - assert-equal($passed, - with-result-status () - assert-condition(, - begin - // default-handler for returns #f - test-warning(); - success? := #t; - test-error() - end) - end); - assert-true(success?); - end; + assert-equal($passed, + with-result-status () + assert-condition(, test-error()) + end); assert-equal($failed, with-result-status () assert-condition(, #f) @@ -1106,3 +1068,74 @@ define test test-assert-equal-output () tabling("a" => 1, "x" => 2, "c" => 3)); end test; */ + +define test test-debug-option--crashes () + let crashing-test + = make(, + name: "test-debug-option-1", + function: curry(error, "error in test-debug-option-1")); + let result-1 = #f; + let runner-1 = make(, + components: list(crashing-test), + progress: $progress-none, + debug: $debug-none); + assert-no-errors(result-1 := run-tests(runner-1, crashing-test), + "crashes are handled by default"); + assert-equal($crashed, result-1.result-status); + + let result-2 = #f; + let runner-2 = make(, + components: list(crashing-test), + progress: $progress-none, + debug: $debug-crashes); + assert-signals(, result-2 := run-tests(runner-2, crashing-test), + "--debug crashes allows errors to escape"); + assert-equal(#f, result-2); +end test; + +define test test-debug-option--failures () + let failing-test + = make(, + name: "test-debug-option-2", + function: method () + assert-true(#f, "failed assertion in test-debug-option-2"); + end); + let result-1 = #f; + let runner-1 = make(, + components: list(failing-test), + progress: $progress-none, + debug: $debug-none); + assert-no-errors(result-1 := run-tests(runner-1, failing-test), + "failures are handled by default"); + assert-equal($failed, result-1.result-status); + + let result-2 = #f; + let runner-2 = make(, + components: list(failing-test), + progress: $progress-none, + debug: $debug-failures); + assert-signals(, + result-2 := run-tests(runner-2, failing-test), + "--debug failures signals "); + assert-equal(#f, result-2); +end test; + +// https://github.com/dylan-lang/testworks/issues/183 --debug crashes should not cause +// assertions to act like expectations. +define test test-bug-183 () + let it = #f; + let failing-test + = make(, + name: "test-bug-183", + function: method () + assert-true(#f); + it := #t; + end); + let runner = make(, + components: list(failing-test), + progress: $progress-none, + debug: $debug-crashes); + let result = run-tests(runner, failing-test); + assert-equal($failed, result.result-status); + assert-false(it); +end test; From 58ceb7df6b68ce8acd0c296e43e4ad6d703d2553 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sun, 14 Sep 2025 13:55:46 -0400 Subject: [PATCH 2/2] Improve error messages generated when --debug option is used --- assertions.dylan | 100 +++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/assertions.dylan b/assertions.dylan index e2941ab..b75e547 100644 --- a/assertions.dylan +++ b/assertions.dylan @@ -11,13 +11,18 @@ define constant $invalid-description = "*** invalid description ***"; // This is used to do a non-local exit to the end of a test and skip remaining // assertions. It's a subclass of so that the debugger will be // invoked if we don't handle it, e.g., for '--debug failures'. -define class () +define class () + constant slot %reason :: , required-init-keyword: reason:; end class; define method condition-to-string (c :: ) => (s :: ) - apply(format-to-string, c.condition-format-string, c.condition-format-arguments) + c.%reason end method; +define function assertion-failure (reason :: ) + signal(make(, reason: reason)) +end function; + /// Assertion macros // The check-* macros are non-terminating, require the caller to provide a @@ -134,16 +139,15 @@ define function do-check-equal else "" end; - record-check(description, $failed, - format-to-string("want: %=\n%s%sgot: %=%s", - want, *indent*, $indent-step, got, detail)); - terminate? & signal(make()); + let reason = format-to-string("want: %=\n%s%sgot: %=%s", + want, *indent*, $indent-step, got, detail); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function; @@ -190,15 +194,14 @@ define function do-check-not-equal record-check(description, $passed, #f); else phase := format-to-string("getting %s failure detail", caller); - record-check(description, $failed, - format-to-string("%= and %= are =.", val1, val2)); - terminate? & signal(make()); + let reason = format-to-string("%= and %= are =.", val1, val2); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function; @@ -340,16 +343,15 @@ define function do-check-instance? if (instance?(value, type) ~= negate?) record-check(description, $passed, #f); else - record-check(description, $failed, - format-to-string("%=, from expression %s, is not an instance of %s.", - value, value-expr, type)); - terminate? & signal(make()); + let reason = format-to-string("%=, from expression %s, is not an instance of %s.", + value, value-expr, type); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function do-check-instance?; @@ -388,15 +390,14 @@ define function do-check-true if (value) record-check(description, $passed, #f); else - record-check(description, $failed, - format-to-string("expression %s is false.", value-expr)); - terminate? & signal(make()); + let reason = format-to-string("expression %s is false.", value-expr); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function do-check-true; @@ -449,16 +450,15 @@ define function do-check-false if (~value) record-check(description, $passed, #f); else - record-check(description, $failed, - format-to-string("expression %s evaluates to %=; expected #f.", - value-expr, value)); - terminate? & signal(make()); + let reason = format-to-string("expression %s evaluates to %=; expected #f.", + value-expr, value); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function do-check-false; @@ -522,26 +522,26 @@ define function do-check-condition expr, condition-class); block () thunk(); - record-check(description, $failed, "no condition signaled"); - terminate? & signal(make()); + let reason = "no condition signaled"; + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); exception (ex :: condition-class) record-check(description, $passed, #f); exception (ex :: , test: method (c) ~instance?(c, ) end) - record-check(description, $failed, - format-to-string("condition of class %s signaled; " + let reason = format-to-string("condition of class %s signaled; " "expected a condition of class %s. " "The error was: %s", - ex.object-class, condition-class, ex)); - terminate? & signal(make()); + ex.object-class, condition-class, ex); + record-check(description, $failed, reason); + terminate? & assertion-failure(concatenate(caller, ": ", reason)); end; exception (err :: , test: handle-assertion-condition?) - record-check(description | $invalid-description, - $crashed, - format-to-string("Error %s: %s", phase, err)); - terminate? & signal(make()); + let reason = format-to-string("Error %s: %s", phase, err); + record-check(description | $invalid-description, $crashed, reason); + terminate? & assertion-failure(reason); end block end function do-check-condition;