[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master a1f8702e834: (help-fns-function-name): New function
|
From: |
Stefan Monnier |
|
Subject: |
master a1f8702e834: (help-fns-function-name): New function |
|
Date: |
Thu, 21 Mar 2024 19:40:30 -0400 (EDT) |
branch: master
commit a1f8702e8345254e6898d35e554bdc06ab09c3ca
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
(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.
---
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 ba0e4c80fa0..eda84d588a8 100644
--- 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'
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 15d87f9925c..422f6e9dddf 100644
--- 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
diff --git a/lisp/help.el b/lisp/help.el
index c6a1e3c6bd9..4171d0c57c7 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
@@ -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))
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 "#<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."
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 ()
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master a1f8702e834: (help-fns-function-name): New function,
Stefan Monnier <=