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

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`.

(cherry picked from commit e819413e24d81875abaf81c281115e695ad5cc28)

diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index eeab995c37d90bdea952553edfc85504ea34cbe8..524a6474cd42b73fc859dd6823ca18f46901117e 100644 (file)
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -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")))
 \f
 ;;; 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)

diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 569f70ca6045e1d7c3833a91a124b595fa682fba..de7468b3e38a74da5be05edb051ce23d7fdf8421 100644 (file)
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -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.

diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index bb56f3f62fb8f3cfa90be6865e68acc1e069e227..d4000187bd1c86fb8d28e2e7dcc3322c9b0c2863 100644 (file)
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -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.