ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build: 'test-driver.scm' prints Scheme values with 'write'.

Browse source 
Previously it would print them with 'display', which was inconvenient.

* build-aux/test-driver.scm (test-display): Use ~S for VALUE.
(test-runner-gnu): Use 'format' instead of 'test-display' for the test
name, location, and result kind.
This commit is contained in:
Ludovic Courtès 2017-03-22 14:59:24 +01:00
parent 50b4d3ac26
commit 73a46451af
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 23 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
build-aux/test-driver.scm
View file

@ -1,6 +1,6 @@
;;;; test-driver.scm - Guile test driver for Automake testsuite harness ;;;; test-driver.scm - Guile test driver for Automake testsuite harness
(define script-version "2016-04-03.12") ;UTC (define script-version "2017-03-22.13") ;UTC
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; ;;;
@ -59,7 +59,7 @@ (define* (test-display field value #:optional (port (current-output-port))
(begin (begin
(format port "~A:~%" field) (format port "~A:~%" field)
(pretty-print value port #:per-line-prefix "+ ")) (pretty-print value port #:per-line-prefix "+ "))
(format port "~A: ~A~%" field value))) (format port "~A: ~S~%" field value)))
(define* (result->string symbol #:key colorize?) (define* (result->string symbol #:key colorize?)
"Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
@ -85,10 +85,10 @@ (define (test-on-test-begin-gnu runner)
;; Procedure called at the start of an individual test case, before the ;; Procedure called at the start of an individual test case, before the
;; test expression (and expected value) are evaluated. ;; test expression (and expected value) are evaluated.
(let ((result (cute assq-ref (test-result-alist runner) <>))) (let ((result (cute assq-ref (test-result-alist runner) <>)))
(test-display "test-name" (result 'test-name)) (format #t "test-name: ~A~%" (result 'test-name))
(test-display "location" (format #t "location: ~A~%"
(string-append (result 'source-file) ":" (string-append (result 'source-file) ":"
(number->string (result 'source-line)))) (number->string (result 'source-line))))
(test-display "source" (result 'source-form) #:pretty? #t))) (test-display "source" (result 'source-form) #:pretty? #t)))
(define (test-on-test-end-gnu runner) (define (test-on-test-end-gnu runner)
@ -99,10 +99,9 @@ (define (test-on-test-end-gnu runner)
(result (cut assq-ref results <>))) (result (cut assq-ref results <>)))
(unless brief? (unless brief?
;; Display the result of each test case on the console. ;; Display the result of each test case on the console.
(test-display (format out-port "~A: ~A - ~A~%"
(result->string (test-result-kind runner) #:colorize? color?) (result->string (test-result-kind runner) #:colorize? color?)
(string-append test-name " - " (test-runner-test-name runner)) test-name (test-runner-test-name runner)))
out-port))
(when (result? 'expected-value) (when (result? 'expected-value)
(test-display "expected-value" (result 'expected-value))) (test-display "expected-value" (result 'expected-value)))
(when (result? 'expected-error) (when (result? 'expected-error)
@ -111,12 +110,11 @@ (define (test-on-test-end-gnu runner)
(test-display "actual-value" (result 'actual-value))) (test-display "actual-value" (result 'actual-value)))
(when (result? 'actual-error) (when (result? 'actual-error)
(test-display "actual-error" (result 'actual-error) #:pretty? #t)) (test-display "actual-error" (result 'actual-error) #:pretty? #t))
(test-display "result" (result->string (result 'result-kind))) (format #t "result: ~a~%" (result->string (result 'result-kind)))
(newline) (newline)
(test-display ":test-result" (format trs-port ":test-result: ~A ~A~%"
(string-append (result->string (test-result-kind runner)) (result->string (test-result-kind runner))
" " (test-runner-test-name runner)) (test-runner-test-name runner))))
trs-port)))
(define (test-on-group-end-gnu runner) (define (test-on-group-end-gnu runner)
;; Procedure called by a 'test-end', including at the end of a test-group. ;; Procedure called by a 'test-end', including at the end of a test-group.
@ -125,21 +123,18 @@ (define (test-on-group-end-gnu runner)
(skip (or (positive? (test-runner-skip-count runner)) (skip (or (positive? (test-runner-skip-count runner))
(positive? (test-runner-xfail-count runner))))) (positive? (test-runner-xfail-count runner)))))
;; XXX: The global results need some refinements for XPASS. ;; XXX: The global results need some refinements for XPASS.
(test-display ":global-test-result" (format trs-port ":global-test-result: ~A~%"
(if fail "FAIL" (if skip "SKIP" "PASS")) (if fail "FAIL" (if skip "SKIP" "PASS")))
trs-port) (format trs-port ":recheck: ~A~%"
(test-display ":recheck" (if fail "yes" "no"))
(if fail "yes" "no") (format trs-port ":copy-in-global-log: ~A~%"
trs-port) (if (or fail skip) "yes" "no"))
(test-display ":copy-in-global-log"
(if (or fail skip) "yes" "no")
trs-port)
(when brief? (when brief?
;; Display the global test group result on the console. ;; Display the global test group result on the console.
(test-display (result->string (if fail 'fail (if skip 'skip 'pass)) (format out-port "~A: ~A~%"
#:colorize? color?) (result->string (if fail 'fail (if skip 'skip 'pass))
test-name #:colorize? color?)
out-port)) test-name))
#f)) #f))
(let ((runner (test-runner-null))) (let ((runner (test-runner-null)))