lisp/faces2.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;; Listing faces.
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 (defconst list-faces-sample-text
   6   "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   7   "Text string to display as the sample text for `list-faces-display'.")
   8
   9
  10 ;; The name list-faces would be more consistent, but let's avoid a
  11 ;; conflict with Lucid, which uses that name differently.
  12
  13 (defvar help-xref-stack)
  14 (defun list-faces-display (&optional regexp)
  15   "List all faces, using the same sample text in each.
  16 The sample text is a string that comes from the variable
  17 `list-faces-sample-text'.
  18
  19 If REGEXP is non-nil, list only those faces with names matching
  20 this regular expression.  When called interactively with a prefix
  21 arg, prompt for a regular expression."
  22   (interactive (list (and current-prefix-arg
  23                           (read-regexp "List faces matching regexp"))))
  24   (let ((all-faces (zerop (length regexp)))
  25         (frame (selected-frame))
  26         (max-length 0)
  27         faces line-format
  28         disp-frame window face-name)
  29     ;; We filter and take the max length in one pass
  30     (setq faces
  31           (delq nil
  32                 (mapcar (lambda (f)
  33                           (let ((s (symbol-name f)))
  34                             (when (or all-faces (string-match-p regexp s))
  35                               (setq max-length (max (length s) max-length))
  36                               f)))
  37                         (sort (face-list) #'string-lessp))))
  38     (unless faces
  39       (error "No faces matching \"%s\"" regexp))
  40     (setq max-length (1+ max-length)
  41           line-format (format "%%-%ds" max-length))
  42     (with-help-window "*Faces*"
  43       (with-current-buffer standard-output
  44         (setq truncate-lines t)
  45         (insert
  46          (substitute-command-keys
  47           (concat
  48            "\\<help-mode-map>Use "
  49            (if (display-mouse-p) "\\[help-follow-mouse] or ")
  50            "\\[help-follow] on a face name to customize it\n"
  51            "or on its sample text for a description of the face.\n\n")))
  52         (setq help-xref-stack nil)
  53         (dolist (face faces)
  54           (setq face-name (symbol-name face))
  55           (insert (format line-format face-name))
  56           ;; Hyperlink to a customization buffer for the face.  Using
  57           ;; the help xref mechanism may not be the best way.
  58           (save-excursion
  59             (save-match-data
  60               (search-backward face-name)
  61               (setq help-xref-stack-item `(list-faces-display ,regexp))
  62               (help-xref-button 0 'help-customize-face face)))
  63           (let ((beg (point))
  64                 (line-beg (line-beginning-position)))
  65             (insert list-faces-sample-text)
  66             ;; Hyperlink to a help buffer for the face.
  67             (save-excursion
  68               (save-match-data
  69                 (search-backward list-faces-sample-text)
  70                 (help-xref-button 0 'help-face face)))
  71             (insert "\n")
  72             (put-text-property beg (1- (point)) 'face face)
  73             ;; Make all face commands default to the proper face
  74             ;; anywhere in the line.
  75             (put-text-property line-beg (1- (point)) 'read-face-name face)
  76             ;; If the sample text has multiple lines, line up all of them.
  77             (goto-char beg)
  78             (forward-line 1)
  79             (while (not (eobp))
  80               (insert-char ?\s max-length)
  81               (forward-line 1))))
  82         (goto-char (point-min))))
  83     ;; If the *Faces* buffer appears in a different frame,
  84     ;; copy all the face definitions from FRAME,
  85     ;; so that the display will reflect the frame that was selected.
  86     (setq window (get-buffer-window (get-buffer "*Faces*") t))
  87     (setq disp-frame (if window (window-frame window)
  88                        (car (frame-list))))
  89     (or (eq frame disp-frame)
  90         (dolist (face (face-list))
  91           (copy-face face face frame disp-frame)))))
  92
  93
  94 (defun describe-face (face &optional frame)
  95   "Display the properties of face FACE on FRAME.
  96 Interactively, FACE defaults to the faces of the character after point
  97 and FRAME defaults to the selected frame.
  98
  99 If the optional argument FRAME is given, report on face FACE in that frame.
 100 If FRAME is t, report on the defaults for face FACE (for new frames).
 101 If FRAME is omitted or nil, use the selected frame."
 102   (interactive (list (read-face-name "Describe face"
 103                                      (or (face-at-point t) 'default)
 104                                      t)))
 105   (let* ((attrs '((:family . "Family")
 106                   (:foundry . "Foundry")
 107                   (:width . "Width")
 108                   (:height . "Height")
 109                   (:weight . "Weight")
 110                   (:slant . "Slant")
 111                   (:foreground . "Foreground")
 112                   (:distant-foreground . "DistantForeground")
 113                   (:background . "Background")
 114                   (:underline . "Underline")
 115                   (:overline . "Overline")
 116                   (:strike-through . "Strike-through")
 117                   (:box . "Box")
 118                   (:inverse-video . "Inverse")
 119                   (:stipple . "Stipple")
 120                   (:font . "Font")
 121                   (:fontset . "Fontset")
 122                   (:inherit . "Inherit")))
 123         (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
 124                                         attrs))))
 125     (help-setup-xref (list #'describe-face face)
 126                      (called-interactively-p 'interactive))
 127     (unless face
 128       (setq face 'default))
 129     (if (not (listp face))
 130         (setq face (list face)))
 131     (with-help-window (help-buffer)
 132       (with-current-buffer standard-output
 133         (dolist (f face)
 134           (if (stringp f) (setq f (intern f)))
 135           ;; We may get called for anonymous faces (i.e., faces
 136           ;; expressed using prop-value plists).  Those can't be
 137           ;; usefully customized, so ignore them.
 138           (when (symbolp f)
 139             (insert "Face: " (symbol-name f))
 140             (if (not (facep f))
 141                 (insert "   undefined face.\n")
 142               (let ((customize-label "customize this face")
 143                     file-name)
 144                 (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
 145                 (princ (concat " (" customize-label ")\n"))
 146                 ;; FIXME not sure how much of this belongs here, and
 147                 ;; how much in `face-documentation'.  The latter is
 148                 ;; not used much, but needs to return nil for
 149                 ;; undocumented faces.
 150                 (let ((alias (get f 'face-alias))
 151                       (face f)
 152                       obsolete)
 153                   (when alias
 154                     (setq face alias)
 155                     (insert
 156                      (format "\n  %s is an alias for the face `%s'.\n%s"
 157                              f alias
 158                              (if (setq obsolete (get f 'obsolete-face))
 159                                  (format "  This face is obsolete%s; use `%s' instead.\n"
 160                                          (if (stringp obsolete)
 161                                              (format " since %s" obsolete)
 162                                            "")
 163                                          alias)
 164                                ""))))
 165                   (insert "\nDocumentation:\n"
 166                           (or (face-documentation face)
 167                               "Not documented as a face.")
 168                           "\n\n"))
 169                 (with-current-buffer standard-output
 170                   (save-excursion
 171                     (re-search-backward
 172                      (concat "\\(" customize-label "\\)") nil t)
 173                     (help-xref-button 1 'help-customize-face f)))
 174                 (setq file-name (find-lisp-object-file-name f 'defface))
 175                 (when file-name
 176                   (princ "Defined in `")
 177                   (princ (file-name-nondirectory file-name))
 178                   (princ "'")
 179                   ;; Make a hyperlink to the library.
 180                   (save-excursion
 181                     (re-search-backward "`\\([^`']+\\)'" nil t)
 182                     (help-xref-button 1 'help-face-def f file-name))
 183                   (princ ".")
 184                   (terpri)
 185                   (terpri))
 186                 (dolist (a attrs)
 187                   (let ((attr (face-attribute f (car a) frame)))
 188                     (insert (make-string (- max-width (length (cdr a))) ?\s)
 189                             (cdr a) ": " (format "%s" attr))
 190                     (if (and (eq (car a) :inherit)
 191                              (not (eq attr 'unspecified)))
 192                         ;; Make a hyperlink to the parent face.
 193                         (save-excursion
 194                           (re-search-backward ": \\([^:]+\\)" nil t)
 195                           (help-xref-button 1 'help-face attr)))
 196                     (insert "\n")))))
 197             (terpri)))))))