bug#64725: 30.0.50; set-face-foreground shows background colors

[Helmut Eller]

On Wed, Jul 19 2023, Eli Zaretskii wrote:

> That's exactly what I meant: when you customize the foreground color
> of a face, show the candidates as text in that color on the background
> of the face's background color, and when you customize the background
> of a face, show the candidates as background with the text in the
> foreground color of the face.  IOW, show the face with its both colors
> as it will look if this candidate is chosen.

OK. Here is a patch that should do this:

>From 69159b5ca0123692373a014ed19e01547c12449e Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Thu, 20 Jul 2023 16:27:34 +0200
Subject: [PATCH] Improve the interactive use of set-face-foreground

When displaying the completion candidates, show how the face would
look with the new foreground.

* lisp/faces.el (faces--string-with-color): New helper. Factored
out from defined-colors-with-face-attributes.
(defined-colors-with-face-attributes): Use it.
(read-color): Add optional argument FACE and pass
it to faces--string-with-color.
(read-face-attribute): Call read-color with more appropriate
foreground and face arguments.

* doc/lispref/minibuf.texi (High-Level Completion): Describe the
intention behind the arguments FOREGROUND and FACE of read-color.
---
 doc/lispref/minibuf.texi |  8 ++++-
 lisp/faces.el            | 64 +++++++++++++++++++++++++---------------
 2 files changed, 48 insertions(+), 24 deletions(-)

diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index a861b8e910b..12ea7b12386 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -1515,7 +1515,8 @@ High-Level Completion
 @code{commandp}.
 @end defun
 
-@deffn Command read-color &optional prompt convert allow-empty display
+@deffn Command read-color &optional prompt convert allow-empty @
+  display foreground face
 This function reads a string that is a color specification, either the
 color's name or an RGB hex value such as @code{#RRRGGGBBB}.  It
 prompts with @var{prompt} (default: @code{"Color (name or #RGB triplet):"})
@@ -1535,6 +1536,11 @@ High-Level Completion
 
 Interactively, or when @var{display} is non-@code{nil}, the return
 value is also displayed in the echo area.
+
+The optional arguments FOREGROUND and FACE control the appearence of
+the completion candidates.  The candidates are displayed like FACE but
+with different colors.  If FOREGROUND is non-@code{nil} the foreground
+varies, otherwise the background.
 @end deffn
 
   See also the functions @code{read-coding-system} and
diff --git a/lisp/faces.el b/lisp/faces.el
index 44d64c743ba..4f51a031156 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1340,10 +1340,11 @@ read-face-attribute
                       (format "%s" old-value))))
             (setq new-value
                    (if (memq attribute '(:foreground :background))
-                       (let ((color
-                              (read-color
-                               (format-prompt "%s for face `%s'"
-                                              default attribute-name face))))
+                       (let* ((prompt (format-prompt
+                                       "%s for face `%s'"
+                                       default attribute-name face))
+                              (fg (eq attribute ':foreground))
+                              (color (read-color prompt nil nil nil fg face)))
                          (if (equal (string-trim color) "")
                              default
                            color))
@@ -1870,15 +1871,26 @@ defined-colors-with-face-attributes
 strings with text properties, that make the color names render
 with the color they represent as background color (if FOREGROUND
 is nil; otherwise use the foreground color)."
-  (mapcar
-   (lambda (color-name)
-     (let ((color (copy-sequence color-name)))
-       (propertize color 'face
-                  (if foreground
-                      (list :foreground color)
-                    (list :foreground (readable-foreground-color color-name)
-                           :background color)))))
-   (defined-colors frame)))
+  (mapcar (lambda (color-name)
+            (faces--string-with-color color-name color-name foreground))
+          (defined-colors frame)))
+
+(defun faces--string-with-color (string color &optional foreground face)
+  "Return a copy of STRING with face attributes for COLOR.
+Set the :background or :foreground attribute to COLOR, depending
+on the argument FOREGROUND.
+
+The optional FACE argument controls the values for other
+attributes."
+  (let* ((defaults (if face (list face) '()))
+         (colors (cond (foreground
+                        (list :foreground color))
+                       (face
+                        (list :background color))
+                       (t
+                        (list :foreground (readable-foreground-color color)
+                              :background color)))))
+    (propertize string 'face (cons colors defaults))))
 
 (defun readable-foreground-color (color)
   "Return a readable foreground color for background COLOR.
@@ -1987,7 +1999,7 @@ display-grayscale-p
     (> (tty-color-gray-shades display) 2)))
 
 (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg
-                            foreground)
+                            foreground face)
   "Read a color name or RGB triplet.
 Completion is available for color names, but not for RGB triplets.
 
@@ -2016,17 +2028,23 @@ read-color
 Interactively, or with optional arg MSG non-nil, print the
 resulting color name in the echo area.
 
-Interactively, displays a list of colored completions.  If optional
-argument FOREGROUND is non-nil, shows them as foregrounds, otherwise
-as backgrounds."
+Interactively, displays a list of colored completions.  If
+optional argument FOREGROUND is non-nil, shows them as
+foregrounds, otherwise as backgrounds.  The optional argument
+FACE controls the default appearance."
   (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
   (let* ((completion-ignore-case t)
-        (colors (append '("foreground at point" "background at point")
-                        (if allow-empty-name '(""))
-                         (if (display-color-p)
-                             (defined-colors-with-face-attributes
-                               nil foreground)
-                           (defined-colors))))
+        (color-alist
+          `(("foreground at point" . ,(foreground-color-at-point))
+            ("background at point" . ,(background-color-at-point))
+            ,@(if allow-empty-name '(("" . unspecified)))
+            ,@(mapcar (lambda (c) (cons c c)) (defined-colors))))
+         (colors (mapcar (lambda (pair)
+                           (let* ((name (car pair))
+                                  (color (cdr pair)))
+                             (faces--string-with-color name color
+                                                       foreground face)))
+                         color-alist))
         (color (completing-read
                 (or prompt "Color (name or #RGB triplet): ")
                 ;; Completing function for reading colors, accepting
-- 
2.39.2