* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
@ 2023-08-30 18:04 David Ponce
2023-08-30 18:35 ` Eli Zaretskii
0 siblings, 1 reply; 6+ messages in thread
From: David Ponce @ 2023-08-30 18:04 UTC (permalink / raw)
To: 65632
[-- Attachment #1: Type: text/plain, Size: 1389 bytes --]
Hello,
I noticed that the functions `foreground-color-at-point' and
`background-color-at-point' don't return expected values when the face
at point includes anonymous face or is a nested list of face, for
example.
Here is a simple recipe that demonstrates the issue (emacs -Q):
In scratch buffer eval:
-----------------------
;; Display "TEST" in red, bold, italic on yellow background.
(insert
(propertize
"TEST" 'font-lock-face
'(bold ((:background "yellow") "italic"
((foreground-color . "red") underline)))))
TESTnil
;; Then click to move point somewhere on TEST and run
M-: (foreground-color-at-point) RET
>>> result is "black" instead of "red"
M-: (background-color-at-point) RET
>>> result is "white" instead of "yellow"
I propose the attached patch to faces.el to improve things.
The patch introduce a new function `face-attribute-lookup' to lookup
face attribute, that works when face specification is complex like in
above example. The function `faces--attribute-at-point' is simplified
to use it.
Here is a possible changelog:
* faces.el: Improve attribute lookup of face at point.
(face--unnamed-attributes): New constant.
(face--attribute-unspecified-p)
(face-attribute-lookup): New functions.
(faces--attribute-at-point): Use it. Remove useless argument.
(foreground-color-at-point)
(background-color-at-point): Update accordingly.
Thanks
[-- Attachment #2: faces-attribute-lookup-V0.patch --]
[-- Type: text/x-patch, Size: 5901 bytes --]
diff --git a/lisp/faces.el b/lisp/faces.el
index 8f93f9b2c0c..dd1d60407cd 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2109,50 +2109,107 @@ face-at-point
(delete-dups (nreverse faces))
(car (last faces)))))
-(defun faces--attribute-at-point (attribute &optional attribute-unnamed)
+(defconst face--unnamed-attributes
+ '((foreground-color . :foreground)
+ (background-color . :background))
+ "Alist of unnamed face attribute with keyword equivalent.
+Used for backward compatibility.")
+
+(defsubst face--attribute-unspecified-p (value)
+ "Return non-nil if face attribute VALUE means unspecified."
+ (member value '(nil unspecified "unspecified-fg" "unspecified-bg")))
+
+(defun face-attribute-lookup (face attribute &optional frame default)
+ "Lookup the value of FACE's ATTRIBUTE on FRAME.
+FACE is a valid face specification:
+
+FACE-SPEC := FACE-NAME | ANONYM-FACE | COLOR | FACE-LIST
+FACE-NAME := SYMBOL | STRING
+ANONYM-FACE := (ATTRIBUTE-1 VALUE-1 ... ATTRIBUTE-N VALUE-N)
+COLOR := FOREGROUND | BACKGROUND
+FOREGROUND := (`foreground-color' . COLOR-NAME)
+BACKGROUND := (`background-color' . COLOR-NAME)
+FACE-LIST := (FACE-SPEC-1 ... FACE-SPEC-N)
+
+If the optional argument FRAME is given, report on FACE in that frame.
+If FRAME is t, report on the defaults for FACE (for new frames).
+If FRAME is omitted or nil, use the selected frame.
+
+Optional argument DEFAULT is a face specification appended to FACE.
+If DEFAULT includes the `default' face, the return value is always
+specified and absolute.
+
+Return the first specified value found for ATTRIBUTE, or nil if
+ATTRIBUTE is unspecified."
+ (catch 'found
+ (let ((faces (append (ensure-list face) (ensure-list default)))
+ (rest nil))
+ (while t
+ (cond
+ ;; End of a face-spec.
+ ((null faces)
+ (if rest
+ (setq faces (car rest) rest (cdr rest))
+ (throw 'found nil)))
+ ;; Malformed face-spec.
+ ((atom faces)
+ (throw 'found nil))
+ ;; Face name.
+ ((facep (car faces))
+ (let* ((face (car faces))
+ (attr (face-attribute (if (stringp face)
+ (intern face)
+ face)
+ attribute frame t)))
+ (if (face--attribute-unspecified-p attr)
+ (setq faces (cdr faces))
+ (throw 'found attr))))
+ ;; Anonymous face (plist).
+ ((keywordp (car faces))
+ (let ((attr (plist-get faces attribute)))
+ (if (face--attribute-unspecified-p attr)
+ (setq faces nil)
+ (throw 'found attr))))
+ ;; Color.
+ ((when-let ((sym (assq (car faces) face--unnamed-attributes)))
+ (if (or (not (eq attribute (cdr sym)))
+ (face--attribute-unspecified-p (cdr faces)))
+ (setq faces nil)
+ (throw 'found (cdr faces)))))
+ ;; Nested face-list.
+ ((consp (car faces))
+ (setq rest (cons (cdr faces) (if (cdr faces)
+ (cons (cdr faces) rest)
+ rest))
+ faces (car faces)))
+ ;; Skip unknow value.
+ ((setq faces (cdr faces))))))))
+
+(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))))
+ (face-attribute-lookup faces attribute nil '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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
^ permalink raw reply related [flat|nested] 6+ messages in thread
* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
2023-08-30 18:04 bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point' David Ponce
@ 2023-08-30 18:35 ` Eli Zaretskii
2023-08-30 19:22 ` Eli Zaretskii
0 siblings, 1 reply; 6+ messages in thread
From: Eli Zaretskii @ 2023-08-30 18:35 UTC (permalink / raw)
To: David Ponce; +Cc: 65632
> Date: Wed, 30 Aug 2023 20:04:49 +0200
> From: David Ponce <da_vid@orange.fr>
>
> I noticed that the functions `foreground-color-at-point' and
> `background-color-at-point' don't return expected values when the face
> at point includes anonymous face or is a nested list of face, for
> example.
>
> Here is a simple recipe that demonstrates the issue (emacs -Q):
>
> In scratch buffer eval:
> -----------------------
>
> ;; 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.
^ permalink raw reply [flat|nested] 6+ messages in thread
* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
2023-08-30 18:35 ` Eli Zaretskii
@ 2023-08-30 19:22 ` Eli Zaretskii
2023-08-30 22:30 ` David Ponce
0 siblings, 1 reply; 6+ messages in thread
From: Eli Zaretskii @ 2023-08-30 19:22 UTC (permalink / raw)
To: da_vid; +Cc: 65632
> Cc: 65632@debbugs.gnu.org
> Date: Wed, 30 Aug 2023 21:35:11 +0300
> From: Eli Zaretskii <eliz@gnu.org>
>
> > ;; 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)))
^ permalink raw reply [flat|nested] 6+ messages in thread
* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
2023-08-30 19:22 ` Eli Zaretskii
@ 2023-08-30 22:30 ` David Ponce
2023-08-31 8:18 ` David Ponce
0 siblings, 1 reply; 6+ messages in thread
From: David Ponce @ 2023-08-30 22:30 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 65632
[-- Attachment #1: Type: text/plain, Size: 1807 bytes --]
On 30/08/2023 21:22, Eli Zaretskii wrote:
>> Cc: 65632@debbugs.gnu.org
>> Date: Wed, 30 Aug 2023 21:35:11 +0300
>> From: Eli Zaretskii <eliz@gnu.org>
>>
>>> ;; 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
[-- Attachment #2: faces-attribute-lookup-V1.patch --]
[-- Type: text/x-patch, Size: 4443 bytes --]
diff --git a/lisp/faces.el b/lisp/faces.el
index 8f93f9b2c0c..e64d33cf1d6 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2109,50 +2109,74 @@ 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)
+ (:reverse-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.")
+
+(defsubst face--attribute-unspecified-p (value)
+ "Return non-nil if face attribute VALUE means unspecified."
+ (member value '(unspecified "unspecified-fg" "unspecified-bg")))
+
+(defun face-attribute-lookup (face attribute &optional default)
+ "Return the value of FACE's ATTRIBUTE or nil if unspecified.
+FACE is a valid face specification.
+Optional argument DEFAULT is a 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 (face--attribute-unspecified-p value)
+ 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))))
+ (face-attribute-lookup 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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
^ permalink raw reply related [flat|nested] 6+ messages in thread
* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
2023-08-30 22:30 ` David Ponce
@ 2023-08-31 8:18 ` David Ponce
2023-08-31 12:08 ` David Ponce
0 siblings, 1 reply; 6+ messages in thread
From: David Ponce @ 2023-08-31 8:18 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 65632
[-- Attachment #1: Type: text/plain, Size: 2763 bytes --]
On 31/08/2023 00:30, David Ponce wrote:
> On 30/08/2023 21:22, Eli Zaretskii wrote:
>>> Cc: 65632@debbugs.gnu.org
>>> Date: Wed, 30 Aug 2023 21:35:11 +0300
>>> From: Eli Zaretskii <eliz@gnu.org>
>>>
>>>> ;; 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
[-- Attachment #2: faces-attribute-lookup-V2.patch --]
[-- Type: text/x-patch, Size: 4286 bytes --]
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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
^ permalink raw reply related [flat|nested] 6+ messages in thread
* bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point'.
2023-08-31 8:18 ` David Ponce
@ 2023-08-31 12:08 ` David Ponce
0 siblings, 0 replies; 6+ messages in thread
From: David Ponce @ 2023-08-31 12:08 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 65632
[-- Attachment #1: Type: text/plain, Size: 3010 bytes --]
On 31/08/2023 10:18, David Ponce wrote:
> On 31/08/2023 00:30, David Ponce wrote:
>> On 30/08/2023 21:22, Eli Zaretskii wrote:
>>>> Cc: 65632@debbugs.gnu.org
>>>> Date: Wed, 30 Aug 2023 21:35:11 +0300
>>>> From: Eli Zaretskii <eliz@gnu.org>
>>>>
>>>>> ;; 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
Sorry, my previous patch was buggy. Here is the correct one.
[-- Attachment #2: faces-attribute-lookup-V3.patch --]
[-- Type: text/x-patch, Size: 4220 bytes --]
diff --git a/lisp/faces.el b/lisp/faces.el
index 8f93f9b2c0c..6d7bf2f410e 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2109,50 +2109,69 @@ 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
+ (list face 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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
^ permalink raw reply related [flat|nested] 6+ messages in thread
end of thread, other threads:[~2023-08-31 12:08 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-08-30 18:04 bug#65632: 30.0.50; Proposal to improve `faces--attribute-at-point' David Ponce
2023-08-30 18:35 ` Eli Zaretskii
2023-08-30 19:22 ` Eli Zaretskii
2023-08-30 22:30 ` David Ponce
2023-08-31 8:18 ` David Ponce
2023-08-31 12:08 ` David Ponce
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).