X-Git-Url: https://git.notmuchmail.org/git?a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=6c8b6a758a696b060d8d0733039118fa88be8ce8;hb=e81c71639e91d9a7f1fcda0f121c2ce8ed0cec63;hp=a4dea39df71a732154770a008977bd24417ac226;hpb=b9a777e0a3983a5b2062e927c5b426ca669da644;p=notmuch
diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el
index a4dea39d..6c8b6a75 100644
--- a/emacs/notmuch-tag.el
+++ b/emacs/notmuch-tag.el
@@ -1,4 +1,4 @@
-;; notmuch-tag.el --- tag messages within emacs
+;;; notmuch-tag.el --- tag messages within emacs
;;
;; Copyright © Damien Cassou
;; Copyright © Carl Worth
@@ -16,7 +16,7 @@
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
-;; along with Notmuch. If not, see .
+;; along with Notmuch. If not, see .
;;
;; Authors: Carl Worth
;; Damien Cassou
@@ -39,7 +39,7 @@
(string :tag "Display as")
(list :tag "Face" :extra-offset -4
(const :format "" :inline t
- (propertize tag 'face))
+ (notmuch-apply-face tag))
(list :format "%v"
(const :format "" quote)
custom-face-edit))
@@ -56,9 +56,23 @@
(string :tag "Custom")))
(sexp :tag "Custom")))))
+(defface notmuch-tag-unread
+ '((t :foreground "red"))
+ "Default face used for the unread tag.
+
+Used in the default value of `notmuch-tag-formats`."
+ :group 'notmuch-faces)
+
+(defface notmuch-tag-flagged
+ '((t :foreground "blue"))
+ "Face used for the flagged tag.
+
+Used in the default value of `notmuch-tag-formats`."
+ :group 'notmuch-faces)
+
(defcustom notmuch-tag-formats
- '(("unread" (propertize tag 'face '(:foreground "red")))
- ("flagged" (propertize tag 'face '(:foreground "blue"))
+ '(("unread" (propertize tag 'face 'notmuch-tag-unread))
+ ("flagged" (propertize tag 'face 'notmuch-tag-flagged)
(notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
"Custom formats for individual tags.
@@ -87,6 +101,59 @@ See also `notmuch-tag-format-image', which can help replace tags
with images."
:group 'notmuch-search
:group 'notmuch-show
+ :group 'notmuch-faces
+ :type 'notmuch-tag-format-type)
+
+(defface notmuch-tag-deleted
+ '((((class color) (supports :strike-through "red")) :strike-through "red")
+ (t :inverse-video t))
+ "Face used to display deleted tags.
+
+Used in the default value of `notmuch-tag-deleted-formats`."
+ :group 'notmuch-faces)
+
+(defcustom notmuch-tag-deleted-formats
+ '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
+ (".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
+ "Custom formats for tags when deleted.
+
+For deleted tags the formats in `notmuch-tag-formats` are applied
+first and then these formats are applied on top; that is `tag'
+passed to the function is the tag with all these previous
+formattings applied. The formatted can access the original
+unformatted tag as `bare-tag'.
+
+By default this shows deleted tags with strike-through in red,
+unless strike-through is not available (e.g., emacs is running in
+a terminal) in which case it uses inverse video. To hide deleted
+tags completely set this to
+ '((\".*\" nil))
+
+See `notmuch-tag-formats' for full documentation."
+ :group 'notmuch-show
+ :group 'notmuch-faces
+ :type 'notmuch-tag-format-type)
+
+(defface notmuch-tag-added
+ '((t :underline "green"))
+ "Default face used for added tags.
+
+Used in the default value for `notmuch-tag-added-formats`."
+ :group 'notmuch-faces)
+
+(defcustom notmuch-tag-added-formats
+ '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
+ "Custom formats for tags when added.
+
+For added tags the formats in `notmuch-tag-formats` are applied
+first and then these formats are applied on top.
+
+To disable special formatting of added tags, set this variable to
+nil.
+
+See `notmuch-tag-formats' for full documentation."
+ :group 'notmuch-show
+ :group 'notmuch-faces
:type 'notmuch-tag-format-type)
(defun notmuch-tag-format-image-data (tag data)
@@ -149,45 +216,71 @@ This can be used with `notmuch-tag-format-image-data'."
"Clear the internal cache of tag formats."
(clrhash notmuch-tag--format-cache))
-(defun notmuch-tag-format-tag (tag)
- "Format TAG by according to `notmuch-tag-formats'.
-
-Callers must ensure that the tag format cache has been recently cleared
-via `notmuch-tag-clear-cache' before using this function. For example,
-it would be appropriate to clear the cache just prior to filling a
-buffer that uses formatted tags."
-
- (let ((formatted (gethash tag notmuch-tag--format-cache 'missing)))
- (when (eq formatted 'missing)
- (let* ((formats
- (save-match-data
- ;; Don't use assoc-default since there's no way to
- ;; distinguish a missing key from a present key with a
- ;; null cdr:.
- (assoc* tag notmuch-tag-formats
- :test (lambda (tag key)
- (and (eq (string-match key tag) 0)
- (= (match-end 0) (length tag))))))))
- (setq formatted
- (cond
- ((null formats) ;; - Tag not in `notmuch-tag-formats',
- tag) ;; the format is the tag itself.
- ((null (cdr formats)) ;; - Tag was deliberately hidden,
- nil) ;; no format must be returned
- (t ;; - Tag was found and has formats,
- (let ((tag tag)) ;; we must apply all the formats.
- (dolist (format (cdr formats) tag)
- (setq tag (eval format)))))))
- (puthash tag formatted notmuch-tag--format-cache)))
- formatted))
-
-(defun notmuch-tag-format-tags (tags &optional face)
+(defun notmuch-tag--get-formats (tag format-alist)
+ "Find the first item whose car regexp-matches TAG."
+ (save-match-data
+ ;; Don't use assoc-default since there's no way to distinguish a
+ ;; missing key from a present key with a null cdr.
+ (assoc* tag format-alist
+ :test (lambda (tag key)
+ (and (eq (string-match key tag) 0)
+ (= (match-end 0) (length tag)))))))
+
+(defun notmuch-tag--do-format (tag formatted-tag formats)
+ "Apply a tag-formats entry to TAG."
+ (cond ((null formats) ;; - Tag not in `formats',
+ formatted-tag) ;; the format is the tag itself.
+ ((null (cdr formats)) ;; - Tag was deliberately hidden,
+ nil) ;; no format must be returned
+ (t
+ ;; Tag was found and has formats, we must apply all the
+ ;; formats. TAG may be null so treat that as a special case.
+ (let ((bare-tag tag)
+ (tag (copy-sequence (or formatted-tag ""))))
+ (dolist (format (cdr formats))
+ (setq tag (eval format)))
+ (if (and (null formatted-tag) (equal tag ""))
+ nil
+ tag)))))
+
+(defun notmuch-tag-format-tag (tags orig-tags tag)
+ "Format TAG according to `notmuch-tag-formats'.
+
+TAGS and ORIG-TAGS are lists of the current tags and the original
+tags; tags which have been deleted (i.e., are in ORIG-TAGS but
+are not in TAGS) are shown using formats from
+`notmuch-tag-deleted-formats'; tags which have been added (i.e.,
+are in TAGS but are not in ORIG-TAGS) are shown using formats
+from `notmuch-tag-added-formats' and tags which have not been
+changed (the normal case) are shown using formats from
+`notmuch-tag-formats'"
+ (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
+ ((not (member tag orig-tags)) 'added)))
+ (formatted-tag (gethash (cons tag tag-state) notmuch-tag--format-cache 'missing)))
+ (when (eq formatted-tag 'missing)
+ (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
+ (over (case tag-state
+ (deleted (notmuch-tag--get-formats
+ tag notmuch-tag-deleted-formats))
+ (added (notmuch-tag--get-formats
+ tag notmuch-tag-added-formats))
+ (otherwise nil))))
+ (setq formatted-tag (notmuch-tag--do-format tag tag base))
+ (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
+
+ (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
+ formatted-tag))
+
+(defun notmuch-tag-format-tags (tags orig-tags &optional face)
"Return a string representing formatted TAGS."
- (let ((face (or face 'notmuch-tag-face)))
+ (let ((face (or face 'notmuch-tag-face))
+ (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
(notmuch-apply-face
(mapconcat #'identity
;; nil indicated that the tag was deliberately hidden
- (delq nil (mapcar #'notmuch-tag-format-tag tags))
+ (delq nil (mapcar
+ (apply-partially #'notmuch-tag-format-tag tags orig-tags)
+ all-tags))
" ")
face
t)))
@@ -195,7 +288,7 @@ buffer that uses formatted tags."
(defcustom notmuch-before-tag-hook nil
"Hooks that are run before tags of a message are modified.
-'tags' will contain the tags that are about to be added or removed as
+'tag-changes' will contain the tags that are about to be added or removed as
a list of strings of the form \"+TAG\" or \"-TAG\".
'query' will be a string containing the search query that determines
the messages that are about to be tagged"
@@ -207,7 +300,7 @@ the messages that are about to be tagged"
(defcustom notmuch-after-tag-hook nil
"Hooks that are run after tags of a message are modified.
-'tags' will contain the tags that were added or removed as
+'tag-changes' will contain the tags that were added or removed as
a list of strings of the form \"+TAG\" or \"-TAG\".
'query' will be a string containing the search query that determines
the messages that were tagged"
@@ -317,6 +410,8 @@ notmuch-after-tag-hook will be run."
(unless (string-match-p "^[-+]\\S-+$" tag-change)
(error "Tag must be of the form `+this_tag' or `-that_tag'")))
tag-changes)
+ (unless query
+ (error "Nothing to tag!"))
(unless (null tag-changes)
(run-hooks 'notmuch-before-tag-hook)
(if (<= (length query) notmuch-tag-argument-limit)