Fontify priorities, tags and TODO in colview

* lisp/org.el (org-get-priority-face): New function.
(org-font-lock-add-priority-faces): Use new function.

* lisp/org-colview.el (org-columns-new-overlay): Preserve face from
  string to display.
(org-columns-display-here): Apply usual face on TODO keywords, tags and
priorities in the columns overlay.
This commit is contained in:
Nicolas Goaziou 2015-08-06 15:35:44 +02:00
parent dc1ed4cdcc
commit 3a632fa201
2 changed files with 48 additions and 34 deletions

View file

@ -150,7 +150,6 @@ This is the compiled version of the format.")
"Create a new column overlay and add it to the list."
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face (or face 'secondary-selection))
(remove-text-properties 0 (length string) '(face nil) string)
(org-overlay-display ov string face)
(push ov org-columns-overlays)
ov))
@ -206,9 +205,7 @@ This is the compiled version of the format.")
(val (or (cdr ass) ""))
(modval
(cond
((and org-columns-modify-value-for-display-function
(functionp
org-columns-modify-value-for-display-function))
((functionp org-columns-modify-value-for-display-function)
(funcall org-columns-modify-value-for-display-function
title val))
((equal property "ITEM") (org-columns-compact-links val))
@ -220,7 +217,23 @@ This is the compiled version of the format.")
(org-columns-number-to-string
(funcall calc (org-columns-string-to-number val fm)) fm))))
(string
(format f (org-columns-add-ellipses (or modval val) width)))
(format f
(let ((v (org-columns-add-ellipses
(or modval val) width)))
(cond
((equal property "PRIORITY")
(propertize v 'face (org-get-priority-face val)))
((equal property "TAGS")
(if (not org-tags-special-faces-re)
(propertize v 'face 'org-tag)
(replace-regexp-in-string
org-tags-special-faces-re
(lambda (m)
(propertize m 'face (org-get-tag-face m)))
v nil nil 1)))
((equal property "TODO")
(propertize v 'face (org-get-todo-face val)))
(t v)))))
(ov (org-columns-new-overlay
(point) (1+ (point)) string (if dateline face1 face))))
(overlay-put ov 'keymap org-columns-map)

View file

@ -6500,6 +6500,14 @@ needs to be inserted at a specific position in the font-lock sequence.")
((eq n 2) org-f)
(t (if org-level-color-stars-only nil org-f))))
(defun org-face-from-face-or-color (context inherit face-or-color)
"Create a face list that inherits INHERIT, but sets the foreground color.
When FACE-OR-COLOR is not a string, just return it."
(if (stringp face-or-color)
(list :inherit inherit
(cdr (assoc context org-faces-easy-properties))
face-or-color)
face-or-color))
(defun org-get-todo-face (kwd)
"Get the right face for a TODO keyword KWD.
@ -6510,14 +6518,28 @@ If KWD is a number, get the corresponding match group."
(and (member kwd org-done-keywords) 'org-done)
'org-todo))
(defun org-face-from-face-or-color (context inherit face-or-color)
"Create a face list that inherits INHERIT, but sets the foreground color.
When FACE-OR-COLOR is not a string, just return it."
(if (stringp face-or-color)
(list :inherit inherit
(cdr (assoc context org-faces-easy-properties))
face-or-color)
face-or-color))
(defun org-get-priority-face (priority)
"Get the right face for PRIORITY.
PRIORITY is a character."
(or (org-face-from-face-or-color
'priority 'org-priority (cdr (assq priority org-priority-faces)))
'org-priority))
(defun org-get-tag-face (tag)
"Get the right face for TAG.
If TAG is a number, get the corresponding match group."
(let ((tag (if (wholenump tag) (match-string tag) tag)))
(or (org-face-from-face-or-color
'tag 'org-tag (cdr (assoc kwd org-tag-faces)))
'org-tag)))
(defun org-font-lock-add-priority-faces (limit)
"Add the special priority faces."
(while (re-search-forward "^\\*+ .*?\\(\\[#\\(.\\)\\]\\)" limit t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (org-get-priority-face (string-to-char (match-string 2)))
'font-lock-fontified t))))
(defun org-font-lock-add-tag-faces (limit)
"Add the special tag faces."
@ -6528,27 +6550,6 @@ When FACE-OR-COLOR is not a string, just return it."
'font-lock-fontified t))
(backward-char 1))))
(defun org-font-lock-add-priority-faces (limit)
"Add the special priority faces."
(while (re-search-forward "\\[#\\([A-Z0-9]\\)\\]" limit t)
(when (save-match-data (org-at-heading-p))
(add-text-properties
(match-beginning 0) (match-end 0)
(list 'face (or (org-face-from-face-or-color
'priority 'org-priority
(cdr (assoc (char-after (match-beginning 1))
org-priority-faces)))
'org-priority)
'font-lock-fontified t)))))
(defun org-get-tag-face (tag)
"Get the right face for TAG.
If TAG is a number, get the corresponding match group."
(let ((tag (if (wholenump tag) (match-string tag) tag)))
(or (org-face-from-face-or-color
'tag 'org-tag (cdr (assoc kwd org-tag-faces)))
'org-tag)))
(defun org-unfontify-region (beg end &optional maybe_loudly)
"Remove fontification and activation overlays from links."
(font-lock-default-unfontify-region beg end)