Improve 'read-face-name'

* doc/lispref/display.texi (Face Functions): Use '@lisp' for Elisp
example.  Document 'read-face-name' and 'read-face-name-sample-text'.
* etc/NEWS: Announce 'read-face-name-sample-text' as a user option.
* lisp/faces.el (read-face-name-sample-text): Make it a user option.
(completion-face-name-affixation, read-face-name-sort-aliases-last)
(completion-face-name-table): New functions.
(read-face-name): Simplify.

diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 10cf5ce89e2372a701c25e0ad6bbef2d3d56df66..240ca3215e862b7874d2ff16a058c020a289db67 100644 (file)
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -3552,9 +3552,9 @@ define a face alias by giving the alias symbol the @code{face-alias}
 property, with a value of the target face name.  The following example
 makes @code{modeline} an alias for the @code{mode-line} face.
 
-@example
+@lisp
 (put 'modeline 'face-alias 'mode-line)
-@end example
+@end lisp
 
 @defmac define-obsolete-face-alias obsolete-face current-face when
 This macro defines @code{obsolete-face} as an alias for
@@ -3564,6 +3564,30 @@ when @code{obsolete-face} was made obsolete (usually a version number
 string).
 @end defmac
 
+@defun read-face-name prompt &optional default multiple
+This function reads a face name in the minibuffer, with completion.
+Arguments @var{prompt} and @var{default} are the minibuffer prompt and
+default value, respectively.  If optional argument @var{multiple} is
+non-@code{nil}, this function reads multiple face names at once, and
+returns them as a list.  To input multiple face names, separate them
+in the minibuffer with @code{crm-separator} (by default, a comma).
+@xref{Minibuffer Completion}.  Commands that prompt the user for a
+face name, such as @code{describe-face}, use this function to do so.
+@end defun
+
+@cindex face samples, in completion
+@defopt read-face-name-sample-text
+This user option controls display of @dfn{face samples} in the
+@file{*Completions*} buffer of @code{read-face-name}.  If this user
+option is non-@code{nil}, @code{read-face-name} shows alongside each
+candidate face name a sample text with that face.  If
+@code{read-face-name-sample-text} is a string, @code{read-face-name}
+uses that string as the sample text.  If it is a non-@code{nil} value
+that is not a string, the face names act as their own sample
+text---@code{read-face-name} fontifies each face name in the
+@file{*Completions*} buffer with the face that it refers to.
+@end defopt
+
 @node Auto Faces
 @subsection Automatic Face Assignment
 @cindex automatic face assignment

diff --git a/etc/NEWS b/etc/NEWS
index 957bcc0a150bafac43554a8308b8fb7afa383d4e..191108ca1d6015ba181a3dd67bec712e39672276 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1248,10 +1248,18 @@ Now, calling '(thing-at-point 'url)' when point is on a bug reference
 will return the URL for that bug.
 
 +++
-*** New user option 'rcirc-log-time-format'
+*** New user option 'rcirc-log-time-format'.
 This allows for rcirc logs to use a custom timestamp format, than the
 chat buffers use by default.
 
++++
+*** New user option 'read-face-name-sample-text'.
+This user option lets you customize the sample text that
+'read-face-name' and commands that invoke 'read-face-name', such as
+'M-x describe-face', use to visually display faces in the
+"*Completions*" buffer.  By default this is set to the string
+"SAMPLE", which retains compatibility with Emacs 29.
+
 ** Customize
 
 +++

diff --git a/lisp/faces.el b/lisp/faces.el
index d5120f42b924f08a1bb314beee7bc52d8db9c87d..b774070c6133712170c65cf16fc3845e70f3abca 100644 (file)
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1096,92 +1096,95 @@ of the default face.  Value is FACE."
 ;;; Interactively modifying faces.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defvar crm-separator) ; from crm.el
+(defcustom read-face-name-sample-text "SAMPLE"
+  "Sample text to fontify and display next to face name completion candidates.
+
+If this user option is a string, as it is by default,
+\(specifically, it defaults to the string \"SAMPLE\"),
+`read-face-name' displays that string next to each face name in
+the *Completions* buffer, fontifying each sample text with the
+candidate face it appears besides, so you can see how it looks.
+
+If this is non-nil and not a string, `read-face-name' fontifies
+the face names themselves with the faces they denote, so each
+face name acts as its own sample text.
+
+If this is nil, `read-face-name' does not show face samples in
+the *Completions* buffer."
+  :version "30.1"
+  :type '(choice string
+                 (const :tag "No sample text" nil)
+                 (const :tag "Use face names" t))
+  :group 'faces)
+
+(defun completion-face-name-affixation (names)
+  "Return completion affixations for face name list NAMES.
 
-(defconst read-face-name-sample-text "SAMPLE"
-  "Text string to display as the sample text for `read-face-name'.")
+The affixation that this function performs depends on the value
+of `read-face-name-sample-text', which see."
+  (mapcar
+   (cond
+    ((stringp read-face-name-sample-text)
+     (let ((max-name (seq-max (mapcar #'string-width names))))
+       (lambda (name)
+         (list name
+               ""
+               (concat
+                (propertize " " 'display `(space :align-to ,(+ max-name 4)))
+                (propertize read-face-name-sample-text 'face name))))))
+    (read-face-name-sample-text
+     (lambda (name) (list (propertize name 'face name) "" "")))
+    (t
+     (lambda (name) (list name "" ""))))
+   names))
+
+(defun read-face-name-sort-aliases-last (names)
+  "Sort face names that are aliases after non-alias faces in list NAMES."
+  (sort names
+        (lambda (l r)
+          (let ((la (get (intern l) 'face-alias))
+                (ra (get (intern r) 'face-alias)))
+            (if la
+                (and ra (string-lessp l r))
+              (or ra (string-lessp l r)))))))
+
+(defun completion-face-name-table (string pred action)
+  "Completion table for face names.
+
+See Info node `(elisp)Programmed Completion' for the meaning of
+STRING, PRED and ACTION."
+  (if (eq action 'metadata)
+      `(metadata
+        (category . face)
+        (display-sort-function . read-face-name-sort-aliases-last)
+        (cycle-sort-function   . read-face-name-sort-aliases-last)
+        ,@(when read-face-name-sample-text
+            '((affixation-function . completion-face-name-affixation))))
+    (complete-with-action action obarray string
+                          (if pred
+                              (lambda (cand)
+                                (and (facep cand) (funcall pred cand)))
+                            #'facep))))
 
 (defun read-face-name (prompt &optional default multiple)
-  "Read one or more face names, prompting with PROMPT.
-PROMPT should not end in a space or a colon.
-
-If DEFAULT is non-nil, it should be a face (a symbol) or a face
-name (a string).  It can also be a list of faces or face names.
-
-If MULTIPLE is non-nil, the return value from this function is a
-list of faces.  Otherwise a single face is returned.
-
-If the user enter the empty string at the prompt, DEFAULT is
-returned after a possible transformation according to MULTIPLE.
-That is, if DEFAULT is a list and MULTIPLE is nil, the first
-element of DEFAULT is returned.  If DEFAULT isn't a list, but
-MULTIPLE is non-nil, a one-element list containing DEFAULT is
-returned.  Otherwise, DEFAULT is returned verbatim."
-  (let (defaults)
-    (setq default (ensure-list default))
-    (when default
-      (setq default
-            (if multiple
-                (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
-                           default ", ")
-              ;; If we only want one, and the default is more than one,
-              ;; discard the unwanted ones and use them only in the
-              ;; "future history" retrieved via `M-n M-n ...'.
-              (setq defaults default default (car default))
-              (if (symbolp default)
-                  (symbol-name default)
-                default))))
-    (when (and default (not multiple))
-      (require 'crm)
-      ;; For compatibility with `completing-read-multiple' use `crm-separator'
-      ;; to define DEFAULT if MULTIPLE is nil.
-      (setq default (car (split-string default crm-separator t))))
-
-    ;; Older versions of `read-face-name' did not append ": " to the
-    ;; prompt, so there are third party libraries that have that in the
-    ;; prompt.  If so, remove it.
-    (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt))
-    (let ((prompt (if default
-                      (format-prompt prompt default)
-                    (format "%s: " prompt)))
-          (completion-extra-properties
-           `(:affixation-function
-             ,(lambda (faces)
-                (mapcar
-                 (lambda (face)
-                   (list face
-                         (concat (propertize read-face-name-sample-text
-                                             'face face)
-                                 "\t")
-                         ""))
-                 faces))))
-          aliasfaces nonaliasfaces faces)
-      ;; Build up the completion tables.
-      (mapatoms (lambda (s)
-                  (if (facep s)
-                      (if (get s 'face-alias)
-                          (push (symbol-name s) aliasfaces)
-                        (push (symbol-name s) nonaliasfaces)))))
-      (if multiple
-          (progn
-            (dolist (face (completing-read-multiple
-                           prompt
-                           (completion-table-in-turn nonaliasfaces aliasfaces)
-                           nil t nil 'face-name-history default))
-              ;; Ignore elements that are not faces
-              ;; (for example, because DEFAULT was "all faces")
-              (if (facep face) (push (if (stringp face)
-                                         (intern face)
-                                       face)
-                                     faces)))
-            (nreverse faces))
-        (let ((face (completing-read
-                     prompt
-                     (completion-table-in-turn nonaliasfaces aliasfaces)
-                     nil t nil 'face-name-history defaults)))
-          (when (facep face) (if (stringp face)
-                                 (intern face)
-                               face)))))))
+  "Read and return a face name (as a symbol), prompting with PROMPT.
+
+Optional argument DEFAULT is the default value (or list of
+default values) in the minibuffer.
+
+You can insert multiple face names in the minibuffer, separated
+by the value of `crm-separator' (normally, a comma).  By default,
+this function returns only the first face name and ignores
+everything after the first separator, but if optional argument
+MULTIPLE is non-nil, this function returns all of the face names
+in your input as a list of face names."
+  (let* ((default (when default (symbol-name default)))
+         (faces
+          (mapcar #'intern
+                  (completing-read-multiple
+                   (format-prompt prompt default) #'completion-face-name-table
+                   nil t nil 'face-name-history default))))
+    (if multiple faces (car faces))))
 
 ;; Not defined without X, but behind window-system test.
 (defvar x-bitmap-file-path)