You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

499 lines
19 KiB

;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
;; Copyright © 2014-2015 Jeff Valk
;; Author: Jeff Valk <jv@jeffvalk.com>
;; 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 <http://www.gnu.org/licenses/>.
;; This file is not part of GNU Emacs.
;;; Commentary:
;; This provides execution, reporting, and navigation support for Clojure tests,
;; specifically using the `clojure.test' machinery. This functionality replaces
;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on
;; nREPL middleware for report running and session support.
;;; Code:
(require 'cider-common)
(require 'cider-client)
(require 'cider-popup)
(require 'cider-stacktrace)
(require 'cider-compat)
(require 'button)
(require 'easymenu)
;;; Variables
(defgroup cider-test nil
"Presentation and navigation for test results."
:prefix "cider-test-"
:group 'cider)
(defcustom cider-test-show-report-on-success nil
"Whether to show the `*cider-test-report*` buffer on passing tests."
:type 'boolean
:group 'cider-test
:package-version '(cider . "0.8.0"))
(defcustom cider-auto-select-test-report-buffer t
"Determines if the test-report buffer should be auto-selected."
:type 'boolean
:group 'cider-test
:package-version '(cider . "0.9.0"))
(defvar cider-test-last-test-ns nil
"The namespace for which tests were last run.")
(defvar cider-test-last-results nil
"The results of the last run test.")
(defconst cider-test-report-buffer "*cider-test-report*"
"Buffer name in which to display test reports.")
(add-to-list 'cider-ancillary-buffers cider-test-report-buffer)
;;; Faces
;; These are as defined in clojure-test-mode.
(defface cider-test-failure-face
'((((class color) (background light))
:background "orange red")
(((class color) (background dark))
:background "firebrick"))
"Face for failed tests."
:group 'cider-test
:package-version '(cider . "0.7.0"))
(defface cider-test-error-face
'((((class color) (background light))
:background "orange1")
(((class color) (background dark))
:background "orange4"))
"Face for erring tests."
:group 'cider-test
:package-version '(cider . "0.7.0"))
(defface cider-test-success-face
'((((class color) (background light))
:foreground "black"
:background "green")
(((class color) (background dark))
:foreground "black"
:background "green"))
"Face for passing tests."
:group 'cider-test
:package-version '(cider . "0.7.0"))
;;; Report mode & key bindings
;; The primary mode of interacting with test results is the report buffer, which
;; allows navigation among tests, jumping to test definitions, expected/actual
;; diff-ing, and cause/stacktrace inspection for test errors.
(defvar cider-test-report-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c ,") #'cider-test-run-tests)
(define-key map (kbd "C-c C-,") #'cider-test-rerun-tests)
(define-key map (kbd "C-c M-,") #'cider-test-run-test)
(define-key map (kbd "M-p") #'cider-test-previous-result)
(define-key map (kbd "M-n") #'cider-test-next-result)
(define-key map (kbd "M-.") #'cider-test-jump)
(define-key map (kbd "<backtab>") #'cider-test-previous-result)
(define-key map (kbd "TAB") #'cider-test-next-result)
(define-key map (kbd "RET") #'cider-test-jump)
(define-key map (kbd "t") #'cider-test-jump)
(define-key map (kbd "d") #'cider-test-ediff)
(define-key map (kbd "e") #'cider-test-stacktrace)
(define-key map "q" #'cider-popup-buffer-quit-function)
(easy-menu-define cider-test-report-mode-menu map
"Menu for CIDER's test result mode"
'("Test-Report"
["Previous result" cider-test-previous-result]
["Next result" cider-test-next-result]
"--"
["Rerun current test" cider-test-run-test]
["Rerun failed/erring tests" cider-test-rerun-tests]
["Rerun all tests" cider-test-run-tests]
"--"
["Jump to test definition" cider-test-jump]
["Display test error" cider-test-stacktrace]
["Display expected/actual diff" cider-test-ediff]))
map))
(define-derived-mode cider-test-report-mode fundamental-mode "Test Report"
"Major mode for presenting Clojure test results.
\\{cider-test-report-mode-map}"
(setq buffer-read-only t)
(setq-local truncate-lines t)
(setq-local electric-indent-chars nil))
;; Report navigation
(defun cider-test-show-report ()
"Show the test report buffer, if one exists."
(interactive)
(if-let ((report-buffer (get-buffer cider-test-report-buffer)))
(switch-to-buffer report-buffer)
(message "No test report buffer")))
(defun cider-test-previous-result ()
"Move point to the previous test result, if one exists."
(interactive)
(with-current-buffer (get-buffer cider-test-report-buffer)
(when-let ((pos (previous-single-property-change (point) 'type)))
(goto-char pos))))
(defun cider-test-next-result ()
"Move point to the next test result, if one exists."
(interactive)
(with-current-buffer (get-buffer cider-test-report-buffer)
(when-let ((pos (next-single-property-change (point) 'type)))
(goto-char pos))))
(defun cider-test-jump (&optional arg)
"Like `cider-find-var', but uses the test at point's definition, if available."
(interactive "P")
(let ((ns (get-text-property (point) 'ns))
(var (get-text-property (point) 'var))
(line (get-text-property (point) 'line)))
(if (and ns var)
(cider-find-var arg (concat ns "/" var) line)
(cider-find-var arg))))
;;; Error stacktraces
(defvar cider-auto-select-error-buffer)
(defun cider-test-stacktrace-for (ns var index)
"Display stacktrace for the erring NS VAR test with the assertion INDEX."
(let (causes)
(cider-nrepl-send-request
(append
(list "op" "test-stacktrace" "session" (cider-current-session)
"ns" ns "var" var "index" index)
(when cider-stacktrace-print-length
(list "print-length" cider-stacktrace-print-length))
(when cider-stacktrace-print-level
(list "print-level" cider-stacktrace-print-level)))
(lambda (response)
(nrepl-dbind-response response (class status)
(cond (class (setq causes (cons response causes)))
(status (when causes
(cider-stacktrace-render
(cider-popup-buffer cider-error-buffer
cider-auto-select-error-buffer)
(reverse causes))))))))))
(defun cider-test-stacktrace ()
"Display stacktrace for the erring test at point."
(interactive)
(let ((ns (get-text-property (point) 'ns))
(var (get-text-property (point) 'var))
(index (get-text-property (point) 'index))
(err (get-text-property (point) 'error)))
(if (and err ns var index)
(cider-test-stacktrace-for ns var index)
(message "No test error at point"))))
;;; Expected vs actual diffing
(defvar cider-test-ediff-buffers nil
"The expected/actual buffers used to display diff.")
(defun cider-test-ediff ()
"Show diff of the expected vs actual value for the test at point.
With the actual value, the outermost '(not ...)' s-expression is removed."
(interactive)
(let ((expected (get-text-property (point) 'expected))
(actual (get-text-property (point) 'actual)))
(if (and expected actual)
(let ((expected-buffer (generate-new-buffer " *expected*"))
(actual-buffer (generate-new-buffer " *actual*")))
(with-current-buffer expected-buffer
(insert expected)
(clojure-mode))
(with-current-buffer actual-buffer
(insert actual)
(goto-char (point-min))
(forward-char)
(forward-sexp)
(forward-whitespace 1)
(let ((beg (point)))
(forward-sexp)
(let ((actual* (buffer-substring beg (point))))
(erase-buffer)
(insert actual*)))
(clojure-mode))
(apply 'ediff-buffers
(setq cider-test-ediff-buffers
(list (buffer-name expected-buffer)
(buffer-name actual-buffer)))))
(message "No test failure at point"))))
(defun cider-test-ediff-cleanup ()
"Cleanup expected/actual buffers used for diff."
(interactive)
(mapc (lambda (b) (when (get-buffer b) (kill-buffer b)))
cider-test-ediff-buffers))
(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup)
;;; Report rendering
(defun cider-test-type-face (type)
"Return the font lock face for the test result TYPE."
(pcase type
("pass" 'cider-test-success-face)
("fail" 'cider-test-failure-face)
("error" 'cider-test-error-face)
(_ 'default)))
(defun cider-test-render-summary (buffer summary)
"Emit into BUFFER the report SUMMARY statistics."
(with-current-buffer buffer
(nrepl-dbind-response summary (var test pass fail error)
(insert (format "Ran %d tests, in %d test functions\n" test var))
(unless (zerop fail)
(cider-insert (format "%d failures" fail) 'cider-test-failure-face t))
(unless (zerop error)
(cider-insert (format "%d errors" error) 'cider-test-error-face t))
(when (zerop (+ fail error))
(cider-insert (format "%d passed" pass) 'cider-test-success-face t))
(insert "\n\n"))))
(defun cider-test-render-assertion (buffer test)
"Emit into BUFFER report detail for the TEST assertion."
(with-current-buffer buffer
(nrepl-dbind-response test (var context type message expected actual error)
(cider-propertize-region (cider-intern-keys (cdr test))
(cider-insert (capitalize type) (cider-test-type-face type) nil " in ")
(cider-insert var 'font-lock-function-name-face t)
(when context (cider-insert context 'font-lock-doc-face t))
(when message (cider-insert message 'font-lock-doc-string-face t))
(when expected (cider-insert "expected: " 'font-lock-comment-face nil
(cider-font-lock-as-clojure expected)))
(when actual (cider-insert " actual: " 'font-lock-comment-face)
(if error
(progn (insert-text-button
error
'follow-link t
'action '(lambda (_button) (cider-test-stacktrace))
'help-echo "View causes and stacktrace")
(insert "\n"))
(insert (cider-font-lock-as-clojure actual)))))
(insert "\n"))))
(defun cider-test-render-report (buffer ns summary results)
"Emit into BUFFER the report for the NS, SUMMARY, and test RESULTS."
(with-current-buffer buffer
(let ((inhibit-read-only t))
(cider-test-report-mode)
(cider-insert "Test Summary" 'bold t)
(cider-insert ns 'font-lock-function-name-face t "\n")
(cider-test-render-summary buffer summary)
(nrepl-dbind-response summary (fail error)
(unless (zerop (+ fail error))
(cider-insert "Results" 'bold t "\n")
(nrepl-dict-map
(lambda (_var tests)
(dolist (test tests)
(nrepl-dbind-response test (type)
(unless (equal "pass" type)
(cider-test-render-assertion buffer test)))))
results)))
(goto-char (point-min))
(current-buffer))))
;;; Summary echo
(defun cider-test-echo-summary (summary)
"Echo SUMMARY statistics for a test run."
(nrepl-dbind-response summary (test fail error)
(message
(propertize
(format "Ran %s tests. %s failures, %s errors." test fail error)
'face (cond ((not (zerop error)) 'cider-test-error-face)
((not (zerop fail)) 'cider-test-failure-face)
(t 'cider-test-success-face))))))
;;; Test definition highlighting
;; On receipt of test results, failing/erring test definitions are highlighted.
;; Highlights are cleared on the next report run, and may be cleared manually
;; by the user.
;; NOTE If keybindings specific to test sources are desired, it would be
;; straightforward to turn this into a `cider-test-mode' minor mode, which we
;; enable on test sources, much like the legacy `clojure-test-mode'. At present,
;; though, there doesn't seem to be much value in this, since the report buffer
;; provides the primary means of interacting with test results.
(defun cider-test-highlight-problem (buffer test)
"Highlight the BUFFER test definition for the non-passing TEST."
(with-current-buffer buffer
(nrepl-dbind-response test (type file line message expected actual)
;; we have to watch out for vars without proper location metadata
;; right now everything evaluated interactively lacks this data
;; TODO: Figure out what to do when the metadata is missing
(when (and file line (not (cider--tooling-file-p file)))
(save-excursion
(goto-char (point-min))
(forward-line (1- line))
(forward-whitespace 1)
(forward-char)
(let ((beg (point)))
(forward-sexp)
(let ((overlay (make-overlay beg (point))))
(overlay-put overlay 'font-lock-face (cider-test-type-face type))
(overlay-put overlay 'type type)
(overlay-put overlay 'help-echo message)
(overlay-put overlay 'message message)
(overlay-put overlay 'expected expected)
(overlay-put overlay 'actual actual))))))))
(defun cider-find-var-file (var)
"Return the buffer visiting the file in which VAR is defined, or nil if
not found."
(cider-ensure-op-supported "info")
(when-let ((info (cider-var-info var))
(file (nrepl-dict-get info "file")))
(cider-find-file file)))
(defun cider-test-highlight-problems (ns results)
"Highlight all non-passing tests in the NS test RESULTS."
(nrepl-dict-map
(lambda (var tests)
(when-let ((buffer (cider-find-var-file (concat ns "/" var))))
(dolist (test tests)
(nrepl-dbind-response test (type)
(unless (equal "pass" type)
(cider-test-highlight-problem buffer test))))))
results))
(defun cider-test-clear-highlights ()
"Clear highlighting of non-passing tests from the last test run."
(interactive)
(when-let ((ns cider-test-last-test-ns))
(dolist (var (nrepl-dict-keys cider-test-last-results))
(when-let ((buffer (cider-find-var-file (concat ns "/" var))))
(with-current-buffer buffer
(remove-overlays))))))
;;; Test namespaces
;; Test namespace inference exists to enable DWIM test running functions: the
;; same "run-tests" function should be able to be used in a source file, and in
;; its corresponding test namespace. To provide this, we need to map the
;; relationship between those namespaces.
(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn
"Function to infer the test namespace for NS.
The default implementation uses the simple Leiningen convention of appending
'-test' to the namespace name."
:type 'symbol
:group 'cider-test
:package-version '(cider . "0.7.0"))
(defun cider-test-default-test-ns-fn (ns)
"For a NS, return the test namespace, which may be the argument itself.
This uses the Leiningen convention of appending '-test' to the namespace name."
(when ns
(let ((suffix "-test"))
;; string-suffix-p is only available in Emacs 24.4+
(if (string-match-p (rx-to-string `(: ,suffix eos) t) ns)
ns
(concat ns suffix)))))
;;; Test execution
(declare-function cider-emit-interactive-eval-output "cider-interaction")
(declare-function cider-emit-interactive-eval-err-output "cider-interaction")
(defun cider-test-execute (ns &optional retest tests)
"Run tests for NS; optionally RETEST failures or run only specified TESTS.
Upon test completion, results are echoed and a test report is optionally
displayed. When test failures/errors occur, their sources are highlighted."
(cider-test-clear-highlights)
(message "Testing...")
(cider-nrepl-send-request
(list "ns" ns "op" (if retest "retest" "test")
"tests" tests "session" (cider-current-session))
(lambda (response)
(nrepl-dbind-response response (summary results status out err)
(cond ((member "namespace-not-found" status)
(message "No tests namespace: %s" ns))
(out (cider-emit-interactive-eval-output out))
(err (cider-emit-interactive-eval-err-output err))
(results
(nrepl-dbind-response summary (error fail)
(setq cider-test-last-test-ns ns)
(setq cider-test-last-results results)
(cider-test-highlight-problems ns results)
(cider-test-echo-summary summary)
(when (or (not (zerop (+ error fail)))
cider-test-show-report-on-success)
(cider-test-render-report
(cider-popup-buffer cider-test-report-buffer
cider-auto-select-test-report-buffer)
ns summary results)))))))))
(defun cider-test-rerun-tests ()
"Rerun failed and erring tests from the last tested namespace."
(interactive)
(if-let ((ns cider-test-last-test-ns))
(cider-test-execute ns t)
(message "No namespace to retest")))
(defun cider-test-run-tests (suppress-inference)
"Run all tests for the current Clojure source or test report context.
With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the
current ns."
(interactive "P")
(if-let ((ns (if suppress-inference
(clojure-find-ns)
(or (funcall cider-test-infer-test-ns (clojure-find-ns))
(when (eq major-mode 'cider-test-report-mode)
cider-test-last-test-ns)))))
(cider-test-execute ns nil)
(message "No namespace to test in current context")))
(defun cider-test-run-test ()
"Run the test at point.
The test ns/var exist as text properties on report items and on highlighted
failed/erred test definitions. When not found, a test definition at point
is searched."
(interactive)
(let ((ns (get-text-property (point) 'ns))
(var (get-text-property (point) 'var)))
(if (and ns var)
(cider-test-execute ns nil (list var))
(let ((ns (clojure-find-ns))
(def (clojure-find-def)))
(if (and ns (member (car def) '("deftest" "defspec")))
(cider-test-execute ns nil (cdr def))
(message "No test at point"))))))
(provide 'cider-test)
;;; cider-test.el ends here