cider-test.el (34851B)
1 ;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- 2 3 ;; Copyright © 2014-2023 Jeff Valk, Bozhidar Batsov and CIDER contributors 4 5 ;; Author: Jeff Valk <jv@jeffvalk.com> 6 7 ;; This program is free software: you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 19 20 ;; This file is not part of GNU Emacs. 21 22 ;;; Commentary: 23 24 ;; This provides execution, reporting, and navigation support for Clojure tests, 25 ;; specifically using the `clojure.test' machinery. This functionality replaces 26 ;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on 27 ;; nREPL middleware for report running and session support. 28 29 ;;; Code: 30 31 (require 'ansi-color) 32 (require 'button) 33 (require 'cl-lib) 34 (require 'easymenu) 35 (require 'map) 36 (require 'seq) 37 (require 'subr-x) 38 39 (require 'cider-common) 40 (require 'cider-client) 41 (require 'cider-popup) 42 (require 'cider-stacktrace) 43 (require 'cider-overlays) 44 45 ;;; Variables 46 47 (defgroup cider-test nil 48 "Presentation and navigation for test results." 49 :prefix "cider-test-" 50 :group 'cider) 51 52 (defcustom cider-test-show-report-on-success nil 53 "Whether to show the `*cider-test-report*` buffer on passing tests." 54 :type 'boolean 55 :package-version '(cider . "0.8.0")) 56 57 (defcustom cider-auto-select-test-report-buffer t 58 "Determines if the test-report buffer should be auto-selected." 59 :type 'boolean 60 :package-version '(cider . "0.9.0")) 61 62 (defcustom cider-test-defining-forms '("deftest" "defspec") 63 "Forms that define individual tests. 64 CIDER considers the \"top-level\" form around point to define a test if 65 the form starts with one of these forms. 66 Add to this list to have CIDER recognize additional test defining macros." 67 :type '(repeat string) 68 :package-version '(cider . "0.15.0")) 69 70 (defvar cider-test-last-summary nil 71 "The summary of the last run test.") 72 73 (defvar cider-test-last-results nil 74 "The results of the last run test.") 75 76 (defconst cider-test-report-buffer "*cider-test-report*" 77 "Buffer name in which to display test reports.") 78 79 ;;; Faces 80 81 (defface cider-test-failure-face 82 '((((class color) (background light)) 83 :background "orange red") 84 (((class color) (background dark)) 85 :background "firebrick")) 86 "Face for failed tests." 87 :package-version '(cider . "0.7.0")) 88 89 (defface cider-test-error-face 90 '((((class color) (background light)) 91 :background "orange1") 92 (((class color) (background dark)) 93 :background "orange4")) 94 "Face for erring tests." 95 :package-version '(cider . "0.7.0")) 96 97 (defface cider-test-success-face 98 '((((class color) (background light)) 99 :foreground "black" 100 :background "green") 101 (((class color) (background dark)) 102 :foreground "black" 103 :background "green")) 104 "Face for passing tests." 105 :package-version '(cider . "0.7.0")) 106 107 108 ;; Colors & Theme Support 109 110 (defvar cider-test-items-background-color 111 (cider-scale-background-color) 112 "Background color for test assertion items.") 113 114 (advice-add 'enable-theme :after #'cider--test-adapt-to-theme) 115 (advice-add 'disable-theme :after #'cider--test-adapt-to-theme) 116 (defun cider--test-adapt-to-theme (&rest _) 117 "When theme is changed, update `cider-test-items-background-color'." 118 (setq cider-test-items-background-color (cider-scale-background-color))) 119 120 121 ;;; Report mode & key bindings 122 ;; 123 ;; The primary mode of interacting with test results is the report buffer, which 124 ;; allows navigation among tests, jumping to test definitions, expected/actual 125 ;; diff-ing, and cause/stacktrace inspection for test errors. 126 127 (defvar cider-test-commands-map 128 (let ((map (define-prefix-command 'cider-test-commands-map))) 129 ;; Duplicates of keys below with C- for convenience 130 (define-key map (kbd "C-r") #'cider-test-rerun-failed-tests) 131 (define-key map (kbd "C-t") #'cider-test-run-test) 132 (define-key map (kbd "C-a") #'cider-test-rerun-test) 133 (define-key map (kbd "C-n") #'cider-test-run-ns-tests) 134 (define-key map (kbd "C-s") #'cider-test-run-ns-tests-with-filters) 135 (define-key map (kbd "C-l") #'cider-test-run-loaded-tests) 136 (define-key map (kbd "C-p") #'cider-test-run-project-tests) 137 (define-key map (kbd "C-b") #'cider-test-show-report) 138 ;; Single-key bindings defined last for display in menu 139 (define-key map (kbd "r") #'cider-test-rerun-failed-tests) 140 (define-key map (kbd "t") #'cider-test-run-test) 141 (define-key map (kbd "a") #'cider-test-rerun-test) 142 (define-key map (kbd "n") #'cider-test-run-ns-tests) 143 (define-key map (kbd "s") #'cider-test-run-ns-tests-with-filters) 144 (define-key map (kbd "l") #'cider-test-run-loaded-tests) 145 (define-key map (kbd "p") #'cider-test-run-project-tests) 146 (define-key map (kbd "b") #'cider-test-show-report) 147 map)) 148 149 (defconst cider-test-menu 150 '("Test" 151 ["Run test" cider-test-run-test] 152 ["Run namespace tests" cider-test-run-ns-tests] 153 ["Run namespace tests with filters" cider-test-run-ns-tests-with-filters] 154 ["Run all loaded tests" cider-test-run-loaded-tests] 155 ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] 156 ["Run all project tests" cider-test-run-project-tests] 157 ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] 158 ["Run tests after load-file" cider-auto-test-mode 159 :style toggle :selected cider-auto-test-mode] 160 "--" 161 ["Interrupt running tests" cider-interrupt] 162 ["Rerun failed/erring tests" cider-test-rerun-failed-tests] 163 ["Show test report" cider-test-show-report] 164 "--" 165 ["Configure testing" (customize-group 'cider-test)]) 166 "CIDER test submenu.") 167 168 (defvar cider-test-report-mode-map 169 (let ((map (make-sparse-keymap))) 170 (define-key map (kbd "C-c ,") 'cider-test-commands-map) 171 (define-key map (kbd "C-c C-t") 'cider-test-commands-map) 172 (define-key map (kbd "M-p") #'cider-test-previous-result) 173 (define-key map (kbd "M-n") #'cider-test-next-result) 174 (define-key map (kbd "M-.") #'cider-test-jump) 175 (define-key map (kbd "<backtab>") #'cider-test-previous-result) 176 (define-key map (kbd "TAB") #'cider-test-next-result) 177 (define-key map (kbd "RET") #'cider-test-jump) 178 (define-key map (kbd "t") #'cider-test-jump) 179 (define-key map (kbd "d") #'cider-test-ediff) 180 (define-key map (kbd "e") #'cider-test-stacktrace) 181 ;; `f' for "run failed". 182 (define-key map "f" #'cider-test-rerun-failed-tests) 183 (define-key map "n" #'cider-test-run-ns-tests) 184 (define-key map "s" #'cider-test-run-ns-tests-with-filters) 185 (define-key map "l" #'cider-test-run-loaded-tests) 186 (define-key map "p" #'cider-test-run-project-tests) 187 ;; `g' generally reloads the buffer. The closest thing we have to that is 188 ;; "run the test at point". But it's not as nice as rerunning all tests in 189 ;; this buffer. 190 (define-key map "g" #'cider-test-run-test) 191 (define-key map "q" #'cider-popup-buffer-quit-function) 192 (easy-menu-define cider-test-report-mode-menu map 193 "Menu for CIDER's test result mode" 194 '("Test-Report" 195 ["Previous result" cider-test-previous-result] 196 ["Next result" cider-test-next-result] 197 "--" 198 ["Rerun current test" cider-test-run-test] 199 ["Rerun failed/erring tests" cider-test-rerun-failed-tests] 200 ["Run all ns tests" cider-test-run-ns-tests] 201 ["Run all ns tests with filters" cider-test-run-ns-tests-with-filters] 202 ["Run all loaded tests" cider-test-run-loaded-tests] 203 ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] 204 ["Run all project tests" cider-test-run-project-tests] 205 ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] 206 "--" 207 ["Jump to test definition" cider-test-jump] 208 ["Display test error" cider-test-stacktrace] 209 ["Display expected/actual diff" cider-test-ediff])) 210 map)) 211 212 (define-derived-mode cider-test-report-mode fundamental-mode "Test Report" 213 "Major mode for presenting Clojure test results. 214 215 \\{cider-test-report-mode-map}" 216 (setq buffer-read-only t) 217 (when cider-special-mode-truncate-lines 218 (setq-local truncate-lines t)) 219 (setq-local sesman-system 'CIDER) 220 (setq-local electric-indent-chars nil) 221 (buffer-disable-undo)) 222 223 ;; Report navigation 224 225 (defun cider-test-show-report () 226 "Show the test report buffer, if one exists." 227 (interactive) 228 (if-let* ((report-buffer (get-buffer cider-test-report-buffer))) 229 (switch-to-buffer report-buffer) 230 (message "No test report buffer"))) 231 232 (defun cider-test-previous-result () 233 "Move point to the previous test result, if one exists." 234 (interactive) 235 (with-current-buffer (get-buffer cider-test-report-buffer) 236 (when-let* ((pos (previous-single-property-change (point) 'type))) 237 (if (get-text-property pos 'type) 238 (goto-char pos) 239 (when-let* ((pos (previous-single-property-change pos 'type))) 240 (goto-char pos)))))) 241 242 (defun cider-test-next-result () 243 "Move point to the next test result, if one exists." 244 (interactive) 245 (with-current-buffer (get-buffer cider-test-report-buffer) 246 (when-let* ((pos (next-single-property-change (point) 'type))) 247 (if (get-text-property pos 'type) 248 (goto-char pos) 249 (when-let* ((pos (next-single-property-change pos 'type))) 250 (goto-char pos)))))) 251 252 (declare-function cider-find-var "cider-find") 253 254 (defun cider-test-jump (&optional arg) 255 "Find definition for test at point, if available. 256 The prefix ARG and `cider-prompt-for-symbol' decide whether to 257 prompt and whether to use a new window. Similar to `cider-find-var'." 258 (interactive "P") 259 (let ((ns (get-text-property (point) 'ns)) 260 (var (get-text-property (point) 'var)) 261 (line (get-text-property (point) 'line))) 262 (if (and ns var) 263 (cider-find-var arg (concat ns "/" var) line) 264 (cider-find-var arg)))) 265 266 ;;; Error stacktraces 267 268 (defvar cider-auto-select-error-buffer) 269 270 (defun cider-test-stacktrace-for (ns var index) 271 "Display stacktrace for the erring NS VAR test with the assertion INDEX." 272 (let (causes) 273 (cider-nrepl-send-request 274 (thread-last 275 (map-merge 'list 276 `(("op" "test-stacktrace") 277 ("ns" ,ns) 278 ("var" ,var) 279 ("index" ,index)) 280 (cider--nrepl-print-request-map fill-column)) 281 (seq-mapcat #'identity)) 282 (lambda (response) 283 (nrepl-dbind-response response (class status) 284 (cond (class (setq causes (cons response causes))) 285 (status (when causes 286 (cider-stacktrace-render 287 (cider-popup-buffer cider-error-buffer 288 cider-auto-select-error-buffer 289 #'cider-stacktrace-mode 290 'ancillary) 291 (reverse causes)))))))))) 292 293 (defun cider-test-stacktrace () 294 "Display stacktrace for the erring test at point." 295 (interactive) 296 (let ((ns (get-text-property (point) 'ns)) 297 (var (get-text-property (point) 'var)) 298 (index (get-text-property (point) 'index)) 299 (err (get-text-property (point) 'error))) 300 (if (and err ns var index) 301 (cider-test-stacktrace-for ns var index) 302 (message "No test error at point")))) 303 304 305 ;;; Expected vs actual diffing 306 307 (defvar cider-test-ediff-buffers nil 308 "The expected/actual buffers used to display diff.") 309 310 (defun cider-test--extract-from-actual (actual n) 311 "Extract form N from ACTUAL, ignoring outermost not. 312 313 ACTUAL is a string like \"(not (= 3 4))\", of the sort returned by 314 clojure.test. 315 316 N = 1 => 3, N = 2 => 4, etc." 317 (with-temp-buffer 318 (insert actual) 319 (clojure-mode) 320 (goto-char (point-min)) 321 (re-search-forward "(" nil t 2) 322 (clojure-forward-logical-sexp n) 323 (forward-whitespace 1) 324 (let ((beg (point))) 325 (clojure-forward-logical-sexp) 326 (buffer-substring beg (point))))) 327 328 (defun cider-test-ediff () 329 "Show diff of the expected vs actual value for the test at point. 330 With the actual value, the outermost '(not ...)' s-expression is removed." 331 (interactive) 332 (let* ((expected-buffer (generate-new-buffer " *expected*")) 333 (actual-buffer (generate-new-buffer " *actual*")) 334 (diffs (get-text-property (point) 'diffs)) 335 (actual* (get-text-property (point) 'actual)) 336 (expected (cond (diffs (get-text-property (point) 'expected)) 337 (actual* (cider-test--extract-from-actual actual* 1)))) 338 (actual (cond (diffs (caar diffs)) 339 (actual* (cider-test--extract-from-actual actual* 2))))) 340 (if (not (and expected actual)) 341 (message "No test failure at point") 342 (with-current-buffer expected-buffer 343 (insert expected) 344 (clojure-mode)) 345 (with-current-buffer actual-buffer 346 (insert actual) 347 (clojure-mode)) 348 (apply #'ediff-buffers 349 (setq cider-test-ediff-buffers 350 (list (buffer-name expected-buffer) 351 (buffer-name actual-buffer))))))) 352 353 (defun cider-test-ediff-cleanup () 354 "Cleanup expected/actual buffers used for diff." 355 (interactive) 356 (mapc (lambda (b) (when (get-buffer b) (kill-buffer b))) 357 cider-test-ediff-buffers)) 358 359 (add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup) 360 361 362 ;;; Report rendering 363 364 (defun cider-test-type-face (type) 365 "Return the font lock face for the test result TYPE." 366 (pcase type 367 ("pass" 'cider-test-success-face) 368 ("fail" 'cider-test-failure-face) 369 ("error" 'cider-test-error-face) 370 (_ 'default))) 371 372 (defun cider-test-type-simple-face (type) 373 "Return a face for the test result TYPE using the highlight color as foreground." 374 (let ((face (cider-test-type-face type))) 375 `(:foreground ,(face-attribute face :background)))) 376 377 (defun cider-test-render-summary (buffer summary) 378 "Emit into BUFFER the report SUMMARY statistics." 379 (with-current-buffer buffer 380 (nrepl-dbind-response summary (ns var test pass fail error) 381 (insert (format "Tested %d namespaces\n" ns)) 382 (insert (format "Ran %d assertions, in %d test functions\n" test var)) 383 (unless (zerop fail) 384 (cider-insert (format "%d failures" fail) 'cider-test-failure-face t)) 385 (unless (zerop error) 386 (cider-insert (format "%d errors" error) 'cider-test-error-face t)) 387 (when (zerop (+ fail error)) 388 (cider-insert (format "%d passed" pass) 'cider-test-success-face t)) 389 (insert "\n\n")))) 390 391 (defun cider-test-render-assertion (buffer test) 392 "Emit into BUFFER report detail for the TEST assertion." 393 (with-current-buffer buffer 394 (nrepl-dbind-response test (var context type message expected actual diffs error gen-input) 395 (cl-flet ((insert-label (s) 396 (cider-insert (format "%8s: " s) 'font-lock-comment-face)) 397 (insert-align-label (s) 398 (insert (format "%12s" s))) 399 (insert-rect (s) 400 (let ((start (point))) 401 (insert-rectangle (thread-first 402 s 403 cider-font-lock-as-clojure 404 (split-string "\n"))) 405 (ansi-color-apply-on-region start (point))) 406 (beginning-of-line))) 407 (cider-propertize-region (cider-intern-keys (cdr test)) 408 (let ((beg (point)) 409 (type-face (cider-test-type-simple-face type)) 410 (bg `(:background ,cider-test-items-background-color :extend t))) 411 (cider-insert (capitalize type) type-face nil " in ") 412 (cider-insert var 'font-lock-function-name-face t) 413 (when context (cider-insert context 'font-lock-doc-face t)) 414 (when message (cider-insert message 'font-lock-string-face t)) 415 (when expected 416 (insert-label "expected") 417 (insert-rect expected) 418 (insert "\n")) 419 (if diffs 420 (dolist (d diffs) 421 (cl-destructuring-bind (actual (removed added)) d 422 (insert-label "actual") 423 (insert-rect actual) 424 (insert-label "diff") 425 (insert "- ") 426 (insert-rect removed) 427 (insert-align-label "+ ") 428 (insert-rect added) 429 (insert "\n"))) 430 (when actual 431 (insert-label "actual") 432 (insert-rect actual))) 433 (when error 434 (insert-label "error") 435 (insert-text-button error 436 'follow-link t 437 'action '(lambda (_button) (cider-test-stacktrace)) 438 'help-echo "View causes and stacktrace") 439 (insert "\n")) 440 (when gen-input 441 (insert-label "input") 442 (insert (cider-font-lock-as-clojure gen-input))) 443 (overlay-put (make-overlay beg (point)) 'font-lock-face bg)) 444 (insert "\n")))))) 445 446 (defun cider-test-non-passing (tests) 447 "For a list of TESTS, each an `nrepl-dict`, return only those that did not pass." 448 (seq-filter (lambda (test) 449 (unless (equal (nrepl-dict-get test "type") "pass") 450 test)) 451 tests)) 452 453 (defun cider-test-render-report (buffer summary results) 454 "Emit into BUFFER the report for the SUMMARY, and test RESULTS." 455 (with-current-buffer buffer 456 (let ((inhibit-read-only t)) 457 (cider-test-report-mode) 458 (cider-insert "Test Summary" 'bold t) 459 (dolist (ns (nrepl-dict-keys results)) 460 (insert (cider-propertize ns 'ns) "\n")) 461 (cider-insert "\n") 462 (cider-test-render-summary buffer summary) 463 (nrepl-dbind-response summary (fail error) 464 (unless (zerop (+ fail error)) 465 (cider-insert "Results" 'bold t "\n") 466 ;; Results are a nested dict, keyed first by ns, then var. Within each 467 ;; var is a sequence of test assertion results. 468 (nrepl-dict-map 469 (lambda (ns vars) 470 (nrepl-dict-map 471 (lambda (_var tests) 472 (let* ((problems (cider-test-non-passing tests)) 473 (count (length problems))) 474 (when (< 0 count) 475 (insert (format "%s\n%d non-passing tests:\n\n" 476 (cider-propertize ns 'ns) count)) 477 (dolist (test problems) 478 (cider-test-render-assertion buffer test))))) 479 vars)) 480 results))) 481 ;; Replace any newline chars with actual newlines to make long error 482 ;; messages more readable 483 (goto-char (point-min)) 484 (while (search-forward "\\n" nil t) 485 (replace-match " 486 ")) 487 (goto-char (point-min)) 488 (current-buffer)))) 489 490 491 ;;; Message echo 492 493 (defun cider-test-echo-running (ns &optional test) 494 "Echo a running message for the test NS, which may be a keyword. 495 The optional arg TEST denotes an individual test name." 496 (if test 497 (message "Running test %s in %s..." 498 (cider-propertize test 'bold) 499 (cider-propertize ns 'ns)) 500 (message "Running tests in %s..." 501 (concat (cider-propertize 502 (cond ((stringp ns) ns) 503 ((eq :non-passing ns) "failing") 504 ((eq :loaded ns) "all loaded") 505 ((eq :project ns) "all project")) 506 'ns) 507 (unless (stringp ns) " namespaces"))))) 508 509 (defun cider-test-echo-summary (summary results) 510 "Echo SUMMARY statistics for a test run returning RESULTS." 511 (nrepl-dbind-response summary (ns test var fail error) 512 (if (nrepl-dict-empty-p results) 513 (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face) 514 "Did you forget to use `is' in your tests?")) 515 (message (propertize 516 "%sRan %d assertions, in %d test functions. %d failures, %d errors." 517 'face (cond ((not (zerop error)) 'cider-test-error-face) 518 ((not (zerop fail)) 'cider-test-failure-face) 519 (t 'cider-test-success-face))) 520 (concat (if (= 1 ns) ; ns count from summary 521 (cider-propertize (car (nrepl-dict-keys results)) 'ns) 522 (propertize (format "%d namespaces" ns) 'face 'default)) 523 (propertize ": " 'face 'default)) 524 test var fail error)))) 525 526 ;;; Test definition highlighting 527 ;; 528 ;; On receipt of test results, failing/erring test definitions are highlighted. 529 ;; Highlights are cleared on the next report run, and may be cleared manually 530 ;; by the user. 531 532 ;; NOTE If keybindings specific to test sources are desired, it would be 533 ;; straightforward to turn this into a `cider-test-mode' minor mode, which we 534 ;; enable on test sources, much like the legacy `clojure-test-mode'. At present, 535 ;; though, there doesn't seem to be much value in this, since the report buffer 536 ;; provides the primary means of interacting with test results. 537 538 (defun cider-test-highlight-problem (buffer test) 539 "Highlight the BUFFER test definition for the non-passing TEST." 540 (with-current-buffer buffer 541 ;; we don't need the file name here, as we always operate on the current 542 ;; buffer and the line data is correct even for vars that were 543 ;; defined interactively 544 (nrepl-dbind-response test (type line message expected actual) 545 (when line 546 (save-excursion 547 (goto-char (point-min)) 548 (forward-line (1- line)) 549 (search-forward "(" nil t) 550 (let ((beg (point))) 551 (forward-sexp) 552 (cider--make-overlay beg (point) 'cider-test 553 'font-lock-face (cider-test-type-face type) 554 'type type 555 'help-echo message 556 'message message 557 'expected expected 558 'actual actual))))))) 559 560 (defun cider-find-var-file (ns var) 561 "Return the buffer visiting the file in which the NS VAR is defined. 562 Or nil if not found." 563 (when-let* ((info (cider-var-info (concat ns "/" var))) 564 (file (nrepl-dict-get info "file"))) 565 (cider-find-file file))) 566 567 (defun cider-test-highlight-problems (results) 568 "Highlight all non-passing tests in the test RESULTS." 569 (nrepl-dict-map 570 (lambda (ns vars) 571 (nrepl-dict-map 572 (lambda (var tests) 573 (when-let* ((buffer (cider-find-var-file ns var))) 574 (dolist (test tests) 575 (nrepl-dbind-response test (type) 576 (unless (equal "pass" type) 577 (cider-test-highlight-problem buffer test)))))) 578 vars)) 579 results)) 580 581 (defun cider-test-clear-highlights () 582 "Clear highlighting of non-passing tests from the last test run." 583 (interactive) 584 (when cider-test-last-results 585 (nrepl-dict-map 586 (lambda (ns vars) 587 (dolist (var (nrepl-dict-keys vars)) 588 (when-let* ((buffer (cider-find-var-file ns var))) 589 (with-current-buffer buffer 590 (remove-overlays nil nil 'category 'cider-test))))) 591 cider-test-last-results))) 592 593 594 ;;; Test namespaces 595 ;; 596 ;; Test namespace inference exists to enable DWIM test running functions: the 597 ;; same "run-tests" function should be able to be used in a source file, and in 598 ;; its corresponding test namespace. To provide this, we need to map the 599 ;; relationship between those namespaces. 600 601 (defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn 602 "Function to infer the test namespace for NS. 603 The default implementation uses the simple Leiningen convention of appending 604 '-test' to the namespace name." 605 :type 'symbol 606 :package-version '(cider . "0.7.0")) 607 608 (defun cider-test-default-test-ns-fn (ns) 609 "For a NS, return the test namespace, which may be the argument itself. 610 This uses the Leiningen convention of appending '-test' to the namespace name." 611 (when ns 612 (let ((suffix "-test")) 613 (if (string-suffix-p suffix ns) 614 ns 615 (concat ns suffix))))) 616 617 618 ;;; Test execution 619 620 (defcustom cider-test-default-include-selectors '() 621 "List of include selector strings to use when executing tests if none provided." 622 :type '(repeat string) 623 :package-version '(cider . "1.1.0")) 624 625 (defcustom cider-test-default-exclude-selectors '() 626 "List of exclude selector strings to use when executing tests if none provided." 627 :type '(repeat string) 628 :package-version '(cider . "1.1.0")) 629 630 (declare-function cider-emit-interactive-eval-output "cider-eval") 631 (declare-function cider-emit-interactive-eval-err-output "cider-eval") 632 633 (defun cider-test--prompt-for-selectors (message) 634 "Prompt for test selectors with MESSAGE. 635 The selectors can be either keywords or strings." 636 (mapcar 637 (lambda (string) (replace-regexp-in-string "^:+" "" string)) 638 (split-string 639 (cider-read-from-minibuffer message)))) 640 641 (defun cider-test-execute (ns &optional tests silent prompt-for-filters) 642 "Run tests for NS, which may be a keyword, optionally specifying TESTS. 643 This tests a single NS, or multiple namespaces when using keywords `:project', 644 `:loaded' or `:non-passing'. Optional TESTS are only honored when a single 645 namespace is specified. Upon test completion, results are echoed and a test 646 report is optionally displayed. When test failures/errors occur, their sources 647 are highlighted. 648 If SILENT is non-nil, suppress all messages other then test results. 649 If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selector filters. 650 The include/exclude selectors will be used to filter the tests before 651 running them." 652 (cider-test-clear-highlights) 653 (let ((include-selectors 654 (if prompt-for-filters 655 (cider-test--prompt-for-selectors 656 "Test selectors to include (space separated): ") 657 cider-test-default-include-selectors)) 658 (exclude-selectors 659 (if prompt-for-filters 660 (cider-test--prompt-for-selectors 661 "Test selectors to exclude (space separated): ") 662 cider-test-default-exclude-selectors))) 663 (cider-map-repls :clj-strict 664 (lambda (conn) 665 (unless silent 666 (if (and tests (= (length tests) 1)) 667 ;; we generate a different message when running individual tests 668 (cider-test-echo-running ns (car tests)) 669 (cider-test-echo-running ns))) 670 (let ((request `("op" ,(cond ((stringp ns) "test") 671 ((eq :project ns) "test-all") 672 ((eq :loaded ns) "test-all") 673 ((eq :non-passing ns) "retest"))))) 674 ;; we add optional parts of the request only when relevant 675 (when (and (listp include-selectors) include-selectors) 676 (setq request (append request `("include" ,include-selectors)))) 677 (when (and (listp exclude-selectors) exclude-selectors) 678 (setq request (append request `("exclude" ,exclude-selectors)))) 679 (when (stringp ns) 680 (setq request (append request `("ns" ,ns)))) 681 (when (stringp ns) 682 (setq request (append request `("tests" ,tests)))) 683 (when (or (stringp ns) (eq :project ns)) 684 (setq request (append request `("load?" ,"true")))) 685 (cider-nrepl-send-request 686 request 687 (lambda (response) 688 (nrepl-dbind-response response (summary results status out err) 689 (cond ((member "namespace-not-found" status) 690 (unless silent 691 (message "No test namespace: %s" (cider-propertize ns 'ns)))) 692 (out (cider-emit-interactive-eval-output out)) 693 (err (cider-emit-interactive-eval-err-output err)) 694 (results 695 (nrepl-dbind-response summary (error fail) 696 (setq cider-test-last-summary summary) 697 (setq cider-test-last-results results) 698 (cider-test-highlight-problems results) 699 (cider-test-echo-summary summary results) 700 (if (or (not (zerop (+ error fail))) 701 cider-test-show-report-on-success) 702 (cider-test-render-report 703 (cider-popup-buffer 704 cider-test-report-buffer 705 cider-auto-select-test-report-buffer) 706 summary 707 results) 708 (when (get-buffer cider-test-report-buffer) 709 (with-current-buffer cider-test-report-buffer 710 (let ((inhibit-read-only t)) 711 (erase-buffer))) 712 (cider-test-render-report 713 cider-test-report-buffer 714 summary results)))))))) 715 conn)))))) 716 717 (defun cider-test-rerun-failed-tests () 718 "Rerun failed and erring tests from the last test run." 719 (interactive) 720 (if cider-test-last-summary 721 (nrepl-dbind-response cider-test-last-summary (fail error) 722 (if (not (zerop (+ error fail))) 723 (cider-test-execute :non-passing) 724 (message "No prior failures to retest"))) 725 (message "No prior results to retest"))) 726 727 (defun cider-test-run-loaded-tests (prompt-for-filters) 728 "Run all tests defined in currently loaded namespaces. 729 730 If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to 731 filter the tests with." 732 (interactive "P") 733 (cider-test-execute :loaded nil nil prompt-for-filters)) 734 735 (defun cider-test-run-project-tests (prompt-for-filters) 736 "Run all tests defined in all project namespaces, loading these as needed. 737 738 If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to 739 filter the tests with." 740 (interactive "P") 741 (cider-test-execute :project nil nil prompt-for-filters)) 742 743 (defun cider-test-run-ns-tests-with-filters (suppress-inference) 744 "Run tests filtered by selectors for the current Clojure namespace context. 745 746 With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the 747 current ns." 748 (interactive "P") 749 (cider-test-run-ns-tests suppress-inference nil 't)) 750 751 (defun cider-test-run-ns-tests (suppress-inference &optional silent prompt-for-filters) 752 "Run all tests for the current Clojure namespace context. 753 754 If SILENT is non-nil, suppress all messages other then test results. 755 With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the 756 current ns. If PROMPT-FOR-FILTERS is non-nil, prompt the user for 757 test selectors to filter the tests with." 758 (interactive "P") 759 (if-let* ((ns (if suppress-inference 760 (cider-current-ns t) 761 (funcall cider-test-infer-test-ns (cider-current-ns t))))) 762 (cider-test-execute ns nil silent prompt-for-filters) 763 (if (eq major-mode 'cider-test-report-mode) 764 (when (y-or-n-p (concat "Test report does not define a namespace. " 765 "Rerun failed/erring tests?")) 766 (cider-test-rerun-failed-tests)) 767 (unless silent 768 (message "No namespace to test in current context"))))) 769 770 (defvar cider-test-last-test-ns nil 771 "The ns of the last test ran with `cider-test-run-test'.") 772 (defvar cider-test-last-test-var nil 773 "The var of the last test ran with `cider-test-run-test'.") 774 775 (defun cider-test-update-last-test (ns var) 776 "Update the last test by setting NS and VAR. 777 778 See `cider-test-rerun-test'." 779 (setq cider-test-last-test-ns ns 780 cider-test-last-test-var var)) 781 782 (defun cider-test-run-test () 783 "Run the test at point. 784 The test ns/var exist as text properties on report items and on highlighted 785 failed/erred test definitions. When not found, a test definition at point 786 is searched." 787 (interactive) 788 (let ((ns (get-text-property (point) 'ns)) 789 (var (get-text-property (point) 'var))) 790 (if (and ns var) 791 ;; we're in a `cider-test-report-mode' buffer 792 ;; or on a highlighted failed/erred test definition 793 (progn 794 (cider-test-update-last-test ns var) 795 (cider-test-execute ns (list var))) 796 ;; we're in a `clojure-mode' buffer 797 (let* ((ns (clojure-find-ns)) 798 (def (clojure-find-def)) ; it's a list of the form (deftest something) 799 (deftype (car def)) 800 (var (cadr def))) 801 (if (and ns (member deftype cider-test-defining-forms)) 802 (progn 803 (cider-test-update-last-test ns (list var)) 804 (cider-test-execute ns (list var))) 805 (message "No test at point")))))) 806 807 (defun cider-test-rerun-test () 808 "Re-run the test that was previously ran." 809 (interactive) 810 (if (and cider-test-last-test-ns cider-test-last-test-var) 811 (cider-test-execute cider-test-last-test-ns cider-test-last-test-var) 812 (user-error "No test to re-run"))) 813 814 ;;; Auto-test mode 815 (defun cider--test-silently () 816 "Like `cider-test-run-tests', but with less feedback. 817 Only notify the user if there actually were any tests to run and only after 818 the results are received." 819 (when (cider-connected-p) 820 (let ((cider-auto-select-test-report-buffer nil) 821 (cider-test-show-report-on-success nil)) 822 (cider-test-run-ns-tests nil 'soft)))) 823 824 ;;;###autoload 825 (define-minor-mode cider-auto-test-mode 826 "Toggle automatic testing of Clojure files. 827 828 When enabled this reruns tests every time a Clojure file is loaded. 829 Only runs tests corresponding to the loaded file's namespace and does 830 nothing if no tests are defined or if the file failed to load." 831 :init-value nil :lighter (cider-mode " Test") :keymap nil 832 :global t 833 (if cider-auto-test-mode 834 (add-hook 'cider-file-loaded-hook #'cider--test-silently) 835 (remove-hook 'cider-file-loaded-hook #'cider--test-silently))) 836 837 (provide 'cider-test) 838 839 ;;; cider-test.el ends here