From: Lars Ingebrigtsen Date: Fri, 20 Sep 2019 22:45:34 +0000 (+0200) Subject: Move describe-face to the new help-fns machinery X-Git-Tag: emacs-27.0.90~1522 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=c56fabdfc731a8498b9ee8e9c988f85180de690f;p=emacs.git 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. --- diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index bb2bf3dd5fa..3da52418fe4 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -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. diff --git a/lisp/faces.el b/lisp/faces.el index efae101cd88..9c5ffe1e590 100644 --- a/lisp/faces.el +++ b/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). diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 90a35715204..3c0a72e2634 100644 --- a/lisp/help-fns.el +++ b/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