[PATCH] Adaptive Org faces in headings?

[Ihor Radchenko <yantar92@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 73 bytes --]

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

Best,
Ihor


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-headline-faces-take-precedence.patch --]
[-- Type: text/x-diff, Size: 5818 bytes --]

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


[-- Attachment #3: Type: text/plain, Size: 2298 bytes --]




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