| 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"))))))) |
|---|
