X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/77f497d292ace3e841827a7b12a18be5f78fe425..5deebc3c914c86e84d11661a7877c00b2d7fddd1:/lisp/help-fns.el diff --git a/lisp/help-fns.el b/lisp/help-fns.el index c3a5f26d26..9464c0b0d9 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 @@ -58,8 +114,9 @@ to get buffer-local values.") (setq val (completing-read (if fn (format "Describe function (default %s): " fn) "Describe function: ") - obarray 'fboundp t nil nil - (and fn (symbol-name fn)))) + #'help--symbol-completion-table + #'fboundp + t nil nil (and fn (symbol-name fn)))) (list (if (equal val "") fn (intern val))))) (or (and function (symbolp function)) @@ -514,7 +571,8 @@ FILE is the file where FUNCTION was probably defined." real-function)) (aliased (or (symbolp def) ;; Advised & aliased function. - (and advised (symbolp real-function)))) + (and advised (symbolp real-function) + (not (eq 'autoload (car-safe def)))))) (real-def (cond (aliased (let ((f real-function)) (while (and (fboundp f) @@ -526,7 +584,8 @@ FILE is the file where FUNCTION was probably defined." (sig-key (if (subrp def) (indirect-function real-def) real-def)) - (file-name (find-lisp-object-file-name function def)) + (file-name (find-lisp-object-file-name function (if aliased 'defun + def))) (pt1 (with-current-buffer (help-buffer) (point))) (beg (if (and (or (byte-code-function-p def) (keymapp def) @@ -541,14 +600,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") @@ -699,17 +758,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) @@ -758,9 +823,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)) @@ -769,17 +833,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))) @@ -1104,7 +1168,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)))) @@ -1131,6 +1201,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)))