(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'.
;; 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
(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))
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)
(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)
;; 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")
(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)
(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))
(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)))
(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))))
"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)))