mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-05 11:45:45 +00:00
cl-print: Put buttons on ellipses
Currently, in *Backtrace* we have a nice behavior for cl-printed objects where they're truncated by default to a manageable size but we can click on the "..." to expand them when needed. The patch below moves that functionality to `cl-print.el` such that it can be enjoyed "everywhere" (bug#64536). It also has the benefit of simplifying the code since `backtrace.el` had to look for ellipses in order to add buttons to them, whereas now we can put the ellipses right when we write them. * lisp/emacs-lisp/cl-print.el (cl-print-object-contents): Improve docstring. (cl-print-expand-ellipsis-function): New var. (cl-print--default-expand-ellipsis): New function. (cl-print-expand-ellipsis): New command. (cl-print-insert-ellipsis): Allow nil instead of 0 to mean "this elides the whole object". (cl-print-ellipsis): Move button type from `backtrace.el`. (cl-print-propertize-ellipsis): Put a button. (cl-print--expand-ellipsis): Rename from `cl-print-expand-ellipsis`. (cl-print-to-string-with-limit): Allow new value t for `limit`. * lisp/emacs-lisp/backtrace.el (backtrace--font-lock-keywords): Simplify. (backtrace--match-ellipsis-in-string): Delete function. (backtrace--change-button-skip): Adjust to new button type name. (backtrace--expand-ellipsis): New function, extracted from `backtrace-expand-ellipsis`. (backtrace-expand-ellipsis): Delete function. (backtrace-ellipsis): Move button type to `cl-print.el`. (backtrace--print-to-string): Don't look for cl-print ellipses any more. (backtrace-mode): Use `backtrace--expand-ellipsis`. * lisp/ielm.el (ielm--expand-ellipsis): New function. (inferior-emacs-lisp-mode): Use it to fill the data when expanded. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-check-ellipsis-expansion) (cl-print-tests-check-ellipsis-expansion-rx): Adjust to new internal function name.
This commit is contained in:
Stefan Monnier
parent
ee4cc106b8
commit
3ffb99f28f
4
etc/NEWS
4
etc/NEWS
@ -92,6 +92,10 @@ plus, minus, check-mark, start, etc.
|
||||
The 'tool-bar-position' frame parameter can be set to 'bottom' on all
|
||||
window systems other than Nextstep.
|
||||
|
||||
** You can expand the "..." truncation everywhere.
|
||||
The code that allowed "..." to be expanded in the *Backtrace* should
|
||||
now work anywhere the data is generated by `cl-print`.
|
||||
|
||||
** Modeline elements can now be right-aligned.
|
||||
Anything following the symbol 'mode-line-format-right-align' in
|
||||
'mode-line-format' will be right-aligned. Exactly where it is
|
||||
|
||||
@ -1927,6 +1927,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
Local variables:
|
||||
coding: utf-8
|
||||
mode: outline
|
||||
mode: emacs-news
|
||||
paragraph-separate: "[ ]*$"
|
||||
end:
|
||||
|
||||
@ -123,7 +123,7 @@ argument).
|
||||
|
||||
In addition, the keyword argument :supertype may be used to specify a
|
||||
`button-type' from which NAME inherits its default property values
|
||||
(however, the inheritance happens only when NAME is defined; subsequent
|
||||
\(however, the inheritance happens only when NAME is defined; subsequent
|
||||
changes to a supertype are not reflected in its subtypes)."
|
||||
(declare (indent defun))
|
||||
(let ((catsym (make-symbol (concat (symbol-name name) "-button")))
|
||||
|
||||
@ -135,8 +135,7 @@ frames before its nearest activation frame are discarded."
|
||||
;; Font Locking support
|
||||
|
||||
(defconst backtrace--font-lock-keywords
|
||||
'((backtrace--match-ellipsis-in-string
|
||||
(1 'button prepend)))
|
||||
'()
|
||||
"Expressions to fontify in Backtrace mode.
|
||||
Fontify these in addition to the expressions Emacs Lisp mode
|
||||
fontifies.")
|
||||
@ -154,16 +153,6 @@ fontifies.")
|
||||
backtrace--font-lock-keywords)
|
||||
"Gaudy level highlighting for Backtrace mode.")
|
||||
|
||||
(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)
|
||||
(get-text-property (- (point) 4) 'cl-print-ellipsis))))
|
||||
|
||||
;;; Xref support
|
||||
|
||||
(defun backtrace--xref-backend () 'elisp)
|
||||
@ -425,11 +414,11 @@ the buffer."
|
||||
|
||||
(defun backtrace--change-button-skip (beg end value)
|
||||
"Change the skip property on all buttons between BEG and END.
|
||||
Set it to VALUE unless the button is a `backtrace-ellipsis' button."
|
||||
Set it to VALUE unless the button is a `cl-print-ellipsis' button."
|
||||
(let ((inhibit-read-only t))
|
||||
(setq beg (next-button beg))
|
||||
(while (and beg (< beg end))
|
||||
(unless (eq (button-type beg) 'backtrace-ellipsis)
|
||||
(unless (eq (button-type beg) cl-print-ellipsis)
|
||||
(button-put beg 'skip value))
|
||||
(setq beg (next-button beg)))))
|
||||
|
||||
@ -497,33 +486,15 @@ Reprint the frame with the new view plist."
|
||||
`(backtrace-index ,index backtrace-view ,view))
|
||||
(goto-char min)))
|
||||
|
||||
(defun backtrace-expand-ellipsis (button)
|
||||
"Expand display of the elided form at BUTTON."
|
||||
(goto-char (button-start button))
|
||||
(unless (get-text-property (point) 'cl-print-ellipsis)
|
||||
(if (and (> (point) (point-min))
|
||||
(get-text-property (1- (point)) 'cl-print-ellipsis))
|
||||
(backward-char)
|
||||
(user-error "No ellipsis to expand here")))
|
||||
(let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
|
||||
(begin (previous-single-property-change end 'cl-print-ellipsis))
|
||||
(value (get-text-property begin 'cl-print-ellipsis))
|
||||
(props (backtrace-get-text-properties begin))
|
||||
(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args)
|
||||
"Wrapper to expand an ellipsis.
|
||||
For use on `cl-print-expand-ellipsis-function'."
|
||||
(let* ((props (backtrace-get-text-properties begin))
|
||||
(inhibit-read-only t))
|
||||
(backtrace--with-output-variables (backtrace-get-view)
|
||||
(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))))
|
||||
(let ((end (apply orig-fun begin end val backtrace-line-length args)))
|
||||
(add-text-properties begin end props)
|
||||
end))))
|
||||
|
||||
(defun backtrace-expand-ellipses (&optional no-limit)
|
||||
"Expand display of all \"...\"s in the backtrace frame at point.
|
||||
@ -696,13 +667,6 @@ line and recenter window line accordingly."
|
||||
(recenter window-line)))
|
||||
(goto-char (point-min)))))
|
||||
|
||||
;; Define button type used for ...'s.
|
||||
;; Set skip property so you don't have to TAB through 100 of them to
|
||||
;; get to the next function name.
|
||||
(define-button-type 'backtrace-ellipsis
|
||||
'skip t 'action #'backtrace-expand-ellipsis
|
||||
'help-echo "mouse-2, RET: expand this ellipsis")
|
||||
|
||||
(defun backtrace-print-to-string (obj &optional limit)
|
||||
"Return a printed representation of OBJ formatted for backtraces.
|
||||
Attempt to get the length of the returned string under LIMIT
|
||||
@ -719,15 +683,6 @@ characters with appropriate settings of `print-level' and
|
||||
(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)
|
||||
@ -918,6 +873,8 @@ followed by `backtrace-print-frame', once for each stack frame."
|
||||
(setq-local filter-buffer-substring-function #'backtrace--filter-visible)
|
||||
(setq-local indent-line-function 'lisp-indent-line)
|
||||
(setq-local indent-region-function 'lisp-indent-region)
|
||||
(add-function :around (local 'cl-print-expand-ellipsis-function)
|
||||
#'backtrace--expand-ellipsis)
|
||||
(add-hook 'xref-backend-functions #'backtrace--xref-backend nil t))
|
||||
|
||||
(put 'backtrace-mode 'mode-class 'special)
|
||||
|
||||
@ -54,9 +54,12 @@ call other entry points instead, such as `cl-prin1'."
|
||||
(prin1 object stream))
|
||||
|
||||
(cl-defgeneric cl-print-object-contents (_object _start _stream)
|
||||
"Dispatcher to print the contents of OBJECT on STREAM.
|
||||
Print the contents starting with the item at START, without
|
||||
delimiters."
|
||||
"Dispatcher to print partial contents of OBJECT on STREAM.
|
||||
This is used when replacing an ellipsis with the contents it
|
||||
represents. OBJECT is the object that has been partially printed
|
||||
and START represents the place at which the contents where
|
||||
replaced with an ellipsis.
|
||||
Print the contents hidden by the ellipsis to STREAM."
|
||||
;; Every cl-print-object method which can print an ellipsis should
|
||||
;; have a matching cl-print-object-contents method to expand an
|
||||
;; ellipsis.
|
||||
@ -65,7 +68,7 @@ delimiters."
|
||||
(cl-defmethod cl-print-object ((object cons) stream)
|
||||
(if (and cl-print--depth (natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(cl-print-insert-ellipsis object nil stream)
|
||||
(let ((car (pop object)))
|
||||
(if (and print-quoted
|
||||
(memq car '(\, quote function \` \,@ \,.))
|
||||
@ -107,7 +110,7 @@ delimiters."
|
||||
(cl-defmethod cl-print-object ((object vector) stream)
|
||||
(if (and cl-print--depth (natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(cl-print-insert-ellipsis object nil stream)
|
||||
(princ "[" stream)
|
||||
(cl-print--vector-contents object 0 stream)
|
||||
(princ "]" stream)))
|
||||
@ -129,6 +132,8 @@ delimiters."
|
||||
(cl-print--vector-contents object start stream)) ;FIXME: η-redex!
|
||||
|
||||
(cl-defmethod cl-print-object ((object hash-table) stream)
|
||||
;; FIXME: Make it possible to see the contents, like `prin1' does,
|
||||
;; e.g. using ellipsis. Make sure `cl-fill' can pretty print the result!
|
||||
(princ "#<hash-table " stream)
|
||||
(princ (hash-table-test object) stream)
|
||||
(princ " " stream)
|
||||
@ -158,6 +163,9 @@ into a button whose action shows the function's disassembly.")
|
||||
|
||||
(autoload 'disassemble-1 "disass")
|
||||
|
||||
;; FIXME: Don't degenerate to `prin1' for the contents of char-tables
|
||||
;; and records!
|
||||
|
||||
(cl-defmethod cl-print-object ((object compiled-function) stream)
|
||||
(unless stream (setq stream standard-output))
|
||||
;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
|
||||
@ -212,7 +220,7 @@ into a button whose action shows the function's disassembly.")
|
||||
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
|
||||
(if (and cl-print--depth (natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(cl-print-insert-ellipsis object nil stream)
|
||||
(princ "#s(" stream)
|
||||
(princ (cl--struct-class-name (cl-find-class (type-of object))) stream)
|
||||
(cl-print--struct-contents object 0 stream)
|
||||
@ -250,7 +258,7 @@ into a button whose action shows the function's disassembly.")
|
||||
cl-print--depth
|
||||
(natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(cl-print-insert-ellipsis object nil stream)
|
||||
;; Print all or part of the string
|
||||
(when has-properties
|
||||
(princ "#(" stream))
|
||||
@ -325,6 +333,7 @@ into a button whose action shows the function's disassembly.")
|
||||
(cl-defmethod cl-print-object :around (object stream)
|
||||
;; FIXME: Only put such an :around method on types where it's relevant.
|
||||
(let ((cl-print--depth (if cl-print--depth (1+ cl-print--depth) 1)))
|
||||
;; FIXME: Handle print-level here once and forall?
|
||||
(cond
|
||||
(print-circle
|
||||
(let ((n (gethash object cl-print--number-table)))
|
||||
@ -401,10 +410,53 @@ into a button whose action shows the function's disassembly.")
|
||||
(cl-print--find-sharing object print-number-table)))
|
||||
print-number-table))
|
||||
|
||||
(define-button-type 'cl-print-ellipsis
|
||||
'skip t 'action #'cl-print-expand-ellipsis
|
||||
'help-echo "mouse-2, RET: expand this ellipsis")
|
||||
|
||||
(defvar cl-print-expand-ellipsis-function
|
||||
#'cl-print--default-expand-ellipsis
|
||||
"Function to tweak the way ellipses are expanded.
|
||||
The function is called with 3 arguments, BEG, END, and FUNC.
|
||||
BEG and END delimit the ellipsis that will be replaced.
|
||||
FUNC is the function that will do the expansion.
|
||||
It should be called with a single argument specifying the desired
|
||||
limit of the expansion's length, as used in `cl-print-to-string-with-limit'.
|
||||
FUNC will return the position of the end of the newly printed text.")
|
||||
|
||||
(defun cl-print--default-expand-ellipsis (begin end value line-length)
|
||||
(delete-region begin end)
|
||||
(insert (cl-print-to-string-with-limit
|
||||
#'cl-print--expand-ellipsis value line-length))
|
||||
(point))
|
||||
|
||||
|
||||
(defun cl-print-expand-ellipsis (&optional button)
|
||||
"Expand display of the elided form at BUTTON.
|
||||
BUTTON can also be a buffer position or nil (to mean point)."
|
||||
(interactive)
|
||||
(goto-char (cond
|
||||
((null button) (point))
|
||||
(t (button-start button))))
|
||||
(unless (get-text-property (point) 'cl-print-ellipsis)
|
||||
(if (and (> (point) (point-min))
|
||||
(get-text-property (1- (point)) 'cl-print-ellipsis))
|
||||
(backward-char)
|
||||
(user-error "No ellipsis to expand here")))
|
||||
(let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
|
||||
(begin (previous-single-property-change end 'cl-print-ellipsis))
|
||||
(value (get-text-property begin 'cl-print-ellipsis)))
|
||||
;; FIXME: Rather than `t' (i.e. reuse the print-length/level unchanged),
|
||||
;; I think it would make sense to increase the level by 1 and to
|
||||
;; double the length at each expansion step.
|
||||
(funcall cl-print-expand-ellipsis-function
|
||||
begin end value t)
|
||||
(goto-char begin)))
|
||||
|
||||
(defun cl-print-insert-ellipsis (object start stream)
|
||||
"Print \"...\" to STREAM with the `cl-print-ellipsis' text property.
|
||||
Save state in the text property in order to print the elided part
|
||||
of OBJECT later. START should be 0 if the whole OBJECT is being
|
||||
of OBJECT later. START should be nil if the whole OBJECT is being
|
||||
elided, otherwise it should be an index or other pointer into the
|
||||
internals of OBJECT which can be passed to
|
||||
`cl-print-object-contents' at a future time."
|
||||
@ -423,11 +475,12 @@ STREAM should be a buffer. OBJECT and START are as described in
|
||||
`cl-print-insert-ellipsis'."
|
||||
(let ((value (list object start cl-print--number-table
|
||||
cl-print--currently-printing)))
|
||||
;; FIXME: Make it into a button!
|
||||
(with-current-buffer stream
|
||||
(put-text-property beg end 'cl-print-ellipsis value stream))))
|
||||
(put-text-property beg end 'cl-print-ellipsis value stream)
|
||||
(make-text-button beg end :type 'cl-print-ellipsis))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-print-expand-ellipsis (value stream)
|
||||
(defun cl-print--expand-ellipsis (value stream)
|
||||
"Print the expansion of an ellipsis to STREAM.
|
||||
VALUE should be the value of the `cl-print-ellipsis' text property
|
||||
which was attached to the ellipsis by `cl-prin1'."
|
||||
@ -439,7 +492,7 @@ which was attached to the ellipsis by `cl-prin1'."
|
||||
(cl-print--currently-printing (nth 3 value)))
|
||||
(when (eq object (car cl-print--currently-printing))
|
||||
(pop cl-print--currently-printing))
|
||||
(if (equal start 0)
|
||||
(if (memq start '(0 nil))
|
||||
(cl-print-object object stream)
|
||||
(cl-print-object-contents object start stream))))
|
||||
|
||||
@ -474,22 +527,25 @@ characters with appropriate settings of `print-level' and
|
||||
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.
|
||||
`print-length' bound to nil, and it can also be t in which case
|
||||
PRINT-FUNCTION will be called with the current values of `print-level'
|
||||
and `print-length'.
|
||||
|
||||
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))
|
||||
abbreviating it with ellipses to fit within a size limit."
|
||||
(setq limit (and (not (eq limit 0)) 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-length (when limit
|
||||
(let* ((print-length (cond
|
||||
((null limit) nil)
|
||||
((eq limit t) print-length)
|
||||
(t (min limit 50))))
|
||||
(print-level (cond
|
||||
((null limit) nil)
|
||||
((eq limit t) print-level)
|
||||
(t (min 8 (truncate (log limit))))))
|
||||
(delta-length (when (natnump limit)
|
||||
(max 1 (truncate (/ print-length print-level))))))
|
||||
(with-temp-buffer
|
||||
(catch 'done
|
||||
@ -499,7 +555,7 @@ limit."
|
||||
(let ((result (- (point-max) (point-min))))
|
||||
;; Stop when either print-level is too low or the value is
|
||||
;; successfully printed in the space allowed.
|
||||
(when (or (not limit) (< result limit) (<= print-level 2))
|
||||
(when (or (not (natnump limit)) (< result limit) (<= print-level 2))
|
||||
(throw 'done (buffer-string)))
|
||||
(let* ((ratio (/ result limit))
|
||||
(delta-level (max 1 (min (- print-level 2) ratio))))
|
||||
|
||||
@ -500,6 +500,11 @@ behavior of the indirect buffer."
|
||||
"Run `ielm-indirect-setup-hook'."
|
||||
(run-hooks 'ielm-indirect-setup-hook))
|
||||
|
||||
(defun ielm--expand-ellipsis (orig-fun beg &rest args)
|
||||
(let ((end (copy-marker (apply orig-fun beg args) t)))
|
||||
(funcall pp-default-function beg end)
|
||||
end))
|
||||
|
||||
;;; Major mode
|
||||
|
||||
(define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM"
|
||||
@ -582,6 +587,8 @@ Customized bindings may be defined in `ielm-map', which currently contains:
|
||||
(setq-local comment-use-syntax t)
|
||||
(setq-local lexical-binding t)
|
||||
|
||||
(add-function :around (local 'cl-print-expand-ellipsis-function)
|
||||
#'ielm--expand-ellipsis)
|
||||
(setq-local indent-line-function #'ielm-indent-line)
|
||||
(setq-local ielm-working-buffer (current-buffer))
|
||||
(setq-local fill-paragraph-function #'lisp-fill-paragraph)
|
||||
|
||||
@ -25,6 +25,7 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-print)
|
||||
|
||||
(cl-defstruct (cl-print-tests-struct
|
||||
(:constructor cl-print-tests-con))
|
||||
@ -113,7 +114,7 @@
|
||||
(should pos)
|
||||
(setq value (get-text-property pos 'cl-print-ellipsis result))
|
||||
(should (equal expected result))
|
||||
(should (equal expanded (with-output-to-string (cl-print-expand-ellipsis
|
||||
(should (equal expanded (with-output-to-string (cl-print--expand-ellipsis
|
||||
value nil))))))
|
||||
|
||||
(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded)
|
||||
@ -122,7 +123,7 @@
|
||||
(value (get-text-property pos 'cl-print-ellipsis result)))
|
||||
(should (string-match expected result))
|
||||
(should (string-match expanded (with-output-to-string
|
||||
(cl-print-expand-ellipsis value nil))))))
|
||||
(cl-print--expand-ellipsis value nil))))))
|
||||
|
||||
(ert-deftest cl-print-tests-print-to-string-with-limit ()
|
||||
(let* ((thing10 (make-list 10 'a))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user