[Emacs-diffs] master c56fabd: Move describe-face to the new help-fns machinery

[Lars Ingebrigtsen]

branch: master
commit c56fabdfc731a8498b9ee8e9c988f85180de690f
Author: Lars Ingebrigtsen <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>

    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.
---
 lisp/emacs-lisp/subr-x.el |   1 +
 lisp/faces.el             | 118 -----------------------------------------
 lisp/help-fns.el          | 132 ++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 133 insertions(+), 118 deletions(-)

diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index bb2bf3d..3da5241 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 efae101..9c5ffe1 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 90a3571..3c0a72e 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