From d3b92616f35bef618016234bf158237b58a5a413 Mon Sep 17 00:00:00 2001 From: Tianxiang Xiong Date: Sat, 24 Sep 2016 19:57:21 -0700 Subject: [PATCH] Use font-lock for `describe-variable` As a side effect, clean up code. --- lisp/help-fns.el | 1052 ++++++++++++++++++++++++++---------------------------- 1 file changed, 504 insertions(+), 548 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index e4e2333..083db5f 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -35,6 +35,7 @@ (require 'cl-lib) (require 'help-mode) (require 'radix-tree) +(require 'subr-x) (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. @@ -109,16 +110,16 @@ describe-function "Display the full documentation of FUNCTION (a symbol)." (interactive (let ((fn (function-called-at-point)) - (enable-recursive-minibuffers t) - val) + (enable-recursive-minibuffers t) + val) (setq val (completing-read (if fn - (format "Describe function (default %s): " fn) - "Describe function: ") - #'help--symbol-completion-table + (format "Describe function (default %s): " fn) + "Describe function: ") + #'help--symbol-completion-table #'fboundp t nil nil (and fn (symbol-name fn)))) (list (if (equal val "") - fn (intern val))))) + fn (intern val))))) (or (and function (symbolp function)) (user-error "You didn't specify a function symbol")) (or (fboundp function) @@ -159,36 +160,36 @@ describe-function ;; "Return the name of the C file where SUBR-OR-VAR is defined. ;; KIND should be `var' for a variable or `subr' for a subroutine." ;; (symbol-file (if (symbolp subr-or-var) subr-or-var -;; (subr-name subr-or-var)) -;; (if (eq kind 'var) 'defvar 'defun))) +;; (subr-name subr-or-var)) +;; (if (eq kind 'var) 'defvar 'defun))) ;;;###autoload (defun help-C-file-name (subr-or-var kind) "Return the name of the C file where SUBR-OR-VAR is defined. KIND should be `var' for a variable or `subr' for a subroutine." (let ((docbuf (get-buffer-create " *DOC*")) - (name (if (eq 'var kind) - (concat "V" (symbol-name subr-or-var)) - (concat "F" (subr-name (advice--cd*r subr-or-var)))))) + (name (if (eq 'var kind) + (concat "V" (symbol-name subr-or-var)) + (concat "F" (subr-name (advice--cd*r subr-or-var)))))) (with-current-buffer docbuf (goto-char (point-min)) (if (eobp) - (insert-file-contents-literally - (expand-file-name internal-doc-file-name doc-directory))) + (insert-file-contents-literally + (expand-file-name internal-doc-file-name doc-directory))) (let ((file (catch 'loop - (while t - (let ((pnt (search-forward (concat "" name "\n")))) - (re-search-backward "S\\(.*\\)") - (let ((file (match-string 1))) - (if (member file build-files) - (throw 'loop file) - (goto-char pnt)))))))) - (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file) - (setq file (replace-match ".m" t t file 1)) - (if (string-match "\\.\\(o\\|obj\\)\\'" file) - (setq file (replace-match ".c" t t file)))) - (if (string-match "\\.\\(c\\|m\\)\\'" file) - (concat "src/" file) - file))))) + (while t + (let ((pnt (search-forward (concat "" name "\n")))) + (re-search-backward "S\\(.*\\)") + (let ((file (match-string 1))) + (if (member file build-files) + (throw 'loop file) + (goto-char pnt)))))))) + (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file) + (setq file (replace-match ".m" t t file 1)) + (if (string-match "\\.\\(o\\|obj\\)\\'" file) + (setq file (replace-match ".c" t t file)))) + (if (string-match "\\.\\(c\\|m\\)\\'" file) + (concat "src/" file) + file))))) (defcustom help-downcase-arguments nil "If non-nil, argument names in *Help* buffers are downcased." @@ -201,7 +202,7 @@ help-highlight-arg Return ARG in face `help-argument-name'; ARG is also downcased if the variable `help-downcase-arguments' is non-nil." (propertize (if help-downcase-arguments (downcase arg) arg) - 'face 'help-argument-name)) + 'face 'help-argument-name)) (defun help-do-arg-highlight (doc args) (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table) @@ -275,50 +276,50 @@ find-lisp-object-file-name means that OBJECT is a function or variable defined in C. If no suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) - (file-name (or (and autoloaded (nth 1 type)) - (symbol-file + (file-name (or (and autoloaded (nth 1 type)) + (symbol-file ;; FIXME: Why do we have this weird "If TYPE is the ;; value returned by `symbol-function' for a function ;; symbol" exception? - object (or (if (symbolp type) type) 'defun))))) + object (or (if (symbolp type) type) 'defun))))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' ;; has only returned a bare string here. (setq file-name - (locate-file file-name load-path '(".el" ".elc") 'readable))) + (locate-file file-name load-path '(".el" ".elc") 'readable))) ((and (stringp file-name) - (string-match "[.]*loaddefs.el\\'" file-name)) + (string-match "[.]*loaddefs.el\\'" file-name)) ;; An autoloaded variable or face. Visit loaddefs.el in a buffer ;; and try to extract the defining file. The following form is ;; from `describe-function-1' and `describe-variable'. (let ((location - (condition-case nil - (find-function-search-for-symbol object nil file-name) - (error nil)))) - (when (cdr location) - (with-current-buffer (car location) - (goto-char (cdr location)) - (when (re-search-backward - "^;;; Generated autoloads from \\(.*\\)" nil t) - (setq file-name - (locate-file - (file-name-sans-extension - (match-string-no-properties 1)) - load-path '(".el" ".elc") 'readable)))))))) + (condition-case nil + (find-function-search-for-symbol object nil file-name) + (error nil)))) + (when (cdr location) + (with-current-buffer (car location) + (goto-char (cdr location)) + (when (re-search-backward + "^;;; Generated autoloads from \\(.*\\)" nil t) + (setq file-name + (locate-file + (file-name-sans-extension + (match-string-no-properties 1)) + load-path '(".el" ".elc") 'readable)))))))) (cond ((and (not file-name) (subrp type)) ;; A built-in function. The form is from `describe-function-1'. (if (get-buffer " *DOC*") - (help-C-file-name type 'subr) - 'C-source)) + (help-C-file-name type 'subr) + 'C-source)) ((and (not file-name) (symbolp object) - (integerp (get object 'variable-documentation))) + (integerp (get object 'variable-documentation))) ;; A variable defined in C. The form is from `describe-variable'. (if (get-buffer " *DOC*") - (help-C-file-name object 'var) - 'C-source)) + (help-C-file-name object 'var) + 'C-source)) ((not (stringp file-name)) ;; If we don't have a file-name string by now, we lost. nil) @@ -327,34 +328,34 @@ find-lisp-object-file-name ;; This applies to config files like ~/.emacs, ;; which people sometimes compile. ((let (fn) - (and (string-match "\\`\\..*\\.elc\\'" - (file-name-nondirectory file-name)) - (string-equal (file-name-directory file-name) - (file-name-as-directory (expand-file-name "~"))) - (file-readable-p (setq fn (file-name-sans-extension file-name))) - fn))) + (and (string-match "\\`\\..*\\.elc\\'" + (file-name-nondirectory file-name)) + (string-equal (file-name-directory file-name) + (file-name-as-directory (expand-file-name "~"))) + (file-readable-p (setq fn (file-name-sans-extension file-name))) + fn))) ;; When the Elisp source file can be found in the install ;; directory, return the name of that file. ((let ((lib-name - (if (string-match "[.]elc\\'" file-name) - (substring-no-properties file-name 0 -1) - file-name))) - (or (and (file-readable-p lib-name) lib-name) - ;; The library might be compressed. - (and (file-readable-p (concat lib-name ".gz")) lib-name)))) + (if (string-match "[.]elc\\'" file-name) + (substring-no-properties file-name 0 -1) + file-name))) + (or (and (file-readable-p lib-name) lib-name) + ;; The library might be compressed. + (and (file-readable-p (concat lib-name ".gz")) lib-name)))) ((let* ((lib-name (file-name-nondirectory file-name)) - ;; The next form is from `describe-simplify-lib-file-name'. - (file-name - ;; Try converting the absolute file name to a library - ;; name, convert that back to a file name and see if we - ;; get the original one. If so, they are equivalent. - (if (equal file-name (locate-file lib-name load-path '(""))) - (if (string-match "[.]elc\\'" lib-name) - (substring-no-properties lib-name 0 -1) - lib-name) - file-name)) - (src-file (locate-library file-name t nil 'readable))) - (and src-file (file-readable-p src-file) src-file)))))) + ;; The next form is from `describe-simplify-lib-file-name'. + (file-name + ;; Try converting the absolute file name to a library + ;; name, convert that back to a file name and see if we + ;; get the original one. If so, they are equivalent. + (if (equal file-name (locate-file lib-name load-path '(""))) + (if (string-match "[.]elc\\'" lib-name) + (substring-no-properties lib-name 0 -1) + lib-name) + file-name)) + (src-file (locate-library file-name t nil 'readable))) + (and src-file (file-readable-p src-file) src-file)))))) (defun help-fns--key-bindings (function) (when (commandp function) @@ -376,7 +377,7 @@ help-fns--key-bindings (princ "Its keys are remapped to ") (princ (if (symbolp remapped) (format-message "`%s'" remapped) - "an anonymous command")) + "an anonymous command")) (princ ".\n")) (when keys @@ -489,14 +490,14 @@ help-fns--parent-mode (defun help-fns--obsolete (function) ;; Ignore lambda constructs, keyboard macros, etc. (let* ((obsolete (and (symbolp function) - (get function 'byte-obsolete-info))) + (get function 'byte-obsolete-info))) (use (car obsolete))) (when obsolete (insert "\nThis " - (if (eq (car-safe (symbol-function function)) 'macro) - "macro" - "function") - " is obsolete") + (if (eq (car-safe (symbol-function function)) 'macro) + "macro" + "function") + " is obsolete") (when (nth 2 obsolete) (insert (format " since %s" (nth 2 obsolete)))) (insert (cond ((stringp use) (concat ";\n" use)) @@ -509,13 +510,13 @@ help-fns--autoloaded-p "Return non-nil if FUNCTION has previously been autoloaded. FILE is the file where FUNCTION was probably defined." (let* ((file (file-name-sans-extension (file-truename file))) - (load-hist load-history) - (target (cons t function)) - found) + (load-hist load-history) + (target (cons t function)) + found) (while (and load-hist (not found)) (and (caar load-hist) - (equal (file-name-sans-extension (caar load-hist)) file) - (setq found (member target (cdar load-hist)))) + (equal (file-name-sans-extension (caar load-hist)) file) + (setq found (member target (cdar load-hist)))) (setq load-hist (cdr load-hist))) found)) @@ -556,128 +557,128 @@ help-fns-short-filename ;;;###autoload (defun describe-function-1 (function) (let* ((advised (and (symbolp function) - (featurep 'nadvice) - (advice--p (advice--symbol-function function)))) - ;; If the function is advised, use the symbol that has the - ;; real definition, if that symbol is already set up. - (real-function - (or (and advised + (featurep 'nadvice) + (advice--p (advice--symbol-function function)))) + ;; If the function is advised, use the symbol that has the + ;; real definition, if that symbol is already set up. + (real-function + (or (and advised (advice--cd*r (advice--symbol-function function))) - function)) - ;; Get the real definition. - (def (if (symbolp real-function) - (or (symbol-function real-function) - (signal 'void-function (list real-function))) - real-function)) - (aliased (or (symbolp def) - ;; Advised & aliased function. - (and advised (symbolp real-function) - (not (eq 'autoload (car-safe def)))) + function)) + ;; Get the real definition. + (def (if (symbolp real-function) + (or (symbol-function real-function) + (signal 'void-function (list real-function))) + real-function)) + (aliased (or (symbolp def) + ;; Advised & aliased function. + (and advised (symbolp real-function) + (not (eq 'autoload (car-safe def)))) (and (subrp def) (not (string= (subr-name def) (symbol-name function)))))) - (real-def (cond + (real-def (cond ((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) + ((subrp def) (intern (subr-name def))) + (t def))) + (sig-key (if (subrp def) (indirect-function real-def) real-def)) - (file-name (find-lisp-object-file-name function (if aliased 'defun + (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) - (memq (car-safe def) '(macro lambda closure))) - (stringp file-name) - (help-fns--autoloaded-p function file-name)) - (if (commandp def) - "an interactive autoloaded " - "an autoloaded ") - (if (commandp def) "an interactive " "a ")))) + (beg (if (and (or (byte-code-function-p def) + (keymapp def) + (memq (car-safe def) '(macro lambda closure))) + (stringp file-name) + (help-fns--autoloaded-p function file-name)) + (if (commandp def) + "an interactive autoloaded " + "an autoloaded ") + (if (commandp def) "an interactive " "a ")))) ;; Print what kind of function-like object FUNCTION is. (princ (cond ((or (stringp def) (vectorp def)) - "a keyboard macro") - ;; 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") - (if (eq (nth 4 def) 'keymap) "keymap" - (if (nth 4 def) "Lisp macro" "Lisp function")))) - ((or (eq (car-safe def) 'macro) - ;; For advised macros, def is a lambda - ;; expression or a byte-code-function-p, so we - ;; need to check macros before functions. - (macrop function)) - (concat beg "Lisp macro")) - ((byte-code-function-p def) - (concat beg "compiled Lisp function")) - ((eq (car-safe def) 'lambda) - (concat beg "Lisp function")) - ((eq (car-safe def) 'closure) - (concat beg "Lisp closure")) - ((keymapp def) - (let ((is-full nil) - (elts (cdr-safe def))) - (while elts - (if (char-table-p (car-safe elts)) - (setq is-full t - elts nil)) - (setq elts (cdr-safe elts))) - (concat beg (if is-full "keymap" "sparse keymap")))) - (t ""))) + "a keyboard macro") + ;; 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") + (if (eq (nth 4 def) 'keymap) "keymap" + (if (nth 4 def) "Lisp macro" "Lisp function")))) + ((or (eq (car-safe def) 'macro) + ;; For advised macros, def is a lambda + ;; expression or a byte-code-function-p, so we + ;; need to check macros before functions. + (macrop function)) + (concat beg "Lisp macro")) + ((byte-code-function-p def) + (concat beg "compiled Lisp function")) + ((eq (car-safe def) 'lambda) + (concat beg "Lisp function")) + ((eq (car-safe def) 'closure) + (concat beg "Lisp closure")) + ((keymapp def) + (let ((is-full nil) + (elts (cdr-safe def))) + (while elts + (if (char-table-p (car-safe elts)) + (setq is-full t + elts nil)) + (setq elts (cdr-safe elts))) + (concat beg (if is-full "keymap" "sparse keymap")))) + (t ""))) (if (and aliased (not (fboundp real-def))) - (princ ",\nwhich is not defined. Please make a bug report.") + (princ ",\nwhich is not defined. Please make a bug report.") (with-current-buffer standard-output - (save-excursion - (save-match-data - (when (re-search-backward (substitute-command-keys + (save-excursion + (save-match-data + (when (re-search-backward (substitute-command-keys "alias for `\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-function real-def))))) + (help-xref-button 1 'help-function real-def))))) (when file-name - ;; We used to add .el to the file name, - ;; but that's completely wrong when the user used load-file. - (princ (format-message " in `%s'" + ;; We used to add .el to the file name, + ;; but that's completely wrong when the user used load-file. + (princ (format-message " in `%s'" (if (eq file-name 'C-source) "C source code" (help-fns-short-filename file-name)))) - ;; Make a hyperlink to the library. - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-function-def function file-name)))) + (help-xref-button 1 'help-function-def function file-name)))) (princ ".") (with-current-buffer (help-buffer) - (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point)) - (point))) + (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point)) + (point))) (terpri)(terpri) (let ((doc-raw (documentation function t)) (key-bindings-buffer (current-buffer))) - ;; If the function is autoloaded, and its docstring has - ;; key substitution constructs, load the library. - (and (autoloadp real-def) doc-raw - help-enable-auto-load - (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) - (autoload-do-load real-def)) + ;; If the function is autoloaded, and its docstring has + ;; key substitution constructs, load the library. + (and (autoloadp real-def) doc-raw + help-enable-auto-load + (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) + (autoload-do-load real-def)) (help-fns--key-bindings function) (with-current-buffer standard-output @@ -708,15 +709,15 @@ variable-at-point If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (with-syntax-table emacs-lisp-mode-syntax-table (or (condition-case () - (save-excursion - (skip-chars-forward "'") - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (following-char)) ?w) - (eq (char-syntax (following-char)) ?_) - (forward-sexp -1)) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (boundp obj) obj))) + (save-excursion + (skip-chars-forward "'") + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (following-char)) ?w) + (eq (char-syntax (following-char)) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (boundp obj) obj))) (error nil)) (let* ((str (find-tag-default)) (sym (if str (intern-soft str)))) @@ -730,337 +731,292 @@ variable-at-point (defun describe-variable-custom-version-info (variable) (let ((custom-version (get variable 'custom-version)) - (cpv (get variable 'custom-package-version)) - (output nil)) + (cpv (get variable 'custom-package-version)) + (output nil)) (if custom-version - (setq output - (format "This variable was introduced, or its default value was changed, in\nversion %s of Emacs.\n" - custom-version)) + (setq output + (format "This variable was introduced, or its default value was changed, in version %s of Emacs.\n" + custom-version)) (when cpv - (let* ((package (car-safe cpv)) - (version (if (listp (cdr-safe cpv)) - (car (cdr-safe cpv)) - (cdr-safe cpv))) - (pkg-versions (assq package customize-package-emacs-version-alist)) - (emacsv (cdr (assoc version pkg-versions)))) - (if (and package version) - (setq output - (format (concat "This variable was introduced, or its default value was changed, in\nversion %s of the %s package" - (if emacsv - (format " that is part of Emacs %s" emacsv)) - ".\n") - version package)))))) + (let* ((package (car-safe cpv)) + (version (if (listp (cdr-safe cpv)) + (car (cdr-safe cpv)) + (cdr-safe cpv))) + (pkg-versions (assq package customize-package-emacs-version-alist)) + (emacsv (cdr (assoc version pkg-versions)))) + (if (and package version) + (setq output + (format (concat "This variable was introduced, or its default value was changed, in version %s of the %s package" + (if emacsv + (format " that is part of Emacs %s" emacsv)) + ".\n") + version package)))))) output)) ;;;###autoload (defun describe-variable (variable &optional buffer frame) "Display the full documentation of VARIABLE (a symbol). -Returns the documentation as a string, also. -If VARIABLE has a buffer-local value in BUFFER or FRAME -\(default to the current buffer and current frame), -it is displayed along with the global value." + +Returns the documentation as a string. + +If VARIABLE has a buffer-local value in BUFFER or FRAME (default +to the current buffer and frame), 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 + (let* ((v (variable-at-point)) + (enable-recursive-minibuffers t) + (orig-buffer (current-buffer)) + (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 (buffer-live-p buffer) (setq buffer (current-buffer))) - (unless (frame-live-p frame) (setq frame (selected-frame))) - (if (not (symbolp variable)) - (message "You did not specify a variable") - (save-excursion - (let ((valvoid (not (with-current-buffer buffer (boundp variable)))) - (permanent-local (get variable 'permanent-local)) - val val-start-pos locus) - ;; Extract the value before setting up the output buffer, - ;; in case `buffer' *is* the output buffer. - (unless valvoid - (with-selected-frame frame - (with-current-buffer buffer - (setq val (symbol-value variable) - locus (variable-binding-locus variable))))) - (help-setup-xref (list #'describe-variable variable buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (with-current-buffer buffer - (prin1 variable) - (setq file-name (find-lisp-object-file-name variable 'defvar)) - - (if file-name - (progn - (princ (format-message - " is a variable defined in `%s'.\n" - (if (eq file-name 'C-source) - "C source code" - (file-name-nondirectory file-name)))) - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys - "`\\([^`']+\\)'") - nil t) - (help-xref-button 1 'help-variable-def - variable file-name))) - (if valvoid - (princ "It is void as a variable.") - (princ "Its "))) - (if valvoid - (princ " is void as a variable.") - (princ (substitute-command-keys "'s "))))) - (unless valvoid - (with-current-buffer standard-output - (setq val-start-pos (point)) - (princ "value is") - (let ((line-beg (line-beginning-position)) - (print-rep - (let ((rep - (let ((print-quoted t)) - (prin1-to-string val)))) - (if (and (symbolp val) (not (booleanp val))) - (format-message "`%s'" rep) - rep)))) - (if (< (+ (length print-rep) (point) (- line-beg)) 68) - (insert " " print-rep) - (terpri) - (pp val) - ;; 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)))) - from) - (when (and (consp sv) - (not (equal origval val)) - (not (equal origval :help-eval-error))) - (princ "\nOriginal value was \n") - (setq from (point)) - (pp origval) - (if (< (point) (+ from 20)) - (delete-region (1- from) from))))))) - (terpri) - (when locus - (cond + t + nil + nil + (when (symbolp v) (symbol-name v))))) + (list (if (equal val "") v (intern val))))) + (unless (buffer-live-p buffer) (setq buffer (current-buffer))) + (unless (frame-live-p frame) (setq frame (selected-frame))) + + ;; Error if no variable is specified + (if (not (symbolp variable)) + (user-error "%s" "You did not specify a variable")) + + (save-excursion + (let* ((void (not (with-current-buffer buffer (boundp variable)))) + (val (if void nil (symbol-value variable))) + (locus (variable-binding-locus variable))) + (cl-flet ((value-pretty (lambda (val) + (with-temp-buffer + (let ((large (and (sequencep val) + (> (length val) 500)))) + (if large + (princ val) + (pp val (current-buffer)) + (when (and (not (null val)) + (not (stringp val)) + (sequencep val)) + (kill-backward-chars 1)) + (emacs-lisp-mode) + (turn-on-font-lock) + (font-lock-ensure)) + (buffer-string)))))) + ;; Setup xrefs + (help-setup-xref (list #'describe-variable variable buffer) + (called-interactively-p 'interactive)) + + (with-help-window (help-buffer) + (with-current-buffer standard-output + ;; Variable name + (insert (propertize (symbol-name variable) + 'face font-lock-variable-name-face)) + + ;; Definition file + (if-let ((file-name (find-lisp-object-file-name variable 'defvar))) + (progn + (insert " is a variable defined in ") + (if (eq file-name 'C-source) + (insert "C source code.") + (help-insert-xref-button (file-name-nondirectory file-name) + 'help-variable-def variable file-name) + (insert ".")))) + (insert "\n\n") + + ;; Value + (if void + (insert "It is void as a variable.") + (if (and (or (null val) + (stringp val) + (not (sequencep val))) + (< (length (prin1-to-string val)) + (- fill-column 13))) + (insert (format-message "Its value is %s.\n" (value-pretty val))) + (insert (format-message "Its value is:\n\n%s\n" (value-pretty val)))) + + ;; Original value + (let* ((sv (get variable 'standard-value)) + (origval (and (consp sv) + (condition-case nil + (eval (car sv)) + (error :help-eval-error))))) + (when (and (consp sv) + (not (equal origval val)) + (not (equal origval :help-eval-error))) + (if (< (length (prin1-to-string origval)) + (- fill-column 19)) + (insert (format "Original value was %s.\n" (value-pretty origval))) + (insert (format "Original value was: \n\n%s" (value-pretty origval))))))) + (insert "\n") + + ;; Locus (where variable's binding comes from) + (when locus + (cond ((bufferp locus) - (princ (format "Local in buffer %s; " - (buffer-name buffer)))) + (insert (format "It is local to buffer %s; " + (buffer-name locus)))) ((framep locus) - (princ (format "It is a frame-local variable; "))) + (insert (format "It is local to frame %s; " + (print1-to-string locus)))) ((terminal-live-p locus) - (princ (format "It is a terminal-local variable; "))) + (insert (format "It is local to terminal %s; " + (prin1-to-string locus)))) (t - (princ (format "It is local to %S" locus)))) - (if (not (default-boundp variable)) - (princ "globally void") - (let ((global-val (default-value variable))) - (with-current-buffer standard-output - (princ "global value is ") - (if (eq val global-val) - (princ "the same.") - (terpri) - ;; Fixme: pp can take an age if you happen to - ;; ask for a very large expression. We should - ;; probably print it raw once and check it's a - ;; sensible size before prettyprinting. -- fx - (let ((from (point))) - (pp global-val) - ;; See previous comment for this function. - ;; (help-xref-on-pp from (point)) - (if (< (point) (+ from 20)) - (delete-region (1- from) from))))))) - (terpri)) - - ;; If the value is large, move it to the end. - (with-current-buffer standard-output - (when (> (count-lines (point-min) (point-max)) 10) - ;; Note that setting the syntax table like below - ;; makes forward-sexp move over a `'s' at the end - ;; of a symbol. - (set-syntax-table emacs-lisp-mode-syntax-table) - (goto-char val-start-pos) - ;; The line below previously read as - ;; (delete-region (point) (progn (end-of-line) (point))) - ;; which suppressed display of the buffer local value for - ;; large values. - (when (looking-at "value is") (replace-match "")) - (save-excursion - (insert "\n\nValue:") - (set (make-local-variable 'help-button-cache) - (point-marker))) - (insert "value is shown ") - (insert-button "below" - 'action help-button-cache - 'follow-link t - 'help-echo "mouse-2, RET: show value") - (insert ".\n"))) - (terpri) - - (let* ((alias (condition-case nil - (indirect-variable variable) - (error variable))) - (obsolete (get variable 'byte-obsolete-variable)) - (use (car obsolete)) - (safe-var (get variable 'safe-local-variable)) - (doc (or (documentation-property - variable 'variable-documentation) - (documentation-property - alias 'variable-documentation))) - (extra-line nil)) - - ;; Mention if it's a local variable. - (cond - ((and (local-variable-if-set-p variable) - (or (not (local-variable-p variable)) - (with-temp-buffer - (local-variable-if-set-p variable)))) - (setq extra-line t) - (princ " Automatically becomes ") - (if permanent-local - (princ "permanently ")) - (princ "buffer-local when set.\n")) - ((not permanent-local)) - ((bufferp locus) - (setq extra-line t) - (princ - (substitute-command-keys - " This variable's buffer-local value is permanent.\n"))) - (t - (setq extra-line t) - (princ (substitute-command-keys - " This variable's value is permanent \ -if it is given a local binding.\n")))) - - ;; Mention if it's an alias. + (insert (format "It is local to %s" locus)))) + (if (not (default-boundp variable)) + (insert "globally void") + (let ((global-val (default-value variable))) + (with-current-buffer standard-output + (insert "global value is ") + (if (eq val global-val) + (insert "the same.") + (insert "\n") + ;; Fixme: pp can take an age if you happen to + ;; ask for a very large expression. We should + ;; probably print it raw once and check it's a + ;; sensible size before prettyprinting. -- fx + (let ((from (point))) + (pp global-val) + ;; See previous comment for this function. + ;; (help-xref-on-pp from (point)) + (if (< (point) (+ from 20)) + (delete-region (1- from) from)))))))) + + ;; Buffer local + (cond + ((and (local-variable-if-set-p variable) + (or (not (local-variable-p variable)) + (with-temp-buffer + (local-variable-if-set-p variable)))) + (insert "Automatically becomes ") + (if (get variable 'permanent-local) + (insert "permanently ")) + (insert "buffer-local when set.\n\n")) + ((not (get variable 'permanent-local))) + ((bufferp locus) + (insert + (substitute-command-keys + "This variable's buffer-local value is permanent.\n\n"))) + (t + (insert "This variable's value is permanent if it is given a local binding.\n\n"))) + + ;; Alias + (let ((alias (condition-case nil + (indirect-variable variable) + (error variable)))) (unless (eq alias variable) - (setq extra-line t) - (princ (format-message - " This variable is an alias for `%s'.\n" - alias))) - - (when obsolete - (setq extra-line t) - (princ " This variable is obsolete") - (if (nth 2 obsolete) - (princ (format " since %s" (nth 2 obsolete)))) - (princ (cond ((stringp use) (concat ";\n " use)) - (use (format-message ";\n use `%s' instead." - (car obsolete))) - (t "."))) - (terpri)) - - (when (member (cons variable val) - (with-current-buffer buffer - file-local-variables-alist)) - (setq extra-line t) - (if (member (cons variable val) - (with-current-buffer buffer - dir-local-variables-alist)) - (let ((file (and (buffer-file-name buffer) - (not (file-remote-p - (buffer-file-name buffer))) - (dir-locals-find-file - (buffer-file-name buffer)))) - (is-directory nil)) - (princ (substitute-command-keys - " This variable's value is directory-local")) - (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))) - (princ (substitute-command-keys "'.\n")))) - (princ (substitute-command-keys - " This variable's value is file-local.\n")))) - - (when (memq variable ignored-local-variables) - (setq extra-line t) - (princ " This variable is ignored as a file-local \ -variable.\n")) - - ;; Can be both risky and safe, eg auto-fill-function. - (when (risky-local-variable-p variable) - (setq extra-line t) - (princ " This variable may be risky if used as a \ -file-local variable.\n") - (when (assq variable safe-local-variable-values) - (princ (substitute-command-keys - " However, you have added it to \ -`safe-local-variable-values'.\n")))) - - (when safe-var - (setq extra-line t) - (princ " This variable is safe as a file local variable ") - (princ "if its value\n satisfies the predicate ") - (princ (if (byte-code-function-p safe-var) - "which is a byte-compiled expression.\n" - (format-message "`%s'.\n" safe-var)))) - - (if extra-line (terpri)) - (princ "Documentation:\n") - (with-current-buffer standard-output - (insert (or doc "Not documented as a variable.")))) - - ;; Make a link to customize if this variable can be customized. - (when (custom-variable-p variable) - (let ((customize-label "customize")) - (terpri) - (terpri) - (princ (concat "You can " customize-label " this variable.")) - (with-current-buffer standard-output - (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) - (help-xref-button 1 'help-customize-variable variable)))) - ;; Note variable's version or package version. - (let ((output (describe-variable-custom-version-info variable))) - (when output - (terpri) - (terpri) - (princ output)))) - - (with-current-buffer standard-output - ;; Return the text we displayed. - (buffer-string)))))))) - + (insert (format-message + "This variable is an alias for `%s'.\n\n" alias)))) + + ;; Obsolete + (let* ((obsolete (get variable 'byte-obsolete-variable)) + (obsolete-since (nth 2 obsolete)) + (use (car obsolete))) + (when obsolete-since + (insert (propertize (format-message "This variable is obsolete since %s" obsolete-since) + 'face 'error)) + (insert (propertize (cond ((stringp use) (concat "; " use "\n")) + (use (format-message "; use `%s' instead.\n" + (car obsolete))) + (t ".\n")) + 'face 'error)) + (insert "\n"))) + + ;; File or directory local + (when (member (cons variable val) + (with-current-buffer buffer + file-local-variables-alist)) + (setq extra-line t) + (if (member (cons variable val) + (with-current-buffer buffer + dir-local-variables-alist)) + (let ((file (and (buffer-file-name buffer) + (not (file-remote-p + (buffer-file-name buffer))) + (dir-locals-find-file + (buffer-file-name buffer)))) + (is-directory nil)) + (insert "This variable's value is directory-local") + (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) + (insert ".\n") + (insert ", set ") + (insert (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 `")))) + (help-insert-xref-button file 'help-dir-local-var-def + variable file) + (insert (substitute-command-keys "'.\n")))) + (insert "This variable's value is file-local.\n"))) + + ;; Ignored local + (when (memq variable ignored-local-variables) + (insert "This variable is ignored as a file-local variable.\n\n")) + + ;; Risky local + (when (risky-local-variable-p variable) + (insert (propertize "This variable may be risky if used as a file-local variable" + 'face font-lock-warning-face)) + (if (assq variable safe-local-variable-values) + (insert "; however, you have added it to `safe-local-variable-values'.\n")) + (insert ".\n\n")) + + ;; Safe local + (when-let ((safe-var (get variable 'safe-local-variable))) + (insert "This variable is safe as a file local variable ") + (insert "if its value satisfies the predicate ") + (insert (if (byte-code-function-p safe-var) + "which is a byte-compiled expression.\n\n" + (format-message "`%s'.\n\n" safe-var)))) + + ;; Documentation + (unless void + (let* ((alias (condition-case nil + (indirect-variable variable) + (error variable))) + (doc (or (documentation-property variable + 'variable-documentation) + (documentation-property alias + 'variable-documentation) + "Not documented as a variable."))) + (insert "Documentation:\n\n") + (insert (propertize doc 'face font-lock-doc-face)) + (insert "\n\n"))) + + ;; Make a link to customize if this variable can be + ;; customized. + (when (custom-variable-p variable) + (insert "You can ") + (help-insert-xref-button "customize" 'help-customize-variable + variable) + (insert " this variable.") + ;; Note variable's version or package version. + (when-let ((output (describe-variable-custom-version-info variable))) + (insert "\n\n") + (insert output))) + + ;; Return the Help buffer string + (buffer-string))))))) (defvar help-xref-stack-item) @@ -1079,17 +1035,17 @@ describe-symbol (found (or found v-or-f)) (enable-recursive-minibuffers t) (val (completing-read (if found - (format + (format "Describe symbol (default %s): " v-or-f) - "Describe symbol: ") - obarray - (lambda (vv) + "Describe symbol: ") + obarray + (lambda (vv) (cl-some (lambda (x) (funcall (nth 1 x) vv)) describe-symbol-backends)) - t nil nil - (if found (symbol-name v-or-f))))) + t nil nil + (if found (symbol-name v-or-f))))) (list (if (equal val "") - v-or-f (intern val))))) + v-or-f (intern val))))) (if (not (symbolp symbol)) (user-error "You didn't specify a function or variable")) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) @@ -1139,22 +1095,22 @@ describe-syntax (interactive) (setq buffer (or buffer (current-buffer))) (help-setup-xref (list #'describe-syntax buffer) - (called-interactively-p 'interactive)) + (called-interactively-p 'interactive)) (with-help-window (help-buffer) (let ((table (with-current-buffer buffer (syntax-table)))) (with-current-buffer standard-output - (describe-vector table 'internal-describe-syntax-value) - (while (setq table (char-table-parent table)) - (insert "\nThe parent syntax table is:") - (describe-vector table 'internal-describe-syntax-value)))))) + (describe-vector table 'internal-describe-syntax-value) + (while (setq table (char-table-parent table)) + (insert "\nThe parent syntax table is:") + (describe-vector table 'internal-describe-syntax-value)))))) (defun help-describe-category-set (value) (insert (cond - ((null value) "default") - ((char-table-p value) "deeper char-table ...") - (t (condition-case nil - (category-set-mnemonics value) - (error "invalid")))))) + ((null value) "default") + ((char-table-p value) "deeper char-table ...") + (t (condition-case nil + (category-set-mnemonics value) + (error "invalid")))))) ;;;###autoload (defun describe-categories (&optional buffer) @@ -1165,57 +1121,57 @@ describe-categories (interactive) (setq buffer (or buffer (current-buffer))) (help-setup-xref (list #'describe-categories buffer) - (called-interactively-p 'interactive)) + (called-interactively-p 'interactive)) (with-help-window (help-buffer) (let* ((table (with-current-buffer buffer (category-table))) - (docs (char-table-extra-slot table 0))) + (docs (char-table-extra-slot table 0))) (if (or (not (vectorp docs)) (/= (length docs) 95)) - (error "Invalid first extra slot in this category table\n")) + (error "Invalid first extra slot in this category table\n")) (with-current-buffer standard-output (setq-default help-button-cache (make-marker)) - (insert "Legend of category mnemonics ") + (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)))) - (setq lines (1+ (/ (1- items) 4))) - (setq n 0) - (dotimes (i 95) - (let ((elt (aref docs i))) - (when elt - (string-match ".*" elt) - (setq elt (match-string 0 elt)) - (if (>= (length elt) 17) - (setq elt (concat (substring elt 0 14) "..."))) - (if (< (point) (point-max)) - (move-to-column (* 20 (/ n lines)) t)) - (insert (+ i ?\s) ?: elt) - (if (< (point) (point-max)) - (forward-line 1) - (insert "\n")) - (setq n (1+ n)) - (if (= (% n lines) 0) - (goto-char pos)))))) - (goto-char (point-max)) - (insert "\n" - "character(s)\tcategory mnemonics\n" - "------------\t------------------") - (describe-vector table 'help-describe-category-set) + (let ((pos (point)) (items 0) lines n) + (dotimes (i 95) + (if (aref docs i) (setq items (1+ items)))) + (setq lines (1+ (/ (1- items) 4))) + (setq n 0) + (dotimes (i 95) + (let ((elt (aref docs i))) + (when elt + (string-match ".*" elt) + (setq elt (match-string 0 elt)) + (if (>= (length elt) 17) + (setq elt (concat (substring elt 0 14) "..."))) + (if (< (point) (point-max)) + (move-to-column (* 20 (/ n lines)) t)) + (insert (+ i ?\s) ?: elt) + (if (< (point) (point-max)) + (forward-line 1) + (insert "\n")) + (setq n (1+ n)) + (if (= (% n lines) 0) + (goto-char pos)))))) + (goto-char (point-max)) + (insert "\n" + "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))) - (when elt - (if (string-match "\n" elt) - (setq elt (substring elt (match-end 0)))) - (insert (+ i ?\s) ": " elt "\n")))) - (while (setq table (char-table-parent table)) - (insert "\nThe parent category table is:") - (describe-vector table 'help-describe-category-set)))))) + (insert "Legend of category mnemonics:\n") + (dotimes (i 95) + (let ((elt (aref docs i))) + (when elt + (if (string-match "\n" elt) + (setq elt (substring elt (match-end 0)))) + (insert (+ i ?\s) ": " elt "\n")))) + (while (setq table (char-table-parent table)) + (insert "\nThe parent category table is:") + (describe-vector table 'help-describe-category-set)))))) ;;; Replacements for old lib-src/ programs. Don't seem especially useful. -- 2.7.4