mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-03 02:31:03 -08:00
Move describe-face to the new help-fns machinery
* lisp/help-fns.el (describe-face): Move to here from faces.el and split up (bug#36670). (help-fns--face-custom-version-info): (help-fns--face-attributes): Factored out into own functions. (help-fns-describe-face-functions): New variable. * lisp/emacs-lisp/subr-x.el (when-let): Add autoload cookie.
This commit is contained in:
Lars Ingebrigtsen
parent
1143232265
commit
c56fabdfc7
3 changed files with 133 additions and 118 deletions
|
|
@ -182,6 +182,7 @@ with an old syntax that accepted only one binding."
|
|||
(setq spec (list spec)))
|
||||
(list 'if-let* spec then (macroexp-progn else)))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro when-let (spec &rest body)
|
||||
"Bind variables according to SPEC and conditionally evaluate BODY.
|
||||
Evaluate each binding in turn, stopping if a binding value is nil.
|
||||
|
|
|
|||
118
lisp/faces.el
118
lisp/faces.el
|
|
@ -1416,124 +1416,6 @@ argument, prompt for a regular expression using `read-regexp'."
|
|||
(dolist (face (face-list))
|
||||
(copy-face face face frame disp-frame)))))
|
||||
|
||||
(declare-function describe-variable-custom-version-info "help-fns"
|
||||
(variable &optional type))
|
||||
|
||||
(defun describe-face (face &optional frame)
|
||||
"Display the properties of face FACE on FRAME.
|
||||
Interactively, FACE defaults to the faces of the character after point
|
||||
and FRAME defaults to the selected frame.
|
||||
|
||||
If the optional argument FRAME is given, report on face FACE in that frame.
|
||||
If FRAME is t, report on the defaults for face FACE (for new frames).
|
||||
If FRAME is omitted or nil, use the selected frame."
|
||||
(interactive (list (read-face-name "Describe face"
|
||||
(or (face-at-point t) 'default)
|
||||
t)))
|
||||
(require 'help-fns)
|
||||
(let* ((attrs '((:family . "Family")
|
||||
(:foundry . "Foundry")
|
||||
(:width . "Width")
|
||||
(:height . "Height")
|
||||
(:weight . "Weight")
|
||||
(:slant . "Slant")
|
||||
(:foreground . "Foreground")
|
||||
(:distant-foreground . "DistantForeground")
|
||||
(:background . "Background")
|
||||
(:underline . "Underline")
|
||||
(:overline . "Overline")
|
||||
(:strike-through . "Strike-through")
|
||||
(:box . "Box")
|
||||
(:inverse-video . "Inverse")
|
||||
(:stipple . "Stipple")
|
||||
(:font . "Font")
|
||||
(:fontset . "Fontset")
|
||||
(:inherit . "Inherit")))
|
||||
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
|
||||
attrs))))
|
||||
(help-setup-xref (list #'describe-face face)
|
||||
(called-interactively-p 'interactive))
|
||||
(unless face
|
||||
(setq face 'default))
|
||||
(if (not (listp face))
|
||||
(setq face (list face)))
|
||||
(with-help-window (help-buffer)
|
||||
(with-current-buffer standard-output
|
||||
(dolist (f face (buffer-string))
|
||||
(if (stringp f) (setq f (intern f)))
|
||||
;; We may get called for anonymous faces (i.e., faces
|
||||
;; expressed using prop-value plists). Those can't be
|
||||
;; usefully customized, so ignore them.
|
||||
(when (symbolp f)
|
||||
(insert "Face: " (symbol-name f))
|
||||
(if (not (facep f))
|
||||
(insert " undefined face.\n")
|
||||
(let ((customize-label "customize this face")
|
||||
file-name)
|
||||
(insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
|
||||
(princ (concat " (" customize-label ")\n"))
|
||||
;; FIXME not sure how much of this belongs here, and
|
||||
;; how much in `face-documentation'. The latter is
|
||||
;; not used much, but needs to return nil for
|
||||
;; undocumented faces.
|
||||
(let ((alias (get f 'face-alias))
|
||||
(face f)
|
||||
obsolete)
|
||||
(when alias
|
||||
(setq face alias)
|
||||
(insert
|
||||
(format-message
|
||||
"\n %s is an alias for the face `%s'.\n%s"
|
||||
f alias
|
||||
(if (setq obsolete (get f 'obsolete-face))
|
||||
(format-message
|
||||
" This face is obsolete%s; use `%s' instead.\n"
|
||||
(if (stringp obsolete)
|
||||
(format " since %s" obsolete)
|
||||
"")
|
||||
alias)
|
||||
""))))
|
||||
(insert "\nDocumentation:\n"
|
||||
(substitute-command-keys
|
||||
(or (face-documentation face)
|
||||
"Not documented as a face."))
|
||||
"\n\n"))
|
||||
(with-current-buffer standard-output
|
||||
(save-excursion
|
||||
(re-search-backward
|
||||
(concat "\\(" customize-label "\\)") nil t)
|
||||
(help-xref-button 1 'help-customize-face f)))
|
||||
(setq file-name (find-lisp-object-file-name f 'defface))
|
||||
(when file-name
|
||||
(princ (substitute-command-keys "Defined in `"))
|
||||
(princ (file-name-nondirectory file-name))
|
||||
(princ (substitute-command-keys "'"))
|
||||
;; Make a hyperlink to the library.
|
||||
(save-excursion
|
||||
(re-search-backward
|
||||
(substitute-command-keys "`\\([^`']+\\)'") nil t)
|
||||
(help-xref-button 1 'help-face-def f file-name))
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri))
|
||||
(dolist (a attrs)
|
||||
(let ((attr (face-attribute f (car a) frame)))
|
||||
(insert (make-string (- max-width (length (cdr a))) ?\s)
|
||||
(cdr a) ": " (format "%s" attr))
|
||||
(if (and (eq (car a) :inherit)
|
||||
(not (eq attr 'unspecified)))
|
||||
;; Make a hyperlink to the parent face.
|
||||
(save-excursion
|
||||
(re-search-backward ": \\([^:]+\\)" nil t)
|
||||
(help-xref-button 1 'help-face attr)))
|
||||
(insert "\n")))))
|
||||
(terpri)
|
||||
(let ((version-info (describe-variable-custom-version-info
|
||||
f 'face)))
|
||||
(when version-info
|
||||
(insert version-info)
|
||||
(terpri)))))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Face specifications (defface).
|
||||
|
|
|
|||
132
lisp/help-fns.el
132
lisp/help-fns.el
|
|
@ -56,6 +56,13 @@ By convention they should indent their output by 2 spaces.
|
|||
Current buffer is the buffer in which we queried the variable,
|
||||
and the output should go to `standard-output'.")
|
||||
|
||||
(defvar help-fns-describe-face-functions nil
|
||||
"List of functions to run in help buffer in `describe-face'.
|
||||
The functions will be used (and take the same parameters) as
|
||||
described in `help-fns-describe-variable-functions', except that
|
||||
the functions are called with two parameters: The face and the
|
||||
frame.")
|
||||
|
||||
;; Functions
|
||||
|
||||
(defvar help-definition-prefixes nil
|
||||
|
|
@ -1235,6 +1242,131 @@ variable.\n")))
|
|||
" This variable's value is permanent \
|
||||
if it is given a local binding.\n"))))))
|
||||
|
||||
|
||||
;; Faces.
|
||||
|
||||
;;;###autoload
|
||||
(defun describe-face (face &optional frame)
|
||||
"Display the properties of face FACE on FRAME.
|
||||
Interactively, FACE defaults to the faces of the character after point
|
||||
and FRAME defaults to the selected frame.
|
||||
|
||||
If the optional argument FRAME is given, report on face FACE in that frame.
|
||||
If FRAME is t, report on the defaults for face FACE (for new frames).
|
||||
If FRAME is omitted or nil, use the selected frame."
|
||||
(interactive (list (read-face-name "Describe face"
|
||||
(or (face-at-point t) 'default)
|
||||
t)))
|
||||
(help-setup-xref (list #'describe-face face)
|
||||
(called-interactively-p 'interactive))
|
||||
(unless face
|
||||
(setq face 'default))
|
||||
(if (not (listp face))
|
||||
(setq face (list face)))
|
||||
(with-help-window (help-buffer)
|
||||
(with-current-buffer standard-output
|
||||
(dolist (f face (buffer-string))
|
||||
(if (stringp f) (setq f (intern f)))
|
||||
;; We may get called for anonymous faces (i.e., faces
|
||||
;; expressed using prop-value plists). Those can't be
|
||||
;; usefully customized, so ignore them.
|
||||
(when (symbolp f)
|
||||
(insert "Face: " (symbol-name f))
|
||||
(if (not (facep f))
|
||||
(insert " undefined face.\n")
|
||||
(let ((customize-label "customize this face")
|
||||
file-name)
|
||||
(insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
|
||||
(princ (concat " (" customize-label ")\n"))
|
||||
;; FIXME not sure how much of this belongs here, and
|
||||
;; how much in `face-documentation'. The latter is
|
||||
;; not used much, but needs to return nil for
|
||||
;; undocumented faces.
|
||||
(let ((alias (get f 'face-alias))
|
||||
(face f)
|
||||
obsolete)
|
||||
(when alias
|
||||
(setq face alias)
|
||||
(insert
|
||||
(format-message
|
||||
"\n %s is an alias for the face `%s'.\n%s"
|
||||
f alias
|
||||
(if (setq obsolete (get f 'obsolete-face))
|
||||
(format-message
|
||||
" This face is obsolete%s; use `%s' instead.\n"
|
||||
(if (stringp obsolete)
|
||||
(format " since %s" obsolete)
|
||||
"")
|
||||
alias)
|
||||
""))))
|
||||
(insert "\nDocumentation:\n"
|
||||
(substitute-command-keys
|
||||
(or (face-documentation face)
|
||||
"Not documented as a face."))
|
||||
"\n\n"))
|
||||
(with-current-buffer standard-output
|
||||
(save-excursion
|
||||
(re-search-backward
|
||||
(concat "\\(" customize-label "\\)") nil t)
|
||||
(help-xref-button 1 'help-customize-face f)))
|
||||
(setq file-name (find-lisp-object-file-name f 'defface))
|
||||
(when file-name
|
||||
(princ (substitute-command-keys "Defined in `"))
|
||||
(princ (file-name-nondirectory file-name))
|
||||
(princ (substitute-command-keys "'"))
|
||||
;; Make a hyperlink to the library.
|
||||
(save-excursion
|
||||
(re-search-backward
|
||||
(substitute-command-keys "`\\([^`']+\\)'") nil t)
|
||||
(help-xref-button 1 'help-face-def f file-name))
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri))))
|
||||
(terpri)
|
||||
(run-hook-with-args 'help-fns-describe-face-functions f frame))))))
|
||||
|
||||
(add-hook 'help-fns-describe-face-functions
|
||||
#'help-fns--face-custom-version-info)
|
||||
(defun help-fns--face-custom-version-info (face _frame)
|
||||
(when-let ((version-info (describe-variable-custom-version-info face 'face)))
|
||||
(insert version-info)
|
||||
(terpri)))
|
||||
|
||||
(add-hook 'help-fns-describe-face-functions #'help-fns--face-attributes)
|
||||
(defun help-fns--face-attributes (face frame)
|
||||
(let* ((attrs '((:family . "Family")
|
||||
(:foundry . "Foundry")
|
||||
(:width . "Width")
|
||||
(:height . "Height")
|
||||
(:weight . "Weight")
|
||||
(:slant . "Slant")
|
||||
(:foreground . "Foreground")
|
||||
(:distant-foreground . "DistantForeground")
|
||||
(:background . "Background")
|
||||
(:underline . "Underline")
|
||||
(:overline . "Overline")
|
||||
(:strike-through . "Strike-through")
|
||||
(:box . "Box")
|
||||
(:inverse-video . "Inverse")
|
||||
(:stipple . "Stipple")
|
||||
(:font . "Font")
|
||||
(:fontset . "Fontset")
|
||||
(:inherit . "Inherit")))
|
||||
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
|
||||
attrs))))
|
||||
(dolist (a attrs)
|
||||
(let ((attr (face-attribute face (car a) frame)))
|
||||
(insert (make-string (- max-width (length (cdr a))) ?\s)
|
||||
(cdr a) ": " (format "%s" attr))
|
||||
(if (and (eq (car a) :inherit)
|
||||
(not (eq attr 'unspecified)))
|
||||
;; Make a hyperlink to the parent face.
|
||||
(save-excursion
|
||||
(re-search-backward ": \\([^:]+\\)" nil t)
|
||||
(help-xref-button 1 'help-face attr)))
|
||||
(insert "\n")))
|
||||
(terpri)))
|
||||
|
||||
(defvar help-xref-stack-item)
|
||||
|
||||
;;;###autoload
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue