* prettify-symbols-mode in org agenda?
@ 2020-10-31 12:11 William Xu
2020-11-03 5:05 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2020-10-31 12:11 UTC (permalink / raw)
To: emacs-orgmode
Hi,
Is there any plan to support prettify-symbols-mode in org agenda? With
that mode, it would make it easier to, for example, replace the todo
keywords with some nice looking unicode chars.
From reddit, I found yantar92 has posted some elisp changes to enable the support:
https://www.reddit.com/r/orgmode/comments/i3upt6/prettifysymbolsmode_not_working_with_orgagenda/
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2020-10-31 12:11 prettify-symbols-mode in org agenda? William Xu
@ 2020-11-03 5:05 ` Ihor Radchenko
2020-11-03 19:05 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2020-11-03 5:05 UTC (permalink / raw)
To: William Xu, emacs-orgmode
Feel free to prepare a patch using my code and send it here.
I think the following function should be sufficient to preserve
pretty-symbols composition:
(el-patch-defun org-agenda-highlight-todo ...
I have added only 3 lines to the original org-agenda-highlight-todo (see
el-patch-add instances in the body).
That change simply preserves 'composition text property in agenda.
Best,
Ihor
William Xu <william.xwl@gmail.com> writes:
> Hi,
>
> Is there any plan to support prettify-symbols-mode in org agenda? With
> that mode, it would make it easier to, for example, replace the todo
> keywords with some nice looking unicode chars.
>
> From reddit, I found yantar92 has posted some elisp changes to enable the support:
> https://www.reddit.com/r/orgmode/comments/i3upt6/prettifysymbolsmode_not_working_with_orgagenda/
>
> --
> William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2020-11-03 5:05 ` Ihor Radchenko
@ 2020-11-03 19:05 ` William Xu
2020-11-04 1:47 ` Ihor Radchenko
2021-04-27 20:53 ` Bastien
0 siblings, 2 replies; 31+ messages in thread
From: William Xu @ 2020-11-03 19:05 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> Feel free to prepare a patch using my code and send it here.
> I think the following function should be sufficient to preserve
> pretty-symbols composition:
>
> (el-patch-defun org-agenda-highlight-todo ...
>
> I have added only 3 lines to the original org-agenda-highlight-todo (see
> el-patch-add instances in the body).
>
> That change simply preserves 'composition text property in agenda.
Thanks for the info. I'll be happy to prepare the patch. However, I
would like to hear what is the opinion of org maintainter(s) on this
topic.
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2020-11-03 19:05 ` William Xu
@ 2020-11-04 1:47 ` Ihor Radchenko
2021-04-27 20:53 ` Bastien
1 sibling, 0 replies; 31+ messages in thread
From: Ihor Radchenko @ 2020-11-04 1:47 UTC (permalink / raw)
To: William Xu, emacs-orgmode
> I would like to hear what is the opinion of org maintainter(s) on this
> topic.
Ok. Marking this thread with X-Woof-Help.
William Xu <william.xwl@gmail.com> writes:
> Ihor Radchenko <yantar92@gmail.com> writes:
>
>> Feel free to prepare a patch using my code and send it here.
>> I think the following function should be sufficient to preserve
>> pretty-symbols composition:
>>
>> (el-patch-defun org-agenda-highlight-todo ...
>>
>> I have added only 3 lines to the original org-agenda-highlight-todo (see
>> el-patch-add instances in the body).
>>
>> That change simply preserves 'composition text property in agenda.
>
> Thanks for the info. I'll be happy to prepare the patch. However, I
> would like to hear what is the opinion of org maintainter(s) on this
> topic.
>
> --
> William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2020-11-03 19:05 ` William Xu
2020-11-04 1:47 ` Ihor Radchenko
@ 2021-04-27 20:53 ` Bastien
2021-05-01 12:33 ` Ihor Radchenko
1 sibling, 1 reply; 31+ messages in thread
From: Bastien @ 2021-04-27 20:53 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
Hi William,
William Xu <william.xwl@gmail.com> writes:
> Thanks for the info. I'll be happy to prepare the patch. However, I
> would like to hear what is the opinion of org maintainter(s) on this
> topic.
Thanks for bringing this idea up.
If allowing prettify-symbols-mode in Org agenda mode does not slow
down the agenda display and does not create spacing problems, then
yes, why not.
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-04-27 20:53 ` Bastien
@ 2021-05-01 12:33 ` Ihor Radchenko
2021-05-01 13:33 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-01 12:33 UTC (permalink / raw)
To: Bastien; +Cc: William Xu, emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 366 bytes --]
Bastien <bzg@gnu.org> writes:
> Thanks for bringing this idea up.
>
> If allowing prettify-symbols-mode in Org agenda mode does not slow
> down the agenda display and does not create spacing problems, then
> yes, why not.
Here is the patch. It will be great if other people test it first, as I
rewrote it from advised functions in my personal config.
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 14116 bytes --]
From 787181ac85c75b2a99e3098b066f9086536c4aa6 Mon Sep 17 00:00:00 2001
Message-Id: <787181ac85c75b2a99e3098b066f9086536c4aa6.1619872197.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Sat, 1 May 2021 20:09:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixelwise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text proerpties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org-buffer-substring-fontified): New function getting fontified
substring from current buffer.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled): Use
org-buffer-substring-fontified to get fontified heading.
(org-agenda-fix-displayed-tags): Fontify tags.
(org-agenda-highlight-todo): Preserve composition property used,
i.e. by `prettify-symbols-mode'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
---
lisp/org-agenda.el | 65 +++++++++++++++++----------
lisp/org-macs.el | 108 ++++++++++++++++++---------------------------
2 files changed, 86 insertions(+), 87 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index bd9d466a6..b7699afa1 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -5562,7 +5562,7 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5973,7 +5973,7 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -6254,7 +6254,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6469,7 +6469,7 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(tags (org-get-tags nil (not inherited-tags)))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6856,6 +6856,15 @@ (defun org-agenda-fix-displayed-tags (txt tags add-inherited hide-re)
x))
tags ":")
(if have-i "::" ":"))))))
+ (let ((tag-string (when (string-match org-tag-group-re txt)
+ (match-string 0 txt))))
+ (when tag-string
+ (with-temp-buffer
+ (save-match-data
+ (let ((org-inhibit-startup t)) (org-mode))
+ (insert "* X" tag-string)
+ (font-lock-ensure))
+ (setf (substring txt (match-beginning 0) (match-end 0)) (buffer-substring 4 (point-max))))))
txt)
(defvar org-agenda-sorting-strategy) ;; because the def is in a let form
@@ -7110,7 +7119,8 @@ (defun org-agenda-limit-interactively (remove)
(defun org-agenda-highlight-todo (x)
(let ((org-done-keywords org-done-keywords-for-agenda)
(case-fold-search nil)
- re)
+ re
+ composition-property)
(if (eq x 'line)
(save-excursion
(beginning-of-line 1)
@@ -7119,10 +7129,12 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (setq composition-property (plist-get (text-properties-at (match-beginning 1)) 'composition))
+ (let ((s (org-buffer-substring-fontified (match-beginning 1) (match-end 1))))
(delete-region (match-beginning 1) (1- (match-end 0)))
(goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (insert (format org-agenda-todo-keyword-format s))
+ (add-text-properties (match-beginning 1) (match-end 1) (list 'composition composition-property)))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9528,33 +9540,40 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ ;; (make-string (max 1 (- c (current-column))) ?\s)
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..0aff82cb0 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,45 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string) '(wrap-prefix t line-prefix t face t) string)
+ (let (;; We need to remove the folds to make sure that folded table alignment is not messed up.
+ (current-invisibility-spec (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el '(org-fold-drawer org-fold-block org-fold-outline))
+ (and (listp el)
+ (memq (car el) '(org-fold-drawer org-fold-block org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec current-invisibility-spec)
+ (setq-local char-property-alias-alist current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1055,12 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (jit-lock-fontify-now beg end))
+ (buffer-substring beg end))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-01 12:33 ` Ihor Radchenko
@ 2021-05-01 13:33 ` William Xu
2021-05-01 14:37 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-01 13:33 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> Bastien <bzg@gnu.org> writes:
>
>> Thanks for bringing this idea up.
>>
>> If allowing prettify-symbols-mode in Org agenda mode does not slow
>> down the agenda display and does not create spacing problems, then
>> yes, why not.
>
> Here is the patch. It will be great if other people test it first, as I
> rewrote it from advised functions in my personal config.
Works for me. Thanks!
> (org-agenda-highlight-todo): Preserve composition property used,
> i.e. by `prettify-symbols-mode'.
It looks like this change is not really needed, my emacs is built from
git master. Maybe the 'composition property is now preserved
automatically in the buffer?
-William
> @@ -7110,7 +7119,8 @@ (defun org-agenda-limit-interactively (remove)
> (defun org-agenda-highlight-todo (x)
> (let ((org-done-keywords org-done-keywords-for-agenda)
> (case-fold-search nil)
> - re)
> + re
> + composition-property)
> (if (eq x 'line)
> (save-excursion
> (beginning-of-line 1)
> @@ -7119,10 +7129,12 @@ (defun org-agenda-highlight-todo (x)
> (when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
> (add-text-properties (match-beginning 0) (match-end 1)
> (list 'face (org-get-todo-face 1)))
> - (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
> + (setq composition-property (plist-get (text-properties-at (match-beginning 1)) 'composition))
> + (let ((s (org-buffer-substring-fontified (match-beginning 1) (match-end 1))))
> (delete-region (match-beginning 1) (1- (match-end 0)))
> (goto-char (match-beginning 1))
> - (insert (format org-agenda-todo-keyword-format s)))))
> + (insert (format org-agenda-todo-keyword-format s))
> + (add-text-properties (match-beginning 1) (match-end 1) (list 'composition composition-property)))))
> (let ((pl (text-property-any 0 (length x) 'org-heading t x)))
> (setq re (get-text-property 0 'org-todo-regexp x))
> (when (and re
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-01 13:33 ` William Xu
@ 2021-05-01 14:37 ` Ihor Radchenko
2021-05-02 12:31 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-01 14:37 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 837 bytes --]
William Xu <william.xwl@gmail.com> writes:
>> (org-agenda-highlight-todo): Preserve composition property used,
>> i.e. by `prettify-symbols-mode'.
>
> It looks like this change is not really needed, my emacs is built from
> git master. Maybe the 'composition property is now preserved
> automatically in the buffer?
This change is needed, for example, when you change todo-state using
`org-agenda-todo'. Refreshing the agenda line in
org-agenda-highlight-todo involves
(insert (format org-agenda-todo-keyword-format s))
`insert' will destroy the 'composition as 'composition is set by
pretty-symbols to be self-destructed on change.
Having said that, I can now see an easier approach to deal with the
problem: simply wrap insert into `with-silent-modifications'
Amended patch with some minor refactoring is attached.
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 13811 bytes --]
From b6edd24d4477467e05b69258eccef58d48b39676 Mon Sep 17 00:00:00 2001
Message-Id: <b6edd24d4477467e05b69258eccef58d48b39676.1619879776.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Sat, 1 May 2021 20:09:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixelwise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text proerpties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org-buffer-substring-fontified): New function getting fontified
substring from current buffer.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled): Use
org-buffer-substring-fontified to get fontified heading.
(org-agenda-fix-displayed-tags): Fontify tags.
(org-agenda-highlight-todo): Preserve composition property used,
i.e. by `prettify-symbols-mode'. The composition is usually set to be
removed on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
---
lisp/org-agenda.el | 63 ++++++++++++++++----------
lisp/org-macs.el | 108 ++++++++++++++++++---------------------------
2 files changed, 83 insertions(+), 88 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index bd9d466a6..5add0e092 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -5562,7 +5562,7 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5973,7 +5973,7 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -6254,7 +6254,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6469,7 +6469,7 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(tags (org-get-tags nil (not inherited-tags)))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6856,6 +6856,15 @@ (defun org-agenda-fix-displayed-tags (txt tags add-inherited hide-re)
x))
tags ":")
(if have-i "::" ":"))))))
+ (let ((tag-string (when (string-match org-tag-group-re txt)
+ (match-string 0 txt))))
+ (when tag-string
+ (with-temp-buffer
+ (save-match-data
+ (let ((org-inhibit-startup t)) (org-mode))
+ (insert "* X" tag-string)
+ (font-lock-ensure))
+ (setf (substring txt (match-beginning 0) (match-end 0)) (buffer-substring 4 (point-max))))))
txt)
(defvar org-agenda-sorting-strategy) ;; because the def is in a let form
@@ -7119,10 +7128,9 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1) (1- (match-end 0))) (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9528,33 +9536,40 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ ;; (make-string (max 1 (- c (current-column))) ?\s)
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..0aff82cb0 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,45 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string) '(wrap-prefix t line-prefix t face t) string)
+ (let (;; We need to remove the folds to make sure that folded table alignment is not messed up.
+ (current-invisibility-spec (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el '(org-fold-drawer org-fold-block org-fold-outline))
+ (and (listp el)
+ (memq (car el) '(org-fold-drawer org-fold-block org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec current-invisibility-spec)
+ (setq-local char-property-alias-alist current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1055,12 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (jit-lock-fontify-now beg end))
+ (buffer-substring beg end))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-01 14:37 ` Ihor Radchenko
@ 2021-05-02 12:31 ` William Xu
2021-05-02 12:58 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-02 12:31 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> This change is needed, for example, when you change todo-state using
> `org-agenda-todo'. Refreshing the agenda line in
> org-agenda-highlight-todo involves
>
> (insert (format org-agenda-todo-keyword-format s))
>
> `insert' will destroy the 'composition as 'composition is set by
> pretty-symbols to be self-destructed on change.
Now I try to test it extensively. Even with all your changes, I find
when I use org-agenda-todo to change the todo-state inside the agenda
buffer, the new state isn't always prettified.
A workaround is that, if I save that org file buffer, then close the
buffer, M-x org-agenda-redo-all again, this time it will be properly
prettified.
Do you see the same behaviour?
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-02 12:31 ` William Xu
@ 2021-05-02 12:58 ` Ihor Radchenko
2021-05-02 13:56 ` William Xu
2021-05-03 17:16 ` Bastien
0 siblings, 2 replies; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-02 12:58 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 464 bytes --]
William Xu <william.xwl@gmail.com> writes:
> Now I try to test it extensively. Even with all your changes, I find
> when I use org-agenda-todo to change the todo-state inside the agenda
> buffer, the new state isn't always prettified.
>
> Do you see the same behaviour?
Oops. Yes, I do see the same behaviour. I only did light testing on
master and I had some unrelated changes nullifying the problem you
observe on my testing branch.
See the updated patch.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 14522 bytes --]
From 06a2d8ab328721835866bf97f0344cce15cd1dee Mon Sep 17 00:00:00 2001
Message-Id: <06a2d8ab328721835866bf97f0344cce15cd1dee.1619960107.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Sat, 1 May 2021 20:09:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixelwise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text proerpties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org-buffer-substring-fontified): New function getting fontified
substring from current buffer.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled): Use
org-buffer-substring-fontified to get fontified heading.
(org-agenda-fix-displayed-tags): Fontify tags.
(org-agenda-highlight-todo): Preserve composition property used,
i.e. by `prettify-symbols-mode'. The composition is usually set to be
removed on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
---
lisp/org-agenda.el | 63 ++++++++++++++++----------
lisp/org-macs.el | 108 ++++++++++++++++++---------------------------
lisp/org.el | 2 +
3 files changed, 85 insertions(+), 88 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index bd9d466a6..5add0e092 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -5562,7 +5562,7 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5973,7 +5973,7 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -6254,7 +6254,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6469,7 +6469,7 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(tags (org-get-tags nil (not inherited-tags)))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6856,6 +6856,15 @@ (defun org-agenda-fix-displayed-tags (txt tags add-inherited hide-re)
x))
tags ":")
(if have-i "::" ":"))))))
+ (let ((tag-string (when (string-match org-tag-group-re txt)
+ (match-string 0 txt))))
+ (when tag-string
+ (with-temp-buffer
+ (save-match-data
+ (let ((org-inhibit-startup t)) (org-mode))
+ (insert "* X" tag-string)
+ (font-lock-ensure))
+ (setf (substring txt (match-beginning 0) (match-end 0)) (buffer-substring 4 (point-max))))))
txt)
(defvar org-agenda-sorting-strategy) ;; because the def is in a let form
@@ -7119,10 +7128,9 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1) (1- (match-end 0))) (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9528,33 +9536,40 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ ;; (make-string (max 1 (- c (current-column))) ?\s)
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..ecc95833c 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,45 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string) '(wrap-prefix t line-prefix t face t) string)
+ (let (;; We need to remove the folds to make sure that folded table alignment is not messed up.
+ (current-invisibility-spec (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el '(org-fold-drawer org-fold-block org-fold-outline))
+ (and (listp el)
+ (memq (car el) '(org-fold-drawer org-fold-block org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec current-invisibility-spec)
+ (setq-local char-property-alias-alist current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1055,12 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index 9bd35db47..81f7dae0c 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7056,6 +7056,8 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(org-back-to-heading t)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp)
+ (org-buffer-substring-fontified (match-beginning 0) (match-end 0))
+ (looking-at org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-02 12:58 ` Ihor Radchenko
@ 2021-05-02 13:56 ` William Xu
2021-05-03 17:16 ` Bastien
1 sibling, 0 replies; 31+ messages in thread
From: William Xu @ 2021-05-02 13:56 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> See the updated patch.
Thanks, it works quite nice now on the agenda line.
The only issue I still see, is that when you org-agenda-redo-all, or
org-agenda-log-mode (which triggers org-agenda-redo-all), the
prettify gets lost again. Maybe org-buffer-substring-fontified call is
also required somewhere during org-agenda-redo-all?
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-02 12:58 ` Ihor Radchenko
2021-05-02 13:56 ` William Xu
@ 2021-05-03 17:16 ` Bastien
2021-05-04 4:23 ` Ihor Radchenko
1 sibling, 1 reply; 31+ messages in thread
From: Bastien @ 2021-05-03 17:16 UTC (permalink / raw)
To: Ihor Radchenko; +Cc: William Xu, emacs-orgmode
Hi Ihor,
Ihor Radchenko <yantar92@gmail.com> writes:
> William Xu <william.xwl@gmail.com> writes:
>
>> Now I try to test it extensively. Even with all your changes, I find
>> when I use org-agenda-todo to change the todo-state inside the agenda
>> buffer, the new state isn't always prettified.
>>
>> Do you see the same behaviour?
>
> Oops. Yes, I do see the same behaviour. I only did light testing on
> master and I had some unrelated changes nullifying the problem you
> observe on my testing branch.
Thank you very much for the patch.
Could it slow down agenda generation for some configurations?
> See the updated patch.
>
> From 06a2d8ab328721835866bf97f0344cce15cd1dee Mon Sep 17 00:00:00 2001
> Message-Id: <06a2d8ab328721835866bf97f0344cce15cd1dee.1619960107.git.yantar92@gmail.com>
> From: Ihor Radchenko <yantar92@gmail.com>
> Date: Sat, 1 May 2021 20:09:10 +0800
> Subject: [PATCH] Make sure that fontification is preserved in agenda
>
> Preserve fontification and composition of headlines and tags in
> agenda. If the headlines/tags are not yet fontified when building
> agenda, make sure that they are fontified in the original Org mode
> buffers first.
>
> In addition, tags alignment is now done pixelwise to avoid alignment
> issues with variable-pitch symbols that may appear in fontified Org
> mode buffers. The alignment is utilising :align-to specification,
> which means that the alignment will be automatically updated as the
> agenda buffer is resized.
Please move the comments after the change log themselves.
> * lisp/org-macs.el (org-string-width): Refactor old code and add
> optional argument to return pixel width. The old code used manual
> parsing of text proerpties to find which parts of string are visible.
> The new code defers this work to Emacs display engine via
> `window-text-pixel-size'. The visibility settings of current buffer
> are taken into account.
>
> (org-buffer-substring-fontified): New function getting fontified
> substring from current buffer.
>
> * lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
> org-agenda-get-deadlines, org-agenda-get-scheduled): Use
> org-buffer-substring-fontified to get fontified heading.
>
> (org-agenda-fix-displayed-tags): Fontify tags.
>
> (org-agenda-highlight-todo): Preserve composition property used,
> i.e. by `prettify-symbols-mode'. The composition is usually set to be
> removed on text change, so we do the changes inside
> `with-silent-modifications'.
>
> (org-agenda-align-tags): Use pixel width and (space . :align-to)
> 'display property to align tags in agenda.
>
> * lisp/org.el (org-get-heading): Make sure that heading is fontified.
> ---
> lisp/org-agenda.el | 63 ++++++++++++++++----------
> lisp/org-macs.el | 108 ++++++++++++++++++---------------------------
> lisp/org.el | 2 +
> 3 files changed, 85 insertions(+), 88 deletions(-)
>
> diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
> index bd9d466a6..5add0e092 100644
> --- a/lisp/org-agenda.el
> +++ b/lisp/org-agenda.el
> @@ -5562,7 +5562,7 @@ (defun org-agenda-get-todos ()
> ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
> ts-date (car ts-date-pair)
> ts-date-type (cdr ts-date-pair)
> - txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
> + txt (org-trim (org-buffer-substring-fontified (match-beginning 2) (match-end 0)))
Here and for the rest of the patch: please try to keep lines below 80
characters. I'm aware this is not always feasible, especially given
long functions with many nested s-exps, but let's try to come as close
as possible to 80.
Thanks!
--
Bastien
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-03 17:16 ` Bastien
@ 2021-05-04 4:23 ` Ihor Radchenko
2021-05-04 14:51 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-04 4:23 UTC (permalink / raw)
To: Bastien; +Cc: William Xu, emacs-orgmode
Bastien <bzg@gnu.org> writes:
> Could it slow down agenda generation for some configurations?
Yes, it can. Specifically, fontifying tags can be costly. For
illustration, below if profiler report for a very large agenda buffer
(1468 entries):
19820 95% - org-agenda
...
4401 21% - org-agenda-fix-displayed-tags
3711 17% + org-mode
...
1410 6% - org-buffer-substring-fontified
1380 6% + jit-lock-fontify-now
(full profiler report at the end of the message)
The total slowdown is ~30%, though the second part will only be slow
before the headings are fontified first time by
org-buffer-substring-fontified. Subsequent agenda rebuilds will be
faster.
The first part is harder. It is related to tag fontification. Currently,
agenda fetches tag list as unfontified strings via org-get-tags. So, I
had to re-fontify tags manual is temporary org-mode buffer. You can see
that running org-mode in fresh buffer takes a lot of time. Alternative
approach would be modifying org-get-tags to return fontified strings,
but I am not sure if it is safe to do - unrelated parts of org
might be affected. Or I can write something like org-get-tags-fontified.
What do you think?
Best,
Ihor
20147 96% - command-execute
20147 96% - funcall-interactively
19820 95% - org-agenda
19820 95% - apply
19820 95% - ad-Advice-org-agenda
19820 95% - #<compiled -0x1c8480b91ecb5c12>
19820 95% - apply
19820 95% - #<compiled -0xb7e1059dab93556>
19761 94% - call-interactively
19761 94% - funcall-interactively
19741 94% - org-todo-list
13331 63% - org-agenda-get-day-entries
13331 63% - apply
13331 63% - #<compiled -0xff9c793bf0466ec>
13331 63% - org-agenda-get-todos
13331 63% - apply
13331 63% - #<compiled -0x1e7566f8a2160f5f>
8115 38% - org-agenda-format-item
4401 21% - org-agenda-fix-displayed-tags
3711 17% + org-mode
409 1% + font-lock-ensure
161 0% + org-fold-core--fix-folded-region
40 0% + #<compiled -0x1c8bdc957a9aff0b>
3554 17% - eval
3554 17% - format
3554 17% - format
3544 17% - org-eval
3463 16% + yant/format-time-balance-multiplier
81 0% + yant/format-summary-for-agenda
10 0% + if
40 0% replace-regexp-in-string
10 0% org-get-time-of-day
3185 15% - org-get-tags
3095 14% + org-up-heading-safe
20 0% org--get-local-tags
20 0% + org-before-first-heading-p
10 0% + mapcar
10 0% + org-remove-uninherited-tags
1410 6% - org-buffer-substring-fontified
1380 6% + jit-lock-fontify-now
362 1% org-get-priority
39 0% org-add-props
20 0% org-get-todo-state
10 0% org-agenda-skip
10 0% replace-regexp-in-string
9 0% org-agenda-new-marker
5400 25% - org-agenda-finalize
2920 14% + org-get-tags
1380 6% + run-hooks
610 2% org-agenda-fontify-priorities
340 1% + org-agenda-align-tags
30 0% + org-activate-links
20 0% + org-agenda-mark-clocking-task
730 3% + org-agenda-prepare
150 0% + org-agenda-finalize-entries
80 0% + org-fold-core--fix-folded-region
59 0% + org-agenda-get-restriction-and-command
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-04 4:23 ` Ihor Radchenko
@ 2021-05-04 14:51 ` Ihor Radchenko
2021-05-05 15:23 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-04 14:51 UTC (permalink / raw)
To: Bastien, William Xu; +Cc: William Xu, emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 1387 bytes --]
Ihor Radchenko <yantar92@gmail.com> writes:
> Bastien <bzg@gnu.org> writes:
>> Could it slow down agenda generation for some configurations?
> The total slowdown is ~30%, though the second part will only be slow
> before the headings are fontified first time by
> org-buffer-substring-fontified. Subsequent agenda rebuilds will be
> faster.
I have updated the code to avoid creating temporary org buffers. Now, I
got 8% slowdown during first agenda run. The slowdown diminishes as the
headlines contributing to agenda get fontified (i.e. for all next
org-agenda-redo).
> Please move the comments after the change log themselves.
Done.
> Here and for the rest of the patch: please try to keep lines below 80
> characters. I'm aware this is not always feasible, especially given
> long functions with many nested s-exps, but let's try to come as close
> as possible to 80.
Done.
William Xu <william.xwl@gmail.com> writes:
> The only issue I still see, is that when you org-agenda-redo-all, or
> org-agenda-log-mode (which triggers org-agenda-redo-all), the
> prettify gets lost again. Maybe org-buffer-substring-fontified call is
> also required somewhere during org-agenda-redo-all?
I managed to reproduce it. This time, I went through all the agenda.el
and updated places where the strings are fetched from Org buffers into
agenda. The updated patch is attached.
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 22045 bytes --]
From 8a6f629669772ff4561180ace320eb0a6365969f Mon Sep 17 00:00:00 2001
Message-Id: <8a6f629669772ff4561180ace320eb0a6365969f.1620134057.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 4 May 2021 20:33:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags): Add optional argument
`fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks): Make sure that fontification is the same with
original Org buffers.
(org-agenda-highlight-todo): Preserve composition property used,
i.e. by `prettify-symbols-mode'. The composition is usually set to be
removed on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 92 ++++++++++++++++++-------------
lisp/org-macs.el | 134 +++++++++++++++++++++++----------------------
lisp/org.el | 24 +++++---
3 files changed, 138 insertions(+), 112 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 4c34ca5fe..420579ecf 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4778,10 +4778,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -5562,7 +5563,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5572,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5789,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5841,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5856,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5975,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +5993,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6011,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6259,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6269,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6472,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6592,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7119,10 +7126,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9530,33 +9538,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..79e9012b7 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1073,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index f3a33d8b3..43f9dc25d 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7073,7 +7073,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -12372,13 +12372,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
-(defun org-get-tags (&optional pos local)
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
+
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12393,7 +12397,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12401,11 +12407,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-04 14:51 ` Ihor Radchenko
@ 2021-05-05 15:23 ` Ihor Radchenko
2021-05-05 18:01 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-05 15:23 UTC (permalink / raw)
To: Bastien; +Cc: William Xu, emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 585 bytes --]
> William Xu <william.xwl@gmail.com> writes:
>> The only issue I still see, is that when you org-agenda-redo-all, or
>> org-agenda-log-mode (which triggers org-agenda-redo-all), the
>> prettify gets lost again. Maybe org-buffer-substring-fontified call is
>> also required somewhere during org-agenda-redo-all?
>
> I managed to reproduce it. This time, I went through all the agenda.el
> and updated places where the strings are fetched from Org buffers into
> agenda. The updated patch is attached.
Still forgot to update fontification in agenda tags view. Yet another
update...
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 24080 bytes --]
From ffc418abbf3169424ccfda059e7456dc33613a38 Mon Sep 17 00:00:00 2001
Message-Id: <ffc418abbf3169424ccfda059e7456dc33613a38.1620227907.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 4 May 2021 20:33:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags, org-scan-tags): Add optional
argument `fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks, org-tags-view): Make sure that fontification is
the same with original Org buffers.
(org-agenda-highlight-todo): Preserve composition property used,
i.e. by `prettify-symbols-mode'. The composition is usually set to be
removed on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 96 ++++++++++++++++++--------------
lisp/org-macs.el | 134 +++++++++++++++++++++++----------------------
lisp/org.el | 36 ++++++++----
3 files changed, 150 insertions(+), 116 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 4c34ca5fe..47cb7a936 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4778,10 +4778,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -5001,7 +5002,9 @@ (defun org-tags-view (&optional todo-only match)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
- org--matcher-tags-todo-only))
+ org--matcher-tags-todo-only
+ nil
+ 'fontify))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
@@ -5562,7 +5565,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5574,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5791,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5843,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5858,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5977,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +5995,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6013,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6261,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6271,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6474,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6594,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7119,10 +7128,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9530,33 +9540,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..79e9012b7 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1073,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index f3a33d8b3..36863165d 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7073,7 +7073,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -11372,7 +11372,7 @@ (defvar org-trust-scanner-tags nil
(defvar org--matcher-tags-todo-only nil)
-(defun org-scan-tags (action matcher todo-only &optional start-level)
+(defun org-scan-tags (action matcher todo-only &optional start-level fontify)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
@@ -11390,7 +11390,9 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
-headlines matching this string."
+headlines matching this string.
+
+When FONTIFY is non-nil, make sure that matches are fontified."
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
@@ -11431,8 +11433,12 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
+ (when (and fontify (bound-and-true-p jit-lock-mode))
+ (save-match-data
+ (jit-lock-fontify-now
+ (match-beginning 0) (match-end 0))))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
- (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
+ (setq tags (and (match-end 4) (org-trim (match-string 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
@@ -12372,13 +12378,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
+
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
-(defun org-get-tags (&optional pos local)
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12393,7 +12403,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12401,11 +12413,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-05 15:23 ` Ihor Radchenko
@ 2021-05-05 18:01 ` William Xu
2021-05-06 2:15 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-05 18:01 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
>>> The only issue I still see, is that when you org-agenda-redo-all, or
>>> org-agenda-log-mode (which triggers org-agenda-redo-all), the
>>> prettify gets lost again. Maybe org-buffer-substring-fontified call is
>>> also required somewhere during org-agenda-redo-all?
>>
>> I managed to reproduce it. This time, I went through all the agenda.el
>> and updated places where the strings are fetched from Org buffers into
>> agenda. The updated patch is attached.
>
> Still forgot to update fontification in agenda tags view. Yet another
> update...
I think I'm still seeing the issue. For example, if i change (M-x
org-agenda-todo) a TODO item into next state ONGOING, which i have made
prettified:
(push '("ONGOING" . "👷" ) prettify-symbols-alist)
So far so good. But as soon as I call org-agenda-redo-all, after the
agenda is refreshed, it changes back to text 'ONGOING'.
Apart from this, it works pretty well.
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-05 18:01 ` William Xu
@ 2021-05-06 2:15 ` Ihor Radchenko
2021-05-14 15:35 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-06 2:15 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 557 bytes --]
William Xu <william.xwl@gmail.com> writes:
> I think I'm still seeing the issue. For example, if i change (M-x
> org-agenda-todo) a TODO item into next state ONGOING, which i have made
> prettified:
>
> (push '("ONGOING" . "👷" ) prettify-symbols-alist)
>
> So far so good. But as soon as I call org-agenda-redo-all, after the
> agenda is refreshed, it changes back to text 'ONGOING'.
I was able to reproduce using prettify-symbols-mode (though not using
pretty-symbols-mode). Should be fixed now in the attached patch.
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 26976 bytes --]
From 46d6c93cd59d56959e0835c958e3c822aa5308d6 Mon Sep 17 00:00:00 2001
Message-Id: <46d6c93cd59d56959e0835c958e3c822aa5308d6.1620267219.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 4 May 2021 20:33:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags, org-scan-tags): Add optional
argument `fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks, org-tags-view, org-agenda-list, org-todo-list,
org-agenda-highlight-todo): Make sure that fontification is the same
with original Org buffers. All the buffer-substring and match-data
queries are changed to ensure that region of interest is fontified.
Also, preserve composition properties, used i.e. by
`prettify-symbols-mode'. The composition is usually set to be removed
on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 126 +++++++++++++++++++++++++-----------------
lisp/org-macs.el | 134 +++++++++++++++++++++++----------------------
lisp/org.el | 36 ++++++++----
3 files changed, 171 insertions(+), 125 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 4c34ca5fe..546a03bc3 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4444,9 +4444,12 @@ (defun org-agenda-list (&optional arg start-day span with-hour)
(put-text-property s (1- (point)) 'org-today t))
(setq rtnall
(org-agenda-add-time-grid-maybe rtnall ndays todayp))
- (when rtnall (insert ;; all entries
- (org-agenda-finalize-entries rtnall 'agenda)
- "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall (insert ;; all entries
+ (org-agenda-finalize-entries rtnall 'agenda)
+ "\n")))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)))
(when (and org-agenda-clockreport-mode clocktable-start)
@@ -4778,10 +4781,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -4815,8 +4819,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(list 'face 'org-agenda-structure)))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'search) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'search) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -4924,8 +4931,11 @@ (defun org-todo-list (&optional arg)
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'todo) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'todo) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -5001,7 +5011,9 @@ (defun org-tags-view (&optional todo-only match)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
- org--matcher-tags-todo-only))
+ org--matcher-tags-todo-only
+ nil
+ 'fontify))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
@@ -5023,8 +5035,11 @@ (defun org-tags-view (&optional todo-only match)
(list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'tags) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
@@ -5562,7 +5577,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5586,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5803,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5855,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5870,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5989,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +6007,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6025,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6273,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6283,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6486,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6606,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7119,10 +7140,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -9530,33 +9552,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index dc0c42b6f..79e9012b7 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1073,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index 87115b546..7e9db9c17 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7073,7 +7073,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -11372,7 +11372,7 @@ (defvar org-trust-scanner-tags nil
(defvar org--matcher-tags-todo-only nil)
-(defun org-scan-tags (action matcher todo-only &optional start-level)
+(defun org-scan-tags (action matcher todo-only &optional start-level fontify)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
@@ -11390,7 +11390,9 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
-headlines matching this string."
+headlines matching this string.
+
+When FONTIFY is non-nil, make sure that matches are fontified."
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
@@ -11431,8 +11433,12 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
+ (when (and fontify (bound-and-true-p jit-lock-mode))
+ (save-match-data
+ (jit-lock-fontify-now
+ (match-beginning 0) (match-end 0))))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
- (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
+ (setq tags (and (match-end 4) (org-trim (match-string 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
@@ -12372,13 +12378,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
+
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
-(defun org-get-tags (&optional pos local)
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12393,7 +12403,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12401,11 +12413,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.26.3
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-06 2:15 ` Ihor Radchenko
@ 2021-05-14 15:35 ` William Xu
2021-05-15 12:15 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-14 15:35 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
>> I think I'm still seeing the issue. For example, if i change (M-x
>> org-agenda-todo) a TODO item into next state ONGOING, which i have made
>> prettified:
>>
>> (push '("ONGOING" . "👷" ) prettify-symbols-alist)
>>
>> So far so good. But as soon as I call org-agenda-redo-all, after the
>> agenda is refreshed, it changes back to text 'ONGOING'.
>
> I was able to reproduce using prettify-symbols-mode (though not using
> pretty-symbols-mode). Should be fixed now in the attached patch.
The issue seems still present.
pretty-symbols-mode is deprecated, and replaced by
prettify-symbols-mode? From its homepage: https://github.com/drothlis/pretty-symbols
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-14 15:35 ` William Xu
@ 2021-05-15 12:15 ` Ihor Radchenko
2021-05-16 9:49 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-15 12:15 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 997 bytes --]
William Xu <william.xwl@gmail.com> writes:
>> I was able to reproduce using prettify-symbols-mode (though not using
>> pretty-symbols-mode). Should be fixed now in the attached patch.
>
> The issue seems still present.
Sorry, I cannot reproduce on my side using Emacs master, Emacs 27, and
Emacs 25. I used the following recipe:
1. cd /path/to/org
2. make clean
3. make
4. emacs -Q -L ./lisp/ -l org -l /tmp/1.el ~/Org/inbox.org
5. M-x org-agenda < t
6. M-x org-todo on the first item selecting "NEXT" state
7. M-x org-agenda-redo-all
The 1.el and inbox.org are attached.
Can you try to reproduce using the same steps as I did?
> pretty-symbols-mode is deprecated, and replaced by
> prettify-symbols-mode? From its homepage: https://github.com/drothlis/pretty-symbols
Sure. However, prettify-symbols-mode can only work with symbols, while I
want to use regexps in my config. So, I keep using pretty-symbols-mode.
If it gets broken, I can just fix it. The code is fairly straightforward
:)
[-- Attachment #2: 1.el --]
[-- Type: application/emacs-lisp, Size: 408 bytes --]
[-- Attachment #3: inbox.org --]
[-- Type: application/vnd.lotus-organizer, Size: 1094 bytes --]
:PROPERTIES:
:ORG-TIME-BALANCE-MULTIPLIER: 0.4
:LOGGING: DONE(!) FAILED(!) MERGED(!) WAITiNG(!) HOLD(!) CANCELLED(!)
:ID: 520930af-75ae-4d88-ae6a-d8dde39ecc72
:END:
#+SETUPFILE: /home/yantar92/Org/common.setup
#+OPTIONS: ^:{} H:9 tags:nil
#+STARTUP: overview
#+FILETAGS: :SKIP:INBOX:
* TODO belluzj [Github] belluzj/fantasque-sans: A font family with a great monospaced variant for programmers. :BOOKMARK:misc:
:PROPERTIES:
:TITLE: belluzj/fantasque-sans: A font family with a great monospaced variant for programmers.
:BTYPE: misc
:ID: Githubbelluzjbelluz_fantas_sans_font_famil02e
:AUTHOR: belluzj
:CREATED: [2021-05-15 Sat 18:07]
:HOWPUBLISHED: Github
:NOTE: Online; accessed 15 May 2021
:URL: https://github.com/belluzj/fantasque-sans
:END:
* TODO #email Ihor Radchenko <yantar92@gmail.com> Re: Bug: Moving org-inline-tasks produces error message [9.3.6 (9.3.6-elpa @ /home/c.hemminghaus/.emacs.d/elpa/org-9.3.6/)] :EMAIL:
:PROPERTIES:
:CREATED: [2021-05-15 Sat 19:08]
:EMAIL-SOURCE: [[notmuch:id:87sg2oqmrx.fsf@localhost]]
:Source: yantar92@gmail.com
:END:
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-15 12:15 ` Ihor Radchenko
@ 2021-05-16 9:49 ` William Xu
2021-05-17 14:04 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-16 9:49 UTC (permalink / raw)
To: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 887 bytes --]
Ihor Radchenko <yantar92@gmail.com> writes:
> Sorry, I cannot reproduce on my side using Emacs master, Emacs 27, and
> Emacs 25. I used the following recipe:
>
> 1. cd /path/to/org
> 2. make clean
> 3. make
> 4. emacs -Q -L ./lisp/ -l org -l /tmp/1.el ~/Org/inbox.org
> 5. M-x org-agenda < t
> 6. M-x org-todo on the first item selecting "NEXT" state
> 7. M-x org-agenda-redo-all
>
> The 1.el and inbox.org are attached.
>
> Can you try to reproduce using the same steps as I did?
I can't reproduce it using your steps and config. I compared the org
config differences. I'm using a different org keyword ONGOING, instead of
NEXT.
In fact, if I replace NEXT with ONGOING in 1.el, then I can reproduce
the issue. This is very strange..
After step 7, I can see it still shows ONGOING text in the agenda buffer,
but in the buffer inbox.org, it is been correctly prettified.
--
William
[-- Attachment #2: 1.el --]
[-- Type: application/emacs-lisp, Size: 414 bytes --]
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-16 9:49 ` William Xu
@ 2021-05-17 14:04 ` Ihor Radchenko
2021-05-17 17:44 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-05-17 14:04 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
William Xu <william.xwl@gmail.com> writes:
> I can't reproduce it using your steps and config. I compared the org
> config differences. I'm using a different org keyword ONGOING, instead of
> NEXT.
>
> In fact, if I replace NEXT with ONGOING in 1.el, then I can reproduce
> the issue. This is very strange..
I can reproduce with ONGOING as well... In fact, I can reproduce the
issue with any TODO keyword of >4 chars length while using
prettify-symbols-mode (but not pretty-symbols-mode). Moreover, the
'composition property is _not_ removed in agenda. Emacs... just does not
show the composed string. In this situation I suspect Emacs bug.
I will try to report to emacs-devel and see what they say.
Best,
Ihor
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-17 14:04 ` Ihor Radchenko
@ 2021-05-17 17:44 ` William Xu
2021-06-20 11:27 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-05-17 17:44 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> I can reproduce with ONGOING as well... In fact, I can reproduce the
> issue with any TODO keyword of >4 chars length while using
> prettify-symbols-mode (but not pretty-symbols-mode). Moreover, the
> 'composition property is _not_ removed in agenda. Emacs... just does not
> show the composed string. In this situation I suspect Emacs bug.
>
> I will try to report to emacs-devel and see what they say.
Thanks. At least not something weird in my emacs config. :)
I think your patch is ready to be merged into orgMode. Hopefully it can be
merged soon.
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-05-17 17:44 ` William Xu
@ 2021-06-20 11:27 ` Ihor Radchenko
2021-06-22 15:25 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-06-20 11:27 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 344 bytes --]
William Xu <william.xwl@gmail.com> writes:
> Thanks. At least not something weird in my emacs config. :)
>
> I think your patch is ready to be merged into orgMode. Hopefully it can be
> merged soon.
I believe that I managed to fix the problem you observe, though I do not
understand how. Can you test the attached updated patch?
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 27986 bytes --]
From 6ce497a4af2da6a7c144c5f470679d154af2db0f Mon Sep 17 00:00:00 2001
Message-Id: <6ce497a4af2da6a7c144c5f470679d154af2db0f.1624188342.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 4 May 2021 20:33:10 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags, org-scan-tags): Add optional
argument `fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks, org-tags-view, org-agenda-list, org-todo-list,
org-agenda-highlight-todo): Make sure that fontification is the same
with original Org buffers. All the buffer-substring and match-data
queries are changed to ensure that region of interest is fontified.
Also, preserve composition properties, used i.e. by
`prettify-symbols-mode'. The composition is usually set to be removed
on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 145 +++++++++++++++++++++++++++------------------
lisp/org-macs.el | 134 +++++++++++++++++++++--------------------
lisp/org.el | 36 +++++++----
3 files changed, 181 insertions(+), 134 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index cbae3c022..071ee24f4 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4444,9 +4444,12 @@ (defun org-agenda-list (&optional arg start-day span with-hour)
(put-text-property s (1- (point)) 'org-today t))
(setq rtnall
(org-agenda-add-time-grid-maybe rtnall ndays todayp))
- (when rtnall (insert ;; all entries
- (org-agenda-finalize-entries rtnall 'agenda)
- "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall (insert ;; all entries
+ (org-agenda-finalize-entries rtnall 'agenda)
+ "\n")))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)))
(when (and org-agenda-clockreport-mode clocktable-start)
@@ -4778,10 +4781,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -4815,8 +4819,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(list 'face 'org-agenda-structure)))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'search) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'search) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -4924,8 +4931,11 @@ (defun org-todo-list (&optional arg)
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'todo) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'todo) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -5001,7 +5011,9 @@ (defun org-tags-view (&optional todo-only match)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
- org--matcher-tags-todo-only))
+ org--matcher-tags-todo-only
+ nil
+ 'fontify))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
@@ -5023,8 +5035,11 @@ (defun org-tags-view (&optional todo-only match)
(list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'tags) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
@@ -5562,7 +5577,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5586,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5803,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5855,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5870,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5989,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +6007,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6025,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6273,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6283,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6486,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6606,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7116,10 +7137,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -7142,15 +7164,16 @@ (defun org-agenda-highlight-todo (x)
x)
(when (match-end 1)
(setq x
- (concat
- (substring x 0 (match-end 1))
- (format org-agenda-todo-keyword-format
- (match-string 2 x))
- ;; Remove `display' property as the icon could leak
- ;; on the white space.
- (org-add-props " " (org-plist-delete (text-properties-at 0 x)
- 'display))
- (substring x (match-end 3)))))))
+ (format "%s%s%s"
+ (substring x 0 (match-end 1))
+ (unless (string-empty-p org-agenda-todo-keyword-format)
+ (format org-agenda-todo-keyword-format
+ (match-string 2 x)))
+ ;; Remove `display' property as the icon could leak
+ ;; on the white space.
+ (org-add-props " " (org-plist-delete (text-properties-at 0 x)
+ 'display))
+ (substring x (match-end 3)))))))
x)))
(defsubst org-cmp-values (a b property)
@@ -9527,33 +9550,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index cd9fd1d83..18b01db0b 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -868,71 +868,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1081,6 +1073,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index a9a2bef55..9d0af7eb5 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7079,7 +7079,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -11378,7 +11378,7 @@ (defvar org-trust-scanner-tags nil
(defvar org--matcher-tags-todo-only nil)
-(defun org-scan-tags (action matcher todo-only &optional start-level)
+(defun org-scan-tags (action matcher todo-only &optional start-level fontify)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
@@ -11396,7 +11396,9 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
-headlines matching this string."
+headlines matching this string.
+
+When FONTIFY is non-nil, make sure that matches are fontified."
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
@@ -11437,8 +11439,12 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
+ (when (and fontify (bound-and-true-p jit-lock-mode))
+ (save-match-data
+ (jit-lock-fontify-now
+ (match-beginning 0) (match-end 0))))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
- (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
+ (setq tags (and (match-end 4) (org-trim (match-string 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
@@ -12378,13 +12384,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
+
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
-(defun org-get-tags (&optional pos local)
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12399,7 +12409,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12407,11 +12419,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.31.1
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-06-20 11:27 ` Ihor Radchenko
@ 2021-06-22 15:25 ` William Xu
2021-06-22 15:42 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-06-22 15:25 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> William Xu <william.xwl@gmail.com> writes:
>> Thanks. At least not something weird in my emacs config. :)
>>
>> I think your patch is ready to be merged into orgMode. Hopefully it can be
>> merged soon.
>
> I believe that I managed to fix the problem you observe, though I do not
> understand how. Can you test the attached updated patch?
On which commit is the patch based? When I try to apply it, somehow I
get failures:
---------------------------------8<-------------------------------------
$ git am ./0001-Make-sure-that-fontification-is-preserved-in-agenda
Applying: Make sure that fontification is preserved in agenda
.git/rebase-apply/patch:269: space before tab in indent.
'display))
error: patch failed: lisp/org-agenda.el:7142
error: lisp/org-agenda.el: patch does not apply
Patch failed at 0001 Make sure that fontification is preserved in agenda
---------------------------------8<-------------------------------------
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-06-22 15:25 ` William Xu
@ 2021-06-22 15:42 ` Ihor Radchenko
2021-06-22 18:07 ` William Xu
2021-07-01 15:49 ` Timothy
0 siblings, 2 replies; 31+ messages in thread
From: Ihor Radchenko @ 2021-06-22 15:42 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 230 bytes --]
William Xu <william.xwl@gmail.com> writes:
> On which commit is the patch based? When I try to apply it, somehow I
> get failures:
Oops. Forgot to rebase the patch to current master. The correct version
is attached.
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 28307 bytes --]
From 924375994e110ba06ea6ed3fa9aa1ecab9380d5b Mon Sep 17 00:00:00 2001
Message-Id: <924375994e110ba06ea6ed3fa9aa1ecab9380d5b.1624376467.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 22 Jun 2021 23:38:29 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags, org-scan-tags): Add optional
argument `fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks, org-tags-view, org-agenda-list, org-todo-list,
org-agenda-highlight-todo): Make sure that fontification is the same
with original Org buffers. All the buffer-substring and match-data
queries are changed to ensure that region of interest is fontified.
Also, preserve composition properties, used i.e. by
`prettify-symbols-mode'. The composition is usually set to be removed
on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
(org-agenda-highlight-todo): Use `format' instead of `concat' to
update the headline in agenda. `concat' may sometimes copy
composition property (see the C code) breaking the composed regions in
agenda view.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 146 +++++++++++++++++++++++++++------------------
lisp/org-macs.el | 134 +++++++++++++++++++++--------------------
lisp/org.el | 36 +++++++----
3 files changed, 181 insertions(+), 135 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 44acd035a..299f9ccf1 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4444,9 +4444,12 @@ (defun org-agenda-list (&optional arg start-day span with-hour)
(put-text-property s (1- (point)) 'org-today t))
(setq rtnall
(org-agenda-add-time-grid-maybe rtnall ndays todayp))
- (when rtnall (insert ;; all entries
- (org-agenda-finalize-entries rtnall 'agenda)
- "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall (insert ;; all entries
+ (org-agenda-finalize-entries rtnall 'agenda)
+ "\n")))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)))
(when (and org-agenda-clockreport-mode clocktable-start)
@@ -4778,10 +4781,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -4815,8 +4819,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(list 'face 'org-agenda-structure)))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'search) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'search) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -4924,8 +4931,11 @@ (defun org-todo-list (&optional arg)
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'todo) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'todo) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -5001,7 +5011,9 @@ (defun org-tags-view (&optional todo-only match)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
- org--matcher-tags-todo-only))
+ org--matcher-tags-todo-only
+ nil
+ 'fontify))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
@@ -5023,8 +5035,11 @@ (defun org-tags-view (&optional todo-only match)
(list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'tags) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
@@ -5562,7 +5577,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5586,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5803,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5855,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5870,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5989,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +6007,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6025,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6273,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6283,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6486,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6606,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7133,10 +7154,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -7159,16 +7181,16 @@ (defun org-agenda-highlight-todo (x)
x)
(when (match-end 1)
(setq x
- (concat
- (substring x 0 (match-end 1))
- (unless (string-empty-p org-agenda-todo-keyword-format)
- (format org-agenda-todo-keyword-format
- (match-string 2 x)))
- ;; Remove `display' property as the icon could leak
- ;; on the white space.
- (org-add-props " " (org-plist-delete (text-properties-at 0 x)
- 'display))
- (substring x (match-end 3)))))))
+ (format "%s%s%s"
+ (substring x 0 (match-end 1))
+ (unless (string-empty-p org-agenda-todo-keyword-format)
+ (format org-agenda-todo-keyword-format
+ (match-string 2 x)))
+ ;; Remove `display' property as the icon could leak
+ ;; on the white space.
+ (org-add-props " " (org-plist-delete (text-properties-at 0 x)
+ 'display))
+ (substring x (match-end 3)))))))
x)))
(defsubst org-cmp-values (a b property)
@@ -9545,33 +9567,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index 77458db96..b9f2a2718 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -873,71 +873,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1086,6 +1078,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index 1bd9e02eb..08ef70ab3 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7103,7 +7103,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -11434,7 +11434,7 @@ (defvar org-trust-scanner-tags nil
(defvar org--matcher-tags-todo-only nil)
-(defun org-scan-tags (action matcher todo-only &optional start-level)
+(defun org-scan-tags (action matcher todo-only &optional start-level fontify)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
@@ -11452,7 +11452,9 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
-headlines matching this string."
+headlines matching this string.
+
+When FONTIFY is non-nil, make sure that matches are fontified."
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
@@ -11493,8 +11495,12 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
+ (when (and fontify (bound-and-true-p jit-lock-mode))
+ (save-match-data
+ (jit-lock-fontify-now
+ (match-beginning 0) (match-end 0))))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
- (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
+ (setq tags (and (match-end 4) (org-trim (match-string 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
@@ -12434,13 +12440,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
+
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
-(defun org-get-tags (&optional pos local)
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12455,7 +12465,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12463,11 +12475,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.31.1
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-06-22 15:42 ` Ihor Radchenko
@ 2021-06-22 18:07 ` William Xu
2021-07-02 14:11 ` Ihor Radchenko
2021-07-01 15:49 ` Timothy
1 sibling, 1 reply; 31+ messages in thread
From: William Xu @ 2021-06-22 18:07 UTC (permalink / raw)
To: emacs-orgmode
Ihor Radchenko <yantar92@gmail.com> writes:
> Oops. Forgot to rebase the patch to current master. The correct version
> is attached.
Thanks for the fix!
I need to make below additional change, otherwise it works perfectly. I
can't reproduce the original issue any more.
Looking at the changes, I see you changed below `concat' call to
`format'. Is this in the end some bug in the `concat' implementation?
---------------------------------8<-------------------------------------
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 299f9ccf1..36a8443c1 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -7181,7 +7181,7 @@ The optional argument TYPE tells the agenda type."
x)
(when (match-end 1)
(setq x
- (format "%s%s%s"
+ (format "%s%s%s%s"
(substring x 0 (match-end 1))
(unless (string-empty-p org-agenda-todo-keyword-format)
(format org-agenda-todo-keyword-format
---------------------------------8<-------------------------------------
--
William
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-06-22 15:42 ` Ihor Radchenko
2021-06-22 18:07 ` William Xu
@ 2021-07-01 15:49 ` Timothy
2021-07-02 14:13 ` Ihor Radchenko
1 sibling, 1 reply; 31+ messages in thread
From: Timothy @ 2021-07-01 15:49 UTC (permalink / raw)
To: Ihor Radchenko; +Cc: emacs-orgmode
Hi Ihor,
This thread is looking promising! Just wondering if you might have time
to respond to William's latest reply?
--
Timothy
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-06-22 18:07 ` William Xu
@ 2021-07-02 14:11 ` Ihor Radchenko
0 siblings, 0 replies; 31+ messages in thread
From: Ihor Radchenko @ 2021-07-02 14:11 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 489 bytes --]
William Xu <william.xwl@gmail.com> writes:
> I need to make below additional change, otherwise it works perfectly.
Incorporated in the attached final version of the patch.
> Looking at the changes, I see you changed below `concat' call to
> `format'. Is this in the end some bug in the `concat' implementation?
It is complex. I am not sure if it is a bug or just some obscure
implementation detail. See Emacs bug#48740
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=48740
Best,
Ihor
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-sure-that-fontification-is-preserved-in-agenda.patch --]
[-- Type: text/x-diff, Size: 28348 bytes --]
From 3f3b2780e5dea3a04eee869a46bf4662103b8143 Mon Sep 17 00:00:00 2001
Message-Id: <3f3b2780e5dea3a04eee869a46bf4662103b8143.1625234837.git.yantar92@gmail.com>
From: Ihor Radchenko <yantar92@gmail.com>
Date: Tue, 22 Jun 2021 23:38:29 +0800
Subject: [PATCH] Make sure that fontification is preserved in agenda
* lisp/org-macs.el (org-string-width): Refactor old code and add
optional argument to return pixel width. The old code used manual
parsing of text properties to find which parts of string are visible.
The new code defers this work to Emacs display engine via
`window-text-pixel-size'. The visibility settings of current buffer
are taken into account.
(org--string-from-props): Removed. It was only used by old
`org-string-width' code.
(org-buffer-substring-fontified): New function. Like
`buffer-substring', but make sure that the substring is fontified.
(org-looking-at-fontified): New function. Like `looking-at', but make
sure that the match is fontified.
* lisp/org.el (org-get-heading): Make sure that heading is fontified.
(org--get-local-tags, org-get-tags, org-scan-tags): Add optional
argument `fontified'. When non-nil, the returned tags are fontified.
* lisp/org-agenda.el (org-agenda-get-todos, org-agenda-get-progress,
org-agenda-get-deadlines, org-agenda-get-scheduled,
org-agenda-fix-displayed-tags, org-search-view, org-agenda-get-todos,
org-agenda-get-timestamps, org-agenda-get-sexps,
org-agenda-get-deadlines, org-agenda-get-progress,
org-agenda-get-blocks, org-tags-view, org-agenda-list, org-todo-list,
org-agenda-highlight-todo): Make sure that fontification is the same
with original Org buffers. All the buffer-substring and match-data
queries are changed to ensure that region of interest is fontified.
Also, preserve composition properties, used i.e. by
`prettify-symbols-mode'. The composition is usually set to be removed
on text change, so we do the changes inside
`with-silent-modifications'.
(org-agenda-align-tags): Use pixel width and (space . :align-to)
'display property to align tags in agenda.
(org-agenda-highlight-todo): Use `format' instead of `concat' to
update the headline in agenda. `concat' may sometimes copy
composition property (see the C code) breaking the composed regions in
agenda view. See Emacs bug#48740 for more details.
Preserve fontification and composition of headlines and tags in
agenda. If the headlines/tags are not yet fontified when building
agenda, make sure that they are fontified in the original Org mode
buffers first.
In addition, tags alignment is now done pixel-wise to avoid alignment
issues with variable-pitch symbols that may appear in fontified Org
mode buffers. The alignment is utilising :align-to specification,
which means that the alignment will be automatically updated as the
agenda buffer is resized.
---
lisp/org-agenda.el | 146 +++++++++++++++++++++++++++------------------
lisp/org-macs.el | 134 +++++++++++++++++++++--------------------
lisp/org.el | 36 +++++++----
3 files changed, 181 insertions(+), 135 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 44acd035a..3dff2b926 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -3984,7 +3984,7 @@ (defun org-agenda-finalize ()
(put-text-property (point-at-bol) (point-at-eol)
'tags
(org-with-point-at mrk
- (org-get-tags))))))))
+ (org-get-tags nil nil t))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
@@ -4444,9 +4444,12 @@ (defun org-agenda-list (&optional arg start-day span with-hour)
(put-text-property s (1- (point)) 'org-today t))
(setq rtnall
(org-agenda-add-time-grid-maybe rtnall ndays todayp))
- (when rtnall (insert ;; all entries
- (org-agenda-finalize-entries rtnall 'agenda)
- "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall (insert ;; all entries
+ (org-agenda-finalize-entries rtnall 'agenda)
+ "\n")))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)))
(when (and org-agenda-clockreport-mode clocktable-start)
@@ -4778,10 +4781,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags
+ nil (not inherited-tags) t)
txt (org-agenda-format-item
""
- (buffer-substring-no-properties
+ (org-buffer-substring-fontified
beg1 (point-at-eol))
level category tags t))
(org-add-props txt props
@@ -4815,8 +4819,11 @@ (defun org-search-view (&optional todo-only string edit-at)
(list 'face 'org-agenda-structure)))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'search) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'search) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -4924,8 +4931,11 @@ (defun org-todo-list (&optional arg)
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'todo) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'todo) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
@@ -5001,7 +5011,9 @@ (defun org-tags-view (&optional todo-only match)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
- org--matcher-tags-todo-only))
+ org--matcher-tags-todo-only
+ nil
+ 'fontify))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
@@ -5023,8 +5035,11 @@ (defun org-tags-view (&optional todo-only match)
(list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
- (when rtnall
- (insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
+ (with-silent-modifications
+ ;; Composition property in entries may be self-destructed
+ ;; on change. Suppress the self-destruction.
+ (when rtnall
+ (insert (org-agenda-finalize-entries rtnall 'tags) "\n")))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
@@ -5562,7 +5577,8 @@ (defun org-agenda-get-todos ()
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
- txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
+ txt (org-trim (org-buffer-substring-fontified
+ (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5570,7 +5586,7 @@ (defun org-agenda-get-todos ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
@@ -5787,10 +5803,10 @@ (defun org-agenda-get-timestamps (&optional deadlines)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (and (looking-at "\\*+[ \t]+\\(.*\\)")
+ (head (and (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
@@ -5839,7 +5855,7 @@ (defun org-agenda-get-sexps ()
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
- (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (setq sexp-entry (if (org-looking-at-fontified "[ \t]*\\(\\S-.*\\)")
(org-trim (match-string 1))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
@@ -5854,7 +5870,7 @@ (defun org-agenda-get-sexps ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime)
extra nil)
@@ -5973,7 +5989,8 @@ (defun org-agenda-get-progress ()
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol)))
+ timestr (org-buffer-substring-fontified
+ (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
@@ -5990,10 +6007,12 @@ (defun org-agenda-get-progress ()
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
- (and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
- (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
+ (and (org-looking-at-fontified
+ ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@@ -6006,9 +6025,9 @@ (defun org-agenda-get-progress ()
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
- tags (org-get-tags nil (not inherited-tags))
+ tags (org-get-tags nil (not inherited-tags) t)
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
@@ -6254,7 +6273,8 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(let* ((category (org-get-category))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6263,7 +6283,7 @@ (defun org-agenda-get-deadlines (&optional with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(time
(cond
;; No time of day designation if it is only
@@ -6466,10 +6486,11 @@ (defun org-agenda-get-scheduled (&optional deadlines with-hour)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
- (tags (org-get-tags nil (not inherited-tags)))
+ (tags (org-get-tags nil (not inherited-tags) t))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
- (head (buffer-substring (point) (line-end-position)))
+ (head (org-buffer-substring-fontified
+ (point) (line-end-position)))
(time
(cond
;; No time of day designation if it is only a
@@ -6585,7 +6606,7 @@ (defun org-agenda-get-blocks ()
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\(.*\\)")
+ (org-looking-at-fontified "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -7133,10 +7154,11 @@ (defun org-agenda-highlight-todo (x)
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
- (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (1- (match-end 0)))
- (goto-char (match-beginning 1))
- (insert (format org-agenda-todo-keyword-format s)))))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (with-silent-modifications
+ (setf (buffer-substring (match-beginning 1)
+ (1- (match-end 0)))
+ (format org-agenda-todo-keyword-format s))))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
@@ -7159,16 +7181,16 @@ (defun org-agenda-highlight-todo (x)
x)
(when (match-end 1)
(setq x
- (concat
- (substring x 0 (match-end 1))
- (unless (string-empty-p org-agenda-todo-keyword-format)
- (format org-agenda-todo-keyword-format
- (match-string 2 x)))
- ;; Remove `display' property as the icon could leak
- ;; on the white space.
- (org-add-props " " (org-plist-delete (text-properties-at 0 x)
- 'display))
- (substring x (match-end 3)))))))
+ (format "%s%s%s%s"
+ (substring x 0 (match-end 1))
+ (unless (string-empty-p org-agenda-todo-keyword-format)
+ (format org-agenda-todo-keyword-format
+ (match-string 2 x)))
+ ;; Remove `display' property as the icon could leak
+ ;; on the white space.
+ (org-add-props " " (org-plist-delete (text-properties-at 0 x)
+ 'display))
+ (substring x (match-end 3)))))))
x)))
(defsubst org-cmp-values (a b property)
@@ -9545,33 +9567,39 @@ (defun org-agenda-align-tags (&optional line)
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
- (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
- (- (window-text-width))
- org-agenda-tags-column))
(end (and line (line-end-position)))
- l c)
+ l lp c)
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
- (match-beginning 1) 'face)))
- (or (listp prop) (setq prop (list prop)))
- (if (memq 'org-tag prop)
- prop
- (cons 'org-tag prop))))))
- (setq l (string-width (match-string 1))
- c (if (< org-agenda-tags-column 0)
- (- (abs org-agenda-tags-column) l)
- org-agenda-tags-column))
+ (match-beginning 1) 'face)))
+ (or (listp prop) (setq prop (list prop)))
+ (if (memq 'org-tag prop)
+ prop
+ (cons 'org-tag prop))))))
+ (setq l (org-string-width (match-string 1))
+ lp (org-string-width (match-string 1) 'pixel)
+ c (unless (eq org-agenda-tags-column 'auto)
+ (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column)))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
- (make-string (max 1 (- c (current-column))) ?\s)
- (plist-put (copy-sequence (text-properties-at (point)))
- 'face nil))))
+ " "
+ (copy-sequence (text-properties-at (point)))
+ 'face nil
+ 'display
+ `(space
+ .
+ (:align-to
+ ,(cond
+ ((eq org-agenda-tags-column 'auto) `(- right (,lp) 1))
+ (t `(+ left ,c))))))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index 77458db96..b9f2a2718 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -873,71 +873,63 @@ (defun org-split-string (string &optional separators)
results ;skip trailing separator
(cons (substring string i) results)))))))
-(defun org--string-from-props (s property beg end)
- "Return the visible part of string S.
-Visible part is determined according to text PROPERTY, which is
-either `invisible' or `display'. BEG and END are 0-indices
-delimiting S."
- (let ((width 0)
- (cursor beg))
- (while (setq beg (text-property-not-all beg end property nil s))
- (let* ((next (next-single-property-change beg property s end))
- (props (text-properties-at beg s))
- (spec (plist-get props property))
- (value
- (pcase property
- (`invisible
- ;; If `invisible' property in PROPS means text is to
- ;; be invisible, return 0. Otherwise return nil so
- ;; as to resume search.
- (and (or (eq t buffer-invisibility-spec)
- (assoc-string spec buffer-invisibility-spec))
- 0))
- (`display
- (pcase spec
- (`nil nil)
- (`(space . ,props)
- (let ((width (plist-get props :width)))
- (and (wholenump width) width)))
- (`(image . ,_)
- (and (fboundp 'image-size)
- (ceiling (car (image-size spec)))))
- ((pred stringp)
- ;; Displayed string could contain invisible parts,
- ;; but no nested display.
- (org--string-from-props spec 'invisible 0 (length spec)))
- (_
- ;; Un-handled `display' value. Ignore it.
- ;; Consider the original string instead.
- nil)))
- (_ (error "Unknown property: %S" property)))))
- (when value
- (cl-incf width
- ;; When looking for `display' parts, we still need
- ;; to look for `invisible' property elsewhere.
- (+ (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor beg))
- ((= cursor beg) 0)
- (t (string-width (substring s cursor beg))))
- value))
- (setq cursor next))
- (setq beg next)))
- (+ width
- ;; Look for `invisible' property in the last part of the
- ;; string. See above.
- (cond ((eq property 'display)
- (org--string-from-props s 'invisible cursor end))
- ((= cursor end) 0)
- (t (string-width (substring s cursor end)))))))
-
-(defun org-string-width (string)
+(defun org-string-width (string &optional pixels)
"Return width of STRING when displayed in the current buffer.
-Unlike `string-width', this function takes into consideration
-`invisible' and `display' text properties. It supports the
-latter in a limited way, mostly for combinations used in Org.
-Results may be off sometimes if it cannot handle a given
-`display' value."
- (org--string-from-props string 'display 0 (length string)))
+Return width in pixels when PIXELS is non-nil."
+ ;; Wrap/line prefix will make `window-text-pizel-size' return too
+ ;; large value including the prefix.
+ ;; Face should be removed to make sure that all the string symbols
+ ;; are using default face with constant width. Constant char width
+ ;; is critical to get right string width from pixel width.
+ (remove-text-properties 0 (length string)
+ '(wrap-prefix t line-prefix t face t)
+ string)
+ (let (;; We need to remove the folds to make sure that folded table
+ ;; alignment is not messed up.
+ (current-invisibility-spec
+ (or (and (not (listp buffer-invisibility-spec))
+ buffer-invisibility-spec)
+ (let (result)
+ (dolist (el buffer-invisibility-spec)
+ (unless (or (memq el
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))
+ (and (listp el)
+ (memq (car el)
+ '(org-fold-drawer
+ org-fold-block
+ org-fold-outline))))
+ (push el result)))
+ result)))
+ (current-char-property-alias-alist char-property-alias-alist))
+ (with-temp-buffer
+ (setq-local buffer-invisibility-spec
+ current-invisibility-spec)
+ (setq-local char-property-alias-alist
+ current-char-property-alias-alist)
+ (let (pixel-width symbol-width)
+ (with-silent-modifications
+ (setf (buffer-string) string)
+ (setq pixel-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))
+ (unless pixels
+ (setf (buffer-string) "a")
+ (setq symbol-width
+ (if (get-buffer-window (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point-max)))))))
+ (if pixels
+ pixel-width
+ (/ pixel-width symbol-width))))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@@ -1086,6 +1078,20 @@ (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
+(defun org-buffer-substring-fontified (beg end)
+ "Return fontified region between BEG and END."
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data (jit-lock-fontify-now beg end)))
+ (buffer-substring beg end))
+
+(defun org-looking-at-fontified (re)
+ "Call `looking-at' and make sure that the match is fontified."
+ (prog1 (looking-at re)
+ (when (bound-and-true-p jit-lock-mode)
+ (save-match-data
+ (jit-lock-fontify-now (match-beginning 0)
+ (match-end 0))))))
+
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
diff --git a/lisp/org.el b/lisp/org.el
index 4fd8b6fa6..a5b4601ce 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -7103,7 +7103,7 @@ (defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp)
+ (org-looking-at-fontified org-complex-heading-regexp)
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
@@ -11436,7 +11436,7 @@ (defvar org-trust-scanner-tags nil
(defvar org--matcher-tags-todo-only nil)
-(defun org-scan-tags (action matcher todo-only &optional start-level)
+(defun org-scan-tags (action matcher todo-only &optional start-level fontify)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
@@ -11454,7 +11454,9 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
-headlines matching this string."
+headlines matching this string.
+
+When FONTIFY is non-nil, make sure that matches are fontified."
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
@@ -11495,8 +11497,12 @@ (defun org-scan-tags (action matcher todo-only &optional start-level)
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
+ (when (and fontify (bound-and-true-p jit-lock-mode))
+ (save-match-data
+ (jit-lock-fontify-now
+ (match-beginning 0) (match-end 0))))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
- (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
+ (setq tags (and (match-end 4) (org-trim (match-string 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
@@ -12436,13 +12442,17 @@ (defun org-make-tag-string (tags)
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
-(defun org--get-local-tags ()
+(defun org--get-local-tags (&optional fontified)
"Return list of tags for the current headline.
-Assume point is at the beginning of the headline."
- (and (looking-at org-tag-line-re)
- (split-string (match-string-no-properties 2) ":" t)))
+Assume point is at the beginning of the headline.
+
+The tags are fontified when FONTIFY is non-nil."
+ (and (if fontified
+ (org-looking-at-fontified org-tag-line-re)
+ (looking-at org-tag-line-re))
+ (split-string (match-string 2) ":" t)))
-(defun org-get-tags (&optional pos local)
+(defun org-get-tags (&optional pos local fontify)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
@@ -12457,7 +12467,9 @@ (defun org-get-tags (&optional pos local)
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
-Inherited tags have the `inherited' text property."
+Inherited tags have the `inherited' text property.
+
+The tags are fontified when FONTIFY is non-nil."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
@@ -12465,11 +12477,11 @@ (defun org-get-tags (&optional pos local)
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
- (let ((ltags (org--get-local-tags)) itags)
+ (let ((ltags (org--get-local-tags fontify)) itags)
(if (or local (not org-use-tag-inheritance)) ltags
(while (org-up-heading-safe)
(setq itags (nconc (mapcar #'org-add-prop-inherited
- (org--get-local-tags))
+ (org--get-local-tags fontify))
itags)))
(setq itags (append org-file-tags itags))
(nreverse
--
2.31.1
^ permalink raw reply related [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-07-01 15:49 ` Timothy
@ 2021-07-02 14:13 ` Ihor Radchenko
2021-10-26 9:03 ` William Xu
0 siblings, 1 reply; 31+ messages in thread
From: Ihor Radchenko @ 2021-07-02 14:13 UTC (permalink / raw)
To: Timothy; +Cc: emacs-orgmode
Timothy <tecosaur@gmail.com> writes:
> Hi Ihor,
>
> This thread is looking promising! Just wondering if you might have time
> to respond to William's latest reply?
Sure. Just descended from work staff down to the Emacs area in my TODO
list ;)
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-07-02 14:13 ` Ihor Radchenko
@ 2021-10-26 9:03 ` William Xu
2021-10-27 6:50 ` Ihor Radchenko
0 siblings, 1 reply; 31+ messages in thread
From: William Xu @ 2021-10-26 9:03 UTC (permalink / raw)
To: emacs-orgmode
Any updates here? I do hope the patch can be merged..
--
William
^ permalink raw reply [flat|nested] 31+ messages in thread
* Re: prettify-symbols-mode in org agenda?
2021-10-26 9:03 ` William Xu
@ 2021-10-27 6:50 ` Ihor Radchenko
0 siblings, 0 replies; 31+ messages in thread
From: Ihor Radchenko @ 2021-10-27 6:50 UTC (permalink / raw)
To: William Xu; +Cc: emacs-orgmode
William Xu <william.xwl@gmail.com> writes:
> Any updates here? I do hope the patch can be merged..
I plan to bump the thread and revisit this patch again some time later,
after we stabilise recent changes in org-element and after preparing the
final patches for org-fold.
Meanwhile, you can try my dev branch [1] :)
[1] https://github.com/yantar92/org
Best,
Ihor
^ permalink raw reply [flat|nested] 31+ messages in thread
end of thread, other threads:[~2021-10-27 6:50 UTC | newest]
Thread overview: 31+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2020-10-31 12:11 prettify-symbols-mode in org agenda? William Xu
2020-11-03 5:05 ` Ihor Radchenko
2020-11-03 19:05 ` William Xu
2020-11-04 1:47 ` Ihor Radchenko
2021-04-27 20:53 ` Bastien
2021-05-01 12:33 ` Ihor Radchenko
2021-05-01 13:33 ` William Xu
2021-05-01 14:37 ` Ihor Radchenko
2021-05-02 12:31 ` William Xu
2021-05-02 12:58 ` Ihor Radchenko
2021-05-02 13:56 ` William Xu
2021-05-03 17:16 ` Bastien
2021-05-04 4:23 ` Ihor Radchenko
2021-05-04 14:51 ` Ihor Radchenko
2021-05-05 15:23 ` Ihor Radchenko
2021-05-05 18:01 ` William Xu
2021-05-06 2:15 ` Ihor Radchenko
2021-05-14 15:35 ` William Xu
2021-05-15 12:15 ` Ihor Radchenko
2021-05-16 9:49 ` William Xu
2021-05-17 14:04 ` Ihor Radchenko
2021-05-17 17:44 ` William Xu
2021-06-20 11:27 ` Ihor Radchenko
2021-06-22 15:25 ` William Xu
2021-06-22 15:42 ` Ihor Radchenko
2021-06-22 18:07 ` William Xu
2021-07-02 14:11 ` Ihor Radchenko
2021-07-01 15:49 ` Timothy
2021-07-02 14:13 ` Ihor Radchenko
2021-10-26 9:03 ` William Xu
2021-10-27 6:50 ` Ihor Radchenko
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.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).