* [PATCH] Add GNU-style error location for failing tests in test-suite.
@ 2014-09-23 16:41 Jan Nieuwenhuizen
2014-10-05 9:33 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v2 Jan Nieuwenhuizen
0 siblings, 1 reply; 5+ messages in thread
From: Jan Nieuwenhuizen @ 2014-09-23 16:41 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 205 bytes --]
Hi,
I am using the test-suite for my project and found that doing TDD it is
very helpful if Emacs jumps automatically to the failing tests'
location.
Patch attached. What do you think?
Greetings, Jan
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch --]
[-- Type: text/x-diff, Size: 7168 bytes --]
From efce4fa4be1c9bc6e368193b82b7eaa9b9957fee Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Tue, 23 Sep 2014 18:37:44 +0200
Subject: [PATCH] Add GNU-style error location for failing tests in test-suite.
2014-09-23 Jan Nieuwenhuizen <janneke@gnu.org>
* test-suite/test-suite/lib.scm (run-test): Add location parameter;
display GNU style error location for failing test.
* test-suite/test-suite/lib.scm (pass-if, pass-if-equal)
(run-test-exception, pass-if-exception, expect-fail-exception):
Update callers.
---
test-suite/test-suite/lib.scm | 45 +++++++++++++++++++++++--------------------
1 file changed, 24 insertions(+), 21 deletions(-)
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 9ecaf89..7bd3260 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -77,16 +77,16 @@
\f
;;;; CORE FUNCTIONS
;;;;
-;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; The function (run-test name location expected-result thunk) is the heart of the
;;;; testing environment. The first parameter NAME is a unique name for the
;;;; test to be executed (for an explanation of this parameter see below under
-;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
+;;;; TEST NAMES). The third parameter EXPECTED-RESULT is a boolean value
;;;; that indicates whether the corresponding test is expected to pass. If
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
;;;; #f the test is expected to fail. Finally, THUNK is the function that
;;;; actually performs the test. For example:
;;;;
-;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;; (run-test "integer addition" (current-source-location) #t (lambda () (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass. To
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
@@ -104,9 +104,9 @@
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
-;;;; (run-test name #t (lambda () body))
+;;;; (run-test name (current-source-location) #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
-;;;; (run-test name #f (lambda () body))
+;;;; (run-test name (current-source-location) #f (lambda () body))
;;;;
;;;; For example:
;;;;
@@ -159,9 +159,9 @@
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
-;;;; (run-test 'expression #t (lambda () expression))
+;;;; (run-test 'expression location #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
-;;;; (run-test 'expression #f (lambda () expression))
+;;;; (run-test 'expression location #f (lambda () expression))
;;;;
;;;; For example:
;;;;
@@ -317,7 +317,7 @@
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test
(let ((test-running #f))
- (lambda (name expect-pass thunk)
+ (lambda (name location expect-pass thunk)
(if test-running
(error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name)))
@@ -331,20 +331,21 @@
(lambda (key . args)
(case key
((pass)
- (report (if expect-pass 'pass 'upass) test-name))
+ (report (if expect-pass 'pass 'upass) test-name location))
((fail)
;; ARGS may contain extra info about the failure,
;; such as the expected and actual value.
(apply report (if expect-pass 'fail 'xfail)
test-name
+ location
args))
((unresolved untested unsupported)
- (report key test-name))
+ (report key test-name location))
((quit)
- (report 'unresolved test-name)
+ (report 'unresolved test-name location)
(quit))
(else
- (report 'error test-name (cons key args))))))
+ (report 'error test-name location (cons key args))))))
(set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
@@ -353,9 +354,9 @@
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
- (run-test 'name #t (lambda () name)))
+ (run-test 'name (current-source-location) #t (lambda () name)))
((_ name rest ...)
- (run-test name #t (lambda () rest ...)))))
+ (run-test name (current-source-location) #t (lambda () rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
@@ -363,7 +364,7 @@
((_ expected body)
(pass-if-equal 'body expected body))
((_ name expected body ...)
- (run-test name #t
+ (run-test name (current-source-location) #t
(lambda ()
(let ((result (begin body ...)))
(or (equal? expected result)
@@ -377,12 +378,12 @@
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
- (run-test 'name #f (lambda () name)))
+ (run-test 'name (current-source-location) #f (lambda () name)))
((_ name rest ...)
- (run-test name #f (lambda () rest ...)))))
+ (run-test name (current-source-location) #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
-(define (run-test-exception name exception expect-pass thunk)
+(define (run-test-exception name location exception expect-pass thunk)
(match exception
((expected-key . expected-pattern)
(run-test
@@ -408,13 +409,13 @@
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #t (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #f (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #f (lambda () body rest ...)))))
\f
;;;; TEST NAMES
@@ -620,11 +621,13 @@
'(fail upass unresolved error))
;;; Display a single test result in formatted form to the given port
-(define (print-result port result name . args)
+(define (print-result port result name location . args)
(let* ((tag (assq result result-tags))
(label (if tag (cadr tag) #f)))
(if label
(begin
+ (if (not (eq? result 'pass))
+ (format port "~a:~a:" (assoc-ref location 'filename) (1+ (assoc-ref location 'line))))
(display label port)
(display ": " port)
(display (format-test-name name) port)
--
/home/janneke/.signature
[-- Attachment #3: Type: text/plain, Size: 151 bytes --]
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v2
2014-09-23 16:41 [PATCH] Add GNU-style error location for failing tests in test-suite Jan Nieuwenhuizen
@ 2014-10-05 9:33 ` Jan Nieuwenhuizen
2014-10-05 21:40 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v3 Jan Nieuwenhuizen
0 siblings, 1 reply; 5+ messages in thread
From: Jan Nieuwenhuizen @ 2014-10-05 9:33 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 299 bytes --]
Jan Nieuwenhuizen writes:
Hi,
New version adds
* test-suite/tests/srfi-64.test (guile-test-runner): Update callers.
Thanks to Mark Weaver, who also suggested this function might better be
moved to test-suite/lib.scm.
Greetings,
Jan
PS: please have a look at my GUD and Guile-Gnome patches?
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch --]
[-- Type: text/x-diff, Size: 8592 bytes --]
From ccf525b93d49be51611c5c9d69f0c17d77b60147 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Tue, 23 Sep 2014 18:37:44 +0200
Subject: [PATCH] Add GNU-style error location for failing tests in test-suite.
2014-10-05 Jan Nieuwenhuizen <janneke@gnu.org>
* test-suite/test-suite/lib.scm (run-test): Add location parameter;
display GNU style error location for failing test.
* test-suite/test-suite/lib.scm (pass-if, pass-if-equal)
(run-test-exception, pass-if-exception, expect-fail-exception):
Update callers.
* test-suite/tests/srfi-64.test (guile-test-runner): update callers.
---
test-suite/test-suite/lib.scm | 45 +++++++++++++++++++++++--------------------
test-suite/tests/srfi-64.test | 14 +++++++++-----
2 files changed, 33 insertions(+), 26 deletions(-)
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 9ecaf89..7bd3260 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -77,16 +77,16 @@
\f
;;;; CORE FUNCTIONS
;;;;
-;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; The function (run-test name location expected-result thunk) is the heart of the
;;;; testing environment. The first parameter NAME is a unique name for the
;;;; test to be executed (for an explanation of this parameter see below under
-;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
+;;;; TEST NAMES). The third parameter EXPECTED-RESULT is a boolean value
;;;; that indicates whether the corresponding test is expected to pass. If
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
;;;; #f the test is expected to fail. Finally, THUNK is the function that
;;;; actually performs the test. For example:
;;;;
-;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;; (run-test "integer addition" (current-source-location) #t (lambda () (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass. To
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
@@ -104,9 +104,9 @@
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
-;;;; (run-test name #t (lambda () body))
+;;;; (run-test name (current-source-location) #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
-;;;; (run-test name #f (lambda () body))
+;;;; (run-test name (current-source-location) #f (lambda () body))
;;;;
;;;; For example:
;;;;
@@ -159,9 +159,9 @@
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
-;;;; (run-test 'expression #t (lambda () expression))
+;;;; (run-test 'expression location #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
-;;;; (run-test 'expression #f (lambda () expression))
+;;;; (run-test 'expression location #f (lambda () expression))
;;;;
;;;; For example:
;;;;
@@ -317,7 +317,7 @@
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test
(let ((test-running #f))
- (lambda (name expect-pass thunk)
+ (lambda (name location expect-pass thunk)
(if test-running
(error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name)))
@@ -331,20 +331,21 @@
(lambda (key . args)
(case key
((pass)
- (report (if expect-pass 'pass 'upass) test-name))
+ (report (if expect-pass 'pass 'upass) test-name location))
((fail)
;; ARGS may contain extra info about the failure,
;; such as the expected and actual value.
(apply report (if expect-pass 'fail 'xfail)
test-name
+ location
args))
((unresolved untested unsupported)
- (report key test-name))
+ (report key test-name location))
((quit)
- (report 'unresolved test-name)
+ (report 'unresolved test-name location)
(quit))
(else
- (report 'error test-name (cons key args))))))
+ (report 'error test-name location (cons key args))))))
(set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
@@ -353,9 +354,9 @@
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
- (run-test 'name #t (lambda () name)))
+ (run-test 'name (current-source-location) #t (lambda () name)))
((_ name rest ...)
- (run-test name #t (lambda () rest ...)))))
+ (run-test name (current-source-location) #t (lambda () rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
@@ -363,7 +364,7 @@
((_ expected body)
(pass-if-equal 'body expected body))
((_ name expected body ...)
- (run-test name #t
+ (run-test name (current-source-location) #t
(lambda ()
(let ((result (begin body ...)))
(or (equal? expected result)
@@ -377,12 +378,12 @@
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
- (run-test 'name #f (lambda () name)))
+ (run-test 'name (current-source-location) #f (lambda () name)))
((_ name rest ...)
- (run-test name #f (lambda () rest ...)))))
+ (run-test name (current-source-location) #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
-(define (run-test-exception name exception expect-pass thunk)
+(define (run-test-exception name location exception expect-pass thunk)
(match exception
((expected-key . expected-pattern)
(run-test
@@ -408,13 +409,13 @@
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #t (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #f (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #f (lambda () body rest ...)))))
\f
;;;; TEST NAMES
@@ -620,11 +621,13 @@
'(fail upass unresolved error))
;;; Display a single test result in formatted form to the given port
-(define (print-result port result name . args)
+(define (print-result port result name location . args)
(let* ((tag (assq result result-tags))
(label (if tag (cadr tag) #f)))
(if label
(begin
+ (if (not (eq? result 'pass))
+ (format port "~a:~a:" (assoc-ref location 'filename) (1+ (assoc-ref location 'line))))
(display label port)
(display ": " port)
(display (format-test-name name) port)
diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test
index 190d6b2..e1250bf 100644
--- a/test-suite/tests/srfi-64.test
+++ b/test-suite/tests/srfi-64.test
@@ -26,13 +26,17 @@
(lambda (runner)
(let* ((result-alist (test-result-alist runner))
(result-kind (assq-ref result-alist 'result-kind))
- (test-name (list (assq-ref result-alist 'test-name))))
+ (test-name (list (assq-ref result-alist 'test-name)))
+ (file-name (assq-ref result-alist 'source-file))
+ (line (assq-ref result-alist 'source-line))
+ (location (list (cons 'filename file-name)
+ (cons 'line line))))
(case result-kind
- ((pass) (report 'pass test-name))
- ((xpass) (report 'upass test-name))
- ((skip) (report 'untested test-name))
+ ((pass) (report 'pass test-name location))
+ ((xpass) (report 'upass test-name location))
+ ((skip) (report 'untested test-name location))
((fail xfail)
- (apply report result-kind test-name result-alist))
+ (apply report result-kind test-name location result-alist))
(else #t)))))
runner))
--
/home/janneke/.signature
[-- Attachment #3: Type: text/plain, Size: 154 bytes --]
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v3
2014-10-05 9:33 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v2 Jan Nieuwenhuizen
@ 2014-10-05 21:40 ` Jan Nieuwenhuizen
2014-10-29 21:40 ` Mark H Weaver
0 siblings, 1 reply; 5+ messages in thread
From: Jan Nieuwenhuizen @ 2014-10-05 21:40 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 139 bytes --]
Jan Nieuwenhuizen writes:
Changes in v3:
* fix source-line/user-source-line confusion in srfi-64
* better conforming commit message
[-- Attachment #2: 0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch --]
[-- Type: text/x-diff, Size: 8860 bytes --]
From 2776b305b1b81ccebbb94ae4ef83ae83996a5253 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Tue, 23 Sep 2014 18:37:44 +0200
Subject: [PATCH] Add GNU-style error location for failing tests in test-suite.
* test-suite/test-suite/lib.scm (run-test): Add location parameter;
display GNU style error location for failing test.
* test-suite/test-suite/lib.scm (pass-if, pass-if-equal)
(run-test-exception, pass-if-exception, expect-fail-exception): Update
callers.
* test-suite/tests/srfi-64.test (guile-test-runner): Update callers.
---
test-suite/test-suite/lib.scm | 45 +++++++++++++++++++++++--------------------
test-suite/tests/srfi-64.test | 14 +++++++++-----
2 files changed, 33 insertions(+), 26 deletions(-)
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 9ecaf89..7bd3260 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -77,16 +77,16 @@
\f
;;;; CORE FUNCTIONS
;;;;
-;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; The function (run-test name location expected-result thunk) is the heart of the
;;;; testing environment. The first parameter NAME is a unique name for the
;;;; test to be executed (for an explanation of this parameter see below under
-;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
+;;;; TEST NAMES). The third parameter EXPECTED-RESULT is a boolean value
;;;; that indicates whether the corresponding test is expected to pass. If
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
;;;; #f the test is expected to fail. Finally, THUNK is the function that
;;;; actually performs the test. For example:
;;;;
-;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;; (run-test "integer addition" (current-source-location) #t (lambda () (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass. To
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
@@ -104,9 +104,9 @@
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
-;;;; (run-test name #t (lambda () body))
+;;;; (run-test name (current-source-location) #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
-;;;; (run-test name #f (lambda () body))
+;;;; (run-test name (current-source-location) #f (lambda () body))
;;;;
;;;; For example:
;;;;
@@ -159,9 +159,9 @@
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
-;;;; (run-test 'expression #t (lambda () expression))
+;;;; (run-test 'expression location #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
-;;;; (run-test 'expression #f (lambda () expression))
+;;;; (run-test 'expression location #f (lambda () expression))
;;;;
;;;; For example:
;;;;
@@ -317,7 +317,7 @@
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test
(let ((test-running #f))
- (lambda (name expect-pass thunk)
+ (lambda (name location expect-pass thunk)
(if test-running
(error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name)))
@@ -331,20 +331,21 @@
(lambda (key . args)
(case key
((pass)
- (report (if expect-pass 'pass 'upass) test-name))
+ (report (if expect-pass 'pass 'upass) test-name location))
((fail)
;; ARGS may contain extra info about the failure,
;; such as the expected and actual value.
(apply report (if expect-pass 'fail 'xfail)
test-name
+ location
args))
((unresolved untested unsupported)
- (report key test-name))
+ (report key test-name location))
((quit)
- (report 'unresolved test-name)
+ (report 'unresolved test-name location)
(quit))
(else
- (report 'error test-name (cons key args))))))
+ (report 'error test-name location (cons key args))))))
(set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
@@ -353,9 +354,9 @@
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
- (run-test 'name #t (lambda () name)))
+ (run-test 'name (current-source-location) #t (lambda () name)))
((_ name rest ...)
- (run-test name #t (lambda () rest ...)))))
+ (run-test name (current-source-location) #t (lambda () rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
@@ -363,7 +364,7 @@
((_ expected body)
(pass-if-equal 'body expected body))
((_ name expected body ...)
- (run-test name #t
+ (run-test name (current-source-location) #t
(lambda ()
(let ((result (begin body ...)))
(or (equal? expected result)
@@ -377,12 +378,12 @@
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
- (run-test 'name #f (lambda () name)))
+ (run-test 'name (current-source-location) #f (lambda () name)))
((_ name rest ...)
- (run-test name #f (lambda () rest ...)))))
+ (run-test name (current-source-location) #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
-(define (run-test-exception name exception expect-pass thunk)
+(define (run-test-exception name location exception expect-pass thunk)
(match exception
((expected-key . expected-pattern)
(run-test
@@ -408,13 +409,13 @@
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #t (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #f (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #f (lambda () body rest ...)))))
\f
;;;; TEST NAMES
@@ -620,11 +621,13 @@
'(fail upass unresolved error))
;;; Display a single test result in formatted form to the given port
-(define (print-result port result name . args)
+(define (print-result port result name location . args)
(let* ((tag (assq result result-tags))
(label (if tag (cadr tag) #f)))
(if label
(begin
+ (if (not (eq? result 'pass))
+ (format port "~a:~a:" (assoc-ref location 'filename) (1+ (assoc-ref location 'line))))
(display label port)
(display ": " port)
(display (format-test-name name) port)
diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test
index 190d6b2..a374443 100644
--- a/test-suite/tests/srfi-64.test
+++ b/test-suite/tests/srfi-64.test
@@ -26,13 +26,17 @@
(lambda (runner)
(let* ((result-alist (test-result-alist runner))
(result-kind (assq-ref result-alist 'result-kind))
- (test-name (list (assq-ref result-alist 'test-name))))
+ (test-name (list (assq-ref result-alist 'test-name)))
+ (file-name (assq-ref result-alist 'source-file))
+ (line (1- (assq-ref result-alist 'source-line)))
+ (location (list (cons 'filename file-name)
+ (cons 'line line))))
(case result-kind
- ((pass) (report 'pass test-name))
- ((xpass) (report 'upass test-name))
- ((skip) (report 'untested test-name))
+ ((pass) (report 'pass test-name location))
+ ((xpass) (report 'upass test-name location))
+ ((skip) (report 'untested test-name location))
((fail xfail)
- (apply report result-kind test-name result-alist))
+ (apply report result-kind test-name location result-alist))
(else #t)))))
runner))
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
[-- Attachment #3: Type: text/plain, Size: 154 bytes --]
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v3
2014-10-05 21:40 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v3 Jan Nieuwenhuizen
@ 2014-10-29 21:40 ` Mark H Weaver
2014-12-07 8:41 ` Jan Nieuwenhuizen
0 siblings, 1 reply; 5+ messages in thread
From: Mark H Weaver @ 2014-10-29 21:40 UTC (permalink / raw)
To: Jan Nieuwenhuizen; +Cc: guile-devel
Hi Jan,
Jan Nieuwenhuizen <janneke@gnu.org> writes:
>
> Changes in v3:
>
> * fix source-line/user-source-line confusion in srfi-64
> * better conforming commit message
Did you try running "make check" with this patch applied? I found
that there were well over a hundred other uses of 'run-test' in the
test-suite directory that you didn't update.
Also, can you try to keep lines to 80 columns max?
Thanks!
Mark
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v3
2014-10-29 21:40 ` Mark H Weaver
@ 2014-12-07 8:41 ` Jan Nieuwenhuizen
0 siblings, 0 replies; 5+ messages in thread
From: Jan Nieuwenhuizen @ 2014-12-07 8:41 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 364 bytes --]
Mark H Weaver writes:
Hi Mark,
> Did you try running "make check" with this patch applied?
> I found that there were well over a hundred other uses of 'run-test'
> in the test-suite directory that you didn't update.
Ouch.
> Also, can you try to keep lines to 80 columns max?
Are those rethorical questions?
Find updated version attached.
Greetings, Jan.
[-- Attachment #2: 0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch --]
[-- Type: text/x-diff, Size: 12780 bytes --]
From 322ebdc43806a95270fb98a1505d3fff49a3fce9 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Tue, 23 Sep 2014 18:37:44 +0200
Subject: [PATCH] Add GNU-style error location for failing tests in test-suite.
* test-suite/test-suite/lib.scm (run-test): Add location parameter;
display GNU style error location for failing test.
* test-suite/test-suite/lib.scm (pass-if, pass-if-equal)
(run-test-exception, pass-if-exception, expect-fail-exception): Update
callers.
* test-suite/tests/getopt-long.test (pass-if-fatal-exception)
test-suite/tests/goops.test (with-test-prefix)
test-suite/tests/numbers.test (run-division-tests)
test-suite/tests/r5rs_pitfall.test (should-be, should-be-but-isnt)
test-suite/tests/srfi-64.test (guile-test-runner): Update callers.
---
test-suite/test-suite/lib.scm | 65 ++++++++++++++++++++++----------------
test-suite/tests/getopt-long.test | 4 ++-
test-suite/tests/goops.test | 1 +
test-suite/tests/numbers.test | 4 +--
test-suite/tests/r5rs_pitfall.test | 14 ++++----
test-suite/tests/srfi-64.test | 14 +++++---
6 files changed, 60 insertions(+), 42 deletions(-)
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 27620a7..76a5820 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -80,16 +80,17 @@
\f
;;;; CORE FUNCTIONS
;;;;
-;;;; The function (run-test name expected-result thunk) is the heart of the
-;;;; testing environment. The first parameter NAME is a unique name for the
-;;;; test to be executed (for an explanation of this parameter see below under
-;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
-;;;; that indicates whether the corresponding test is expected to pass. If
-;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
-;;;; #f the test is expected to fail. Finally, THUNK is the function that
-;;;; actually performs the test. For example:
-;;;;
-;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;; The function (run-test name location expected-result thunk) is the heart
+;;;; of the testing environment. The first parameter NAME is a unique name
+;;;; for the test to be executed (for an explanation of this parameter see
+;;;; below under TEST NAMES). The third parameter EXPECTED-RESULT is a
+;;;; boolean value that indicates whether the corresponding test is expected
+;;;; to pass. If EXPECTED-RESULT is #t the test is expected to pass, if
+;;;; EXPECTED-RESULT is #f the test is expected to fail. Finally, THUNK is
+;;;; the function that actually performs the test. For example:
+;;;;
+;;;; (run-test "integer addition" (current-source-location) #t (lambda ()
+;;;; (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass. To
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
@@ -107,9 +108,9 @@
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
-;;;; (run-test name #t (lambda () body))
+;;;; (run-test name (current-source-location) #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
-;;;; (run-test name #f (lambda () body))
+;;;; (run-test name (current-source-location) #f (lambda () body))
;;;;
;;;; For example:
;;;;
@@ -162,9 +163,9 @@
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
-;;;; (run-test 'expression #t (lambda () expression))
+;;;; (run-test 'expression location #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
-;;;; (run-test 'expression #f (lambda () expression))
+;;;; (run-test 'expression location #f (lambda () expression))
;;;;
;;;; For example:
;;;;
@@ -320,7 +321,7 @@
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test
(let ((test-running #f))
- (lambda (name expect-pass thunk)
+ (lambda (name location expect-pass thunk)
(if test-running
(error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name)))
@@ -334,20 +335,21 @@
(lambda (key . args)
(case key
((pass)
- (report (if expect-pass 'pass 'upass) test-name))
+ (report (if expect-pass 'pass 'upass) test-name location))
((fail)
;; ARGS may contain extra info about the failure,
;; such as the expected and actual value.
(apply report (if expect-pass 'fail 'xfail)
test-name
+ location
args))
((unresolved untested unsupported)
- (report key test-name))
+ (report key test-name location))
((quit)
- (report 'unresolved test-name)
+ (report 'unresolved test-name location)
(quit))
(else
- (report 'error test-name (cons key args))))))
+ (report 'error test-name location (cons key args))))))
(set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
@@ -356,9 +358,9 @@
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
- (run-test 'name #t (lambda () name)))
+ (run-test 'name (current-source-location) #t (lambda () name)))
((_ name rest ...)
- (run-test name #t (lambda () rest ...)))))
+ (run-test name (current-source-location) #t (lambda () rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
@@ -366,7 +368,7 @@
((_ expected body)
(pass-if-equal 'body expected body))
((_ name expected body ...)
- (run-test name #t
+ (run-test name (current-source-location) #t
(lambda ()
(let ((result (begin body ...)))
(or (equal? expected result)
@@ -380,16 +382,17 @@
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
- (run-test 'name #f (lambda () name)))
+ (run-test 'name (current-source-location) #f (lambda () name)))
((_ name rest ...)
- (run-test name #f (lambda () rest ...)))))
+ (run-test name (current-source-location) #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
-(define (run-test-exception name exception expect-pass thunk)
+(define (run-test-exception name location exception expect-pass thunk)
(match exception
((expected-key . expected-pattern)
(run-test
name
+ location
expect-pass
(lambda ()
(catch expected-key
@@ -411,13 +414,15 @@
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #t (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #t
+ (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #f (lambda () body rest ...)))))
+ (run-test-exception name (current-source-location) exception #f
+ (lambda () body rest ...)))))
\f
;;;; TEST NAMES
@@ -636,11 +641,15 @@
'(fail upass unresolved error))
;;; Display a single test result in formatted form to the given port
-(define (print-result port result name . args)
+(define (print-result port result name location . args)
(let* ((tag (assq result result-tags))
(label (if tag (cadr tag) #f)))
(if label
(begin
+ (if (not (eq? result 'pass))
+ (format port "~a:~a:"
+ (assoc-ref location 'filename)
+ (1+ (assoc-ref location 'line))))
(display label port)
(display ": " port)
(display (format-test-name name) port)
diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test
index 4ae6048..a89d4a4 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -28,7 +28,9 @@
(with-error-to-port port
(lambda ()
(run-test
- name #t
+ name
+ (current-source-location)
+ #t
(lambda ()
(catch (car exn)
(lambda () exp #f)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index d8a5ecf..94823b4 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -110,6 +110,7 @@
(with-output-to-string
(lambda ()
(display class))))
+ (current-source-location)
#t
(lambda ()
(catch #t
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 847f939..adf9fc1 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -5221,7 +5221,7 @@
(define (run-division-tests quo+rem quo rem valid-answer?)
(define (test n d)
- (run-test (list n d) #t
+ (run-test (list n d) (current-source-location) #t
(lambda ()
(let-values (((q r) (quo+rem n d)))
(and (test-eqv? q (quo n d))
@@ -5240,7 +5240,7 @@
(pass-if-exception name exception (quo n d))
(pass-if-exception name exception (rem n d))))
- (run-test "documented?" #t
+ (run-test "documented?" (current-source-location) #t
(lambda ()
(and (documented? quo+rem)
(documented? quo)
diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test
index 1d9fcf7..e44d1d3 100644
--- a/test-suite/tests/r5rs_pitfall.test
+++ b/test-suite/tests/r5rs_pitfall.test
@@ -25,16 +25,18 @@
(define-syntax should-be
(syntax-rules ()
((_ test-id value expression)
- (run-test test-id #t (lambda ()
- (false-if-exception
- (equal? expression value)))))))
+ (run-test test-id (current-source-location) #t
+ (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
(define-syntax should-be-but-isnt
(syntax-rules ()
((_ test-id value expression)
- (run-test test-id #f (lambda ()
- (false-if-exception
- (equal? expression value)))))))
+ (run-test test-id (current-source-location) #f
+ (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
(define call/cc call-with-current-continuation)
diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test
index 190d6b2..a374443 100644
--- a/test-suite/tests/srfi-64.test
+++ b/test-suite/tests/srfi-64.test
@@ -26,13 +26,17 @@
(lambda (runner)
(let* ((result-alist (test-result-alist runner))
(result-kind (assq-ref result-alist 'result-kind))
- (test-name (list (assq-ref result-alist 'test-name))))
+ (test-name (list (assq-ref result-alist 'test-name)))
+ (file-name (assq-ref result-alist 'source-file))
+ (line (1- (assq-ref result-alist 'source-line)))
+ (location (list (cons 'filename file-name)
+ (cons 'line line))))
(case result-kind
- ((pass) (report 'pass test-name))
- ((xpass) (report 'upass test-name))
- ((skip) (report 'untested test-name))
+ ((pass) (report 'pass test-name location))
+ ((xpass) (report 'upass test-name location))
+ ((skip) (report 'untested test-name location))
((fail xfail)
- (apply report result-kind test-name result-alist))
+ (apply report result-kind test-name location result-alist))
(else #t)))))
runner))
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
[-- Attachment #3: Type: text/plain, Size: 154 bytes --]
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
^ permalink raw reply related [flat|nested] 5+ messages in thread
end of thread, other threads:[~2014-12-07 8:41 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2014-09-23 16:41 [PATCH] Add GNU-style error location for failing tests in test-suite Jan Nieuwenhuizen
2014-10-05 9:33 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v2 Jan Nieuwenhuizen
2014-10-05 21:40 ` [PATCH] Add GNU-style error location for failing tests in test-suite. v3 Jan Nieuwenhuizen
2014-10-29 21:40 ` Mark H Weaver
2014-12-07 8:41 ` Jan Nieuwenhuizen
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).