-
Notifications
You must be signed in to change notification settings - Fork 17
/
eldev-ert.el
231 lines (208 loc) · 14.9 KB
/
eldev-ert.el
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
224
225
226
227
228
229
230
231
;;; eldev-ert.el --- Elisp development tool -*- lexical-binding: t -*-
;;; Copyright (C) 2019-2024 Paul Pogonyshev
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see https://www.gnu.org/licenses.
;;; Code:
(require 'eldev)
(require 'ert)
;; Forward-declare some variables.
(defvar ert-quiet)
(defvar ert-batch-backtrace-right-margin)
;; Functions for binding Eldev with ERT testing framework. Broken out
;; into a separate file so that `eldev.el' doesn't have to require
;; `ert' feature.
(defvar eldev--test-ert-short-backtraces nil)
(defvar eldev--test-ert-concise-expected nil)
(defvar eldev--test-ert-results nil)
(defvar-local eldev--ert-backtrace-buffer nil)
(defun eldev-test-ert-preprocess-selectors (selectors)
"Convert SELECTORS to ERT format."
(eldev-test-selectors-to-elisp-values selectors t))
(defun eldev-test-ert-load-results ()
"Load previous ERT test results if they are present."
(eldev-test-do-load-results "ert" "previous ERT test results" 1
(let ((results (cdr (assq 'results contents))))
(dolist (result results)
(when (ert-test-boundp (car result))
(setf (ert-test-most-recent-result (ert-get-test (car result))) (cdr result))))
(setf eldev--test-ert-results results))))
(defun eldev-test-ert-save-results ()
"Save ERT test results for future use."
(eldev-test-do-save-results "ert" "ERT test results" 1
(let (results)
(mapatoms (lambda (symbol)
(when (ert-test-boundp symbol)
(let ((result (ert-test-most-recent-result (ert-get-test symbol))))
(when result
(setf result (copy-sequence result))
(cond ((ert-test-passed-p result)
;; These can be huge in some tests that contain `(should ...)' forms in a loop
;; and apparently serve no purpose. Remove them to reduce file size.
(setf (ert-test-result-should-forms result) '(...)))
((not (ert-test-aborted-with-non-local-exit-p result))
;; Of course we cannot print-read the backtraces (and probably something else)
;; directly. Lisp...
(setf (ert-test-result-with-condition-condition result) '(...)
(ert-test-result-with-condition-backtrace result) '(...)
(ert-test-result-with-condition-infos result) '(...)))))
(push `(,symbol . ,result) results)))))
;; Use `eldev--test-ert-results' to not forget results of tests that were not loaded
;; this time.
(dolist (result eldev--test-ert-results)
(unless (assq (car result) results)
(push result results)))
`((results . ,results)))))
(defun eldev-run-ert-tests (selectors &optional environment)
"Run ERT tests according to given SELECTORS.
This is a wrapper around `ert-run-tests-batch' that handles
`eldev-test-stop-on-unexpected'. Test runners should generally
use this for ERT framework, unless they can do better."
;; Since ERT doesn't support features we want out-of-the-box, we have to hack.
(eldev-bind-from-environment environment (ert-quiet ert-batch-backtrace-right-margin eldev--test-ert-short-backtraces eldev--test-ert-concise-expected)
(let ((width (eldev-shrink-screen-width-as-needed eldev-test-print-backtraces)))
(if (integerp width)
(setf ert-batch-backtrace-right-margin (when (> width 0) (max (1- width) 1)))
;; Otherwise use value of `eldev-backtrace-style', but only if test runner doesn't
;; specify anything.
(unless (assq 'ert-batch-backtrace-right-margin environment)
(setf width (eldev-shrink-screen-width-as-needed eldev-backtrace-style)
ert-batch-backtrace-right-margin (when (and (integerp width) (> width 0)) (max (1- width) 1))))))
;; Workaround: older Emacsen don't support setting `ert-batch-backtrace-right-margin'
;; to nil. We assume that if the variable is customizable, nil is already supported.
(unless (or ert-batch-backtrace-right-margin (get 'ert-batch-backtrace-right-margin 'custom-type))
(setf ert-batch-backtrace-right-margin 1000000))
(let ((have-ert--run-test-internal (fboundp 'ert--run-test-internal))
completed-tests)
(eldev-advised (#'ert-run-tests
;; There is a difference in number arguments in Emacs 24, so just hide
;; the extra arguments with `&rest'.
:around (lambda (original selector listener &rest rest)
(apply original selector
(lambda (event-type &rest arguments)
(when (and eldev--test-ert-concise-expected (eq event-type 'test-ended))
(let* ((stats (nth 0 arguments))
(test (nth 1 arguments))
(result (nth 2 arguments))
(num-completed (ert-stats-completed stats)))
(eldev-test-runner-concise-tick (not (ert-test-result-expected-p test result))
num-completed (ert-stats-total stats))))
;; Older ERT versions have `ert--print-backtrace',
;; newer use `backtrace-to-string'. Not using
;; function-quoting to avoid warnings.
(prog1 (eldev-advised ('backtrace-to-string
:around (lambda (original &optional frames)
(if eldev-test-print-backtraces
(progn (setf eldev--ert-backtrace-buffer t)
(eldev-highlight-backtrace
(funcall original (eldev--ert-maybe-shorten-backtrace frames))))
" [omitted]")))
(eldev-advised ('ert--print-backtrace
:around (lambda (original &optional frames &rest arguments)
(if eldev-test-print-backtraces
(apply original (eldev--ert-maybe-shorten-backtrace frames) arguments)
(insert " [omitted]\n"))))
;; Workaround for ERT stripping faces we set in backtraces.
(eldev-advised ('buffer-substring-no-properties
:around (lambda (original &rest arguments)
(apply (if eldev--ert-backtrace-buffer #'buffer-substring original) arguments)))
(if (and eldev--test-ert-concise-expected
(eq event-type 'test-ended)
(let ((test (nth 1 arguments))
(result (nth 2 arguments)))
(ert-test-result-expected-p test result)))
(eldev-output-reroute-messages
(let ((eldev-message-rerouting-wrapper #'ignore))
(apply listener event-type arguments)))
(apply listener event-type arguments)))))
(pcase event-type
(`run-started
(eldev-test-validate-amount (ert-stats-total (nth 0 arguments))))
(`test-ended
(when eldev-test-stop-on-unexpected
(let ((stats (nth 0 arguments))
(test (nth 1 arguments))
(result (nth 2 arguments))
(num-tests-ignored 0))
(push test completed-tests)
(unless (or (ert-test-result-expected-p test result)
(> (setf eldev-test-stop-on-unexpected (1- eldev-test-stop-on-unexpected)) 0))
;; Since this really goes into internals, assert some things beforehand.
(when (and (fboundp #'ert--stats-tests) (fboundp #'ert-test-most-recent-result)
(vectorp (ert--stats-tests stats)))
(setf num-tests-ignored (- (length (ert--stats-tests stats)) (length completed-tests))
(ert--stats-tests stats) (vconcat (nreverse completed-tests))))
(when (> num-tests-ignored 0)
(eldev-warn "\nStopping before %s" (eldev-message-plural num-tests-ignored "more test")))
(signal 'eldev-quit 1))))))))
rest)))
;; Inject profiling support if wanted. Profile `ert-run-test' if
;; `ert--run-test-internal' is gone in a future Emacs version.
(eldev-advised ('ert--run-test-internal :around (when (and eldev--effective-profile-mode have-ert--run-test-internal)
(lambda (original &rest args)
(eldev-backtrace-notch 'eldev
(eldev-profile-body
(apply original args))))))
(eldev-advised ('ert-run-test :around (when (and eldev--effective-profile-mode (not have-ert--run-test-internal))
(lambda (original &rest args)
(eldev-backtrace-notch 'eldev
(eldev-profile-body
(apply original args))))))
;; No easy way to highlight successful test summary with `success' color, so
;; not doing this as low-importance and to avoid false positives.
(let* ((statistics (ert-run-tests-batch (eldev-build-ert-selector selectors)))
(num-unexpected (ert-stats-completed-unexpected statistics)))
;; We map ERT's expected/unexpected to passed/failed here.
(setf eldev-test-num-passed (+ eldev-test-num-passed (ert-stats-completed-expected statistics))
eldev-test-num-failed (+ eldev-test-num-failed num-unexpected)
eldev-test-num-skipped (+ eldev-test-num-skipped (ert-stats-skipped statistics)))
(unless (= num-unexpected 0)
(signal 'eldev-error `("%s produced an unexpected result" ,(eldev-message-plural num-unexpected "ERT test")))))))))))
(defun eldev-count-ert-tests (selectors)
"Count ERT tests matching given SELECTORS."
(length (ert-select-tests (or (eldev-build-ert-selector selectors) t) t)))
;; See new functionality of `eldev-backtrace'. Maybe we could reuse that somehow?
(defun eldev--ert-maybe-shorten-backtrace (frames)
(when eldev--test-ert-short-backtraces
;; Drop the frames that are inside ERT and Eldev.
(let ((scan (reverse frames)))
(while scan
(let ((frame (pop scan)))
(when (eq (eldev-backtrace-frame-function frame) 'ert--run-test-internal)
;; Heuristic: older Emacs versions have two more "uninteresting" frames where
;; first is a `funcall' and second is some byte-compiled function.
(when (and (eq (eldev-backtrace-frame-function (car scan)) 'funcall)
(byte-code-function-p (eldev-backtrace-frame-function (cadr scan))))
(setf scan (cddr scan)))
(setf frames (nreverse scan)
scan nil))))))
frames)
(defun eldev-build-ert-selector (selectors)
"Convert a list of SELECTORS to a single ERT selector.
If the list contains several selectors, they are combined with
`or' operator, as promised by the `test' command documentation.
When `eldev-dwim' is set, any symbol that is not an exact test
name is instead treated as a regular expression that is supposed
to match test names."
(let ((ert-selectors (mapcar (lambda (selector)
(let ((as-elisp (car selector))
(as-string (cdr selector)))
(if (and eldev-dwim
(or (and (symbolp as-elisp) (not (memq as-elisp '(nil t))) (not (keywordp as-elisp)) (not (ert-test-boundp as-elisp)))
(numberp as-elisp)))
as-string
as-elisp)))
selectors)))
(if (cdr ert-selectors)
`(or ,@ert-selectors)
(car ert-selectors))))
(provide 'eldev-ert)
;;; eldev-ert.el ends here