[PATCH] Adaptive Org faces in headings?

[Ihor Radchenko]

The attached patch seems to fix the issue.
Can anyone test?

Best,
Ihor

>From 7a5bfe2f514af1f6af48652155732dbcb9fe22d0 Mon Sep 17 00:00:00 2001
From: Ihor Radchenko <yantar92@gmail.com>
Date: Thu, 17 Sep 2020 16:14:11 +0800
Subject: [PATCH] Make sure that headline faces take precedence

* lisp/org.el (org-activate-links): Prepend instead of overriding
existing face.
(org-set-font-lock-defaults): Prepend keyword, `org-headline-todo', and
`org-headline-done' faces instead of overriding.
(org-font-lock-add-priority-faces): Prepend priority face instead of
overriding.
(org-font-lock-add-tag-faces): Prepend tag faces instead of
overriding.

Fix bug when org-level-N headline face is overridden while fontifying
smaller elements within headline.  Prepend the element faces instead.
---
 lisp/org.el | 62 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 35 insertions(+), 27 deletions(-)

diff --git a/lisp/org.el b/lisp/org.el
index bc74cedc7..69040a540 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -5142,30 +5142,31 @@ This includes angle, plain, and bracket links."
                 (link (org-element-property :raw-link link-object))
                 (type (org-element-property :type link-object))
                 (path (org-element-property :path link-object))
+                 (face-property (pcase (org-link-get-parameter type :face)
+                                 ((and (pred functionp) face) (funcall face 
path))
+                                 ((and (pred facep) face) face)
+                                 ((and (pred consp) face) face) ;anonymous
+                                 (_ 'org-link)))
                 (properties            ;for link's visible part
-                 (list
-                  'face (pcase (org-link-get-parameter type :face)
-                          ((and (pred functionp) face) (funcall face path))
-                          ((and (pred facep) face) face)
-                          ((and (pred consp) face) face) ;anonymous
-                          (_ 'org-link))
-                  'mouse-face (or (org-link-get-parameter type :mouse-face)
-                                  'highlight)
-                  'keymap (or (org-link-get-parameter type :keymap)
-                              org-mouse-map)
-                  'help-echo (pcase (org-link-get-parameter type :help-echo)
-                               ((and (pred stringp) echo) echo)
-                               ((and (pred functionp) echo) echo)
-                               (_ (concat "LINK: " link)))
-                  'htmlize-link (pcase (org-link-get-parameter type
-                                                               :htmlize-link)
-                                  ((and (pred functionp) f) (funcall f))
-                                  (_ `(:uri ,link)))
-                  'font-lock-multiline t)))
+                 (list 'mouse-face (or (org-link-get-parameter type 
:mouse-face)
+                                       'highlight)
+                       'keymap (or (org-link-get-parameter type :keymap)
+                                   org-mouse-map)
+                       'help-echo (pcase (org-link-get-parameter type 
:help-echo)
+                                    ((and (pred stringp) echo) echo)
+                                    ((and (pred functionp) echo) echo)
+                                    (_ (concat "LINK: " link)))
+                       'htmlize-link (pcase (org-link-get-parameter type
+                                                                 :htmlize-link)
+                                       ((and (pred functionp) f) (funcall f))
+                                       (_ `(:uri ,link)))
+                       'font-lock-multiline t)))
            (org-remove-flyspell-overlays-in start end)
            (org-rear-nonsticky-at end)
            (if (not (eq 'bracket style))
-               (add-text-properties start end properties)
+               (progn
+                  (add-face-text-property start end face-property)
+                 (add-text-properties start end properties))
              ;; Handle invisible parts in bracket links.
              (remove-text-properties start end '(invisible nil))
              (let ((hidden
@@ -5174,6 +5175,7 @@ This includes angle, plain, and bracket links."
                                    'org-link))
                             properties)))
                (add-text-properties start visible-start hidden)
+                (add-face-text-property visible-start visible-end 
face-property)
                (add-text-properties visible-start visible-end properties)
                (add-text-properties visible-end end hidden)
                (org-rear-nonsticky-at visible-start)
@@ -5641,7 +5643,7 @@ needs to be inserted at a specific position in the 
font-lock sequence.")
           ;; TODO keyword
           (list (format org-heading-keyword-regexp-format
                         org-todo-regexp)
-                '(2 (org-get-todo-face 2) t))
+                '(2 (org-get-todo-face 2) prepend))
           ;; TODO
           (when org-fontify-todo-headline
             (list (format org-heading-keyword-regexp-format
@@ -5649,7 +5651,7 @@ needs to be inserted at a specific position in the 
font-lock sequence.")
                            "\\(?:"
                            (mapconcat 'regexp-quote org-not-done-keywords 
"\\|")
                            "\\)"))
-                  '(2 'org-headline-todo t)))
+                  '(2 'org-headline-todo prepend)))
           ;; DONE
           (when org-fontify-done-headline
             (list (format org-heading-keyword-regexp-format
@@ -5657,7 +5659,7 @@ needs to be inserted at a specific position in the 
font-lock sequence.")
                            "\\(?:"
                            (mapconcat 'regexp-quote org-done-keywords "\\|")
                            "\\)"))
-                  '(2 'org-headline-done t)))
+                  '(2 'org-headline-done prepend)))
           ;; Priorities
           '(org-font-lock-add-priority-faces)
           ;; Tags
@@ -5841,18 +5843,24 @@ If TAG is a number, get the corresponding match group."
 (defun org-font-lock-add-priority-faces (limit)
   "Add the special priority faces."
   (while (re-search-forward org-priority-regexp limit t)
+    (add-face-text-property
+     (match-beginning 1)
+     (match-end 1)
+     (org-get-priority-face (string-to-char (match-string 2))))
     (add-text-properties
      (match-beginning 1) (match-end 1)
-     (list 'face (org-get-priority-face (string-to-char (match-string 2)))
-          'font-lock-fontified t))))
+     (list 'font-lock-fontified t))))
 
 (defun org-font-lock-add-tag-faces (limit)
   "Add the special tag faces."
   (when (and org-tag-faces org-tags-special-faces-re)
     (while (re-search-forward org-tags-special-faces-re limit t)
+      (add-face-text-property
+       (match-beginning 1)
+       (match-end 1)
+       (org-get-tag-face 1))
       (add-text-properties (match-beginning 1) (match-end 1)
-                          (list 'face (org-get-tag-face 1)
-                                'font-lock-fontified t))
+                          (list 'font-lock-fontified t))
       (backward-char 1))))
 
 (defun org-unfontify-region (beg end &optional _maybe_loudly)
-- 
2.26.2



Protesilaos Stavrou <info@protesilaos.com> writes:

> Bastien <bzg@gnu.org> [2020-09-09, 10:49 +0200]:
>
>> Protesilaos Stavrou <info@protesilaos.com> writes:
>>
>>> Diego Zamboni <diego@zzamboni.org> [2020-09-05, 23:39 +0200]:
>>>
>>>> I had seen the same in my setup. I recently started using Doom Emacs
>>>> (https://github.com/hlissner/doom-emacs/) and was pleasantly surprised
>>>> to discover that todo and tag faces scale according to the headline in
>>>> which they are. I don't know precisely how this is done, but there are
>>>> some hints here, you might use it as a starting point:
>>>> https://github.com/hlissner/doom-emacs/blob/develop/modules/lang/org/config.el#L146-L175
>>>
>>> I noticed that the doom-themes have some extra code to fontify Org.[0]
>>> It also has some opinionated extras that do not belong to the issue I
>>> raised.  I am curious whether this was ever shared/discussed on this
>>> mailing list.
>>
>> I can't remember any such discussion.
>>
>> (In general, it would be good if downstream enhancements like these
>> could be shared upstream, we are generally quite grateful for help!)
>>
>> In any case, thanks for reporting this issue, I confirm we should
>> work on it for a future release.
>>
>> Patches welcome,
>
> Hello again!
>
> I am not sure I can help with the patch, but at least I can share some
> more user feedback.
>
> Please see the attached screenshots that could help improve our
> understanding of the issue.  The gist is that Org already has working
> code that adapts some faces to the underlying heading style (in this
> case font height and weight).
>
> To reproduce this demo on emacs -Q:
>
> + Open an org-mode file, e.g. C-x C-f /tmp/test.org
> + Insert a level 1 heading:
>
>   * TODO [#A] Do they adapt ~test-heading-faces~ and =another-test=?
>
> + Evaluate each of the expressions in the code block and notice how the
>   heading's faces adapt to it:
>
> #+begin_src emacs-lisp
> (set-face-attribute 'org-level-1 nil :height 3.0 :weight 'normal)
> (set-face-attribute 'org-level-1 nil :weight 'bold)
> #+end_src
>
> This is in addition to what I noted in a previous message:
> https://lists.gnu.org/archive/html/emacs-orgmode/2020-09/msg00331.html
>
> Best regards,
> Protesilaos
>
> -- 
> Protesilaos Stavrou
> protesilaos.com