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 <https://www.gnu.org/licenses/>.
21 ;; Authors: Carl Worth <cworth@cworth.org>
22 ;; Damien Cassou <damien.cassou@gmail.com>
29 (require 'notmuch-lib)
31 (declare-function notmuch-search-tag "notmuch" tag-changes)
32 (declare-function notmuch-show-tag "notmuch-show" tag-changes)
33 (declare-function notmuch-tree-tag "notmuch-tree" tag-changes)
35 (autoload 'notmuch-jump "notmuch-jump")
37 (define-widget 'notmuch-tag-key-type 'list
38 "A single key tagging binding."
40 :args '((list :inline t
42 (key-sequence :tag "Key")
43 (radio :tag "Tag operations" (repeat :tag "Tag list" (string :format "%v" :tag "change"))
44 (variable :tag "Tag variable"))
45 (string :tag "Name"))))
47 (defcustom notmuch-tagging-keys
48 `((,(kbd "a") notmuch-archive-tags "Archive")
49 (,(kbd "u") notmuch-show-mark-read-tags "Mark read")
50 (,(kbd "f") ("+flagged") "Flag")
51 (,(kbd "s") ("+spam" "-inbox") "Mark as spam")
52 (,(kbd "d") ("+deleted" "-inbox") "Delete"))
53 "A list of keys and corresponding tagging operations.
55 For each key (or key sequence) you can specify a sequence of
56 tagging operations to apply, or a variable which contains a list
57 of tagging operations such as `notmuch-archive-tags'. The final
58 element is a name for this tagging operation. If the name is
59 omitted or empty then the list of tag changes, or the variable
60 name is used as the name.
62 The key `notmuch-tag-jump-reverse-key' (k by default) should not
63 be used (either as a key, or as the start of a key sequence) as
64 it is already bound: it switches the menu to a menu of the
65 reverse tagging operations. The reverse of a tagging operation is
66 the same list of individual tag-ops but with `+tag` replaced by
67 `-tag` and vice versa.
69 If setting this variable outside of customize then it should be a
70 list of triples (lists of three elements). Each triple should be
71 of the form (key-binding tagging-operations name). KEY-BINDING
72 can be a single character or a key sequence; TAGGING-OPERATIONS
73 should either be a list of individual tag operations each of the
74 form `+tag` or `-tag`, or the variable name of a variable that is
75 a list of tagging operations; NAME should be a name for the
76 tagging operation, if omitted or empty than then name is taken
77 from TAGGING-OPERATIONS."
78 :tag "List of tagging bindings"
79 :type '(repeat notmuch-tag-key-type)
82 (define-widget 'notmuch-tag-format-type 'lazy
83 "Customize widget for notmuch-tag-format and friends"
84 :type '(alist :key-type (regexp :tag "Tag")
88 (const :tag "Hidden" nil)
90 (string :tag "Display as")
91 (list :tag "Face" :extra-offset -4
92 (const :format "" :inline t
93 (notmuch-apply-face tag))
95 (const :format "" quote)
97 (list :format "%v" :extra-offset -4
98 (const :format "" :inline t
99 (notmuch-tag-format-image-data tag))
102 (notmuch-tag-star-icon))
103 (const :tag "Empty star"
104 (notmuch-tag-star-empty-icon))
106 (notmuch-tag-tag-icon))
107 (string :tag "Custom")))
108 (sexp :tag "Custom")))))
110 (defface notmuch-tag-unread
111 '((t :foreground "red"))
112 "Default face used for the unread tag.
114 Used in the default value of `notmuch-tag-formats`."
115 :group 'notmuch-faces)
117 (defface notmuch-tag-flagged
118 '((t :foreground "blue"))
119 "Face used for the flagged tag.
121 Used in the default value of `notmuch-tag-formats`."
122 :group 'notmuch-faces)
124 (defcustom notmuch-tag-formats
125 '(("unread" (propertize tag 'face 'notmuch-tag-unread))
126 ("flagged" (propertize tag 'face 'notmuch-tag-flagged)
127 (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
128 "Custom formats for individual tags.
130 This is an association list that maps from tag name regexps to
131 lists of formatting expressions. The first entry whose car
132 regexp-matches a tag will be used to format that tag. The regexp
133 is implicitly anchored, so to match a literal tag name, just use
134 that tag name (if it contains special regexp characters like
135 \".\" or \"*\", these have to be escaped). The cdr of the
136 matching entry gives a list of Elisp expressions that modify the
137 tag. If the list is empty, the tag will simply be hidden.
138 Otherwise, each expression will be evaluated in order: for the
139 first expression, the variable `tag' will be bound to the tag
140 name; for each later expression, the variable `tag' will be bound
141 to the result of the previous expression. In this way, each
142 expression can build on the formatting performed by the previous
143 expression. The result of the last expression will displayed in
146 For example, to replace a tag with another string, simply use
147 that string as a formatting expression. To change the foreground
148 of a tag to red, use the expression
149 (propertize tag 'face '(:foreground \"red\"))
151 See also `notmuch-tag-format-image', which can help replace tags
153 :group 'notmuch-search
155 :group 'notmuch-faces
156 :type 'notmuch-tag-format-type)
158 (defface notmuch-tag-deleted
159 '((((class color) (supports :strike-through "red")) :strike-through "red")
160 (t :inverse-video t))
161 "Face used to display deleted tags.
163 Used in the default value of `notmuch-tag-deleted-formats`."
164 :group 'notmuch-faces)
166 (defcustom notmuch-tag-deleted-formats
167 '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
168 (".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
169 "Custom formats for tags when deleted.
171 For deleted tags the formats in `notmuch-tag-formats` are applied
172 first and then these formats are applied on top; that is `tag'
173 passed to the function is the tag with all these previous
174 formattings applied. The formatted can access the original
175 unformatted tag as `bare-tag'.
177 By default this shows deleted tags with strike-through in red,
178 unless strike-through is not available (e.g., emacs is running in
179 a terminal) in which case it uses inverse video. To hide deleted
180 tags completely set this to
183 See `notmuch-tag-formats' for full documentation."
185 :group 'notmuch-faces
186 :type 'notmuch-tag-format-type)
188 (defface notmuch-tag-added
189 '((t :underline "green"))
190 "Default face used for added tags.
192 Used in the default value for `notmuch-tag-added-formats`."
193 :group 'notmuch-faces)
195 (defcustom notmuch-tag-added-formats
196 '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
197 "Custom formats for tags when added.
199 For added tags the formats in `notmuch-tag-formats` are applied
200 first and then these formats are applied on top.
202 To disable special formatting of added tags, set this variable to
205 See `notmuch-tag-formats' for full documentation."
207 :group 'notmuch-faces
208 :type 'notmuch-tag-format-type)
210 (defun notmuch-tag-format-image-data (tag data)
211 "Replace TAG with image DATA, if available.
213 This function returns a propertized string that will display image
214 DATA in place of TAG.This is designed for use in
215 `notmuch-tag-formats'.
217 DATA is the content of an SVG picture (e.g., as returned by
218 `notmuch-tag-star-icon')."
219 (propertize tag 'display
225 (defun notmuch-tag-star-icon ()
226 "Return SVG data representing a star icon.
227 This can be used with `notmuch-tag-format-image-data'."
228 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
229 <svg version=\"1.1\" width=\"16\" height=\"16\">
230 <g transform=\"translate(-242.81601,-315.59635)\">
232 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\"
233 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
234 style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
238 (defun notmuch-tag-star-empty-icon ()
239 "Return SVG data representing an empty star icon.
240 This can be used with `notmuch-tag-format-image-data'."
241 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
242 <svg version=\"1.1\" width=\"16\" height=\"16\">
243 <g transform=\"translate(-242.81601,-315.59635)\">
245 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\"
246 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
247 style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
251 (defun notmuch-tag-tag-icon ()
252 "Return SVG data representing a tag icon.
253 This can be used with `notmuch-tag-format-image-data'."
254 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
255 <svg version=\"1.1\" width=\"16\" height=\"16\">
256 <g transform=\"translate(0,-1036.3622)\">
258 d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
259 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\" />
263 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
264 "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.")
266 (defun notmuch-tag-clear-cache ()
267 "Clear the internal cache of tag formats."
268 (clrhash notmuch-tag--format-cache))
270 (defun notmuch-tag--get-formats (tag format-alist)
271 "Find the first item whose car regexp-matches TAG."
273 ;; Don't use assoc-default since there's no way to distinguish a
274 ;; missing key from a present key with a null cdr.
275 (assoc* tag format-alist
276 :test (lambda (tag key)
277 (and (eq (string-match key tag) 0)
278 (= (match-end 0) (length tag)))))))
280 (defun notmuch-tag--do-format (tag formatted-tag formats)
281 "Apply a tag-formats entry to TAG."
282 (cond ((null formats) ;; - Tag not in `formats',
283 formatted-tag) ;; the format is the tag itself.
284 ((null (cdr formats)) ;; - Tag was deliberately hidden,
285 nil) ;; no format must be returned
287 ;; Tag was found and has formats, we must apply all the
288 ;; formats. TAG may be null so treat that as a special case.
290 (tag (copy-sequence (or formatted-tag ""))))
291 (dolist (format (cdr formats))
292 (setq tag (eval format)))
293 (if (and (null formatted-tag) (equal tag ""))
297 (defun notmuch-tag-format-tag (tags orig-tags tag)
298 "Format TAG according to `notmuch-tag-formats'.
300 TAGS and ORIG-TAGS are lists of the current tags and the original
301 tags; tags which have been deleted (i.e., are in ORIG-TAGS but
302 are not in TAGS) are shown using formats from
303 `notmuch-tag-deleted-formats'; tags which have been added (i.e.,
304 are in TAGS but are not in ORIG-TAGS) are shown using formats
305 from `notmuch-tag-added-formats' and tags which have not been
306 changed (the normal case) are shown using formats from
307 `notmuch-tag-formats'"
308 (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
309 ((not (member tag orig-tags)) 'added)))
310 (formatted-tag (gethash (cons tag tag-state) notmuch-tag--format-cache 'missing)))
311 (when (eq formatted-tag 'missing)
312 (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
313 (over (case tag-state
314 (deleted (notmuch-tag--get-formats
315 tag notmuch-tag-deleted-formats))
316 (added (notmuch-tag--get-formats
317 tag notmuch-tag-added-formats))
319 (setq formatted-tag (notmuch-tag--do-format tag tag base))
320 (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
322 (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
325 (defun notmuch-tag-format-tags (tags orig-tags &optional face)
326 "Return a string representing formatted TAGS."
327 (let ((face (or face 'notmuch-tag-face))
328 (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
330 (mapconcat #'identity
331 ;; nil indicated that the tag was deliberately hidden
333 (apply-partially #'notmuch-tag-format-tag tags orig-tags)
339 (defcustom notmuch-before-tag-hook nil
340 "Hooks that are run before tags of a message are modified.
342 'tag-changes' will contain the tags that are about to be added or removed as
343 a list of strings of the form \"+TAG\" or \"-TAG\".
344 'query' will be a string containing the search query that determines
345 the messages that are about to be tagged"
348 :options '(notmuch-hl-line-mode)
349 :group 'notmuch-hooks)
351 (defcustom notmuch-after-tag-hook nil
352 "Hooks that are run after tags of a message are modified.
354 'tag-changes' will contain the tags that were added or removed as
355 a list of strings of the form \"+TAG\" or \"-TAG\".
356 'query' will be a string containing the search query that determines
357 the messages that were tagged"
359 :options '(notmuch-hl-line-mode)
360 :group 'notmuch-hooks)
362 (defvar notmuch-select-tag-history nil
363 "Variable to store minibuffer history for
364 `notmuch-select-tag-with-completion' function.")
366 (defvar notmuch-read-tag-changes-history nil
367 "Variable to store minibuffer history for
368 `notmuch-read-tag-changes' function.")
370 (defun notmuch-tag-completions (&rest search-terms)
371 "Return a list of tags for messages matching SEARCH-TERMS.
373 Returns all tags if no search terms are given."
374 (if (null search-terms)
375 (setq search-terms (list "*")))
377 (with-output-to-string
378 (with-current-buffer standard-output
379 (apply 'call-process notmuch-command nil t
380 nil "search" "--output=tags" "--exclude=false" search-terms)))
383 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
384 (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
385 (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
387 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
388 "Prompt for tag changes in the minibuffer.
390 CURRENT-TAGS is a list of tags that are present on the message or
391 messages to be changed. These are offered as tag removal
392 completions. CURRENT-TAGS may contain duplicates. PROMPT, if
393 non-nil, is the query string to present in the minibuffer. It
394 defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
395 initial input in the minibuffer."
397 (let* ((all-tag-list (notmuch-tag-completions))
398 (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
399 (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
400 (tag-list (append add-tag-list remove-tag-list))
401 (prompt (concat (or prompt "Tags") " (+add -drop): "))
403 ;; By default, space is bound to "complete word" function.
404 ;; Re-bind it to insert a space instead. Note that <tab>
405 ;; still does the completion.
406 (crm-local-completion-map
407 (let ((map (make-sparse-keymap)))
408 (set-keymap-parent map crm-local-completion-map)
409 (define-key map " " 'self-insert-command)
411 (delete "" (completing-read-multiple
413 ;; Append the separator to each completion so when the
414 ;; user completes a tag they can immediately begin
415 ;; entering another. `completing-read-multiple'
416 ;; ultimately splits the input on crm-separator, so we
417 ;; don't need to strip this back off (we just need to
418 ;; delete "empty" entries caused by trailing spaces).
419 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
420 nil nil initial-input
421 'notmuch-read-tag-changes-history))))
423 (defun notmuch-update-tags (tags tag-changes)
424 "Return a copy of TAGS with additions and removals from TAG-CHANGES.
426 TAG-CHANGES must be a list of tags names, each prefixed with
427 either a \"+\" to indicate the tag should be added to TAGS if not
428 present or a \"-\" to indicate that the tag should be removed
429 from TAGS if present."
430 (let ((result-tags (copy-sequence tags)))
431 (dolist (tag-change tag-changes)
432 (let ((op (string-to-char tag-change))
433 (tag (unless (string= tag-change "") (substring tag-change 1))))
435 (?+ (unless (member tag result-tags)
436 (push tag result-tags)))
437 (?- (setq result-tags (delete tag result-tags)))
439 (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
440 (sort result-tags 'string<)))
442 (defconst notmuch-tag-argument-limit 1000
443 "Use batch tagging if the tagging query is longer than this.
445 This limits the length of arguments passed to the notmuch CLI to
446 avoid system argument length limits and performance problems.")
448 (defun notmuch-tag (query tag-changes)
449 "Add/remove tags in TAG-CHANGES to messages matching QUERY.
451 QUERY should be a string containing the search-terms.
452 TAG-CHANGES is a list of strings of the form \"+tag\" or
453 \"-tag\" to add or remove tags, respectively.
455 Note: Other code should always use this function alter tags of
456 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
457 directly, so that hooks specified in notmuch-before-tag-hook and
458 notmuch-after-tag-hook will be run."
459 ;; Perform some validation
460 (mapc (lambda (tag-change)
461 (unless (string-match-p "^[-+]\\S-+$" tag-change)
462 (error "Tag must be of the form `+this_tag' or `-that_tag'")))
465 (error "Nothing to tag!"))
466 (unless (null tag-changes)
467 (run-hooks 'notmuch-before-tag-hook)
468 (if (<= (length query) notmuch-tag-argument-limit)
469 (apply 'notmuch-call-notmuch-process "tag"
470 (append tag-changes (list "--" query)))
471 ;; Use batch tag mode to avoid argument length limitations
472 (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
474 (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
475 (run-hooks 'notmuch-after-tag-hook)))
477 (defun notmuch-tag-change-list (tags &optional reverse)
478 "Convert TAGS into a list of tag changes.
480 Add a \"+\" prefix to any tag in TAGS list that doesn't already
481 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
482 \"+\" prefixes with \"-\" and vice versa in the result."
483 (mapcar (lambda (str)
484 (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
486 (concat (if (= (string-to-char s) ?-) "+" "-")
491 (defvar notmuch-tag-jump-reverse-key "k"
492 "The key in tag-jump to switch to the reverse tag changes.")
494 (defun notmuch-tag-jump (reverse)
495 "Create a jump menu for tagging operations.
497 Creates and displays a jump menu for the tagging operations
498 specified in `notmuch-tagging-keys'. If REVERSE is set then it
499 offers a menu of the reverses of the operations specified in
500 `notmuch-tagging-keys'; i.e. each `+tag` is replaced by `-tag`
502 ;; In principle this function is simple, but it has to deal with
503 ;; lots of cases: different modes (search/show/tree), whether a name
504 ;; is specified, whether the tagging operations is a list of
505 ;; tag-ops, or a symbol that evaluates to such a list, and whether
506 ;; REVERSE is specified.
509 (dolist (binding notmuch-tagging-keys)
510 (let* ((tag-function (case major-mode
511 (notmuch-search-mode #'notmuch-search-tag)
512 (notmuch-show-mode #'notmuch-show-tag)
513 (notmuch-tree-mode #'notmuch-tree-tag)))
514 (key (first binding))
515 (forward-tag-change (if (symbolp (second binding))
516 (symbol-value (second binding))
518 (tag-change (if reverse
519 (notmuch-tag-change-list forward-tag-change 't)
521 (name (or (and (not (string= (third binding) ""))
523 (and (symbolp (second binding))
524 (symbol-name (second binding)))))
525 (name-string (if name
526 (if reverse (concat "Reverse " name)
528 (mapconcat #'identity tag-change " "))))
529 (push (list key name-string
530 `(lambda () (,tag-function ',tag-change)))
532 (push (list notmuch-tag-jump-reverse-key
534 "Forward tag changes "
535 "Reverse tag changes")
536 (apply-partially 'notmuch-tag-jump (not reverse)))
538 (setq action-map (nreverse action-map))
539 (notmuch-jump action-map "Tag: ")))
543 (provide 'notmuch-tag)
546 ;; byte-compile-warnings: (not cl-functions)