procyberian/emacs
1
0
Fork 0
Code Issues 1 Pull requests Projects 1 Releases Packages Wiki Activity Actions

Speed up describe-char when a property has a large value

Browse source 
Doing `C-u C-x =` on a buffer position where the overlay/text
properties hold large values (e.g. inside the profiler report)
can be surprisingly slow because it pretty prints all those properties.
Change the code to do the pretty printing more lazily.
While at it, share that duplicated code between `descr-text.el` and
`wid-browse.el`.

* lisp/emacs-lisp/pp.el (pp-insert-short-sexp): New function.

* lisp/descr-text.el (describe-text-sexp): Delete function.
(describe-property-list): Use `pp-insert-short-sexp` instead.

* lisp/wid-browse.el (widget-browse-sexp): Use `pp-insert-short-sexp`
and `widget--allow-insertion`.
This commit is contained in:
Stefan Monnier 2024-03-21 12:28:54 -04:00
parent 129bc91a2c
commit e819413e24
3 changed files with 44 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
lisp/descr-text.el
View file

@ -42,26 +42,6 @@
(insert-text-button
"(widget)Top" 'type 'help-info 'help-args '("(widget)Top")))
(defun describe-text-sexp (sexp)
"Insert a short description of SEXP in the current buffer."
(let ((pp (condition-case signal
(pp-to-string sexp)
(error (prin1-to-string signal)))))
(when (string-match-p "\n\\'" pp)
(setq pp (substring pp 0 (1- (length pp)))))
(if (and (not (string-search "\n" pp))
(<= (length pp) (- (window-width) (current-column))))
(insert pp)
(insert-text-button
"[Show]"
'follow-link t
'action (lambda (&rest _ignore)
(with-output-to-temp-buffer
"*Pp Eval Output*"
(princ pp)))
'help-echo "mouse-2, RET: pretty print value in another buffer"))))
(defun describe-property-list (properties)
"Insert a description of PROPERTIES in the current buffer.
PROPERTIES should be a list of overlay or text properties.
@ -92,7 +72,9 @@ into help buttons that call `describe-text-category' or
(format "%S" value)
'type 'help-face 'help-args (list value)))
(t
(describe-text-sexp value))))
(require 'pp)
(declare-function pp-insert-short-sexp "pp" (sexp &optional width))
(pp-insert-short-sexp value))))
(insert "\n")))
;;; Describe-Text Commands.
@ -522,24 +504,24 @@ The character information includes:
(setcar composition
(concat
" with the surrounding characters \""
(mapconcat 'describe-char-padded-string
(buffer-substring from pos) "")
(mapconcat #'describe-char-padded-string
(buffer-substring from pos))
"\" and \""
(mapconcat 'describe-char-padded-string
(buffer-substring (1+ pos) to) "")
(mapconcat #'describe-char-padded-string
(buffer-substring (1+ pos) to))
"\""))
(setcar composition
(concat
" with the preceding character(s) \""
(mapconcat 'describe-char-padded-string
(buffer-substring from pos) "")
(mapconcat #'describe-char-padded-string
(buffer-substring from pos))
"\"")))
(if (< (1+ pos) to)
(setcar composition
(concat
" with the following character(s) \""
(mapconcat 'describe-char-padded-string
(buffer-substring (1+ pos) to) "")
(mapconcat #'describe-char-padded-string
(buffer-substring (1+ pos) to))
"\""))
(setcar composition nil)))
(setcar (cdr composition)
@ -568,7 +550,7 @@ The character information includes:
("character"
,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)"
char-description
(apply 'propertize char-description
(apply #'propertize char-description
(text-properties-at pos))
char char char))
("charset"
@ -620,7 +602,7 @@ The character information includes:
(if (consp key-list)
(list "type"
(concat "\""
(mapconcat 'identity
(mapconcat #'identity
key-list "\" or \"")
"\"")
"with"
@ -721,7 +703,7 @@ The character information includes:
(let ((unicodedata (describe-char-unicode-data char)))
(if unicodedata
(cons (list "Unicode data" "") unicodedata))))))
(setq max-width (apply 'max (mapcar (lambda (x)
(setq max-width (apply #'max (mapcar (lambda (x)
(if (cadr x) (length (car x)) 0))
item-list)))
(set-buffer src-buf)
@ -736,7 +718,7 @@ The character information includes:
(dolist (clm (cdr elt))
(cond ((eq (car-safe clm) 'insert-text-button)
(insert " ")
(eval clm))
(eval clm t))
((not (zerop (length clm)))
(insert " " clm))))
(insert "\n"))))
@ -855,7 +837,7 @@ The character information includes:
(insert "\n")
(dolist (elt
(cond ((eq describe-char-unidata-list t)
(nreverse (mapcar 'car char-code-property-alist)))
(nreverse (mapcar #'car char-code-property-alist)))
((< char 32)
;; Temporary fix (2016-05-22): The
;; decomposition item for \n corrupts the
@ -898,7 +880,7 @@ characters."
(setq width (- width (length (car last)) 1)))
(let ((ellipsis (and (cdr last) "...")))
(setcdr last nil)
(concat (mapconcat 'identity words " ") ellipsis)))
(concat (mapconcat #'identity words " ") ellipsis)))
"")))
(defun describe-char-eldoc--format (ch &optional width)

17
lisp/emacs-lisp/pp.el
View file

@ -346,6 +346,23 @@ after OUT-BUFFER-NAME."
(setq buffer-read-only nil)
(setq-local font-lock-verbose nil)))))
(defun pp-insert-short-sexp (sexp &optional width)
"Insert a short description of SEXP in the current buffer.
WIDTH is the maximum width to use for it and it defaults to the
space available between point and the window margin."
(let ((printed (format "%S" sexp)))
(if (and (not (string-search "\n" printed))
(<= (string-width printed)
(or width (- (window-width) (current-column)))))
(insert printed)
(insert-text-button
"[Show]"
'follow-link t
'action (lambda (&rest _ignore)
;; FIXME: Why "eval output"?
(pp-display-expression sexp "*Pp Eval Output*"))
'help-echo "mouse-2, RET: pretty print value in another buffer"))))
;;;###autoload
(defun pp-eval-expression (expression)
"Evaluate EXPRESSION and pretty-print its value.

34
lisp/wid-browse.el
View file

@ -141,7 +141,7 @@ The following commands are available:
(setq key (nth 0 items)
value (nth 1 items)
printer (or (get key 'widget-keyword-printer)
'widget-browse-sexp)
#'widget-browse-sexp)
items (cdr (cdr items)))
(widget-insert "\n" (symbol-name key) "\n\t")
(funcall printer widget key value)
@ -204,24 +204,10 @@ VALUE is assumed to be a list of widgets."
(defun widget-browse-sexp (_widget _key value)
"Insert description of WIDGET's KEY VALUE.
Nothing is assumed about value."
(let ((pp (condition-case signal
(pp-to-string value)
(error (prin1-to-string signal)))))
(when (string-match "\n\\'" pp)
(setq pp (substring pp 0 (1- (length pp)))))
(if (cond ((string-search "\n" pp)
nil)
((> (length pp) (- (window-width) (current-column)))
nil)
(t t))
(widget-insert pp)
(widget-create 'push-button
:tag "show"
:action (lambda (widget &optional _event)
(with-output-to-temp-buffer
"*Pp Eval Output*"
(princ (widget-get widget :value))))
pp))))
(require 'pp)
(declare-function pp-insert-short-sexp "pp" (sexp &optional width))
(widget--allow-insertion
(pp-insert-short-sexp value)))
(defun widget-browse-sexps (widget key value)
"Insert description of WIDGET's KEY VALUE.
@ -235,11 +221,11 @@ VALUE is assumed to be a list of widgets."
;;; Keyword Printers.
(put :parent 'widget-keyword-printer 'widget-browse-widget)
(put :children 'widget-keyword-printer 'widget-browse-widgets)
(put :buttons 'widget-keyword-printer 'widget-browse-widgets)
(put :button 'widget-keyword-printer 'widget-browse-widget)
(put :args 'widget-keyword-printer 'widget-browse-sexps)
(put :parent 'widget-keyword-printer #'widget-browse-widget)
(put :children 'widget-keyword-printer #'widget-browse-widgets)
(put :buttons 'widget-keyword-printer #'widget-browse-widgets)
(put :button 'widget-keyword-printer #'widget-browse-widget)
(put :args 'widget-keyword-printer #'widget-browse-sexps)
;;; Widget Minor Mode.