[Emacs-diffs] scratch/backtrace-mode fb3578b 11/11: Add new command to expand all "..."s in a backtrace frame

[Gemini Lasswell]

branch: scratch/backtrace-mode
commit fb3578bb1b6f852d651eedd17057e92f6ff23fc4
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>

    Add new command to expand all "..."s in a backtrace frame
    
    Also move the code that tries to fit a printed representation into a
    limited number of characters using appropriate values of print-level
    and print-length into a new function in cl-print.el for future use by
    other parts of Emacs.
    * doc/lispref/debugging.texi (Backtraces): Document new keybinding.
    * lisp/emacs-lisp/backtrace.el (backtrace-line-length): Add the
    option of unlimited line length.
    (backtrace--match-ellipsis-in-string): Add a comment to explain
    why this function is necessary.
    (backtrace-mode-map): Add keybinding for 'backtrace-expand-ellipses'.
    (backtrace-expand-ellipsis): Use 'cl-print-to-string-with-limit'.
    (backtrace-expand-ellipses): New function.
    (backtrace-pretty-print): Update TODO comment with bug number.
    (backtrace-print-to-string): Use 'cl-print-to-string-with-limit'.
    Tag the printed forms with a gensym instead of the values of
    print-length and print-level.
    (backtrace--print): Add 'stream' argument.
    (backtrace-mode): Remove a TODO comment.
    * test/lisp/emacs-lisp/backtrace-tests.el
    (backtrace-tests--expand-ellipsis): Make the test less dependent
    on the implementation.
    (backtrace-tests--expand-ellipses): New test.
    
    * lisp/emacs-lisp/cl-print.el (cl-print-to-string-with-limit): New
    function.
    * test/lisp/emacs-lisp/cl-print-tests.el
    (cl-print-tests-print-to-string-with-limit): New test.
---
 doc/lispref/debugging.texi              |   3 +
 lisp/emacs-lisp/backtrace.el            | 126 ++++++++++++++++----------------
 lisp/emacs-lisp/cl-print.el             |  40 ++++++++++
 test/lisp/emacs-lisp/backtrace-tests.el |  60 ++++++++++++---
 test/lisp/emacs-lisp/cl-print-tests.el  |  36 +++++++++
 5 files changed, 193 insertions(+), 72 deletions(-)

diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index 5230854..87429a6 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -457,6 +457,9 @@ Collapse the top-level Lisp form at point back to a single 
line.
 @item #
 Toggle @code{print-circle} for the frame at point.
 
address@hidden .
+Expand all the forms abbreviated with ``...'' in the frame at point.
+
 @end table
 
 @node Debugger Commands
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index 79a0e64..50c5341 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -55,7 +55,8 @@ order to debug the code that does fontification."
   "Target length for lines in Backtrace buffers.
 Backtrace mode will attempt to abbreviate printing of backtrace
 frames to make them shorter than this, but success is not
-guaranteed."
+guaranteed.  If set to nil or zero, Backtrace mode will not
+abbreviate the forms it prints."
   :type 'integer
   :group 'backtrace
   :version "27.1")
@@ -142,6 +143,9 @@ fontifies.")
 
 (defun backtrace--match-ellipsis-in-string (bound)
   ;; Fontify ellipses within strings as buttons.
+  ;; This is necessary because ellipses are text property buttons
+  ;; instead of overlay buttons, which is done because there could
+  ;; be a large number of them.
   (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t)
     (and (get-text-property (- (point) 2) 'cl-print-ellipsis)
          (get-text-property (- (point) 3) 'cl-print-ellipsis)
@@ -192,6 +196,7 @@ This is commonly used to recompute `backtrace-frames'.")
     (define-key map "\C-m" 'backtrace-help-follow-symbol)
     (define-key map "+" 'backtrace-pretty-print)
     (define-key map "-" 'backtrace-collapse)
+    (define-key map "." 'backtrace-expand-ellipses)
     (define-key map "x" 'backtrace-describe-point) ;TODO remove
     (define-key map [follow-link] 'mouse-face)
     (define-key map [mouse-2] 'mouse-select-window)
@@ -213,9 +218,7 @@ This is commonly used to recompute `backtrace-frames'.")
 ;; backtrace-form: A value applied to each printed representation of a
 ;;   top-level s-expression, which needs to be different for sexps
 ;;   printed adjacent to each other, so the limits can be quickly
-;;   found for pretty-printing.  The value chosen is a list contining
-;;   the values of print-level and print-length used to print the
-;;   sexp, and those values are used when expanding ellipses.
+;;   found for pretty-printing.
 
 (defsubst backtrace-get-index (&optional pos)
   "Return the index of the backtrace frame at POS.
@@ -447,9 +450,6 @@ Reprint the frame with the new view plist."
 
 (defun backtrace-expand-ellipsis (button)
   "Expand display of the elided form at BUTTON."
-  ;; TODO a command to expand all ... in form at point
-  ;; with argument, don't bind print-level, length??
-  ;; Enable undo so there's a way to go back?
   (interactive)
   (goto-char (button-start button))
   (unless (get-text-property (point) 'cl-print-ellipsis)
@@ -461,29 +461,48 @@ Reprint the frame with the new view plist."
          (begin (previous-single-property-change end 'cl-print-ellipsis))
          (value (get-text-property begin 'cl-print-ellipsis))
          (props (backtrace-get-text-properties begin))
-         (tag (backtrace-get-form begin))
-         (length (nth 0 tag))  ; TODO should this work with a target char count
-         (level (nth 1 tag))   ; like backtrace-print-to-string?
          (inhibit-read-only t))
     (backtrace--with-output-variables (backtrace-get-view)
-      (let ((print-level level)
-            (print-length length))
-        (delete-region begin end)
-        (cl-print-expand-ellipsis value (current-buffer))
-        (setq end (point))
-        (goto-char begin)
-        (while (< (point) end)
-          (let ((next (next-single-property-change (point) 'cl-print-ellipsis
-                                                   nil end)))
-            (when (get-text-property (point) 'cl-print-ellipsis)
-              (make-text-button (point) next :type 'backtrace-ellipsis))
-            (goto-char next)))
-        (goto-char begin)
-        (add-text-properties begin end props)))))
+      (delete-region begin end)
+      (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value
+                                          backtrace-line-length))
+      (setq end (point))
+      (goto-char begin)
+      (while (< (point) end)
+        (let ((next (next-single-property-change (point) 'cl-print-ellipsis
+                                                 nil end)))
+          (when (get-text-property (point) 'cl-print-ellipsis)
+            (make-text-button (point) next :type 'backtrace-ellipsis))
+          (goto-char next)))
+      (goto-char begin)
+      (add-text-properties begin end props))))
+
+(defun backtrace-expand-ellipses (&optional no-limit)
+  "Expand display of all \"...\"s in the backtrace frame at point.
+\\<backtrace-mode-map>
+Each ellipsis will be limited to `backtrace-line-length'
+characters in its expansion.  With optional prefix argument
+NO-LIMIT, do not limit the number of characters.  Note that with
+or without the argument, using this command can result in very
+long lines and very poor display performance.  If this happens
+and is a problem, use `\\[revert-buffer]' to return to the
+initial state of the Backtrace buffer."
+  (interactive "P")
+  (save-excursion
+    (let ((start (backtrace-get-frame-start))
+          (end (backtrace-get-frame-end))
+          (backtrace-line-length (unless no-limit backtrace-line-length)))
+      (goto-char end)
+      (while (> (point) start)
+        (let ((next (previous-single-property-change (point) 'cl-print-ellipsis
+                                                     nil start)))
+          (when (get-text-property (point) 'cl-print-ellipsis)
+            (push-button (point)))
+          (goto-char next))))))
 
 (defun backtrace-pretty-print ()
   "Pretty-print the top level s-expression at point."
-  ;; TODO indent-sexp is broken with print-circle syntax
+  ;; indent-sexp is broken with print-circle syntax (bug#31984).
   (interactive)
   (backtrace--reformat-sexp #'backtrace--pretty-print
                             "No form here to pretty-print"))
@@ -645,8 +664,7 @@ line and recenter window line accordingly."
   "Return a printed representation of OBJ formatted for backtraces.
 Attempt to get the length of the returned string under LIMIT
 charcters with appropriate settings of `print-level' and
-`print-length.'  Attach the settings used with the text property
-`backtrace-form'.  LIMIT defaults to `backtrace-line-length'."
+`print-length.'  LIMIT defaults to `backtrace-line-length'."
   (backtrace--with-output-variables backtrace-view
     (backtrace--print-to-string obj limit)))
 
@@ -654,36 +672,20 @@ charcters with appropriate settings of `print-level' and
   ;; This is for use by callers who wrap the call with
   ;; backtrace--with-output-variables.
   (setq limit (or limit backtrace-line-length))
-  (let* ((length 50)  ; (/ backtrace-line-length 100) ??
-         (level (truncate (log limit)))
-         (delta (truncate (/ length level))))
-    (with-temp-buffer
-       (catch 'done
-         (while t
-           (erase-buffer)
-           (let ((standard-output (current-buffer))
-                 (print-length length)
-                 (print-level level))
-             (backtrace--print sexp))
-           ;; Stop when either the level is too low or the sexp is
-           ;; successfully printed in the space allowed.
-           (when (or (< (- (point-max) (point-min)) limit) (= level 2))
-             (throw 'done nil))
-           (cl-decf level)
-           (cl-decf length delta)))
-       (put-text-property (point-min) (point)
-                          'backtrace-form (list length level))
-       ;; Make buttons from all the "..."s.
-       ;; TODO should this be under control of :do-ellipses in the view
-       ;; plist?
-       (goto-char (point-min))
-       (while (< (point) (point-max))
-         (let ((end (next-single-property-change (point) 'cl-print-ellipsis
-                                                 nil (point-max))))
-           (when (get-text-property (point) 'cl-print-ellipsis)
-             (make-text-button (point) end :type 'backtrace-ellipsis))
-           (goto-char end)))
-       (buffer-string))))
+  (with-temp-buffer
+    (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit))
+    ;; Add a unique backtrace-form property.
+    (put-text-property (point-min) (point) 'backtrace-form (gensym))
+    ;; Make buttons from all the "..."s.  Since there might be many of
+    ;; them, use text property buttons.
+    (goto-char (point-min))
+    (while (< (point) (point-max))
+      (let ((end (next-single-property-change (point) 'cl-print-ellipsis
+                                              nil (point-max))))
+        (when (get-text-property (point) 'cl-print-ellipsis)
+          (make-text-button (point) end :type 'backtrace-ellipsis))
+        (goto-char end)))
+    (buffer-string)))
 
 (defun backtrace-print-frame (frame view)
   "Insert a backtrace FRAME at point formatted according to VIEW.
@@ -768,14 +770,14 @@ Print them only if :show-locals is non-nil in the VIEW 
plist."
           (insert "\n")))
       (put-text-property beg (point) 'backtrace-section 'locals))))
 
-(defun backtrace--print (obj)
-  "Attempt to print OBJ using `backtrace-print-function'.
+(defun backtrace--print (obj &optional stream)
+  "Attempt to print OBJ to STREAM using `backtrace-print-function'.
 Fall back to `prin1' if there is an error."
   (condition-case err
-      (funcall backtrace-print-function obj)
+      (funcall backtrace-print-function obj stream)
     (error
      (message "Error in backtrace printer: %S" err)
-     (prin1 obj))))
+     (prin1 obj stream))))
 
 (defun backtrace-update-flags ()
   "Update the display of the flags in the backtrace frame at point."
@@ -846,8 +848,6 @@ followed by `backtrace-print-frame', once for each stack 
frame."
              backtrace-font-lock-keywords-1
              backtrace-font-lock-keywords-2)
             nil nil nil nil
-            ;; TODO This one doesn't look necessary:
-            ;; (font-lock-mark-block-function . mark-defun)
            (font-lock-syntactic-face-function
             . lisp-font-lock-syntactic-face-function))))
   (setq truncate-lines t)
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 186ff8a..c26d719 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -524,5 +524,45 @@ node `(elisp)Output Variables'."
     (cl-prin1 object (current-buffer))
     (buffer-string)))
 
+;;;###autoload
+(defun cl-print-to-string-with-limit (print-function value limit)
+  "Return a string containing a printed representation of VALUE.
+Attempt to get the length of the returned string under LIMIT
+characters with appropriate settings of `print-level' and
+`print-length.'  Use PRINT-FUNCTION to print, which should take
+the arguments VALUE and STREAM and which should respect
+`print-length' and `print-level'.  LIMIT may be nil or zero in
+which case PRINT-FUNCTION will be called with `print-level' and
+`print-length' bound to nil.
+
+Use this function with `cl-prin1' to print an object,
+abbreviating it with ellipses to fit within a size limit.  Use
+this function with `cl-prin1-expand-ellipsis' to expand an
+ellipsis, abbreviating the expansion to stay within a size
+limit."
+  (setq limit (and (natnump limit)
+                   (not (zerop limit))
+                   limit))
+  ;; Since this is used by the debugger when stack space may be
+  ;; limited, if you increase print-level here, add more depth in
+  ;; call_debugger (bug#31919).
+  (let* ((print-length (when limit (min limit 50)))
+         (print-level (when limit (min 8 (truncate (log limit)))))
+         (delta (when limit
+                  (max 1 (truncate (/ print-length print-level))))))
+    (with-temp-buffer
+      (catch 'done
+        (while t
+          (erase-buffer)
+          (funcall print-function value (current-buffer))
+          ;; Stop when either print-level is too low or the value is
+          ;; successfully printed in the space allowed.
+          (when (or (not limit)
+                    (< (- (point-max) (point-min)) limit)
+                    (= print-level 2))
+            (throw 'done (buffer-string)))
+          (cl-decf print-level)
+          (cl-decf print-length delta))))))
+
 (provide 'cl-print)
 ;;; cl-print.el ends here
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el 
b/test/lisp/emacs-lisp/backtrace-tests.el
index a072c7c..eacebca 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -349,32 +349,74 @@ digit and replace with #[0-9]."
     (buffer-string)))
 
 (ert-deftest backtrace-tests--expand-ellipsis ()
-  "Backtrace buffers ellipsify large forms and can expand the ellipses."
+  "Backtrace buffers ellipsify large forms as buttons which expand the 
ellipses."
   ;; make a backtrace with an ellipsis
   ;; expand the ellipsis
   (ert-with-test-buffer (:name "variables")
     (let* ((print-level nil)
            (print-length nil)
-           (arg (let ((long (make-list 100 'a))
-                      (deep '(0 (1 (2 (3 (4 (5 (6 (7 (8 (9))))))))))))
-                  (setf (nth 1 long) deep)
-                  long))
+           (backtrace-line-length 300)
+           (arg (make-list 40 (make-string 10 ?a)))
            (results (backtrace-tests--result arg)))
       (backtrace-tests--make-backtrace arg)
       (backtrace-print)
 
-      ;; There should be two ellipses. Find and expand them.
+      ;; There should be an ellipsis. Find and expand it.
       (goto-char (point-min))
       (search-forward "...")
       (backward-char)
       (push-button)
-      (search-forward "...")
-      (backward-char)
-      (push-button)
 
       (should (string= (backtrace-tests--get-substring (point-min) (point-max))
                        results)))))
 
+(ert-deftest backtrace-tests--expand-ellipses ()
+  "Backtrace buffers ellipsify large forms and can expand the ellipses."
+  (ert-with-test-buffer (:name "variables")
+    (let* ((print-level nil)
+           (print-length nil)
+           (backtrace-line-length 300)
+           (arg (let ((outer (make-list 40 (make-string 10 ?a)))
+                      (nested (make-list 40 (make-string 10 ?b))))
+                  (setf (nth 39 nested) (make-list 40 (make-string 10 ?c)))
+                  (setf (nth 39 outer) nested)
+                  outer))
+           (results (backtrace-tests--result-with-locals arg)))
+
+      ;; Make a backtrace with local variables visible.
+      (backtrace-tests--make-backtrace arg)
+      (backtrace-print)
+      (backtrace-toggle-locals '(4))
+
+      ;; There should be two ellipses.
+      (goto-char (point-min))
+      (should (search-forward "..."))
+      (should (search-forward "..."))
+      (should-error (search-forward "..."))
+
+      ;; Expanding the last frame without argument should expand both
+      ;; ellipses, but the expansions will contain one ellipsis each.
+      (let ((buffer-len (- (point-max) (point-min))))
+        (goto-char (point-max))
+        (backtrace-backward-frame)
+        (backtrace-expand-ellipses)
+        (should (> (- (point-max) (point-min)) buffer-len))
+        (goto-char (point-min))
+        (should (search-forward "..."))
+        (should (search-forward "..."))
+        (should-error (search-forward "...")))
+
+      ;; Expanding with argument should remove all ellipses.
+      (goto-char (point-max))
+      (backtrace-backward-frame)
+      (backtrace-expand-ellipses '(4))
+      (goto-char (point-min))
+
+      (should-error (search-forward "..."))
+      (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+                       results)))))
+
+
 (ert-deftest backtrace-tests--to-string ()
   "Backtraces can be produced as strings."
   (let ((frames (ert-with-test-buffer (:name nil)
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el 
b/test/lisp/emacs-lisp/cl-print-tests.el
index 7594d24..2be1d2c 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -233,5 +233,41 @@
     (let ((print-circle t))
       (should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x))))))
 
+(ert-deftest cl-print-tests-print-to-string-with-limit ()
+  (let* ((thing10 (make-list 10 'a))
+         (thing100 (make-list 100 'a))
+         (thing10x10 (make-list 10 thing10))
+         (nested-thing (let ((val 'a))
+                         (dotimes (i 20)
+                           (setq val (list val)))
+                         val))
+         ;; Make a consistent environment for this test.
+         (print-circle nil)
+         (print-level nil)
+         (print-length nil))
+
+    ;; Print something that fits in the space given.
+    (should (string= (cl-prin1-to-string thing10)
+                     (cl-print-to-string-with-limit #'cl-prin1 thing10 100)))
+
+    ;; Print something which needs to be abbreviated and which can be.
+    (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100))
+               100
+               (length (cl-prin1-to-string thing100))))
+
+    ;; Print something resistant to easy abbreviation.
+    (should (string= (cl-prin1-to-string thing10x10)
+                     (cl-print-to-string-with-limit #'cl-prin1 thing10x10 
100)))
+
+    ;; Print something which should be abbreviated even if the limit is large.
+    (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 
1000))
+               (length (cl-prin1-to-string nested-thing))))
+
+    ;; Print with no limits.
+    (dolist (thing (list thing10 thing100 thing10x10 nested-thing))
+      (let ((rep (cl-prin1-to-string thing)))
+        (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 
0)))
+        (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 
nil)))))))
+
 
 ;;; cl-print-tests.el ends here.