X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=f54aa9d69ef8d440a2e81756fd570ab32a96a2d8;hp=42c425ed4624572dad29dad94f672396b06cc365;hb=4e2c351c588ad74f4800ca0344232be90387c54a;hpb=7023466ece21b43a62dc0a2502e84bea78b1501c diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index 42c425ed..f54aa9d6 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -28,6 +28,34 @@ (require 'crm) (require 'notmuch-lib) +(define-widget 'notmuch-tag-format-type 'lazy + "Customize widget for notmuch-tag-format and friends" + :type '(alist :key-type (regexp :tag "Tag") + :extra-offset -3 + :value-type + (radio :format "%v" + (const :tag "Hidden" nil) + (set :tag "Modified" + (string :tag "Display as") + (list :tag "Face" :extra-offset -4 + (const :format "" :inline t + (notmuch-apply-face tag)) + (list :format "%v" + (const :format "" quote) + custom-face-edit)) + (list :format "%v" :extra-offset -4 + (const :format "" :inline t + (notmuch-tag-format-image-data tag)) + (choice :tag "Image" + (const :tag "Star" + (notmuch-tag-star-icon)) + (const :tag "Empty star" + (notmuch-tag-star-empty-icon)) + (const :tag "Tag" + (notmuch-tag-tag-icon)) + (string :tag "Custom"))) + (sexp :tag "Custom"))))) + (defcustom notmuch-tag-formats '(("unread" (propertize tag 'face '(:foreground "red"))) ("flagged" (propertize tag 'face '(:foreground "blue")) @@ -57,34 +85,53 @@ of a tag to red, use the expression See also `notmuch-tag-format-image', which can help replace tags with images." - :group 'notmuch-search :group 'notmuch-show - :type '(alist :key-type (regexp :tag "Tag") - :extra-offset -3 - :value-type - (radio :format "%v" - (const :tag "Hidden" nil) - (set :tag "Modified" - (string :tag "Display as") - (list :tag "Face" :extra-offset -4 - (const :format "" :inline t - (propertize tag 'face)) - (list :format "%v" - (const :format "" quote) - custom-face-edit)) - (list :format "%v" :extra-offset -4 - (const :format "" :inline t - (notmuch-tag-format-image-data tag)) - (choice :tag "Image" - (const :tag "Star" - (notmuch-tag-star-icon)) - (const :tag "Empty star" - (notmuch-tag-star-empty-icon)) - (const :tag "Tag" - (notmuch-tag-tag-icon)) - (string :tag "Custom"))) - (sexp :tag "Custom"))))) + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +(defcustom notmuch-tag-deleted-formats + '(("unread" (notmuch-apply-face bare-tag + (if (display-supports-face-attributes-p '(:strike-through "red")) + '(:strike-through "red") + '(:inverse-video t)))) + (".*" (notmuch-apply-face tag + (if (display-supports-face-attributes-p '(:strike-through "red")) + '(:strike-through "red") + '(:inverse-video t))))) + "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) + +(defcustom notmuch-tag-added-formats + '((".*" (notmuch-apply-face tag '(:underline "green")))) + "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) "Replace TAG with image DATA, if available. @@ -146,45 +193,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))) @@ -314,6 +387,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)