source: project/release/4/test/trunk/test-support.scm @ 30595

Last change on this file since 30595 was 30595, checked in by Alex Shinn, 6 years ago

Patch from David Krentzlin - fixing indentation of values and source
info. Exporting current-test-group and other procedures.

File size: 19.8 KB
Line 
1;;;; test-support.scm -- runtime for test extension
2;;
3;; Copyright (c) 2007-2014 Alex Shinn. All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7
8(require-library regex data-structures extras ports)
9(import scheme chicken regex data-structures extras ports)
10
11;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12;; test-group representation
13
14(define (make-test-group name)
15  (list name
16        (cons 'start-time (current-seconds))
17        (cons 'start-milliseconds (current-milliseconds))))
18
19(define test-group-name car)
20
21(define (test-group-ref group field . o)
22  (apply assq-ref (cdr group) field o))
23
24(define (test-group-set! group field value)
25  (cond ((assq field (cdr group))
26         => (lambda (x) (set-cdr! x value)))
27        (else (set-cdr! group (cons (cons field value) (cdr group))))))
28
29(define (test-group-inc! group field)
30  (cond ((assq field (cdr group))
31         => (lambda (x) (set-cdr! x (+ 1 (cdr x)))))
32        (else (set-cdr! group (cons (cons field 1) (cdr group))))))
33
34(define (test-group-push! group field value)
35  (cond ((assq field (cdr group))
36         => (lambda (x) (set-cdr! x (cons value (cdr x)))))
37        (else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
38
39;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40;; utilities
41
42(define (every pred ls)
43  (let lp ((ls ls))
44    (or (null? ls) (and (pred (car ls)) (lp (cdr ls))))))
45
46(define (assq-ref ls key . o)
47  (cond ((assq key ls) => cdr)
48        ((pair? o) (car o))
49        (else #f)))
50
51(define (approx-equal? a b epsilon)
52  (cond
53   ((> (abs a) (abs b))
54    (approx-equal? b a epsilon))
55   ((zero? b)
56    (< (abs a) epsilon))
57   (else
58    (< (abs (/ (- a b) b)) epsilon))))
59
60;; partial pretty printing to abbreviate `quote' forms and the like
61(define (write-to-string x)
62  (with-output-to-string
63    (lambda ()
64      (let wr ((x x))
65        (if (pair? x)
66            (cond
67              ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
68                    (assq (car x)
69                          '((quote . "'") (quasiquote . "`")
70                            (unquote . ",") (unquote-splicing . ",@"))))
71               => (lambda (s) (display (cdr s)) (wr (cadr x))))
72              (else
73               (display "(")
74               (wr (car x))
75               (let lp ((ls (cdr x)))
76                 (cond ((pair? ls)
77                        (display " ")
78                        (wr (car ls))
79                        (lp (cdr ls)))
80                       ((not (null? ls))
81                        (display " . ")
82                        (write ls))))
83               (display ")")))
84            (write x))))))
85
86(define (truncate-source x width . o)
87  (let* ((str (write-to-string x))
88         (len (string-length str)))
89    (cond
90      ((<= len width)
91       str)
92      ((and (pair? x) (eq? 'let (car x)))
93       (if (and (pair? o) (car o))
94           (truncate-source (car (reverse x)) width #t)
95           (string-append "..."
96                          (truncate-source (car (reverse x)) (- width 3) #t))))
97      ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
98       (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
99      (else
100       (string-append
101        (substring str 0 (min (max 0 (- width 3)) (string-length str)))
102        "...")))))
103
104(define (test-get-name! info)
105  (or
106   (assq-ref info 'name)
107   (assq-ref info 'gen-name)
108   (let ((name
109          (cond
110            ((assq-ref info 'source)
111             => (lambda (src)
112                  (truncate-source src (- (current-column-width) 12))))
113            ((current-test-group)
114             => (lambda (g)
115                  (string-append
116                   "test-"
117                   (number->string (test-group-ref g 'count 0)))))
118            (else ""))))
119     (if (pair? info)
120         (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
121     name)))
122
123(define (test-print-name info . indent)
124  (let ((width (- (current-column-width)
125                  (or (and (pair? indent) (car indent)) 0)))
126        (name (test-get-name! info)))
127    (display name)
128    (display " ")
129    (let ((diff (- width 9 (string-length name))))
130      (cond
131       ((positive? diff)
132        (display (make-string diff #\.)))))
133    (display " ")
134    (flush-output)))
135
136(define (test-group-indent-width group)
137  (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
138                              (test-first-indentation))))))
139    (* 4 (min level (test-max-indentation)))))
140
141;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142;; ansi tools
143
144(define (red x) (string-append "\x1B[31m" (->string x) "\x1B[0m"))
145(define (green x) (string-append "\x1B[32m" (->string x) "\x1B[0m"))
146(define (yellow x) (string-append "\x1B[33m" (->string x) "\x1B[0m"))
147;; (define (blue x) (string-append "\x1B[34m" (->string x) "\x1B[0m"))
148;; (define (magenta x) (string-append "\x1B[35m" (->string x) "\x1B[0m"))
149;; (define (cyan x) (string-append "\x1B[36m" (->string x) "\x1B[0m"))
150(define (bold x) (string-append "\x1B[1m" (->string x) "\x1B[0m"))
151(define (underline x) (string-append "\x1B[4m" (->string x) "\x1B[0m"))
152
153;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154
155(define (test-run expect expr info)
156  (if (and (cond ((current-test-group)
157                  => (lambda (g) (not (test-group-ref g 'skip-group?))))
158                 (else #t))
159           (every (lambda (f) (f info)) (current-test-filters)))
160    ((current-test-applier) expect expr info)
161    ((current-test-skipper) expect expr info)))
162
163(define (test-default-applier expect expr info)
164  (let* ((group (current-test-group))
165         (verbose? (or (not group) (test-group-ref group 'verbosity)))
166         (indent (and group (test-group-indent-width group))))
167    (cond
168     (verbose?
169      (cond
170       ((and group
171             (equal? 0 (test-group-ref group 'count 0))
172             (zero? (test-group-ref group 'subgroups-count 0))
173             (test-group-ref group 'verbosity))
174        (newline)
175        (print-header-line
176         (string-append "testing " (or (test-group-name group) ""))
177         (or indent 0))))
178      (if (and indent (positive? indent))
179          (display (make-string indent #\space)))
180      (test-print-name info indent)))
181    (let ((expect-val
182           (condition-case
183               (expect)
184             (e ()
185                (warning "bad expect value")
186                (print-error-message e)
187                #f))))
188      (condition-case
189          (let ((res (expr)))
190            (let ((status
191                   (if (and (not (assq-ref info 'expect-error))
192                            (if (assq-ref info 'assertion)
193                                res
194                                ((current-test-comparator) expect-val res)))
195                       'PASS
196                       'FAIL))
197                  (info `((result . ,res) (expected . ,expect-val) ,@info)))
198              ((current-test-handler) status expect expr info)))
199        (e ()
200           ((current-test-handler)
201            (if (assq-ref info 'expect-error) 'PASS 'ERROR)
202            expect
203            expr
204            (append `((exception . ,e) (trace . ,get-call-chain)) info)))))))
205
206(define (test-default-skipper expect expr info)
207  ((current-test-handler) 'SKIP expect expr info))
208
209(define (test-default-handler status expect expr info)
210  ;; update group info
211  (let* ((group (current-test-group))
212         (verbose? (or (not group) (test-group-ref group 'verbosity)))
213         (indent
214          (cond (group
215                 => (lambda (group)
216                      (make-string (+ 4 (or (test-group-indent-width group) 0))
217                                   #\space)))
218                (else (make-string 4 #\space)))))
219    (cond ((current-test-group)
220           => (lambda (group)
221                (if (not (eq? 'SKIP status))
222                    (test-group-inc! group 'count))
223                (test-group-inc! group status))))
224    (cond
225     ((or (eq? status 'FAIL) (eq? status 'ERROR))
226      (test-failure-count (+ 1 (test-failure-count)))))
227    (cond
228     ((not verbose?)
229      (write-char (case status
230                    ((PASS) #\.) ((FAIL) #\x) ((ERROR) #\!) (else #\space)))
231      (if (zero? (modulo (test-group-ref group 'count)
232                         (current-column-width)))
233          (newline)))
234     ((not (eq? status 'SKIP))
235      ;; display status
236      (display "[")
237      (if (not (eq? status 'ERROR)) (display " ")) ; pad
238      (display ((if (test-ansi?)
239                    (case status
240                      ((ERROR) (compose underline red))
241                      ((FAIL) red)
242                      ((SKIP) yellow)
243                      (else green))
244                    identity)
245                status))
246      (display "]")
247      (newline)
248      ;; display status explanation
249      (cond ((not (eq? status 'PASS))
250             (display indent)))
251      (cond
252       ((eq? status 'ERROR)
253        (cond ((assq 'exception info)
254               => (lambda (e)
255                    (print-error-message (cdr e) (current-output-port)))))
256        ;;(print-call-chain (current-output-port) 10)
257        )
258       ((and (eq? status 'FAIL) (assq-ref info 'assertion))
259        (display "assertion failed\n"))
260       ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
261        (display "expected an error but got ")
262        (write (assq-ref info 'result)) (newline))
263       ((eq? status 'FAIL)
264        (display "expected ") (write (assq-ref info 'expected))
265        (display " but got ") (write (assq-ref info 'result)) (newline)))
266      ;; display line, source and values info
267      (cond
268       ((or (not (current-test-group))
269            (test-group-ref (current-test-group) 'verbosity))
270        (case status
271          ((FAIL ERROR)
272           (cond
273            ((assq-ref info 'line-number)
274             => (lambda (line)
275                  (display indent)
276                  (display "in line ")
277                  (write line)
278                  (cond ((assq-ref info 'file-name)
279                         => (lambda (file) (display " of file ") (write file))))
280                  (newline))))
281           (cond
282            ((assq-ref info 'source)
283             => (lambda (s)
284                  (if (or (assq-ref info 'name)
285                          (> (string-length (write-to-string s))
286                             (current-column-width)))
287                      (for-each
288                       (lambda (line) (display indent) (display line) (newline))
289                       (string-split
290                        (with-output-to-string (lambda () (pp s)))
291                        "\n"))))))
292           (cond
293            ((assq-ref info 'values)
294             => (lambda (v)
295                  (for-each
296                   (lambda (v)
297                     (display indent) (display (car v))
298                     (display ": ") (write (cdr v)) (newline))
299                   v)))))
300          ))))))
301  status)
302
303(define (test-default-group-reporter group)
304  (define (plural word n)
305    (if (= n 1) word (string-append word "s")))
306  (define (percent n d)
307    (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)"))
308  (let* ((end-time (current-seconds))
309         (end-milliseconds (current-milliseconds))
310         (start-time (test-group-ref group 'start-time))
311         (start-milliseconds
312          (or (test-group-ref group 'start-milliseconds) 0))
313         (duration
314          (if (and start-time (> (- end-time start-time) 60))
315              (/ (- (+ (* end-time 1000) end-milliseconds)
316                    (+ (* start-time 1000) start-milliseconds))
317                 1000)
318              (/ (- end-milliseconds start-milliseconds) 1000)))
319         (count (or (test-group-ref group 'count) 0))
320         (pass (or (test-group-ref group 'PASS) 0))
321         (fail (or (test-group-ref group 'FAIL) 0))
322         (err (or (test-group-ref group 'ERROR) 0))
323         (skip (or (test-group-ref group 'SKIP) 0))
324         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
325         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
326         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
327    (if (not (test-group-ref group 'verbosity))
328        (newline))
329    (cond
330     ((or (positive? count) (positive? subgroups-count))
331      (if (not (= count (+ pass fail err)))
332          (warning "inconsistent count:" count pass fail err))
333      (display indent)
334      (cond
335       ((positive? count)
336        (write count) (display (plural " test" count))))
337      (if (and (positive? count) (positive? subgroups-count))
338          (display " and "))
339      (cond
340       ((positive? subgroups-count)
341        (write subgroups-count)
342        (display (plural " subgroup" subgroups-count))))
343      (display " completed in ") (write duration) (display " seconds")
344      (cond
345       ((not (zero? skip))
346        (display " (") (write skip) (display (plural " test" skip))
347        (display " skipped)")))
348      (display ".") (newline)
349      (cond ((positive? fail)
350             (display indent)
351             (display
352              ((if (test-ansi?) red identity)
353               (string-append
354                (number->string fail) (plural " failure" fail)
355                (percent fail count) ".")))
356             (newline)))
357      (cond ((positive? err)
358             (display indent)
359             (display
360              ((if (test-ansi?) (compose underline red) identity)
361               (string-append
362                (number->string err) (plural " error" err)
363                (percent err count) ".")))
364             (newline)))
365      (cond
366       ((positive? count)
367        (display indent)
368        (display
369         ((if (and (test-ansi?) (= pass count)) green identity)
370          (string-append
371           (number->string pass) " out of " (number->string count)
372           (percent pass count) (plural " test" pass) " passed.")))
373        (newline)))
374      (cond
375       ((positive? subgroups-count)
376        (display indent)
377        (display
378         ((if (and (test-ansi?) (= subgroups-pass subgroups-count))
379              green identity)
380          (string-append
381           (number->string subgroups-pass) " out of "
382           (number->string subgroups-count)
383           (percent subgroups-pass subgroups-count)
384           (plural " subgroup" subgroups-pass) " passed.")))
385        (newline)))
386      ))
387    (print-header-line
388     (string-append "done testing " (or (test-group-name group) ""))
389     (or (test-group-indent-width group) 0))
390    (newline)
391    ))
392
393;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394
395(define (test-equal? expect res)
396  (or (equal? expect res)
397      (and (number? expect)
398           (inexact? expect)
399           (inexact? res)
400           (approx-equal? expect res (current-test-epsilon)))))
401
402(define (print-header-line str . indent)
403  (let* ((header (string-append
404                  (make-string (if (pair? indent) (car indent) 0) #\space)
405                  "-- " str " "))
406         (len (string-length header)))
407      (display (if (test-ansi?) (bold header) header))
408      (display (make-string (max 0 (- (current-column-width) len)) #\-))
409      (newline)))
410
411(define (test-begin . o)
412  (let* ((name (if (pair? o) (car o) ""))
413         (group (make-test-group name))
414         (parent (current-test-group)))
415    (cond
416     ((and parent
417           (equal? 0 (test-group-ref parent 'count 0))
418           (zero? (test-group-ref parent 'subgroups-count 0))
419           (test-group-ref parent 'verbosity))
420      (newline)
421      (print-header-line
422       (string-append "testing " (test-group-name parent))
423       (or (test-group-indent-width parent) 0))))
424    (test-group-set! group 'parent parent)
425    (test-group-set! group 'verbosity
426                     (if parent
427                         (test-group-ref parent 'verbosity)
428                         (current-test-verbosity)))
429    (test-group-set! group 'level
430                     (if parent
431                         (+ 1 (test-group-ref parent 'level 0))
432                         0))
433    (test-group-set!
434     group
435     'skip-group?
436     (or (and parent (test-group-ref parent 'skip-group?))
437         (not (every (lambda (f) (f group)) (current-test-group-filters)))))
438    (current-test-group group)))
439
440(define (test-end . o)
441  (cond
442    ((current-test-group)
443     => (lambda (group)
444          (if (and (pair? o) (not (equal? (car o) (test-group-name group))))
445            (warning "mismatched test-end:" (car o) (test-group-name group)))
446          (let ((parent (test-group-ref group 'parent)))
447            (cond
448             ((not (test-group-ref group 'skip-group?))
449              ;; only report if there's something to say
450              ((current-test-group-reporter) group)
451              (cond
452               (parent
453                (test-group-inc! parent 'subgroups-count)
454                (cond
455                 ((and (zero? (test-group-ref group 'FAIL 0))
456                       (zero? (test-group-ref group 'ERROR 0))
457                       (= (test-group-ref group 'subgroups-pass 0)
458                          (test-group-ref group 'subgroups-count 0)))
459                  (test-group-inc! parent 'subgroups-pass)))))))
460            (current-test-group parent)
461            group)))))
462
463(define (test-exit . o)
464  (exit (if (positive? (test-failure-count)) (if (pair? o) (car o) 1) 0)))
465
466;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
467;; parameters
468
469(define current-test-group (make-parameter #f))
470(define current-test-verbosity
471  (make-parameter
472   (cond ((get-environment-variable "TEST_QUIET") => (lambda (s) (equal? s "0"))) (else #t))))
473(define current-test-epsilon (make-parameter 1e-5))
474(define current-test-comparator (make-parameter test-equal?))
475(define current-test-applier (make-parameter test-default-applier))
476(define current-test-handler (make-parameter test-default-handler))
477(define current-test-skipper (make-parameter test-default-skipper))
478(define current-test-group-reporter
479  (make-parameter test-default-group-reporter))
480(define test-failure-count (make-parameter 0))
481
482(define test-first-indentation
483  (make-parameter
484   (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") => string->number) (else #f))
485       1)))
486
487(define test-max-indentation
488  (make-parameter
489   (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") => string->number) (else #f))
490       5)))
491
492(define (string->info-matcher str)
493  (let ((rx (regexp str)))
494    (lambda (info)
495      (cond ((test-get-name! info)
496             => (lambda (n) (string-search rx n)))
497            (else #f)))))
498
499(define (string->group-matcher str)
500  (let ((rx (regexp str)))
501    (lambda (group)
502      (string-search rx (car group)))))
503
504(define (getenv-filter-list proc name . o)
505  (cond
506    ((get-environment-variable name)
507     => (lambda (s)
508          (condition-case
509           (let ((f (proc s)))
510             (list (if (and (pair? o) (car o)) (complement f) f)))
511           (e ()
512             (warning
513              (string-append "invalid filter regexp '" s
514                             "' from environment variable: " name))
515             (print-error-message e)
516             '()))))
517    (else '())))
518
519(define current-test-filters
520  (make-parameter
521   (append (getenv-filter-list string->info-matcher "TEST_FILTER")
522           (getenv-filter-list string->info-matcher "TEST_REMOVE" #t))))
523
524(define current-test-group-filters
525  (make-parameter
526   (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")
527           (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t))))
528
529(define current-column-width
530  (make-parameter
531   (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") => string->number) (else #f))
532       78)))
533
534(define test-ansi?
535  (make-parameter
536   (cond
537    ((get-environment-variable "TEST_USE_ANSI")
538     => (lambda (s) (not (equal? s "0"))))
539    (else
540     (and (##sys#tty-port? (current-output-port))
541          (member (get-environment-variable "TERM")
542                  '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
543                    "linux" "screen" "screen-256color" "vt100")))))))
Note: See TracBrowser for help on using the repository browser.