From 44afe0596b64c7ca0c5f72ca33e8f56fb3dd1f7c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 19:40:20 -0400 Subject: [PATCH] (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. (cherry picked from commit a1f8702e8345254e6898d35e554bdc06ab09c3ca) --- etc/NEWS | 6 ++++ lisp/bind-key.el | 1 + lisp/help-fns.el | 68 +++++++++++++++++++++++++++++++++++++++++++ lisp/help.el | 44 +++++++++------------------- lisp/profiler.el | 74 +++++++++++++++++------------------------------ lisp/transient.el | 22 +++++++------- 6 files changed, 127 insertions(+), 88 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index e4453291fff..726e319b2a1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1785,6 +1785,12 @@ the region and never want to restrict 'undo' to that region, it is preferable to use the existing 'undo-inhibit-region' symbol property instead of this variable. +** 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' diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 1e59c75566a..780314fecbd 100644 --- 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)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 917f0094014..33988b4b091 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2471,6 +2471,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 diff --git a/lisp/help.el b/lisp/help.el index 3148e5b5a82..037c887eedb 100644 --- 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 @@ -880,7 +882,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. @@ -1225,7 +1227,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." @@ -1648,34 +1650,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") @@ -2015,8 +1997,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.") @@ -2260,7 +2242,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))))) @@ -2425,7 +2407,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)) diff --git a/lisp/profiler.el b/lisp/profiler.el index 80f84037a63..4e02cd1d890 100644 --- 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 "#" (sxhash entry))) - ((byte-code-function-p entry) - (format "#" (sxhash entry))) - ((or (subrp entry) (symbolp entry) (stringp entry)) - (format "%s" entry)) - (t - (format "#" (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." diff --git a/lisp/transient.el b/lisp/transient.el index 2d8566a3ac4..c3b9448e2c4 100644 --- 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 () -- 2.39.5