Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-07 13:16:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Use (chibi term ansi) library in (chibi test) instead of inlined ansi procedures.

Browse source
This commit is contained in:
Alex Shinn 2014-07-22 23:36:43 +09:00
parent 1925b068ef
commit 76501b602f
2 changed files with 110 additions and 134 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

241
lib/chibi/test.scm
View file

@ -1,4 +1,4 @@
;; Copyright (c) 2010-2013 Alex Shinn. All rights reserved. ;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> Simple testing framework adapted from the Chicken \scheme{test} ;;> Simple testing framework adapted from the Chicken \scheme{test}
@ -86,7 +86,7 @@
(define-syntax test-assert (define-syntax test-assert
(syntax-rules () (syntax-rules ()
((_ expr) ((_ expr)
(test-assert #f expr)) (test-assert #f expr))
((_ name expr) ((_ name expr)
(test-propagate-info name #f expr ((assertion . #t)))) (test-propagate-info name #f expr ((assertion . #t))))
((test a ...) ((test a ...)
@ -110,7 +110,7 @@
(define-syntax test-values (define-syntax test-values
(syntax-rules () (syntax-rules ()
((_ expect expr) ((_ expect expr)
(test-values #f expect expr)) (test-values #f expect expr))
((_ name expect expr) ((_ name expect expr)
(test name (call-with-values (lambda () expect) (lambda results results)) (test name (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results)))))) (call-with-values (lambda () expr) (lambda results results))))))
@ -171,13 +171,13 @@
(error "a name is required, got " 'name-expr name)) (error "a name is required, got " 'name-expr name))
(test-begin name) (test-begin name)
(guard (guard
(exn (exn
(else (else
(warning "error in group outside of tests") (warning "error in group outside of tests")
(print-exception exn (current-error-port)) (print-exception exn (current-error-port))
(test-group-inc! (current-test-group) 'count) (test-group-inc! (current-test-group) 'count)
(test-group-inc! (current-test-group) 'ERROR))) (test-group-inc! (current-test-group) 'ERROR)))
body ...) body ...)
(test-end name) (test-end name)
(current-test-group old-group))))) (current-test-group old-group)))))
@ -266,52 +266,55 @@
(let wr ((x x)) (let wr ((x x))
(if (pair? x) (if (pair? x)
(cond (cond
((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
(assq (car x) (assq (car x)
'((quote . "'") (quasiquote . "`") '((quote . "'") (quasiquote . "`")
(unquote . ",") (unquote-splicing . ",@")))) (unquote . ",") (unquote-splicing . ",@"))))
=> (lambda (s) (display (cdr s) out) (wr (cadr x)))) => (lambda (s) (display (cdr s) out) (wr (cadr x))))
(else (else
(display "(" out) (display "(" out)
(wr (car x)) (wr (car x))
(let lp ((ls (cdr x))) (let lp ((ls (cdr x)))
(cond ((pair? ls) (cond ((pair? ls)
(display " " out) (display " " out)
(wr (car ls)) (wr (car ls))
(lp (cdr ls))) (lp (cdr ls)))
((not (null? ls)) ((not (null? ls))
(display " . " out) (display " . " out)
(write ls out)))) (write ls out))))
(display ")" out))) (display ")" out)))
(write x out)))))) (write x out))))))
(define (display-to-string x)
(if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
;; if we need to truncate, try first dropping let's to get at the ;; if we need to truncate, try first dropping let's to get at the
;; heart of the expression ;; heart of the expression
(define (truncate-source x width . o) (define (truncate-source x width . o)
(let* ((str (write-to-string x)) (let* ((str (write-to-string x))
(len (string-length str))) (len (string-length str)))
(cond (cond
((<= len width) ((<= len width)
str) str)
((and (pair? x) (eq? 'let (car x))) ((and (pair? x) (eq? 'let (car x)))
(if (and (pair? o) (car o)) (if (and (pair? o) (car o))
(truncate-source (car (reverse x)) width #t) (truncate-source (car (reverse x)) width #t)
(string-append "..." (string-append "..."
(truncate-source (car (reverse x)) (- width 3) #t)))) (truncate-source (car (reverse x)) (- width 3) #t))))
((and (pair? x) (eq? 'call-with-current-continuation (car x))) ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
(truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
((and (pair? x) (eq? 'call-with-values (car x))) ((and (pair? x) (eq? 'call-with-values (car x)))
(string-append (string-append
"..." "..."
(truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x)))) (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
(car (reverse (cadr x))) (car (reverse (cadr x)))
(cadr x)) (cadr x))
(- width 3) (- width 3)
#t))) #t)))
(else (else
(string-append (string-append
(substring str 0 (min (max 0 (- width 3)) (string-length str))) (substring str 0 (min (max 0 (- width 3)) (string-length str)))
"..."))))) "...")))))
(define (test-get-name! info) (define (test-get-name! info)
(or (or
@ -319,18 +322,18 @@
(assq-ref info 'gen-name) (assq-ref info 'gen-name)
(let ((name (let ((name
(cond (cond
((assq-ref info 'source) ((assq-ref info 'source)
=> (lambda (src) => (lambda (src)
(truncate-source src (- (current-column-width) 12)))) (truncate-source src (- (current-column-width) 12))))
((current-test-group) ((current-test-group)
=> (lambda (g) => (lambda (g)
(display "no source in: " (current-error-port)) (display "no source in: " (current-error-port))
(write info (current-error-port)) (write info (current-error-port))
(display "\n" (current-error-port)) (display "\n" (current-error-port))
(string-append (string-append
"test-" "test-"
(number->string (test-group-ref g 'count 0))))) (number->string (test-group-ref g 'count 0)))))
(else "")))) (else ""))))
(if (pair? info) (if (pair? info)
(set-cdr! info (cons (cons 'gen-name name) (cdr info)))) (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
name))) name)))
@ -353,22 +356,6 @@
(test-first-indentation)))))) (test-first-indentation))))))
(* 4 (min level (test-max-indentation))))) (* 4 (min level (test-max-indentation)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ansi tools
(define (display-to-string x)
(if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
(define (ansi-color code)
(lambda (x)
(string-append "\x1B;[" (number->string code) "m"
(display-to-string x) "\x1B;[0m")))
(define red (ansi-color 31))
(define green (ansi-color 32))
(define yellow (ansi-color 33))
(define bold (ansi-color 1))
(define underline (ansi-color 4))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-expand-info info) (define (test-expand-info info)
@ -400,40 +387,38 @@
(test-print-name info indent))) (test-print-name info indent)))
(let ((expect-val (let ((expect-val
(guard (guard
(exn (exn
(else (else
(warning "bad expect value") (warning "bad expect value")
(print-exception exn (current-error-port)) (print-exception exn (current-error-port))
#f)) #f))
(expect)))) (expect))))
(guard (guard
(exn (exn
(else (else
((current-test-handler) ((current-test-handler)
(if (assq-ref info 'expect-error) 'PASS 'ERROR) (if (assq-ref info 'expect-error) 'PASS 'ERROR)
(append `((exception . ,exn)) info)))) (append `((exception . ,exn)) info))))
(let ((res (expr))) (let ((res (expr)))
(let ((status (let ((status
(if (and (not (assq-ref info 'expect-error)) (if (and (not (assq-ref info 'expect-error))
(if (assq-ref info 'assertion) (if (assq-ref info 'assertion)
res res
((current-test-comparator) expect-val res))) ((current-test-comparator) expect-val res)))
'PASS 'PASS
'FAIL)) 'FAIL))
(info `((result . ,res) (expected . ,expect-val) ,@info))) (info `((result . ,res) (expected . ,expect-val) ,@info)))
((current-test-handler) status info))))))) ((current-test-handler) status info)))))))
(define (test-default-skipper info) (define (test-default-skipper info)
((current-test-handler) 'SKIP info)) ((current-test-handler) 'SKIP info))
(define (test-status-color status) (define (test-status-color status)
(if (test-ansi?) (case status
(case status ((ERROR) (lambda (x) (underline (red x))))
((ERROR) (lambda (x) (underline (red x)))) ((FAIL) red)
((FAIL) red) ((SKIP) yellow)
((SKIP) yellow) (else (lambda (x) x))))
(else (lambda (x) x)))
(lambda (x) x)))
(define (test-status-message status) (define (test-status-message status)
((test-status-color status) status)) ((test-status-color status) status))
@ -520,9 +505,9 @@
(make-string (if (pair? indent) (car indent) 0) #\space) (make-string (if (pair? indent) (car indent) 0) #\space)
"-- " str " ")) "-- " str " "))
(len (string-length header))) (len (string-length header)))
(display (if (test-ansi?) (bold header) header)) (display (bold header))
(display (make-string (max 0 (- (current-column-width) len)) #\-)) (display (make-string (max 0 (- (current-column-width) len)) #\-))
(newline))) (newline)))
(define (test-default-handler status info) (define (test-default-handler status info)
(define indent (define indent
@ -607,7 +592,7 @@
((positive? count) ((positive? count)
(display indent) (display indent)
(display (display
((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) ((if (= pass count) green (lambda (x) x))
(string-append (string-append
(number->string pass) " out of " (number->string count) (number->string pass) " out of " (number->string count)
(percent pass count)))) (percent pass count))))
@ -623,14 +608,14 @@
(cond ((positive? fail) (cond ((positive? fail)
(display indent) (display indent)
(display (display
((if (test-ansi?) red (lambda (x) x)) (red
(string-append (string-append
(number->string fail) (plural " failure" fail) (number->string fail) (plural " failure" fail)
(percent fail count) ".\n"))))) (percent fail count) ".\n")))))
(cond ((positive? err) (cond ((positive? err)
(display indent) (display indent)
(display (display
((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) ((lambda (x) (underline (red x)))
(string-append (string-append
(number->string err) (plural " error" err) (number->string err) (plural " error" err)
(percent err count) ".\n"))))) (percent err count) ".\n")))))
@ -639,7 +624,7 @@
(for-each (for-each
(lambda (failure) (lambda (failure)
(display indent) (display indent)
(display ((if (test-ansi?) red (lambda (x) x)) (display (red
(string-append (display-to-string (cadr failure)) ": "))) (string-append (display-to-string (cadr failure)) ": ")))
(display (test-get-name! (car (cddr failure)))) (display (test-get-name! (car (cddr failure))))
(newline) (newline)
@ -649,7 +634,7 @@
((positive? subgroups-count) ((positive? subgroups-count)
(display indent) (display indent)
(display (display
((if (and (test-ansi?) (= subgroups-pass subgroups-count)) ((if (= subgroups-pass subgroups-count)
green (lambda (x) x)) green (lambda (x) x))
(string-append (string-append
(number->string subgroups-pass) " out of " (number->string subgroups-pass) " out of "
@ -777,21 +762,21 @@
(define (getenv-filter-list proc name . o) (define (getenv-filter-list proc name . o)
(cond (cond
((get-environment-variable name) ((get-environment-variable name)
=> (lambda (s) => (lambda (s)
(guard (guard
(exn (exn
(else (else
(warning (warning
(string-append "invalid filter '" s (string-append "invalid filter '" s
"' from environment variable: " name)) "' from environment variable: " name))
(print-exception exn (current-error-port)) (print-exception exn (current-error-port))
'())) '()))
(let ((f (proc s))) (let ((f (proc s)))
(list (if (and (pair? o) (car o)) (list (if (and (pair? o) (car o))
(lambda (x) (not (f x))) (lambda (x) (not (f x)))
f)))))) f))))))
(else '()))) (else '())))
(define current-test-filters (define current-test-filters
(make-parameter (make-parameter
@ -809,13 +794,3 @@
=> string->number) => string->number)
(else #f)) (else #f))
78))) 78)))
(define test-ansi?
(make-parameter
(cond
((get-environment-variable "TEST_USE_ANSI")
=> (lambda (s) (not (equal? s "0"))))
(else
(member (get-environment-variable "TERM")
'("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
"linux" "screen" "screen-256color" "vt100"))))))

3
lib/chibi/test.sld
View file

@ -12,7 +12,8 @@
(import (scheme write) (import (scheme write)
(scheme complex) (scheme complex)
(scheme process-context) (scheme process-context)
(scheme time)) (scheme time)
(chibi term ansi))
(cond-expand (cond-expand
(chibi (chibi
(import (except (scheme base) guard) (import (except (scheme base) guard)