blob: a45bd42165ba19193d3868805884f2b8072c1af3 (
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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
(define-module (hnh test testrunner)
:use-module (srfi srfi-64)
:use-module (hnh test util)
:use-module (hnh util type)
:use-module (hnh util atomic-queue)
:use-module (ice-9 pretty-print)
:use-module (ice-9 format)
:use-module (ice-9 curried-definitions)
:export (verbose? construct-test-runner
test-runner-test-name/description))
(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?: #f
per-line-prefix: prefix
width: (- 79 (string-length indent)))))
(string-append indent prefix-1))))
;;; Return a "name" for the test.
;;; If the test was explicitly named, than that name will be used.
;;; Otherwise a string describing the expected value will be returned.
(define (test-runner-test-name/description runner)
(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)))))))
(define (test-runner-describe-error runner depth)
(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: "))
(display
(string-join
(map (lambda (line) (string-append indent "|" line))
(string-split (diff expected actual) #\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)) "> ")))
(define ((construct-test-runner print err-queue))
(typecheck err-queue atomic-queue?)
(define runner (test-runner-null))
;; TODO wouldn't `depth` need to be atomic to work?
(define depth 0)
(test-runner-on-test-begin! runner
(lambda (runner)
;; This should be thread local, TODO test that
(test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
(test-runner-on-test-end! runner
(lambda (runner)
(when (verbose?) (display (make-indent depth)))
(display
(case (test-result-kind runner)
((pass) (green "X"))
((fail) (red "E"))
((xpass) (red "X"))
((xfail) (yellow "E"))
((skip) (yellow "-"))))
(when (or (verbose?) #;(eq? 'fail (test-result-kind)))
(format #t " ~a~%" (test-runner-test-name/description runner)))
(when (eq? 'fail (test-result-kind))
(enqueue!
(with-output-to-string
(lambda ()
(display
(yellow (format #f "Test failed: ~a~%"
(test-runner-test-name/description runner))))
(display
(yellow
(format #f " Path: ~s~%"
(cdr (test-runner-group-path runner)))))
(test-runner-describe-error runner 0)))
err-queue))
(let ((start (test-runner-aux-value runner))
(end (transform-time-of-day (gettimeofday))))
(when (< (µs 1) (- end start))
(enqueue!
(format #f "~%Slow test: ~s, took ~a~%"
(test-runner-test-name/description runner)
(exact->inexact (/ (- end start) (µs 1))))
err-queue)))
))
;; on start of group
(test-runner-on-group-begin! runner
;; count is number of #f
(lambda (runner name count)
(if (<= depth 0)
(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)
|
