Re: prettify-symbols-mode in org agenda?

[Ihor Radchenko]

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.

>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