diff options
Diffstat (limited to 'lisp/help-fns.el')
| -rw-r--r-- | lisp/help-fns.el | 184 |
1 files changed, 134 insertions, 50 deletions
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 7dfa6700b29..6402f770927 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -34,6 +34,7 @@ (require 'cl-lib) (require 'help-mode) +(require 'radix-tree) (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. @@ -43,6 +44,61 @@ The functions will receive the function name as argument.") ;; Functions +(defvar help-definition-prefixes nil + ;; FIXME: We keep `definition-prefixes' as a hash-table so as to + ;; avoid pre-loading radix-tree and because it takes slightly less + ;; memory. But when we use this table it's more efficient to + ;; represent it as a radix tree, since the main operation is to do + ;; `radix-tree-prefixes'. Maybe we should just bite the bullet and + ;; use a radix tree for `definition-prefixes' (it's not *that* + ;; costly, really). + "Radix-tree representation replacing `definition-prefixes'.") + +(defun help-definition-prefixes () + "Return the up-to-date radix-tree form of `definition-prefixes'." + (when (> (hash-table-count definition-prefixes) 0) + (maphash (lambda (prefix files) + (let ((old (radix-tree-lookup help-definition-prefixes prefix))) + (setq help-definition-prefixes + (radix-tree-insert help-definition-prefixes + prefix (append old files))))) + definition-prefixes) + (clrhash definition-prefixes)) + help-definition-prefixes) + +(defun help--loaded-p (file) + "Try and figure out if FILE has already been loaded." + (or (let ((feature (intern-soft file))) + (and feature (featurep feature))) + (let* ((re (load-history-regexp file)) + (done nil)) + (dolist (x load-history) + (if (string-match-p re (car x)) (setq done t))) + done))) + +(defun help--load-prefixes (prefixes) + (pcase-dolist (`(,prefix . ,files) prefixes) + (setq help-definition-prefixes + (radix-tree-insert help-definition-prefixes prefix nil)) + (dolist (file files) + ;; FIXME: Should we scan help-definition-prefixes to remove + ;; other prefixes of the same file? + ;; FIXME: this regexp business is not good enough: for file + ;; `toto', it will say `toto' is loaded when in reality it was + ;; just cedet/semantic/toto that has been loaded. + (unless (help--loaded-p file) + (load file 'noerror 'nomessage))))) + +(defun help--symbol-completion-table (string pred action) + (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) + (help--load-prefixes prefixes)) + (let ((prefix-completions + (mapcar #'intern (all-completions string definition-prefixes)))) + (complete-with-action action obarray string + (if pred (lambda (sym) + (or (funcall pred sym) + (memq sym prefix-completions))))))) + (defvar describe-function-orig-buffer nil "Buffer that was current when `describe-function' was invoked. Functions on `help-fns-describe-function-functions' can use this @@ -59,7 +115,7 @@ When called from lisp, FUNCTION may also be a function object." (if fn (format "Describe function (default %s): " fn) "Describe function: ") - obarray 'fboundp t nil nil + #'help--symbol-completion-table #'fboundp t nil nil (and fn (symbol-name fn))))) (unless (equal val "") (setq fn (intern val))) @@ -68,6 +124,7 @@ When called from lisp, FUNCTION may also be a function object." (unless (fboundp fn) (user-error "Symbol's function definition is void: %s" fn)) (list fn))) + ;; We save describe-function-orig-buffer on the help xref stack, so ;; it is restored by the back/forward buttons. 'help-buffer' ;; expects (current-buffer) to be a help buffer when processing @@ -516,13 +573,17 @@ FILE is the file where FUNCTION was probably defined." (aliased (or (symbolp def) ;; Advised & aliased function. (and advised (symbolp real-function) - (not (eq 'autoload (car-safe def)))))) + (not (eq 'autoload (car-safe def)))) + (and (subrp def) + (not (string= (subr-name def) + (symbol-name function)))))) (real-def (cond - (aliased (let ((f real-function)) - (while (and (fboundp f) - (symbolp (symbol-function f))) - (setq f (symbol-function f))) - f)) + ((and aliased (not (subrp def))) + (let ((f real-function)) + (while (and (fboundp f) + (symbolp (symbol-function f))) + (setq f (symbol-function f))) + f)) ((subrp def) (intern (subr-name def))) (t def))) (sig-key (if (subrp def) @@ -544,14 +605,14 @@ FILE is the file where FUNCTION was probably defined." ;; Print what kind of function-like object FUNCTION is. (princ (cond ((or (stringp def) (vectorp def)) "a keyboard macro") - ((subrp def) - (if (eq 'unevalled (cdr (subr-arity def))) - (concat beg "special form") - (concat beg "built-in function"))) ;; Aliases are Lisp functions, so we need to check ;; aliases before functions. (aliased (format-message "an alias for `%s'" real-def)) + ((subrp def) + (if (eq 'unevalled (cdr (subr-arity def))) + (concat beg "special form") + (concat beg "built-in function"))) ((autoloadp def) (format "%s autoloaded %s" (if (commandp def) "an interactive" "an") @@ -702,17 +763,23 @@ it is displayed along with the global value." (interactive (let ((v (variable-at-point)) (enable-recursive-minibuffers t) + (orig-buffer (current-buffer)) val) - (setq val (completing-read (if (symbolp v) - (format - "Describe variable (default %s): " v) - "Describe variable: ") - obarray - (lambda (vv) - (or (get vv 'variable-documentation) - (and (boundp vv) (not (keywordp vv))))) - t nil nil - (if (symbolp v) (symbol-name v)))) + (setq val (completing-read + (if (symbolp v) + (format + "Describe variable (default %s): " v) + "Describe variable: ") + #'help--symbol-completion-table + (lambda (vv) + ;; In case the variable only exists in the buffer + ;; the command we switch back to that buffer before + ;; we examine the variable. + (with-current-buffer orig-buffer + (or (get vv 'variable-documentation) + (and (boundp vv) (not (keywordp vv)))))) + t nil nil + (if (symbolp v) (symbol-name v)))) (list (if (equal val "") v (intern val))))) (let (file-name) @@ -761,9 +828,8 @@ it is displayed along with the global value." (unless valvoid (with-current-buffer standard-output (setq val-start-pos (point)) - (princ "value is ") - (let ((from (point)) - (line-beg (line-beginning-position)) + (princ "value is") + (let ((line-beg (line-beginning-position)) (print-rep (let ((rep (let ((print-quoted t)) @@ -772,17 +838,17 @@ it is displayed along with the global value." (format-message "`%s'" rep) rep)))) (if (< (+ (length print-rep) (point) (- line-beg)) 68) - (insert print-rep) + (insert " " print-rep) (terpri) (pp val) - (if (< (point) (+ 68 (line-beginning-position 0))) - (delete-region from (1+ from)) - (delete-region (1- from) from))) + ;; Remove trailing newline. + (delete-char -1)) (let* ((sv (get variable 'standard-value)) (origval (and (consp sv) (condition-case nil (eval (car sv)) - (error :help-eval-error))))) + (error :help-eval-error)))) + from) (when (and (consp sv) (not (equal origval val)) (not (equal origval :help-eval-error))) @@ -797,8 +863,6 @@ it is displayed along with the global value." ((bufferp locus) (princ (format "Local in buffer %s; " (buffer-name buffer)))) - ((framep locus) - (princ (format "It is a frame-local variable; "))) ((terminal-live-p locus) (princ (format "It is a terminal-local variable; "))) (t @@ -852,6 +916,7 @@ it is displayed along with the global value." (indirect-variable variable) (error variable))) (obsolete (get variable 'byte-obsolete-variable)) + (watchpoints (get-variable-watchers variable)) (use (car obsolete)) (safe-var (get variable 'safe-local-variable)) (doc (or (documentation-property @@ -901,6 +966,12 @@ if it is given a local binding.\n")))) (t "."))) (terpri)) + (when watchpoints + (setq extra-line t) + (princ " Calls these functions when changed: ") + (princ watchpoints) + (terpri)) + (when (member (cons variable val) (with-current-buffer buffer file-local-variables-alist)) @@ -913,29 +984,35 @@ if it is given a local binding.\n")))) (buffer-file-name buffer))) (dir-locals-find-file (buffer-file-name buffer)))) - (dir-file t)) + (is-directory nil)) (princ (substitute-command-keys " This variable's value is directory-local")) - (if (null file) - (princ ".\n") - (princ ", set ") - (if (consp file) ; result from cache - ;; If the cache element has an mtime, we - ;; assume it came from a file. - (if (nth 2 file) - (setq file (expand-file-name - dir-locals-file (car file))) - ;; Otherwise, assume it was set directly. - (setq file (car file) - dir-file nil))) - (princ (substitute-command-keys - (if dir-file - "by the file\n `" - "for the directory\n `"))) + (when (consp file) ; result from cache + ;; If the cache element has an mtime, we + ;; assume it came from a file. + (if (nth 2 file) + ;; (car file) is a directory. + (setq file (dir-locals--all-files (car file))) + ;; Otherwise, assume it was set directly. + (setq file (car file) + is-directory t))) + (if (null file) + (princ ".\n") + (princ ", set ") + (princ (substitute-command-keys + (cond + (is-directory "for the directory\n `") + ;; Many files matched. + ((and (consp file) (cdr file)) + (setq file (file-name-directory (car file))) + (format "by one of the\n %s files in the directory\n `" + dir-locals-file)) + (t (setq file (car file)) + "by the file\n `")))) (with-current-buffer standard-output (insert-text-button file 'type 'help-dir-local-var-def - 'help-args (list variable file))) + 'help-args (list variable file))) (princ (substitute-command-keys "'.\n")))) (princ (substitute-command-keys " This variable's value is file-local.\n")))) @@ -1101,7 +1178,13 @@ BUFFER should be a buffer or a buffer name." (if (or (not (vectorp docs)) (/= (length docs) 95)) (error "Invalid first extra slot in this category table\n")) (with-current-buffer standard-output - (insert "Legend of category mnemonics (see the tail for the longer description)\n") + (setq-default help-button-cache (make-marker)) + (insert "Legend of category mnemonics ") + (insert-button "(longer descriptions at the bottom)" + 'action help-button-cache + 'follow-link t + 'help-echo "mouse-2, RET: show full legend") + (insert "\n") (let ((pos (point)) (items 0) lines n) (dotimes (i 95) (if (aref docs i) (setq items (1+ items)))) @@ -1128,6 +1211,7 @@ BUFFER should be a buffer or a buffer name." "character(s)\tcategory mnemonics\n" "------------\t------------------") (describe-vector table 'help-describe-category-set) + (set-marker help-button-cache (point)) (insert "Legend of category mnemonics:\n") (dotimes (i 95) (let ((elt (aref docs i))) |