From 8378d38839e4baf3cf809a688f1ad0d48a1da279 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. --- ChangeLog.2 | 4 + lisp/help-fns.el | 549 ++++++++++++++++++++++++++----------------------------- 2 files changed, 260 insertions(+), 293 deletions(-) diff --git a/ChangeLog.2 b/ChangeLog.2 index 4e79295..c7ebcf0 100644 --- a/ChangeLog.2 +++ b/ChangeLog.2 @@ -1,3 +1,7 @@ +2016-10-08 Tianiang Xiong + + * lisp/help-fns.el (describe-variable): Use font lock, clean up + code etc. 2016-08-22 Philipp Stephani Some assorted documentation clarifications diff --git a/lisp/help-fns.el b/lisp/help-fns.el index e4e2333..9673ce4 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'. @@ -755,313 +756,275 @@ describe-variable-custom-version-info ;;;###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 - (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) + (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) + (with-current-buffer orig-buffer + (or (get vv 'variable-documentation) + (and (boundp vv) (not (keywordp vv)))))) + 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))) + (should-pp (and (sequencep val) + (let ((l (if (ring-p val) + (ring-length val) + (length val)))) + (< l 500)))) + (place-at-end (> (length (prin1-to-string val)) 3000)) + (locus (variable-binding-locus variable))) + (cl-labels ((pretty-maybe (val) + (with-temp-buffer + (if (not should-pp) + (princ val (current-buffer)) + (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))) + (insert-value-section (val) + (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" (pretty-maybe val))) + (insert (format-message "Its value is:\n\n%s\n" (pretty-maybe 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" (pretty-maybe origval))) + (insert (format "Original value was: \n\n%s" (pretty-maybe origval))))))))) + ;; 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") + + ;; If value is not large, insert it here + ;; Otherwise, insert it later + (when (not place-at-end) + (insert-value-section val) + (insert "\n")) + + ;; Locus (where variable's binding comes from) (when locus (cond - ((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 - (princ (format "It is local to %S" locus)))) + ((bufferp locus) + (insert (format "It is local to buffer %s; " + (buffer-name locus)))) + ((framep locus) + (insert (format "It is local to frame %s; " + (print1-to-string locus)))) + ((terminal-live-p locus) + (insert (format "It is local to terminal %s; " + (prin1-to-string locus)))) + (t + (insert (format "It is local to %s" locus)))) (if (not (default-boundp variable)) - (princ "globally void") + (insert "globally void") (let ((global-val (default-value variable))) (with-current-buffer standard-output - (princ "global value is ") + (insert "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 + (insert "the same.") + (insert "\n") (let ((from (point))) - (pp global-val) + (pretty-maybe 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. - (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. + (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) + (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\nthe 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"))) + + ;; If value is large, insert it here + (when place-at-end + (insert-value-section val)) + + ;; 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)))) + (insert "You can ") + (help-insert-xref-button "customize" 'help-customize-variable + variable) + (insert " this 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)))))))) - + (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) ;;;###autoload -- 2.7.4