blob: 384afd4b0b9eb4bc04e64313ec425c3bdb11aed6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
(define-module (hnh test testrunner)
:use-module (srfi srfi-64)
:use-module (hnh test util)
:use-module (ice-9 pretty-print)
:use-module (ice-9 format)
:export (verbose? construct-test-runner)
)
(define verbose? (make-parameter #f))
(define (pp form indent prefix-1)
(let ((prefix (make-string (+ (string-length indent)
(string-length prefix-1))
#\space)))
(string-replace-head
(with-output-to-string
(lambda () (pretty-print
form
display?: #t
per-line-prefix: prefix
width: (- 79 (string-length indent)))))
(string-append indent prefix-1))))
(define (construct-test-runner)
(define runner (test-runner-null))
(define depth 0)
;; end of individual test case
(test-runner-on-test-begin! runner
(lambda (runner)
(test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
(test-runner-on-test-end! runner
(lambda (runner)
(when (verbose?) (display (make-indent depth)))
(case (test-result-kind runner)
((pass) (display (green "X")))
((fail) (display (red "E")))
((xpass) (display (yellow "X")))
((xfail) (display (yellow "E")))
((skip) (display (yellow "-"))))
(when (or (verbose?) (eq? 'fail (test-result-kind)))
(format #t " ~a~%"
(cond ((test-runner-test-name runner)
(negate string-null?) => identity)
((test-result-ref runner 'expected-value)
=> (lambda (p) (with-output-to-string
(lambda ()
(display (bold "[SOURCE]: "))
(truncated-print p width: 60))))))))
(when (eq? 'fail (test-result-kind))
(cond ((test-result-ref runner 'actual-error)
=> (lambda (err)
(if (and (list? err)
(= 5 (length err)))
(let ((err (list-ref err 0))
(proc (list-ref err 1))
(fmt (list-ref err 2))
(args (list-ref err 3)))
(format #t "~a~a in ~a: ~?~%"
(make-indent (1+ depth))
err proc fmt args))
(format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
(else
(let ((unknown-expected (gensym))
(unknown-actual (gensym)))
(let ((expected (test-result-ref runner 'expected-value unknown-expected))
(actual (test-result-ref runner 'actual-value unknown-actual)))
(let ((indent (make-indent (1+ depth))))
(if (eq? expected unknown-expected)
(format #t "~aAssertion failed~%" indent)
(begin
(display (pp expected indent "Expected: "))
(display (pp actual indent "Received: "))
(let ((d (diff (pp expected "" "")
(pp actual "" ""))))
(display
(string-join
(map (lambda (line) (string-append indent "|" line))
(string-split d #\newline))
"\n" 'suffix))))))))))
(format #t "~aNear ~a:~a~%"
(make-indent (1+ depth))
(test-result-ref runner 'source-file)
(test-result-ref runner 'source-line))
(pretty-print (test-result-ref runner 'source-form)
(current-output-port)
per-line-prefix: (string-append (make-indent (1+ depth)) "> ")
))
(let ((start (test-runner-aux-value runner))
(end (transform-time-of-day (gettimeofday))))
(when (< (µs 1) (- end start))
(format #t "~%Slow test: ~s, took ~a~%"
(test-runner-test-name runner)
(exact->inexact (/ (- end start) (µs 1)))
)))))
;; on start of group
(test-runner-on-group-begin! runner
;; count is number of #f
(lambda (runner name count)
(if (<= depth 1)
(format #t "~a ~a ~a~%"
(make-string 10 #\=)
name
(make-string 10 #\=))
(when (verbose?)
(format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
(set! depth (1+ depth))))
(test-runner-on-group-end! runner
(lambda (runner)
(set! depth (1- depth))
(when (<= depth 1)
(newline))))
;; after everything else is done
(test-runner-on-final! runner
(lambda (runner)
(format #t "Guile version ~a~%~%" (version))
(format #t "pass: ~a~%" (test-runner-pass-count runner))
(format #t "fail: ~a~%" (test-runner-fail-count runner))
(format #t "xpass: ~a~%" (test-runner-xpass-count runner))
(format #t "xfail: ~a~%" (test-runner-xfail-count runner))
))
runner)
|
