1 ;; notmuch-tag.el --- tag messages within emacs
3 ;; Copyright © Damien Cassou
4 ;; Copyright © Carl Worth
6 ;; This file is part of Notmuch.
8 ;; Notmuch is free software: you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; Notmuch is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>.
21 ;; Authors: Carl Worth <cworth@cworth.org>
22 ;; Damien Cassou <damien.cassou@gmail.com>
29 (require 'notmuch-lib)
31 (define-widget 'notmuch-tag-format-type 'lazy
32 "Customize widget for notmuch-tag-format and friends"
33 :type '(alist :key-type (regexp :tag "Tag")
37 (const :tag "Hidden" nil)
39 (string :tag "Display as")
40 (list :tag "Face" :extra-offset -4
41 (const :format "" :inline t
42 (notmuch-apply-face tag))
44 (const :format "" quote)
46 (list :format "%v" :extra-offset -4
47 (const :format "" :inline t
48 (notmuch-tag-format-image-data tag))
51 (notmuch-tag-star-icon))
52 (const :tag "Empty star"
53 (notmuch-tag-star-empty-icon))
55 (notmuch-tag-tag-icon))
56 (string :tag "Custom")))
57 (sexp :tag "Custom")))))
59 (defcustom notmuch-tag-formats
60 '(("unread" (propertize tag 'face '(:foreground "red")))
61 ("flagged" (propertize tag 'face '(:foreground "blue"))
62 (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
63 "Custom formats for individual tags.
65 This is an association list that maps from tag name regexps to
66 lists of formatting expressions. The first entry whose car
67 regexp-matches a tag will be used to format that tag. The regexp
68 is implicitly anchored, so to match a literal tag name, just use
69 that tag name (if it contains special regexp characters like
70 \".\" or \"*\", these have to be escaped). The cdr of the
71 matching entry gives a list of Elisp expressions that modify the
72 tag. If the list is empty, the tag will simply be hidden.
73 Otherwise, each expression will be evaluated in order: for the
74 first expression, the variable `tag' will be bound to the tag
75 name; for each later expression, the variable `tag' will be bound
76 to the result of the previous expression. In this way, each
77 expression can build on the formatting performed by the previous
78 expression. The result of the last expression will displayed in
81 For example, to replace a tag with another string, simply use
82 that string as a formatting expression. To change the foreground
83 of a tag to red, use the expression
84 (propertize tag 'face '(:foreground \"red\"))
86 See also `notmuch-tag-format-image', which can help replace tags
88 :group 'notmuch-search
91 :type 'notmuch-tag-format-type)
93 (defcustom notmuch-tag-deleted-formats
94 '(("unread" (notmuch-apply-face bare-tag
95 (if (display-supports-face-attributes-p '(:strike-through "red"))
96 '(:strike-through "red")
97 '(:inverse-video t))))
98 (".*" (notmuch-apply-face tag
99 (if (display-supports-face-attributes-p '(:strike-through "red"))
100 '(:strike-through "red")
101 '(:inverse-video t)))))
102 "Custom formats for tags when deleted.
104 For deleted tags the formats in `notmuch-tag-formats` are applied
105 first and then these formats are applied on top; that is `tag'
106 passed to the function is the tag with all these previous
107 formattings applied. The formatted can access the original
108 unformatted tag as `bare-tag'.
110 By default this shows deleted tags with strike-through in red,
111 unless strike-through is not available (e.g., emacs is running in
112 a terminal) in which case it uses inverse video. To hide deleted
113 tags completely set this to
116 See `notmuch-tag-formats' for full documentation."
118 :group 'notmuch-faces
119 :type 'notmuch-tag-format-type)
121 (defcustom notmuch-tag-added-formats
122 '((".*" (notmuch-apply-face tag '(:underline "green"))))
123 "Custom formats for tags when added.
125 For added tags the formats in `notmuch-tag-formats` are applied
126 first and then these formats are applied on top.
128 To disable special formatting of added tags, set this variable to
131 See `notmuch-tag-formats' for full documentation."
133 :group 'notmuch-faces
134 :type 'notmuch-tag-format-type)
136 (defun notmuch-tag-format-image-data (tag data)
137 "Replace TAG with image DATA, if available.
139 This function returns a propertized string that will display image
140 DATA in place of TAG.This is designed for use in
141 `notmuch-tag-formats'.
143 DATA is the content of an SVG picture (e.g., as returned by
144 `notmuch-tag-star-icon')."
145 (propertize tag 'display
151 (defun notmuch-tag-star-icon ()
152 "Return SVG data representing a star icon.
153 This can be used with `notmuch-tag-format-image-data'."
154 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
155 <svg version=\"1.1\" width=\"16\" height=\"16\">
156 <g transform=\"translate(-242.81601,-315.59635)\">
158 d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
159 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
160 style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
164 (defun notmuch-tag-star-empty-icon ()
165 "Return SVG data representing an empty star icon.
166 This can be used with `notmuch-tag-format-image-data'."
167 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
168 <svg version=\"1.1\" width=\"16\" height=\"16\">
169 <g transform=\"translate(-242.81601,-315.59635)\">
171 d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
172 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
173 style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
177 (defun notmuch-tag-tag-icon ()
178 "Return SVG data representing a tag icon.
179 This can be used with `notmuch-tag-format-image-data'."
180 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
181 <svg version=\"1.1\" width=\"16\" height=\"16\">
182 <g transform=\"translate(0,-1036.3622)\">
184 d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
185 style=\"fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.25;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1\" />
189 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
190 "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.")
192 (defun notmuch-tag-clear-cache ()
193 "Clear the internal cache of tag formats."
194 (clrhash notmuch-tag--format-cache))
196 (defun notmuch-tag--get-formats (tag format-alist)
197 "Find the first item whose car regexp-matches TAG."
199 ;; Don't use assoc-default since there's no way to distinguish a
200 ;; missing key from a present key with a null cdr.
201 (assoc* tag format-alist
202 :test (lambda (tag key)
203 (and (eq (string-match key tag) 0)
204 (= (match-end 0) (length tag)))))))
206 (defun notmuch-tag--do-format (tag formatted-tag formats)
207 "Apply a tag-formats entry to TAG."
208 (cond ((null formats) ;; - Tag not in `formats',
209 formatted-tag) ;; the format is the tag itself.
210 ((null (cdr formats)) ;; - Tag was deliberately hidden,
211 nil) ;; no format must be returned
213 ;; Tag was found and has formats, we must apply all the
214 ;; formats. TAG may be null so treat that as a special case.
216 (tag (copy-sequence (or formatted-tag ""))))
217 (dolist (format (cdr formats))
218 (setq tag (eval format)))
219 (if (and (null formatted-tag) (equal tag ""))
223 (defun notmuch-tag-format-tag (tags orig-tags tag)
224 "Format TAG according to `notmuch-tag-formats'.
226 TAGS and ORIG-TAGS are lists of the current tags and the original
227 tags; tags which have been deleted (i.e., are in ORIG-TAGS but
228 are not in TAGS) are shown using formats from
229 `notmuch-tag-deleted-formats'; tags which have been added (i.e.,
230 are in TAGS but are not in ORIG-TAGS) are shown using formats
231 from `notmuch-tag-added-formats' and tags which have not been
232 changed (the normal case) are shown using formats from
233 `notmuch-tag-formats'"
234 (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
235 ((not (member tag orig-tags)) 'added)))
236 (formatted-tag (gethash (cons tag tag-state) notmuch-tag--format-cache 'missing)))
237 (when (eq formatted-tag 'missing)
238 (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
239 (over (case tag-state
240 (deleted (notmuch-tag--get-formats
241 tag notmuch-tag-deleted-formats))
242 (added (notmuch-tag--get-formats
243 tag notmuch-tag-added-formats))
245 (setq formatted-tag (notmuch-tag--do-format tag tag base))
246 (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
248 (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
251 (defun notmuch-tag-format-tags (tags orig-tags &optional face)
252 "Return a string representing formatted TAGS."
253 (let ((face (or face 'notmuch-tag-face))
254 (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
256 (mapconcat #'identity
257 ;; nil indicated that the tag was deliberately hidden
259 (apply-partially #'notmuch-tag-format-tag tags orig-tags)
265 (defcustom notmuch-before-tag-hook nil
266 "Hooks that are run before tags of a message are modified.
268 'tags' will contain the tags that are about to be added or removed as
269 a list of strings of the form \"+TAG\" or \"-TAG\".
270 'query' will be a string containing the search query that determines
271 the messages that are about to be tagged"
274 :options '(notmuch-hl-line-mode)
275 :group 'notmuch-hooks)
277 (defcustom notmuch-after-tag-hook nil
278 "Hooks that are run after tags of a message are modified.
280 'tags' will contain the tags that were added or removed as
281 a list of strings of the form \"+TAG\" or \"-TAG\".
282 'query' will be a string containing the search query that determines
283 the messages that were tagged"
285 :options '(notmuch-hl-line-mode)
286 :group 'notmuch-hooks)
288 (defvar notmuch-select-tag-history nil
289 "Variable to store minibuffer history for
290 `notmuch-select-tag-with-completion' function.")
292 (defvar notmuch-read-tag-changes-history nil
293 "Variable to store minibuffer history for
294 `notmuch-read-tag-changes' function.")
296 (defun notmuch-tag-completions (&rest search-terms)
297 "Return a list of tags for messages matching SEARCH-TERMS.
299 Returns all tags if no search terms are given."
300 (if (null search-terms)
301 (setq search-terms (list "*")))
303 (with-output-to-string
304 (with-current-buffer standard-output
305 (apply 'call-process notmuch-command nil t
306 nil "search" "--output=tags" "--exclude=false" search-terms)))
309 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
310 (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
311 (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
313 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
314 "Prompt for tag changes in the minibuffer.
316 CURRENT-TAGS is a list of tags that are present on the message or
317 messages to be changed. These are offered as tag removal
318 completions. CURRENT-TAGS may contain duplicates. PROMPT, if
319 non-nil, is the query string to present in the minibuffer. It
320 defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
321 initial input in the minibuffer."
323 (let* ((all-tag-list (notmuch-tag-completions))
324 (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
325 (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
326 (tag-list (append add-tag-list remove-tag-list))
327 (prompt (concat (or prompt "Tags") " (+add -drop): "))
329 ;; By default, space is bound to "complete word" function.
330 ;; Re-bind it to insert a space instead. Note that <tab>
331 ;; still does the completion.
332 (crm-local-completion-map
333 (let ((map (make-sparse-keymap)))
334 (set-keymap-parent map crm-local-completion-map)
335 (define-key map " " 'self-insert-command)
337 (delete "" (completing-read-multiple
339 ;; Append the separator to each completion so when the
340 ;; user completes a tag they can immediately begin
341 ;; entering another. `completing-read-multiple'
342 ;; ultimately splits the input on crm-separator, so we
343 ;; don't need to strip this back off (we just need to
344 ;; delete "empty" entries caused by trailing spaces).
345 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
346 nil nil initial-input
347 'notmuch-read-tag-changes-history))))
349 (defun notmuch-update-tags (tags tag-changes)
350 "Return a copy of TAGS with additions and removals from TAG-CHANGES.
352 TAG-CHANGES must be a list of tags names, each prefixed with
353 either a \"+\" to indicate the tag should be added to TAGS if not
354 present or a \"-\" to indicate that the tag should be removed
355 from TAGS if present."
356 (let ((result-tags (copy-sequence tags)))
357 (dolist (tag-change tag-changes)
358 (let ((op (string-to-char tag-change))
359 (tag (unless (string= tag-change "") (substring tag-change 1))))
361 (?+ (unless (member tag result-tags)
362 (push tag result-tags)))
363 (?- (setq result-tags (delete tag result-tags)))
365 (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
366 (sort result-tags 'string<)))
368 (defconst notmuch-tag-argument-limit 1000
369 "Use batch tagging if the tagging query is longer than this.
371 This limits the length of arguments passed to the notmuch CLI to
372 avoid system argument length limits and performance problems.")
374 (defun notmuch-tag (query tag-changes)
375 "Add/remove tags in TAG-CHANGES to messages matching QUERY.
377 QUERY should be a string containing the search-terms.
378 TAG-CHANGES is a list of strings of the form \"+tag\" or
379 \"-tag\" to add or remove tags, respectively.
381 Note: Other code should always use this function alter tags of
382 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
383 directly, so that hooks specified in notmuch-before-tag-hook and
384 notmuch-after-tag-hook will be run."
385 ;; Perform some validation
386 (mapc (lambda (tag-change)
387 (unless (string-match-p "^[-+]\\S-+$" tag-change)
388 (error "Tag must be of the form `+this_tag' or `-that_tag'")))
391 (error "Nothing to tag!"))
392 (unless (null tag-changes)
393 (run-hooks 'notmuch-before-tag-hook)
394 (if (<= (length query) notmuch-tag-argument-limit)
395 (apply 'notmuch-call-notmuch-process "tag"
396 (append tag-changes (list "--" query)))
397 ;; Use batch tag mode to avoid argument length limitations
398 (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
400 (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
401 (run-hooks 'notmuch-after-tag-hook)))
403 (defun notmuch-tag-change-list (tags &optional reverse)
404 "Convert TAGS into a list of tag changes.
406 Add a \"+\" prefix to any tag in TAGS list that doesn't already
407 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
408 \"+\" prefixes with \"-\" and vice versa in the result."
409 (mapcar (lambda (str)
410 (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
412 (concat (if (= (string-to-char s) ?-) "+" "-")
420 (provide 'notmuch-tag)
423 ;; byte-compile-warnings: (not cl-functions)