(help-fns-function-name): New function

Consolidate code used in profiler and help--describe-command, and improve it while we're at it. Also use #' to quote a few function names along the way. * lisp/help-fns.el (help-fns--function-numbers, help-fns--function-names): New vars. (help-fns--display-function): New aux function. (help-fns-function-name): New function, inspired from `help--describe-command`. * lisp/help.el (help--describe-command): Use `help-fns-function-name`. (help--for-help-make-sections): Remove redundant "" arg to `mapconcat`. * lisp/profiler.el (profiler-format-entry, profiler-fixup-entry): Delete functions. (profiler-report-make-entry-part): Use `help-fns-function-name` instead. (profiler-report-find-entry): Use `push-button`. * lisp/transient.el (transient--debug): Use `help-fns-function-name` when available.
2024-11-21 06:55:39 +00:00 · 2024-03-21 19:40:20 -04:00 · 2024-03-21 19:40:20 -04:00 · a1f8702e83
commit a1f8702e83
parent 946280365d
6 changed files with 127 additions and 88 deletions
--- a/etc/NEWS
+++ b/etc/NEWS
@ -1647,6 +1647,12 @@ values.

 * Lisp Changes in Emacs 30.1

+** New function 'help-fns-function-name'.
+For named functions, it just returns the name and otherwise
+it returns a short "unique" string that identifies the function.
+In either case, the string is propertized so clicking on it gives
+further details.
+
 ** New function 'cl-type-of'.
 This function is like 'type-of' except that it sometimes returns
 a more precise type.  For example, for nil and t it returns 'null'
--- a/lisp/bind-key.el
+++ b/lisp/bind-key.el
@ -468,6 +468,7 @@ other modes.  See `override-global-mode'."
     ((and bind-key-describe-special-forms (functionp elem)
           (stringp (setq doc (documentation elem))))
      doc) ;;FIXME: Keep only the first line?
+     ;; FIXME: Use `help-fns-function-name'?
     ((consp elem)
      (if (symbolp (car elem))
          (format "#<%s>" (car elem))
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@ -2448,6 +2448,74 @@ one of them returns non-nil."
    (setq buffer-undo-list nil)
    (texinfo-mode)))

+(defconst help-fns--function-numbers
+  (make-hash-table :test 'equal :weakness 'value))
+(defconst help-fns--function-names (make-hash-table :weakness 'key))
+
+(defun help-fns--display-function (function)
+  (cond
+   ((subr-primitive-p function)
+    (describe-function function))
+   ((and (compiled-function-p function)
+         (not (and (fboundp 'kmacro-p) (kmacro-p function))))
+    (disassemble function))
+   (t
+    ;; FIXME: Use cl-print!
+    (pp-display-expression function "*Help Source*" (consp function)))))
+
+;;;###autoload
+(defun help-fns-function-name (function)
+  "Return a short string representing FUNCTION."
+  ;; FIXME: For kmacros, should we print the key-sequence?
+  (cond
+   ((symbolp function)
+    (let ((name (if (eq (intern-soft (symbol-name function)) function)
+                    (symbol-name function)
+                  (concat "#:" (symbol-name function)))))
+      (if (not (fboundp function))
+          name
+        (make-text-button name nil
+                          'type 'help-function
+                          'help-args (list function)))))
+   ((gethash function help-fns--function-names))
+   ((subrp function)
+    (let ((name (subr-name function)))
+      ;; FIXME: For native-elisp-functions, should we use `help-function'
+      ;; or `disassemble'?
+      (format "#<%s %s>"
+              (cl-type-of function)
+              (make-text-button name nil
+                                'type 'help-function
+                                ;; Let's hope the subr hasn't been redefined!
+                                'help-args (list (intern name))))))
+   (t
+    (let ((type (or (oclosure-type function)
+                    (if (consp function)
+                        (car function) (cl-type-of function))))
+          (hash (sxhash-eq function))
+          ;; Use 3 digits minimum.
+          (mask #xfff)
+          name)
+      (while
+          (let* ((hex (format (concat "%0"
+                                      (number-to-string (1+ (/ (logb mask) 4)))
+                                      "X")
+                              (logand mask hash)))
+                 ;; FIXME: For kmacros, we don't want to `disassemble'!
+                 (button (buttonize
+                          hex #'help-fns--display-function function
+                          ;; FIXME: Shouldn't `buttonize' add
+                          ;; the "mouse-2, RET:" prefix?
+                          "mouse-2, RET: Display the function's body")))
+            (setq name (format "#<%s %s>" type button))
+            (and (< mask (abs hash))    ; We can add more digits.
+                 (gethash name help-fns--function-numbers)))
+        ;; Add a digit.
+        (setq mask (+ (ash mask 4) #x0f)))
+      (puthash name function help-fns--function-numbers)
+      (puthash function name help-fns--function-names)
+      name))))
+
 (provide 'help-fns)

 ;;; help-fns.el ends here
--- a/lisp/help.el
+++ b/lisp/help.el
@ -301,6 +301,8 @@ Do not call this in the scope of `with-help-window'."
       (let ((first-message
 	      (cond ((or
 		      pop-up-frames
+		      ;; FIXME: `special-display-p' is obsolete since
+		      ;; the vars on which it depends are obsolete!
 		      (special-display-p (buffer-name standard-output)))
 		     (setq help-return-method (cons (selected-window) t))
 		     ;; If the help output buffer is a special display buffer,
@ -382,9 +384,9 @@ Do not call this in the scope of `with-help-window'."
        (propertize title 'face 'help-for-help-header)
        "\n\n"
        (help--for-help-make-commands commands))))
-   sections ""))
+   sections))

-(defalias 'help 'help-for-help)
+(defalias 'help #'help-for-help)
 (make-help-screen help-for-help
  (purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?")
  (concat
@ -876,7 +878,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
 	  (format "%s (translated from %s)" string otherstring))))))

 (defun help--binding-undefined-p (defn)
-  (or (null defn) (integerp defn) (equal defn 'undefined)))
+  (or (null defn) (integerp defn) (equal defn #'undefined)))

 (defun help--analyze-key (key untranslated &optional buffer)
  "Get information about KEY its corresponding UNTRANSLATED events.
@ -1221,7 +1223,7 @@ appeared on the mode-line."
 (defun describe-minor-mode-completion-table-for-symbol ()
  ;; In order to list up all minor modes, minor-mode-list
  ;; is used here instead of minor-mode-alist.
-  (delq nil (mapcar 'symbol-name minor-mode-list)))
+  (delq nil (mapcar #'symbol-name minor-mode-list)))

 (defun describe-minor-mode-from-symbol (symbol)
  "Display documentation of a minor mode given as a symbol, SYMBOL."
@ -1644,34 +1646,14 @@ Return nil if the key sequence is too long."
          (t value))))

 (defun help--describe-command (definition &optional translation)
-  (cond ((symbolp definition)
-         (if (and (fboundp definition)
-                  help-buffer-under-preparation)
-             (insert-text-button (symbol-name definition)
-                                 'type 'help-function
-                                 'help-args (list definition))
-           (insert (symbol-name definition)))
-         (insert "\n"))
-        ((or (stringp definition) (vectorp definition))
+  (cond ((or (stringp definition) (vectorp definition))
         (if translation
             (insert (key-description definition nil) "\n")
+           ;; These should be rare nowadays, replaced by `kmacro's.
           (insert "Keyboard Macro\n")))
        ((keymapp definition)
         (insert "Prefix Command\n"))
-        ((byte-code-function-p definition)
-         (insert (format "[%s]\n"
-                         (buttonize "byte-code" #'disassemble definition))))
-        ((and (consp definition)
-              (memq (car definition) '(closure lambda)))
-         (insert (format "[%s]\n"
-                         (buttonize
-                          (symbol-name (car definition))
-                          (lambda (_)
-                            (pp-display-expression
-                             definition "*Help Source*" t))
-                          nil "View definition"))))
-        (t
-         (insert "??\n"))))
+        (t (insert (help-fns-function-name definition) "\n"))))

 (define-obsolete-function-alias 'help--describe-translation
  #'help--describe-command "29.1")
@ -2011,8 +1993,8 @@ and some others."
  (if temp-buffer-resize-mode
      ;; `help-make-xrefs' may add a `back' button and thus increase the
      ;; text size, so `resize-temp-buffer-window' must be run *after* it.
-      (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append)
-    (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window)))
+      (add-hook 'temp-buffer-show-hook #'resize-temp-buffer-window 'append)
+    (remove-hook 'temp-buffer-show-hook #'resize-temp-buffer-window)))

 (defvar resize-temp-buffer-window-inhibit nil
  "Non-nil means `resize-temp-buffer-window' should not resize.")
@ -2256,7 +2238,7 @@ The `temp-buffer-window-setup-hook' hook is called."
 ;; Don't print to *Help*; that would clobber Help history.
 (defun help-form-show ()
  "Display the output of a non-nil `help-form'."
-  (let ((msg (eval help-form)))
+  (let ((msg (eval help-form t)))
    (if (stringp msg)
 	(with-output-to-temp-buffer " *Char Help*"
 	  (princ msg)))))
@ -2421,7 +2403,7 @@ the same names as used in the original source code, when possible."
                   (t arg)))
 		arglist)))

-(define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1")
+(define-obsolete-function-alias 'help-make-usage #'help--make-usage "25.1")

 (defun help--make-usage-docstring (fn arglist)
  (let ((print-escape-newlines t))
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@ -38,8 +38,7 @@

 (defcustom profiler-sampling-interval 1000000
  "Default sampling interval in nanoseconds."
-  :type 'natnum
-  :group 'profiler)
+  :type 'natnum)


 ;;; Utilities
@ -68,7 +67,7 @@
 	       collect c into s
 	       do (cl-decf i)
 	       finally return
-	       (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+	       (apply #'string (if (eq (car s) ?,) (cdr s) s)))
    (profiler-ensure-string number)))

 (defun profiler-format (fmt &rest args)
@ -76,7 +75,7 @@
 	   for arg in args
 	   for str = (cond
 		      ((consp subfmt)
-		       (apply 'profiler-format subfmt arg))
+		       (apply #'profiler-format subfmt arg))
 		      ((stringp subfmt)
 		       (format subfmt arg))
 		      ((and (symbolp subfmt)
@ -91,7 +90,8 @@
 	   if (< width len)
           collect (progn (put-text-property (max 0 (- width 2)) len
                                             'invisible 'profiler str)
-                          str) into frags
+                          str)
+           into frags
 	   else
 	   collect
           (let ((padding (make-string (max 0 (- width len)) ?\s)))
@ -100,32 +100,11 @@
 	       (right (concat padding str))))
 	   into frags
 	   finally return (apply #'concat frags)))
-
-
-;;; Entries
-
-(defun profiler-format-entry (entry)
-  "Format ENTRY in human readable string.
-ENTRY would be a function name of a function itself."
-  (cond ((memq (car-safe entry) '(closure lambda))
-	 (format "#<lambda %#x>" (sxhash entry)))
-	((byte-code-function-p entry)
-	 (format "#<compiled %#x>" (sxhash entry)))
-	((or (subrp entry) (symbolp entry) (stringp entry))
-	 (format "%s" entry))
-	(t
-	 (format "#<unknown %#x>" (sxhash entry)))))
-
-(defun profiler-fixup-entry (entry)
-  (if (symbolp entry)
-      entry
-    (profiler-format-entry entry)))
-

 ;;; Backtraces

 (defun profiler-fixup-backtrace (backtrace)
-  (apply 'vector (mapcar 'profiler-fixup-entry backtrace)))
+  (apply #'vector (mapcar #'help-fns-function-name backtrace)))


 ;;; Logs
@ -434,18 +413,15 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."

 (defcustom profiler-report-closed-mark "+"
  "An indicator of closed calltrees."
-  :type 'string
-  :group 'profiler)
+  :type 'string)

 (defcustom profiler-report-open-mark "-"
  "An indicator of open calltrees."
-  :type 'string
-  :group 'profiler)
+  :type 'string)

 (defcustom profiler-report-leaf-mark " "
  "An indicator of calltree leaves."
-  :type 'string
-  :group 'profiler)
+  :type 'string)

 (defvar profiler-report-cpu-line-format
  '((17 right ((12 right)
@ -474,17 +450,18 @@ Do not touch this variable directly.")
  (let ((string (cond
 		 ((eq entry t)
 		  "Others")
-		 ((and (symbolp entry)
-		       (fboundp entry))
-		  (propertize (symbol-name entry)
-			      'face 'link
-                              'follow-link "\r"
-			      'mouse-face 'highlight
-			      'help-echo "\
+		 (t (propertize (help-fns-function-name entry)
+		                ;; Override the `button-map' which
+		                ;; otherwise adds RET, mouse-1, and TAB
+		                ;; bindings we don't want.  :-(
+		                'keymap '(make-sparse-keymap)
+		                'follow-link "\r"
+		                ;; FIXME: The help-echo code gets confused
+		                ;; by the `follow-link' property and rewrites
+		                ;; `mouse-2' to `mouse-1' :-(
+		                'help-echo "\
 mouse-2: jump to definition\n\
-RET: expand or collapse"))
-		 (t
-		  (profiler-format-entry entry)))))
+RET: expand or collapse")))))
    (propertize string 'profiler-entry entry)))

 (defun profiler-report-make-name-part (tree)
@ -719,10 +696,13 @@ point."
        (current-buffer))
    (and event (setq event (event-end event))
         (posn-set-point event))
-    (let ((tree (profiler-report-calltree-at-point)))
-      (when tree
-        (let ((entry (profiler-calltree-entry tree)))
-          (find-function entry))))))
+    (save-excursion
+      (forward-line 0)
+      (let ((eol (pos-eol)))
+        (forward-button 1)
+        (if (> (point) eol)
+            (error "No entry found")
+          (push-button))))))

 (defun profiler-report-describe-entry ()
  "Describe entry at point."
--- a/lisp/transient.el
+++ b/lisp/transient.el
@ -1249,7 +1249,7 @@ symbol property.")
 (when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1
           (not read-extended-command-predicate))
  (setq read-extended-command-predicate
-        'transient-command-completion-not-suffix-only-p))
+        #'transient-command-completion-not-suffix-only-p))

 (defun transient-parse-suffix (prefix suffix)
  "Parse SUFFIX, to be added to PREFIX.
@ -1258,7 +1258,7 @@ SUFFIX is a suffix command or a group specification (of
  the same forms as expected by `transient-define-prefix').
 Intended for use in a group's `:setup-children' function."
  (cl-assert (and prefix (symbolp prefix)))
-  (eval (car (transient--parse-child prefix suffix))))
+  (eval (car (transient--parse-child prefix suffix)) t))

 (defun transient-parse-suffixes (prefix suffixes)
  "Parse SUFFIXES, to be added to PREFIX.
@ -1278,7 +1278,7 @@ Intended for use in a group's `:setup-children' function."
                (string suffix)))
         (mem (transient--layout-member loc prefix))
         (elt (car mem)))
-    (setq suf (eval suf))
+    (setq suf (eval suf t))
    (cond
     ((not mem)
      (message "Cannot insert %S into %s; %s not found"
@ -1736,7 +1736,8 @@ to `transient-predicate-map'.  Also see `transient-base-map'."
                           "Hide common commands"
                         "Show common permanently")))
               (list "C-x l" "Show/hide suffixes" #'transient-set-level)
-               (list "C-x a" #'transient-toggle-level-limit))))))))
+               (list "C-x a" #'transient-toggle-level-limit)))))
+       t)))

 (defvar-keymap transient-popup-navigation-map
  :doc "One of the keymaps used when popup navigation is enabled.
@ -2574,10 +2575,11 @@ value.  Otherwise return CHILDREN as is."
      (if (symbolp arg)
          (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)"
                   arg
-                   (or (and (symbolp this-command) this-command)
-                       (if (byte-code-function-p this-command)
-                           "#[...]"
-                         this-command))
+                   (if (fboundp 'help-fns-function-name)
+                       (help-fns-function-name this-command)
+                     (if (byte-code-function-p this-command)
+                         "#[...]"
+                       this-command))
                   (key-description (this-command-keys-vector))
                   transient--exitp
                   (cond ((keywordp (car args))
@ -2982,7 +2984,7 @@ transient is active."
  (interactive)
  (transient-set-value (transient-prefix-object)))

-(defalias 'transient-set-and-exit 'transient-set
+(defalias 'transient-set-and-exit #'transient-set
  "Set active transient's value for this Emacs session and exit.")

 (defun transient-save ()
@ -2990,7 +2992,7 @@ transient is active."
  (interactive)
  (transient-save-value (transient-prefix-object)))

-(defalias 'transient-save-and-exit 'transient-save
+(defalias 'transient-save-and-exit #'transient-save
  "Save active transient's value for this and future Emacs sessions and exit.")

 (defun transient-reset ()