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

47
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}
@ -285,6 +285,9 @@
(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)
@ -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)
@ -427,13 +414,11 @@
((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,7 +505,7 @@
(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)))
@ -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 "
@ -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)