(read-face-name): New defaulting features.

New args STRING-DESCRIBING-DEFAULT and MULTIPLE.
(list-faces-display): Use the face, not its name string,
as arg when running customize-face.
Put a `read-face-name' prop on the entire line.
(describe-face): Handle multiple faces via read-face-name.

lisp/faces.el

@@ -846,21 +846,56 @@ of the default face.  Value is FACE."
 ;;; Interactively modifying faces.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defun read-face-name (prompt)
+(defun read-face-name (prompt &optional string-describing-default multiple)
-  "Read and return a face symbol, prompting with PROMPT.
+  "Read a face, defaulting to the face or faces on the char after point.
-PROMPT should not end with a blank, since this function appends one.
+If it has a `read-face-name' property, that overrides the `face' property.
-Value is a symbol naming a known face."
+PROMPT describes what you will do with the face (don't end in a space).
-  (let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x))
+STRING-DESCRIBING-DEFAULT describes what default you will use
-			   (face-list)))
+if this function returns nil.
-	(def (thing-at-point 'symbol))
+If MULTIPLE is non-nil, return a list of faces (possibly only one).
-	face)
+Otherwise, return a single face."
-    (cond ((assoc def face-list)
+  (let ((faceprop (or (get-char-property (point) 'read-face-name)
-	   (setq prompt (concat prompt " (default " def "): ")))
+		      (get-char-property (point) 'face)))
-	  (t (setq def nil)
+	faces)
-	     (setq prompt (concat prompt ": "))))
+    ;; Make a list of the named faces that the `face' property uses.
-    (while (equal "" (setq face (completing-read
+    (if (listp faceprop)
-				 prompt face-list nil t nil nil def))))
+	(dolist (f faceprop)
-    (intern face)))
+	  (if (symbolp f)
+	      (push f faces)))
+      (if (symbolp faceprop)
+	  (setq faces (list faceprop))))
+    ;; If there are none, try to get a face name from the buffer.
+    (if (and (null faces)
+	     (memq (intern-soft (thing-at-point 'symbol)) (face-list)))
+	(setq faces (list (intern-soft (thing-at-point 'symbol)))))
+
+    ;; 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)))))
+    (let* ((input
+	    ;; Read the input.
+	    (completing-read
+	     (if (or faces string-describing-default)
+		 (format "%s (default %s): " prompt
+			 (if faces (mapconcat 'symbol-name faces ", ")
+			   string-describing-default))
+	       prompt)
+	     obarray 'custom-facep t))
+	   ;; Canonicalize the output.
+	   (output
+	    (if (equal input "")
+		faces
+	      (if (stringp input)
+		  (list (intern input))
+		input))))
+      ;; Return either a list of faces or just one face.
+      (if multiple
+	  output
+	(car output)))))
+
+
 
 
 (defun face-valid-attribute-values (attribute &optional frame)
@@ -1137,8 +1172,9 @@ The sample text is a string that comes from the variable
 	  (save-excursion
 	    (save-match-data
 	      (search-backward face-name)
-	      (help-xref-button 0 'help-customize-face face-name)))
+	      (help-xref-button 0 'help-customize-face face)))
-	  (let ((beg (point)))
+	  (let ((beg (point))
+		(line-beg (line-beginning-position)))
 	    (insert list-faces-sample-text)
 	    ;; Hyperlink to a help buffer for the face.
 	    (save-excursion
@@ -1147,6 +1183,9 @@ The sample text is a string that comes from the variable
 		(help-xref-button 0 'help-face face)))
 	    (insert "\n")
 	    (put-text-property beg (1- (point)) 'face face)
+	    ;; Make all face commands default to the proper face
+	    ;; anywhere in the line.
+	    (put-text-property line-beg (1- (point)) 'read-face-name face)
 	    ;; If the sample text has multiple lines, line up all of them.
 	    (goto-char beg)
 	    (forward-line 1)
@@ -1167,13 +1206,15 @@ The sample text is a string that comes from the variable
 	    (copy-face (car faces) (car faces) frame disp-frame)
 	    (setq faces (cdr faces)))))))
 
-
 (defun describe-face (face &optional frame)
   "Display the properties of face FACE on FRAME.
+Interactevely, FACE defaults to the faces of the character after point
+and FRAME defaults to the selected frame.
+
 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")))
+  (interactive (list (read-face-name "Describe face" "= `default' face" t)))
   (let* ((attrs '((:family . "Family")
 		  (:width . "Width")
 		  (:height . "Height")
@@ -1192,25 +1233,33 @@ If FRAME is omitted or nil, use the selected frame."
 	(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
 					attrs))))
     (help-setup-xref (list #'describe-face face) (interactive-p))
+    (unless face
+      (setq face 'default))
+    (if (not (listp face))
+	(setq face (list face)))
     (with-output-to-temp-buffer (help-buffer)
       (save-excursion
 	(set-buffer standard-output)
-	(dolist (a attrs)
+	(dolist (f face)
-	  (let ((attr (face-attribute face (car a) frame)))
+	  (insert "Face: " (symbol-name f))
-	    (insert (make-string (- max-width (length (cdr a))) ?\ )
+	  (if (not (facep f))
-		    (cdr a) ": " (format "%s" attr) "\n")))
+	      (insert "   undefined face.\n")
-	(insert "\nDocumentation:\n\n"
+	    (let ((customize-label "customize this face"))
-		(or (face-documentation face)
+	      (princ (concat " (" customize-label ")\n"))
-		    "not documented as a face."))
+	      (insert "Documentation: "
-	(let ((customize-label "customize"))
+		      (or (face-documentation f)
-	  (terpri)
+			  "not documented as a face.")
-	  (terpri)
+		      "\n\n")
-	  (princ (concat "You can " customize-label " this face."))
+	      (with-current-buffer standard-output
-	  (with-current-buffer standard-output
+		(save-excursion
-	    (save-excursion
+		  (re-search-backward
-	      (re-search-backward
+		   (concat "\\(" customize-label "\\)") nil t)
-	       (concat "\\(" customize-label "\\)") nil t)
+		  (help-xref-button 1 'help-customize-face f)))
-	      (help-xref-button 1 'help-customize-face face)))))
+	      (dolist (a attrs)
+		(let ((attr (face-attribute f (car a) frame)))
+		  (insert (make-string (- max-width (length (cdr a))) ?\ )
+			  (cdr a) ": " (format "%s" attr) "\n")))))
+	  (terpri)))
       (print-help-return-message))))