From: F. Jason Park <jp@neverwas.me>
Date: Fri, 9 Aug 2024 23:49:28 +0000 (-0700)
Subject: Indent ERT failure explanations rigidly
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=769f758436f98d777888f9d5f596406ad9004690;p=emacs.git

Indent ERT failure explanations rigidly

This also affects the listing of `should' forms produced by hitting
the L key on a test button in an ERT buffer.

* lisp/emacs-lisp/ert.el (ert--pp-with-indentation-and-newline):
Indent the pretty-printed result to match the caller's current column
as a reference indentation.
* test/lisp/emacs-lisp/ert-tests.el
(ert--pp-with-indentation-and-newline): New test.  (Bug#72561)

(cherry picked from commit 0a500193087efc96aa3791dc4c2084ef5f6c3c06)
---

diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 93dcfc39d1b..9ec23aec92e 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -1317,13 +1317,12 @@ empty string."
   "Pretty-print OBJECT, indenting it to the current column of point.
 Ensures a final newline is inserted."
   (let ((begin (point))
+        (cols (current-column))
         (pp-escape-newlines t)
         (print-escape-control-characters t))
     (pp object (current-buffer))
     (unless (bolp) (insert "\n"))
-    (save-excursion
-      (goto-char begin)
-      (indent-sexp))))
+    (indent-rigidly begin (point) cols)))
 
 (defun ert--insert-infos (result)
   "Insert `ert-info' infos from RESULT into current buffer.
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 1aff73d66f6..9ca336697a6 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -876,6 +876,60 @@ This macro is used to test if macroexpansion in `should' works."
   (should (eq (ert--get-explainer 'string-equal) 'ert--explain-string-equal))
   (should (eq (ert--get-explainer 'string=) 'ert--explain-string-equal)))
 
+(ert-deftest ert--pp-with-indentation-and-newline ()
+  :tags '(:causes-redisplay)
+  (let ((failing-test (make-ert-test
+                       :name 'failing-test
+                       :body (lambda ()
+                               (should (equal '((:one "1" :three "3" :two "2"))
+                                              '((:one "1")))))))
+        (want-body "\
+Selector: <failing-test>
+Passed:  0
+Failed:  1 (1 unexpected)
+Skipped: 0
+Total:   1/1
+
+Started at:   @@TIMESTAMP@@
+Finished.
+Finished at:  @@TIMESTAMP@@
+
+F
+
+F failing-test
+    (ert-test-failed
+     ((should (equal '((:one \"1\" :three \"3\" :two \"2\")) '((:one \"1\"))))
+      :form (equal ((:one \"1\" :three \"3\" :two \"2\")) ((:one \"1\"))) :value
+      nil :explanation
+      (list-elt 0
+                (proper-lists-of-different-length 6 2
+                                                  (:one \"1\" :three \"3\"
+                                                        :two \"2\")
+                                                  (:one \"1\")
+                                                  first-mismatch-at 2))))
+\n\n")
+        (want-msg "Ran 1 tests, 0 results were as expected, 1 unexpected")
+        (buffer-name (generate-new-buffer-name " *ert-test-run-tests*")))
+    (cl-letf* ((ert-debug-on-error nil)
+               (ert--output-buffer-name buffer-name)
+               (messages nil)
+               ((symbol-function 'message)
+                (lambda (format-string &rest args)
+                  (push (apply #'format format-string args) messages)))
+               ((symbol-function 'ert--format-time-iso8601)
+                (lambda (_) "@@TIMESTAMP@@")))
+      (save-window-excursion
+        (unwind-protect
+            (let ((fill-column 70))
+              (ert-run-tests-interactively failing-test)
+              (should (equal (list want-msg) messages))
+              (should (equal (string-replace "\t" "        "
+                                             (with-current-buffer buffer-name
+                                               (buffer-string)))
+                             want-body)))
+          (when noninteractive
+            (kill-buffer buffer-name)))))))
+
 (provide 'ert-tests)
 
 ;;; ert-tests.el ends here