Show the face colours when completing in `read-color'

* lisp/faces.el (defined-colors-with-face-attributes): New function.
(readable-foreground-color, defined-colors-with-face-attributes)
(readable-foreground-color): Ditto.
(read-color): Use them (bug#5305).

1 files changed, 58 insertions, 4 deletions

diff --git a/lisp/faces.el b/lisp/faces.el
index bfb5d4c0f69..b5e9fdca08e 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1792,6 +1792,58 @@ If FRAME is nil, that stands for the selected frame."
     (mapcar 'car (tty-color-alist frame))))
 (defalias 'x-defined-colors 'defined-colors)
 
+(defun defined-colors-with-face-attributes (&optional frame)
+  "Return a list of colors supported for a particular frame.
+See `defined-colors' for arguments and return value. In contrast
+to `define-colors' the elements of the returned list are color
+strings with text properties, that make the color names render
+with the color they represent as background color."
+  (mapcar
+   (lambda (color-name)
+     (let ((foreground (readable-foreground-color color-name))
+	   (color      (copy-sequence color-name)))
+       (propertize color 'face (list :foreground foreground
+				     :background color))))
+   (defined-colors frame)))
+
+(defun readable-foreground-color (color)
+  "Return a readable foreground color for background COLOR."
+  (let* ((rgb   (color-values color))
+	 (max   (apply #'max rgb))
+	 (black (car (color-values "black")))
+	 (white (car (color-values "white"))))
+    ;; Select black or white depending on which one is less similar to
+    ;; the brightest component.
+    (if (> (abs (- max black)) (abs (- max white)))
+	"black"
+      "white")))
+
+(defun defined-colors-with-face-attributes (&optional frame)
+  "Return a list of colors supported for a particular frame.
+See `defined-colors' for arguments and return value. In contrast
+to `define-colors' the elements of the returned list are color
+strings with text properties, that make the color names render
+with the color they represent as background color."
+  (mapcar
+   (lambda (color-name)
+     (let ((foreground (readable-foreground-color color-name))
+	   (color      (copy-sequence color-name)))
+       (propertize color 'face (list :foreground foreground
+				     :background color))))
+   (defined-colors frame)))
+
+(defun readable-foreground-color (color)
+  "Return a readable foreground color for background COLOR."
+  (let* ((rgb   (color-values color))
+	 (max   (apply #'max rgb))
+	 (black (car (color-values "black")))
+	 (white (car (color-values "white"))))
+    ;; Select black or white depending on which one is less similar to
+    ;; the brightest component.
+    (if (> (abs (- max black)) (abs (- max white)))
+	"black"
+      "white")))
+
 (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
 
 (defun color-defined-p (color &optional frame)
@@ -1896,22 +1948,24 @@ resulting color name in the echo area."
 	 (colors (or facemenu-color-alist
 		     (append '("foreground at point" "background at point")
 			     (if allow-empty-name '(""))
-			     (defined-colors))))
+                             (if (display-color-p)
+                                 (defined-colors-with-face-attributes)
+                               (defined-colors)))))
 	 (color (completing-read
 		 (or prompt "Color (name or #RGB triplet): ")
 		 ;; Completing function for reading colors, accepting
 		 ;; both color names and RGB triplets.
 		 (lambda (string pred flag)
 		   (cond
-		    ((null flag) ; Try completion.
+		    ((null flag)        ; Try completion.
 		     (or (try-completion string colors pred)
 			 (if (color-defined-p string)
 			     string)))
-		    ((eq flag t) ; List all completions.
+		    ((eq flag t)        ; List all completions.
 		     (or (all-completions string colors pred)
 			 (if (color-defined-p string)
 			     (list string))))
-		    ((eq flag 'lambda) ; Test completion.
+		    ((eq flag 'lambda)  ; Test completion.
 		     (or (member string colors)
 			 (color-defined-p string)))))
 		 nil t)))