1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-03 18:41:25 -08:00

Automatically find vars and functions via definition-prefixes

* lisp/help-fns.el (help-definition-prefixes): New var and function.
(help--loaded-p, help--load-prefixes, help--symbol-completion-table):
New functions.
(describe-function, describe-variable): Use them.

* lisp/emacs-lisp/radix-tree.el (radix-tree--prefixes)
(radix-tree-prefixes, radix-tree-from-map): New functions.
This commit is contained in:
Stefan Monnier 2016-06-15 13:21:59 -04:00
parent 40e0ef4811
commit fd8084aaf9
2 changed files with 119 additions and 4 deletions

View file

@ -103,6 +103,47 @@
(if (integerp val) `(t . ,val) val) (if (integerp val) `(t . ,val) val)
i)))) i))))
;; (defun radix-tree--trim (tree string i)
;; (if (= i (length string))
;; tree
;; (pcase tree
;; (`((,prefix . ,ptree) . ,rtree)
;; (let* ((ni (+ i (length prefix)))
;; (cmp (compare-strings prefix nil nil string i ni))
;; ;; FIXME: We could compute nrtree more efficiently
;; ;; whenever cmp is not -1 or 1.
;; (nrtree (radix-tree--trim rtree string i)))
;; (if (eq t cmp)
;; (pcase (radix-tree--trim ptree string ni)
;; (`nil nrtree)
;; (`((,pprefix . ,pptree))
;; `((,(concat prefix pprefix) . ,pptree) . ,nrtree))
;; (nptree `((,prefix . ,nptree) . ,nrtree)))
;; (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
;; (cond
;; ((equal (+ n i) (length string))
;; `((,prefix . ,ptree) . ,nrtree))
;; (t nrtree))))))
;; (val val))))
(defun radix-tree--prefixes (tree string i prefixes)
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (compare-strings prefix nil nil string i ni))
;; FIXME: We could compute prefixes more efficiently
;; whenever cmp is not -1 or 1.
(prefixes (radix-tree--prefixes rtree string i prefixes)))
(if (eq t cmp)
(radix-tree--prefixes ptree string ni prefixes)
prefixes)))
(val
(if (null val)
prefixes
(cons (cons (substring string 0 i)
(if (eq (car-safe val) t) (cdr val) val))
prefixes)))))
(defun radix-tree--subtree (tree string i) (defun radix-tree--subtree (tree string i)
(if (equal (length string) i) tree (if (equal (length string) i) tree
(pcase tree (pcase tree
@ -143,6 +184,16 @@ If not found, return nil."
"Return the subtree of TREE rooted at the prefix STRING." "Return the subtree of TREE rooted at the prefix STRING."
(radix-tree--subtree tree string 0)) (radix-tree--subtree tree string 0))
;; (defun radix-tree-trim (tree string)
;; "Return a TREE which only holds entries \"related\" to STRING.
;; \"Related\" is here defined as entries where there's a `string-prefix-p' relation
;; between STRING and the key."
;; (radix-tree-trim tree string 0))
(defun radix-tree-prefixes (tree string)
"Return an alist of all bindings in TREE for prefixes of STRING."
(radix-tree--prefixes tree string 0 nil))
(eval-and-compile (eval-and-compile
(pcase-defmacro radix-tree-leaf (vpat) (pcase-defmacro radix-tree-leaf (vpat)
;; FIXME: We'd like to use a negative pattern (not consp), but pcase ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
@ -181,8 +232,15 @@ PREFIX is only used internally."
(defun radix-tree-count (tree) (defun radix-tree-count (tree)
(let ((i 0)) (let ((i 0))
(radix-tree-iter-mappings tree (lambda (_ _) (setq i (1+ i)))) (radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i))))
i)) i))
(defun radix-tree-from-map (map)
;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...)
(require 'map)
(let ((rt nil))
(map-apply (lambda (k v) (setq rt (radix-tree-insert rt k v))) map)
rt))
(provide 'radix-tree) (provide 'radix-tree)
;;; radix-tree.el ends here ;;; radix-tree.el ends here

View file

@ -34,6 +34,7 @@
(require 'cl-lib) (require 'cl-lib)
(require 'help-mode) (require 'help-mode)
(require 'radix-tree)
(defvar help-fns-describe-function-functions nil (defvar help-fns-describe-function-functions nil
"List of functions to run in help buffer in `describe-function'. "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 ;; 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 (defvar describe-function-orig-buffer nil
"Buffer that was current when `describe-function' was invoked. "Buffer that was current when `describe-function' was invoked.
Functions on `help-fns-describe-function-functions' can use this 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 (setq val (completing-read (if fn
(format "Describe function (default %s): " fn) (format "Describe function (default %s): " fn)
"Describe function: ") "Describe function: ")
obarray 'fboundp t nil nil #'help--symbol-completion-table
(and fn (symbol-name fn)))) #'fboundp
t nil nil (and fn (symbol-name fn))))
(list (if (equal val "") (list (if (equal val "")
fn (intern val))))) fn (intern val)))))
(or (and function (symbolp function)) (or (and function (symbolp function))
@ -706,7 +763,7 @@ it is displayed along with the global value."
(format (format
"Describe variable (default %s): " v) "Describe variable (default %s): " v)
"Describe variable: ") "Describe variable: ")
obarray #'help--symbol-completion-table
(lambda (vv) (lambda (vv)
;; In case the variable only exists in the buffer ;; In case the variable only exists in the buffer
;; the command we switch back to that buffer before ;; the command we switch back to that buffer before