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

Last change on this file since 32706 was 32706, checked in by evhan, 5 years ago

test: Remove regex dependency (patch from Arthur Maciel)

File size: 19.9 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 irregex data-structures extras ports)
9(import scheme chicken irregex 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? a)
56    (< (abs b) 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 ((not (eq? 'SKIP status))
225           (test-total-count (+ 1 (test-total-count)))))
226    (cond
227     ((or (eq? status 'FAIL) (eq? status 'ERROR))
228      (test-failure-count (+ 1 (test-failure-count)))))
229    (cond
230     ((not verbose?)
231      (write-char (case status
232                    ((PASS) #\.) ((FAIL) #\x) ((ERROR) #\!) (else #\space)))
233      (if (zero? (modulo (test-group-ref group 'count)
234                         (current-column-width)))
235          (newline)))
236     ((not (eq? status 'SKIP))
237      ;; display status
238      (display "[")
239      (if (not (eq? status 'ERROR)) (display " ")) ; pad
240      (display ((if (test-ansi?)
241                    (case status
242                      ((ERROR) (compose underline red))
243                      ((FAIL) red)
244                      ((SKIP) yellow)
245                      (else green))
246                    identity)
247                status))
248      (display "]")
249      (newline)
250      ;; display status explanation
251      (cond ((not (eq? status 'PASS))
252             (display indent)))
253      (cond
254       ((eq? status 'ERROR)
255        (cond ((assq 'exception info)
256               => (lambda (e)
257                    (print-error-message (cdr e) (current-output-port)))))
258        ;;(print-call-chain (current-output-port) 10)
259        )
260       ((and (eq? status 'FAIL) (assq-ref info 'assertion))
261        (display "assertion failed\n"))
262       ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
263        (display "expected an error but got ")
264        (write (assq-ref info 'result)) (newline))
265       ((eq? status 'FAIL)
266        (display "expected ") (write (assq-ref info 'expected))
267        (display " but got ") (write (assq-ref info 'result)) (newline)))
268      ;; display line, source and values info
269      (cond
270       ((or (not (current-test-group))
271            (test-group-ref (current-test-group) 'verbosity))
272        (case status
273          ((FAIL ERROR)
274           (cond
275            ((assq-ref info 'line-number)
276             => (lambda (line)
277                  (display indent)
278                  (display "in line ")
279                  (write line)
280                  (cond ((assq-ref info 'file-name)
281                         => (lambda (file) (display " of file ") (write file))))
282                  (newline))))
283           (cond
284            ((assq-ref info 'source)
285             => (lambda (s)
286                  (if (or (assq-ref info 'name)
287                          (> (string-length (write-to-string s))
288                             (current-column-width)))
289                      (for-each
290                       (lambda (line) (display indent) (display line) (newline))
291                       (string-split
292                        (with-output-to-string (lambda () (pp s)))
293                        "\n"))))))
294           (cond
295            ((assq-ref info 'values)
296             => (lambda (v)
297                  (for-each
298                   (lambda (v)
299                     (display indent) (display (car v))
300                     (display ": ") (write (cdr v)) (newline))
301                   v)))))
302          ))))))
303  status)
304
305(define (test-default-group-reporter group)
306  (define (plural word n)
307    (if (= n 1) word (string-append word "s")))
308  (define (percent n d)
309    (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)"))
310  (let* ((end-time (current-seconds))
311         (end-milliseconds (current-milliseconds))
312         (start-time (test-group-ref group 'start-time))
313         (start-milliseconds
314          (or (test-group-ref group 'start-milliseconds) 0))
315         (duration
316          (if (and start-time (> (- end-time start-time) 60))
317              (/ (- (+ (* end-time 1000) end-milliseconds)
318                    (+ (* start-time 1000) start-milliseconds))
319                 1000)
320              (/ (- end-milliseconds start-milliseconds) 1000)))
321         (count (or (test-group-ref group 'count) 0))
322         (pass (or (test-group-ref group 'PASS) 0))
323         (fail (or (test-group-ref group 'FAIL) 0))
324         (err (or (test-group-ref group 'ERROR) 0))
325         (skip (or (test-group-ref group 'SKIP) 0))
326         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
327         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
328         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
329    (if (not (test-group-ref group 'verbosity))
330        (newline))
331    (cond
332     ((or (positive? count) (positive? subgroups-count))
333      (if (not (= count (+ pass fail err)))
334          (warning "inconsistent count:" count pass fail err))
335      (display indent)
336      (cond
337       ((positive? count)
338        (write count) (display (plural " test" count))))
339      (if (and (positive? count) (positive? subgroups-count))
340          (display " and "))
341      (cond
342       ((positive? subgroups-count)
343        (write subgroups-count)
344        (display (plural " subgroup" subgroups-count))))
345      (display " completed in ") (write duration) (display " seconds")
346      (cond
347       ((not (zero? skip))
348        (display " (") (write skip) (display (plural " test" skip))
349        (display " skipped)")))
350      (display ".") (newline)
351      (cond ((positive? fail)
352             (display indent)
353             (display
354              ((if (test-ansi?) red identity)
355               (string-append
356                (number->string fail) (plural " failure" fail)
357                (percent fail count) ".")))
358             (newline)))
359      (cond ((positive? err)
360             (display indent)
361             (display
362              ((if (test-ansi?) (compose underline red) identity)
363               (string-append
364                (number->string err) (plural " error" err)
365                (percent err count) ".")))
366             (newline)))
367      (cond
368       ((positive? count)
369        (display indent)
370        (display
371         ((if (and (test-ansi?) (= pass count)) green identity)
372          (string-append
373           (number->string pass) " out of " (number->string count)
374           (percent pass count) (plural " test" pass) " passed.")))
375        (newline)))
376      (cond
377       ((positive? subgroups-count)
378        (display indent)
379        (display
380         ((if (and (test-ansi?) (= subgroups-pass subgroups-count))
381              green identity)
382          (string-append
383           (number->string subgroups-pass) " out of "
384           (number->string subgroups-count)
385           (percent subgroups-pass subgroups-count)
386           (plural " subgroup" subgroups-pass) " passed.")))
387        (newline)))
388      ))
389    (print-header-line
390     (string-append "done testing " (or (test-group-name group) ""))
391     (or (test-group-indent-width group) 0))
392    (newline)
393    ))
394
395;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
396
397(define (test-equal? expect res)
398  (or (equal? expect res)
399      (and (number? expect)
400           (inexact? expect)
401           (inexact? res)
402           (approx-equal? expect res (current-test-epsilon)))))
403
404(define (print-header-line str . indent)
405  (let* ((header (string-append
406                  (make-string (if (pair? indent) (car indent) 0) #\space)
407                  "-- " str " "))
408         (len (string-length header)))
409      (display (if (test-ansi?) (bold header) header))
410      (display (make-string (max 0 (- (current-column-width) len)) #\-))
411      (newline)))
412
413(define (test-begin . o)
414  (let* ((name (if (pair? o) (car o) ""))
415         (group (make-test-group name))
416         (parent (current-test-group)))
417    (cond
418     ((and parent
419           (equal? 0 (test-group-ref parent 'count 0))
420           (zero? (test-group-ref parent 'subgroups-count 0))
421           (test-group-ref parent 'verbosity))
422      (newline)
423      (print-header-line
424       (string-append "testing " (test-group-name parent))
425       (or (test-group-indent-width parent) 0))))
426    (test-group-set! group 'parent parent)
427    (test-group-set! group 'verbosity
428                     (if parent
429                         (test-group-ref parent 'verbosity)
430                         (current-test-verbosity)))
431    (test-group-set! group 'level
432                     (if parent
433                         (+ 1 (test-group-ref parent 'level 0))
434                         0))
435    (test-group-set!
436     group
437     'skip-group?
438     (or (and parent (test-group-ref parent 'skip-group?))
439         (not (every (lambda (f) (f group)) (current-test-group-filters)))))
440    (current-test-group group)))
441
442(define (test-end . o)
443  (cond
444    ((current-test-group)
445     => (lambda (group)
446          (if (and (pair? o) (not (equal? (car o) (test-group-name group))))
447            (warning "mismatched test-end:" (car o) (test-group-name group)))
448          (let ((parent (test-group-ref group 'parent)))
449            (cond
450             ((not (test-group-ref group 'skip-group?))
451              ;; only report if there's something to say
452              ((current-test-group-reporter) group)
453              (cond
454               (parent
455                (test-group-inc! parent 'subgroups-count)
456                (cond
457                 ((and (zero? (test-group-ref group 'FAIL 0))
458                       (zero? (test-group-ref group 'ERROR 0))
459                       (= (test-group-ref group 'subgroups-pass 0)
460                          (test-group-ref group 'subgroups-count 0)))
461                  (test-group-inc! parent 'subgroups-pass)))))))
462            (current-test-group parent)
463            group)))))
464
465(define (test-exit . o)
466  (exit (if (positive? (test-failure-count)) (if (pair? o) (car o) 1) 0)))
467
468;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469;; parameters
470
471(define current-test-group (make-parameter #f))
472(define current-test-verbosity
473  (make-parameter
474   (cond ((get-environment-variable "TEST_QUIET") => (lambda (s) (equal? s "0"))) (else #t))))
475(define current-test-epsilon (make-parameter 1e-5))
476(define current-test-comparator (make-parameter test-equal?))
477(define current-test-applier (make-parameter test-default-applier))
478(define current-test-handler (make-parameter test-default-handler))
479(define current-test-skipper (make-parameter test-default-skipper))
480(define current-test-group-reporter
481  (make-parameter test-default-group-reporter))
482(define test-failure-count (make-parameter 0))
483(define test-total-count (make-parameter 0))
484
485(define test-first-indentation
486  (make-parameter
487   (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") => string->number) (else #f))
488       1)))
489
490(define test-max-indentation
491  (make-parameter
492   (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") => string->number) (else #f))
493       5)))
494
495(define (string->info-matcher str)
496  (let ((rx (irregex str)))
497    (lambda (info)
498      (cond ((test-get-name! info)
499             => (lambda (n) (irregex-search rx n)))
500            (else #f)))))
501
502(define (string->group-matcher str)
503  (let ((rx (irregex str)))
504    (lambda (group)
505      (irregex-search rx (car group)))))
506
507(define (getenv-filter-list proc name . o)
508  (cond
509    ((get-environment-variable name)
510     => (lambda (s)
511          (condition-case
512           (let ((f (proc s)))
513             (list (if (and (pair? o) (car o)) (complement f) f)))
514           (e ()
515             (warning
516              (string-append "invalid filter regexp '" s
517                             "' from environment variable: " name))
518             (print-error-message e)
519             '()))))
520    (else '())))
521
522(define current-test-filters
523  (make-parameter
524   (append (getenv-filter-list string->info-matcher "TEST_FILTER")
525           (getenv-filter-list string->info-matcher "TEST_REMOVE" #t))))
526
527(define current-test-group-filters
528  (make-parameter
529   (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")
530           (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t))))
531
532(define current-column-width
533  (make-parameter
534   (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") => string->number) (else #f))
535       78)))
536
537(define test-ansi?
538  (make-parameter
539   (cond
540    ((get-environment-variable "TEST_USE_ANSI")
541     => (lambda (s) (not (equal? s "0"))))
542    (else
543     (and (##sys#tty-port? (current-output-port))
544          (member (get-environment-variable "TERM")
545                  '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
546                    "linux" "screen" "screen-256color" "vt100")))))))
Note: See TracBrowser for help on using the repository browser.