Hi, thanks to #199 I was reminded to go through my tree and send couple of fixes I had lying around for SRFI-64. You can find them attached. Consider installing the patches.
Thanks and have a nice day, Tomas -- There are only two hard things in Computer Science: cache invalidation, naming things and off-by-one errors.
>From 03433ce4d1488d97a9dea6cff4b6c1a066c6f2e4 Mon Sep 17 00:00:00 2001 From: Tomas Volf <[email protected]> Date: Sun, 10 Nov 2024 23:25:29 +0100 Subject: [PATCH 1/4] srfi-64: Fix maybe-print-prop. Previously it always printed the property, regardless of whether it was set or not. * module/srfi/srfi-64.scm (test-on-test-end-simple)[maybe-print-prop]: Print only set properties. --- module/srfi/srfi-64.scm | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 98fcef645..13ae26d48 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -418,15 +418,16 @@ instead." (define (test-on-test-end-simple runner) "Log that test is done." (define (maybe-print-prop prop pretty?) - (let* ((val (test-result-ref runner prop)) - (val (string-trim-both - (with-output-to-string - (λ () - (if pretty? - (pretty-print val #:per-line-prefix " ") - (display val))))))) - (when val - (format #t "~a: ~a~%" prop val)))) + (let* ((default (list)) + (val (test-result-ref runner prop default))) + (unless (eq? val default) + (let ((val (string-trim-both + (with-output-to-string + (λ () + (if pretty? + (pretty-print val #:per-line-prefix " ") + (display val))))))) + (format #t "~a: ~a~%" prop val))))) (let ((result-kind (test-result-kind runner))) ;; Skip tests not executed due to run list. -- 2.54.0
>From a2c8f8fdc406fd06552583fd7e5429d66b43d2ab Mon Sep 17 00:00:00 2001 From: Tomas Volf <[email protected]> Date: Mon, 11 Nov 2024 00:46:45 +0100 Subject: [PATCH 2/4] srfi-64: Use ~s when printing some properties. This will help to properly debug failing tests like: (test-equal "some failing test" "a b " "a b") Before there was no way to tell that one "a b" as extra trailing space, now there is. * module/srfi/srfi-64.scm (test-on-test-end-simple)['expected-value] ['expected-error, 'actual-value, 'actual-error]: Print using ~s. [maybe-print-prop]: Take the code for format as a parameter. --- module/srfi/srfi-64.scm | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 13ae26d48..7b3341bf0 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -27,7 +27,6 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -417,17 +416,11 @@ instead." (define (test-on-test-end-simple runner) "Log that test is done." - (define (maybe-print-prop prop pretty?) + (define (maybe-print-prop prop pretty? code) (let* ((default (list)) (val (test-result-ref runner prop default))) (unless (eq? val default) - (let ((val (string-trim-both - (with-output-to-string - (λ () - (if pretty? - (pretty-print val #:per-line-prefix " ") - (display val))))))) - (format #t "~a: ~a~%" prop val))))) + (format #t "~a: ~@?~&" prop code val)))) (let ((result-kind (test-result-kind runner))) ;; Skip tests not executed due to run list. @@ -436,13 +429,13 @@ instead." result-kind (test-runner-test-name runner)) (unless (member result-kind '(pass xfail)) - (maybe-print-prop 'source-file #f) - (maybe-print-prop 'source-line #f) - (maybe-print-prop 'source-form #t) - (maybe-print-prop 'expected-value #f) - (maybe-print-prop 'expected-error #t) - (maybe-print-prop 'actual-value #f) - (maybe-print-prop 'actual-error #t))))) + (maybe-print-prop 'source-file #f "~a") + (maybe-print-prop 'source-line #f "~a") + (maybe-print-prop 'source-form #t "~y") + (maybe-print-prop 'expected-value #f "~s") + (maybe-print-prop 'expected-error #t "~s") + (maybe-print-prop 'actual-value #f "~s") + (maybe-print-prop 'actual-error #t "~s"))))) (define (test-runner-simple) "Creates a new simple test-runner, that prints errors and a summary on the -- 2.54.0
>From 99205d86ab6b2bb3b428ece28517f0427befeb78 Mon Sep 17 00:00:00 2001 From: Tomas Volf <[email protected]> Date: Fri, 15 Nov 2024 22:26:57 +0100 Subject: [PATCH 3/4] srfi-64: Export define-equality-test. Interest was expressed on the mailing list to have %test-2 as a part of the public API. So rename it and export from the module. * module/srfi/srfi-64.scm (define-equality-test): Rename from %test-2. (%test-2): Rename from %%test-2. (test-eq, test-eqv, test-equal): Adjust. (define-module)<#:export>: Export it. --- module/srfi/srfi-64.scm | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 7b3341bf0..203db49ea 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -118,6 +118,8 @@ test-procedure? test-thunk + define-equality-test + &bad-end-name bad-end-name? bad-end-name-begin-name @@ -728,7 +730,7 @@ to invoke @code{test-assert} if there is no current test runner. @end defspec") -(define-syntax %%test-2 +(define-syntax %test-2 (λ (x) (syntax-case x () ((_ syn test-proc test-name expected test-expr) @@ -742,20 +744,34 @@ to invoke @code{test-assert} if there is no current test runner. (test-result-set! r 'actual-value a) (test-proc e a)))))))) -(define-syntax %test-2 +(define-syntax define-equality-test (syntax-rules () ((_ name test-proc) (define-syntax name (λ (x) (syntax-case x () ((_ test-name expected test-expr) - #`(%%test-2 #,x test-proc test-name expected test-expr)) + #`(%test-2 #,x test-proc test-name expected test-expr)) ((_ expected test-expr) - #`(%%test-2 #,x test-proc #f expected test-expr)))))))) + #`(%test-2 #,x test-proc #f expected test-expr)))))))) +(set-documentation! 'define-equality-test + "@defspec define-equality-test identifier proc +Define a new test form named @var{identifier} with same signature and usage as +@code{test-eq} but using @var{proc} instead of @code{eq?}. -(%test-2 test-eq eq?) -(%test-2 test-eqv eqv?) -(%test-2 test-equal equal?) +For example, the provided equality checks are defined as: + +@lisp +(define-equality-test test-eq eq?) +(define-equality-test test-eqv eqv?) +(define-equality-test test-equal equal?) +@end lisp + +@end defspec") + +(define-equality-test test-eq eq?) +(define-equality-test test-eqv eqv?) +(define-equality-test test-equal equal?) (set-documentation! 'test-eq "@defspec test-eq test-name expected test-expr -- 2.54.0
>From 7720c0c735688850b6fefef063260220abaed994 Mon Sep 17 00:00:00 2001 From: Tomas Volf <[email protected]> Date: Sat, 16 Nov 2024 18:19:45 +0100 Subject: [PATCH 4/4] srfi-64: Report failed tests in (standards)Errors format. There is a page in the GNU Standards document regarding the format of error messages. Both GNU Emacs and Vim are able to parse it and support jumping to next/previous error. My version did not produce a line in this format for failed tests and this commit rectifies that. * module/srfi/srfi-64.scm (test-on-test-end-simple)[non-passed]: Write out (standards)Errors compatible line. --- module/srfi/srfi-64.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 203db49ea..98f6c8114 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-71) @@ -431,6 +432,10 @@ instead." result-kind (test-runner-test-name runner)) (unless (member result-kind '(pass xfail)) + (and-let* ((file (test-result-ref runner 'source-file)) + (line (test-result-ref runner 'source-line))) + ;; Satisfy (standards)Errors + (format #t "~a:~a: unexpected result~%" file line)) (maybe-print-prop 'source-file #f "~a") (maybe-print-prop 'source-line #f "~a") (maybe-print-prop 'source-form #t "~y") -- 2.54.0
