-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathyarty.lisp
223 lines (200 loc) · 8.99 KB
/
yarty.lisp
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
;;;; yarty.lisp
(in-package #:yarty)
(defvar *tests* ()
"An alist of ((package . (test-function-names*))*)")
(defvar *handle-errors* t
"t: handle in tests; nil: decline to handle. Default is t.")
(defvar *output* (make-synonym-stream '*standard-output*)
"The stream testing info is print to.
This defaults to a *standard-output* synonym-stream.")
(defvar *restart-queue* (lparallel.queue:make-queue :fixed-capacity 1))
(defvar *in-progress-queue* (lparallel.queue:make-queue :fixed-capacity 1))
(defvar *test-system* ())
(define-condition test-results ()
((results :initarg :results :reader results))
(:documentation
"RUN-TESTS signals this with its result before returning."))
(defun run-tests (&rest packages)
"Runs all the tests defined by DEFTEST in the given packages.
Returns output suitable for use by cl-test-grid: either the
keyword :ok, or a list whose first element is the
keyword :failed-tests and whose second element is a list of the
names (as strings) of those tests."
(let (failing-tests
(packages (if packages
(mapcar (lambda (p)
(or (find-package p)
(error "Package ~A not found." p)))
packages)
(list *package*))))
(declare (special failing-tests))
(flet ((finish ()
(let ((res (if failing-tests
(list :failed-tests (mapcar #'string-downcase
failing-tests))
:ok)))
(print res *output*)
(signal (make-condition 'test-results :results res))
res))
(restart ()
(declare (ftype function autorun-test-system))
(return-from run-tests (autorun-test-system *test-system*))))
(dolist (test
(alexandria:mappend (lambda (p)
(reverse (cdr (assoc p *tests*))))
packages)
(finish))
(let ((restartp (lparallel.queue:peek-queue *restart-queue*)))
(cond (restartp
(lparallel.queue:try-pop-queue *restart-queue*)
(restart))
(t
(let ((start (get-internal-run-time)))
(funcall test)
(setf (get test :duration) (- (get-internal-run-time)
start))))))))))
(defun combine-results (r1 r2)
"Combine two cl-test-grid style test results as if they belong to
the same system."
(cond ((not r1)
r2)
((not r2)
r1)
((eq r1 :ok)
r2)
((eq r2 :ok)
r1)
(t (list :failed-tests (append (second r1) (second r2))))))
(defun test-system (system &key quit)
"Test the system. Either return the value of RUN-TESTS or quit the image.
Internally calls ASDF:TEST-SYSTEM. If quit is nil, then this returns
the combination of the results of any calls to RUN-TESTS made during
ASDF:TEST-SYSTEM.
If QUIT is true then it exits the image after testing. In this case
the exit code of the process indicates the status of the tests.
Exit Code Status
0 Tests Succeeded
1 Tests Failed
125 Could Not Test"
(let (res)
(handler-bind ((test-results
(lambda (c)
(setq res (combine-results res (results c)))))
(error
(lambda (c)
(when quit
(format *output* "Testing aborted due to error \"~A.\"" c)
(quit 125)))))
(funcall (find-symbol (string :test-system) :asdf) system)
(if quit
(case res
(:ok (quit 0))
(otherwise (quit 1)))
res))))
(defmacro each (&body forms)
"Test that each form returns truthy.
If any don't, set the current test to failing."
(cond ((null forms) t)
(t
(let* ((f (gensym))
(errp (gensym))
(len (if (listp (car forms))
(length (car forms))
()))
(args (alexandria:make-gensym-list
(if (and len (plusp len)) (1- len) 0))))
`(let (,f
,errp
,@args)
(declare (ignorable ,@args))
(ensure-dynamic-bindings (current-test failing-tests)
(block handler
(handler-bind ((error
(lambda (c)
(setq ,errp t)
(format *output*
"~& each in ~A threw \"~A\"~&"
current-test
c)
(if *handle-errors*
(return-from handler)
(restart-case (invoke-debugger c)
(continue ()
:report "Continue testing."
(return-from handler)))))))
(unwind-protect
,(if (and (listp (car forms))
(function-name-p (caar forms)))
`(setq ,@(alexandria:mappend
#'list args (cdar forms))
,f (funcall #',(caar forms) ,@args))
`(setq ,f ,(car forms)))
(when (not ,f)
(pushnew current-test failing-tests)
(cond ((not ,errp)
(when current-test
(format *output* "~& In ~A" current-test))
(format *output* "~& Failing Form ~A"
',(car forms))
,(when (and args
(listp (car forms))
(function-name-p (caar forms)))
`(format
t
"~& (~A~{ ~S~^~})"
',(caar forms)
(list ,@args))))
(t
(format *output* "~& Erroring Form ~A"
',(car forms)))))))))
(each ,@(cdr forms)))))))
(defmacro def-deftest (name obody documentation)
(alexandria:with-gensyms (cons forms decl doc)
`(defmacro ,name (name &body body)
,documentation
(multiple-value-bind (,forms ,decl ,doc)
(alexandria:parse-body body :documentation t)
`(let ((,',cons (or (assoc *package* *tests*)
(car (push (cons *package* ()) *tests*)))))
(pushnew ',name (cdr ,',cons))
(export ',name)
(defun ,name ()
,@,decl
,,doc
(let ((current-test ',name))
(declare (special current-test))
(ensure-dynamic-bindings (failing-tests)
(block handler
(handler-bind ((error
(lambda (c)
(pushnew current-test failing-tests)
(format *output*
"~& ~A's toplevel threw \"~A\"~&"
current-test
c)
(if *handle-errors*
(return-from handler)
(restart-case (invoke-debugger c)
(continue ()
:report "Continue testing."
(return-from handler)))))))
(,',obody ,@,forms)))
(if failing-tests
(cons :failed-tests failing-tests)
:ok)))))))))
(def-deftest deftest progn
"Define a function that will be called during RUN-TESTS.
Insert forms which should return truthy inside an EACH.")
(def-deftest deftest/each each
"Like DEFTEST but wraps its body in an EACH.")
(defmacro signals-a (condition &body body)
"Returns true if body signals the condition."
`(handler-case (prog1 () ,@body)
(,condition (c) (declare (ignore c)) t)))
(defun clear-tests (&optional (package *package*))
"Clear the tests for the given package, default to *package*.
If nil is given as an explicit argument, clear all tests for all
packages."
(if package
(assocf (find-package package) () *tests*)
(setq *tests* ())))