From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Jan Nieuwenhuizen Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add GNU-style error location for failing tests in test-suite. Date: Tue, 23 Sep 2014 18:41:42 +0200 Organization: AvatarAcademy.nl Message-ID: <87wq8uffw9.fsf@drakenvlieg.flower> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1411490537 3410 80.91.229.3 (23 Sep 2014 16:42:17 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 23 Sep 2014 16:42:17 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Sep 23 18:42:11 2014 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1XWTAG-0002os-2Q for guile-devel@m.gmane.org; Tue, 23 Sep 2014 18:42:08 +0200 Original-Received: from localhost ([::1]:54444 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XWTAF-0006r6-JL for guile-devel@m.gmane.org; Tue, 23 Sep 2014 12:42:07 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:48567) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XWTA6-0006qr-RG for guile-devel@gnu.org; Tue, 23 Sep 2014 12:42:03 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XWTA0-00080R-Sx for guile-devel@gnu.org; Tue, 23 Sep 2014 12:41:57 -0400 Original-Received: from smtp-vbr1.xs4all.nl ([194.109.24.21]:2605) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XWTA0-0007ze-Gu for guile-devel@gnu.org; Tue, 23 Sep 2014 12:41:52 -0400 Original-Received: from drakenvlieg.flower.peder.onsbrabantnet.nl (static.kpn.net [92.70.116.82] (may be forged)) (authenticated bits=0) by smtp-vbr1.xs4all.nl (8.13.8/8.13.8) with ESMTP id s8NGfhAK066748 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES128-SHA bits=128 verify=NO); Tue, 23 Sep 2014 18:41:44 +0200 (CEST) (envelope-from janneke@gnu.org) X-Url: http://AvatarAcademy.nl User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-Virus-Scanned: by XS4ALL Virus Scanner X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 194.109.24.21 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17519 Archived-At: --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch >From efce4fa4be1c9bc6e368193b82b7eaa9b9957fee Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen 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 * 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 @@ ;;;; 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 ...))))) ;;;; 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 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable -- Jan Nieuwenhuizen | GNU LilyPond http://lilypond.org Freelance IT http://JoyofSource.com | Avatar=C2=AE http://AvatarAcademy.nl --=-=-=--