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: Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v2 Date: Sun, 05 Oct 2014 11:33:59 +0200 Organization: AvatarAcademy.nl Message-ID: <87sij2j1x4.fsf@drakenvlieg.flower> References: <87wq8uffw9.fsf@drakenvlieg.flower> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1412501682 17151 80.91.229.3 (5 Oct 2014 09:34:42 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 5 Oct 2014 09:34:42 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Oct 05 11:34:32 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 1XaiCt-0002dZ-FA for guile-devel@m.gmane.org; Sun, 05 Oct 2014 11:34:23 +0200 Original-Received: from localhost ([::1]:46846 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XaiCt-0007au-1H for guile-devel@m.gmane.org; Sun, 05 Oct 2014 05:34:23 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:54628) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XaiCm-0007a1-4X for guile-devel@gnu.org; Sun, 05 Oct 2014 05:34:20 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XaiCh-0008Gk-9y for guile-devel@gnu.org; Sun, 05 Oct 2014 05:34:16 -0400 Original-Received: from smtp-vbr12.xs4all.nl ([194.109.24.32]:2744) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XaiCg-0008GG-Sv for guile-devel@gnu.org; Sun, 05 Oct 2014 05:34:11 -0400 Original-Received: from drakenvlieg.flower.peder.onsbrabantnet.nl (static.kpn.net [92.70.116.82] (may be forged)) (authenticated bits=0) by smtp-vbr12.xs4all.nl (8.13.8/8.13.8) with ESMTP id s959Y0W8003701 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES128-SHA bits=128 verify=NO); Sun, 5 Oct 2014 11:34:01 +0200 (CEST) (envelope-from janneke@gnu.org) X-Url: http://AvatarAcademy.nl In-Reply-To: <87wq8uffw9.fsf@drakenvlieg.flower> (Jan Nieuwenhuizen's message of "Tue, 23 Sep 2014 18:41:42 +0200") 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.32 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:17543 Archived-At: --=-=-= Content-Type: text/plain 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? --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch >From ccf525b93d49be51611c5c9d69f0c17d77b60147 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-10-05 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/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 @@ ;;;; 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) 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 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable --=20 Jan Nieuwenhuizen | GNU LilyPond http://lilypond.org Freelance IT http://JoyofSource.com | Avatar=C2=AE http://AvatarAcademy.nl= =20=20 --=-=-=--