From: Tianxiang Xiong <tianxiang.xiong@gmail.com>
To: emacs-devel@gnu.org
Subject: Re: Proposal: font lock for `describe-variable`
Date: Sun, 25 Sep 2016 11:25:51 -0700 [thread overview]
Message-ID: <1474827951.10801.4.camel@gmail.com> (raw)
In-Reply-To: 9263dde0-ac77-168f-e6f9-0cfd9862985f@gmail.com
[-- Attachment #1: Type: text/plain, Size: 168 bytes --]
I've attached a new patch without the whitespace differences (although,
as a side note, I think it's good practice to add `whitespace-cleanup`
to `before-save-hook`).
[-- Attachment #2: 0002-Use-font-lock-for-describe-variable.patch --]
[-- Type: text/x-patch, Size: 27486 bytes --]
From 8dfffc1c7661c27c27ec01782b91b51410f313fa Mon Sep 17 00:00:00 2001
From: Tianxiang Xiong <tianxiang.xiong@gmail.com>
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 | 570 +++++++++++++++++++++++++------------------------------
1 file changed, 263 insertions(+), 307 deletions(-)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index e4e2333..768a288 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'.
@@ -733,334 +734,289 @@ describe-variable-custom-version-info
(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)
--
2.7.4
next reply other threads:[~2016-09-25 18:25 UTC|newest]
Thread overview: 24+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-09-25 18:25 Tianxiang Xiong [this message]
-- strict thread matches above, loose matches on Subject: below --
2016-09-27 4:09 Proposal: font lock for `describe-variable` Tianxiang Xiong
2016-09-27 15:49 ` Eli Zaretskii
2016-09-27 16:30 ` Tianxiang Xiong
2016-09-27 17:40 ` Eli Zaretskii
2016-09-28 3:45 ` Tianxiang Xiong
2016-09-28 4:21 ` Clément Pit--Claudel
2016-09-30 7:34 ` Tianxiang Xiong
2016-09-30 13:20 ` Stefan Monnier
2016-09-30 14:41 ` Stefan Monnier
2016-10-03 13:57 ` Tino Calancha
2016-10-08 21:51 ` Tianxiang Xiong
2016-10-09 15:48 ` Tino Calancha
2016-10-11 4:11 ` Tianxiang Xiong
2016-10-11 5:40 ` Tino Calancha
2016-10-11 5:51 ` Clément Pit--Claudel
2016-10-11 5:59 ` Tino Calancha
2016-10-11 13:31 ` Clément Pit--Claudel
2016-10-11 13:57 ` Tino Calancha
2016-09-25 3:36 Tianxiang Xiong
2016-09-25 14:47 ` Clément Pit--Claudel
2016-09-25 19:02 ` Stefan Monnier
2016-09-25 19:46 ` Clément Pit--Claudel
2016-09-25 21:12 ` Stefan Monnier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1474827951.10801.4.camel@gmail.com \
--to=tianxiang.xiong@gmail.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).