Subject: bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.

From: David Ponce <[email-masked]>
Date: Thu, 31 Aug 2023 10:18:43 +0200

On 31/08/2023 00:30, David Ponce wrote:
> On 30/08/2023 21:22, Eli Zaretskii wrote:
>>> Cc: [email-masked]
>>> Date: Wed, 30 Aug 2023 21:35:11 +0300
>>> From: Eli Zaretskii <[email-masked]>
>>>
>>>> ;; Display "TEST" in red, bold, italic on yellow background.
>>>> (insert
>>>>    (propertize
>>>>     "TEST" 'font-lock-face
>>>>     '(bold ((:background "yellow") "italic"
>>>>             ((foreground-color . "red") underline)))))
>>>
>>> This is not a valid face, AFAIU.  That it works is sheer luck (because
>>> Emacs is very lenient with this stuff).  The correct face definition
>>> for what you want is this (see 'set-face-attribute's doc string):
>>>
>>>    (insert
>>>      (propertize
>>>       "TEST" 'font-lock-face
>>>       '(:weight bold :background "yellow" :slant italic
>>>          :foreground "red" :underline t)))
>>>
>>> If you use the above, foreground-color-at-point etc. will work as
>>> expected.
>>>
>>> I'm not sure we want to go out of our way to support the kind of face
>>> specifications that you used.
>>
>> However, if we do want that, we already have the technology:
>>
>>    (face-attributes-as-vector (get-char-property (point) 'font-lock-face))
>>
>> This will return a vector of face attribute values, where you can find
>> the value of any attribute you like.  For example, to get the
>> foreground color, evaluate:
>>
>>    (aref 9
>>      (face-attributes-as-vector (get-char-property (point) 'font-lock-face)))
> 
> Hi Eli,
> 
> Thank you very much for letting me know about `face-attributes-as-vector'
> (maybe its doc string could be improved?).  It is exactly the function I need :-)
> 
> In case you are interested, I attached an updated patch to faces.el that use
> this function to lookup face attribute, which improves and simplify  the
> functions `faces--attribute-at-point', `foreground-color-at-point' and
> `background-color-at-point'.
> 
> Regards

Please find attached a revised patch.  I used the name
`faces-attribute' instead of `face-attribute-lookup' for consistency
with `faces--attribute-at-point'.  I simplified this new function
because `face-attributes-as-vector' always returns the symbol
`unspecified' when an attribute is not specified (according to what I
understand of the implementation in xfaces.c).  I also improved the
doc string to include a link to the Elisp manual regarding the meaning
of face specification.

Here is an updated changelog:

	* faces.el: Improve attribute lookup of face at point.
	(face--attribute-index): New constant.
	(faces-attribute): New function.
	(faces--attribute-at-point): Use it.  Remove unused argument.
	(foreground-color-at-point)
	(background-color-at-point): Call accordingly.

Regards

diff --git a/lisp/faces.el b/lisp/faces.el
index 8f93f9b2c0c..1db0bbccf1e 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2109,50 +2109,70 @@ face-at-point
         (delete-dups (nreverse faces))
       (car (last faces)))))
 
-(defun faces--attribute-at-point (attribute &optional attribute-unnamed)
+(defconst face--attribute-index
+  ;; From lface_attribute_index in src/dispextern.h.
+  '((:family             . 1)
+    (:foundry            . 2)
+    (:width              . 3)
+    (:height             . 4)
+    (:weight             . 5)
+    (:slant              . 6)
+    (:underline          . 7)
+    (:inverse-video      . 8)
+    (:foreground         . 9)
+    (:background         . 10)
+    (:stipple            . 11)
+    (:overline           . 12)
+    (:strike-through     . 13)
+    (:box                . 14)
+    (:font               . 15)
+    (:inherit            . 16)
+    (:fontset            . 17)
+    (:distant-foreground . 18)
+    (:extend             . 19)
+    )
+  "Indices of face attributes in Lisp face vectors.")
+
+(defun faces-attribute (face attribute &optional default)
+  "Return the value of FACE's ATTRIBUTE or nil if unspecified.
+FACE is a valid face specification (see description of the `face'
+text property in Info node `(elisp) Special Properties').
+DEFAULT is an optional face specification appended to FACE.  If
+DEFAULT includes the `default' face, the return value is always
+specified and absolute."
+  (when-let ((index (cdr (assq attribute face--attribute-index)))
+             (value (aref (face-attributes-as-vector
+                           (append (ensure-list face)
+                                   (ensure-list default)))
+                          index)))
+    (unless (eq value 'unspecified)
+      value)))
+
+(defun faces--attribute-at-point (attribute)
   "Return the face ATTRIBUTE at point.
-ATTRIBUTE is a keyword.
-If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in
-unnamed faces (e.g, `foreground-color')."
+ATTRIBUTE is a keyword."
   ;; `face-at-point' alone is not sufficient.  It only gets named faces.
   ;; Need also pick up any face properties that are not associated with named faces.
   (let ((faces (or (get-char-property (point) 'read-face-name)
                    ;; If `font-lock-mode' is on, `font-lock-face' takes precedence.
                    (and font-lock-mode
                         (get-char-property (point) 'font-lock-face))
-                   (get-char-property (point) 'face)))
-        (found nil))
-    (dolist (face (if (face-list-p faces)
-                      faces
-                    (list faces)))
-      (cond (found)
-            ((and face (symbolp face))
-             (let ((value (face-attribute-specified-or
-                           (face-attribute face attribute nil t)
-                           nil)))
-               (unless (member value '(nil "unspecified-fg" "unspecified-bg"))
-                 (setq found value))))
-            ((consp face)
-             (setq found (cond ((and attribute-unnamed
-                                     (memq attribute-unnamed face))
-                                (cdr (memq attribute-unnamed face)))
-                               ((memq attribute face) (cadr (memq attribute face))))))))
-    (or found
-        (face-attribute 'default attribute))))
+                   (get-char-property (point) 'face))))
+    (faces-attribute faces attribute 'default)))
 
 (defun foreground-color-at-point ()
   "Return the foreground color of the character after point.
 On TTY frames, the returned color name can be \"unspecified-fg\",
 which stands for the unknown default foreground color of the
 display where the frame is displayed."
-  (faces--attribute-at-point :foreground 'foreground-color))
+  (faces--attribute-at-point :foreground))
 
 (defun background-color-at-point ()
   "Return the background color of the character after point.
 On TTY frames, the returned color name can be \"unspecified-bg\",
 which stands for the unknown default background color of the
 display where the frame is displayed."
-  (faces--attribute-at-point :background 'background-color))
+  (faces--attribute-at-point :background))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;