make read-face-name behave as promised

["Roland Winkler" <winkler@gnu.org>]

[-- Attachment #1: message body text --]
[-- Type: text/plain, Size: 1141 bytes --]

After fixing a bug in completing-read-multiple (remove empty strings
from the list of read strings) I thought I could also clean up
read-face-name, which worked around this bug.

Yet I got side-tracked by the fact that currently read-face-name
does not behave as promised by its doc string:

- The arg DEFAULT is treated like a single string, though the doc
  string says it should be a list of faces. 

- The arg DEFAULT is ignored if the text at point has a
  `read-face-name' or `face' property. This appears like a bug to me
  because it makes the arg DEFAULT useless in this case.

- If the thing at point is a face, this is taken as the first element
  of DEFAULT.

The patch below makes read-face-name behave as promised by its doc
string. Yet this may cause trouble elsewhere if code relies on the
current behavior of read-face-name.  So I first wanted to post this
patch to emacs-devel.  In the emacs trunk, I found only one function
(describe-face) that relies on the current behavior of
read-face-name. So the patch below fixes this, too. But there might
be other emacs packages (not part of the trunk) that I do not know
about.


[-- Attachment #2: faces.patch --]
[-- Type: application/octet-stream, Size: 6203 bytes --]

=== modified file 'lisp/faces.el'
--- lisp/faces.el	2013-01-10 03:43:02 +0000
+++ lisp/faces.el	2013-04-01 01:29:04 +0000
@@ -935,80 +935,75 @@
 
 The optional argument DEFAULT specifies the default face name(s)
 to return if the user just types RET.  If its value is non-nil,
-it should be a list of face names (symbols); in that case, the
-default return value is the `car' of DEFAULT (if the argument
+it should be a list of face names (symbols or strings); in that case,
+the default return value is the `car' of DEFAULT (if the argument
 MULTIPLE is non-nil), or DEFAULT (if MULTIPLE is nil).  See below
 for the meaning of MULTIPLE.
 
 If DEFAULT is nil, the list of default face names is taken from
-the `read-face-name' property of the text at point, or, if that
-is nil, from the `face' property of the text at point.
+the symbol at point and the `read-face-name' property of the text at point,
+or, if that is nil, from the `face' property of the text at point.
 
-This function uses `completing-read-multiple' with \",\" as the
-separator character.  Thus, the user may enter multiple face
+This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\"
+as the separator regexp.  Thus, the user may enter multiple face
 names, separated by commas.  The optional argument MULTIPLE
 specifies the form of the return value.  If MULTIPLE is non-nil,
 return a list of face names; if the user entered just one face
 name, the return value would be a list of one face name.
 Otherwise, return a single face name; if the user entered more
 than one face name, return only the first one."
-  (let ((faceprop (or (get-char-property (point) 'read-face-name)
-		      (get-char-property (point) 'face)))
-        (aliasfaces nil)
-        (nonaliasfaces nil)
-	faces)
-    ;; Try to get a face name from the buffer.
-    (if (memq (intern-soft (thing-at-point 'symbol)) (face-list))
-	(setq faces (list (intern-soft (thing-at-point 'symbol)))))
-    ;; Add the named faces that the `face' property uses.
-    (if (and (listp faceprop)
-	     ;; Don't treat an attribute spec as a list of faces.
-	     (not (keywordp (car faceprop)))
-	     (not (memq (car faceprop) '(foreground-color background-color))))
-	(dolist (f faceprop)
-	  (if (symbolp f)
-	      (push f faces)))
-      (if (symbolp faceprop)
-	  (push faceprop faces)))
-    (delete-dups faces)
-
-    ;; Build up the completion tables.
+  (unless default
+    ;; Try to get a default face name from the buffer.
+    (let ((thing (intern-soft (thing-at-point 'symbol))))
+      (if (memq thing (face-list))
+          (setq default (list thing))))
+    ;; Add the named faces that the `read-face-name' or `face' property uses.
+    ;; Should we use the default face (as in `face-at-point') if both
+    ;; the `read-face-name' or `face' properties are nil?
+    (let ((faceprop (or (get-char-property (point) 'read-face-name)
+                        (get-char-property (point) 'face))))
+      (if (and (listp faceprop)
+               ;; Don't treat an attribute spec as a list of faces.
+               (not (keywordp (car faceprop)))
+               (not (memq (car faceprop) '(foreground-color background-color))))
+          (dolist (face faceprop)
+            (if (symbolp face)
+                (push face default)))
+        (if (symbolp faceprop)
+            (push faceprop default)))
+      (delete-dups default)))
+
+  ;; If we only want one, and the default is more than one,
+  ;; discard the unwanted ones now.
+  (if (and default (not multiple))
+      (setq default (list (car default))))
+
+  (if default
+      (setq default (mapconcat (lambda (f)
+                                 (if (symbolp f) (symbol-name f) f))
+                               default ", ")))
+
+  ;; Build up the completion tables.
+  (let (aliasfaces nonaliasfaces)
     (mapatoms (lambda (s)
                 (if (custom-facep s)
                     (if (get s 'face-alias)
                         (push (symbol-name s) aliasfaces)
                       (push (symbol-name s) nonaliasfaces)))))
 
-    ;; If we only want one, and the default is more than one,
-    ;; discard the unwanted ones now.
-    (unless multiple
-      (if faces
-	  (setq faces (list (car faces)))))
-    (require 'crm)
-    (let* ((input
-	    ;; Read the input.
-	    (completing-read-multiple
-	     (if (or faces default)
-		 (format "%s (default `%s'): " prompt
-			 (if faces (mapconcat 'symbol-name faces ",")
-			   default))
-	       (format "%s: " prompt))
-	     (completion-table-in-turn nonaliasfaces aliasfaces)
-	     nil t nil 'face-name-history
-	     (if faces (mapconcat 'symbol-name faces ","))))
-	   ;; Canonicalize the output.
-	   (output
-	    (cond ((or (equal input "") (equal input '("")))
-		   (or faces (unless (stringp default) default)))
-		  ((stringp input)
-		   (mapcar 'intern (split-string input ", *" t)))
-		  ((listp input)
-		   (mapcar 'intern input))
-		  (input))))
+    (let ((faces
+           ;; Read the faces.
+           (mapcar 'intern
+                   (completing-read-multiple
+                    (if default
+                        (format "%s (default `%s'): " prompt default)
+                      (format "%s: " prompt))
+                    (completion-table-in-turn nonaliasfaces aliasfaces)
+                    nil t nil 'face-name-history default))))
       ;; Return either a list of faces or just one face.
       (if multiple
-	  output
-	(car output)))))
+	  faces
+	(car faces)))))
 
 ;; Not defined without X, but behind window-system test.
 (defvar x-bitmap-file-path)
@@ -1363,7 +1358,10 @@
 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" 'default t)))
+  (interactive (list (read-face-name "Describe face"
+                                     (if (eq 'default (face-at-point))
+                                         '(default))
+                                     t)))
   (let* ((attrs '((:family . "Family")
 		  (:foundry . "Foundry")
 		  (:width . "Width")