1 ;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*-
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>
28 (require 'notmuch-lib)
30 (declare-function notmuch-search-tag "notmuch"
31 (tag-changes &optional beg end only-matched))
32 (declare-function notmuch-show-tag "notmuch-show" (tag-changes))
33 (declare-function notmuch-tree-tag "notmuch-tree" (tag-changes))
34 (declare-function notmuch-jump "notmuch-jump" (action-map prompt))
38 (define-widget 'notmuch-tag-key-type 'list
39 "A single key tagging binding."
41 :args '((list :inline t
43 (key-sequence :tag "Key")
44 (radio :tag "Tag operations"
45 (repeat :tag "Tag list"
46 (string :format "%v" :tag "change"))
47 (variable :tag "Tag variable"))
48 (string :tag "Name"))))
50 (defcustom notmuch-tagging-keys
51 `((,(kbd "a") notmuch-archive-tags "Archive")
52 (,(kbd "u") notmuch-show-mark-read-tags "Mark read")
53 (,(kbd "f") ("+flagged") "Flag")
54 (,(kbd "s") ("+spam" "-inbox") "Mark as spam")
55 (,(kbd "d") ("+deleted" "-inbox") "Delete"))
56 "A list of keys and corresponding tagging operations.
58 For each key (or key sequence) you can specify a sequence of
59 tagging operations to apply, or a variable which contains a list
60 of tagging operations such as `notmuch-archive-tags'. The final
61 element is a name for this tagging operation. If the name is
62 omitted or empty then the list of tag changes, or the variable
63 name is used as the name.
65 The key `notmuch-tag-jump-reverse-key' (k by default) should not
66 be used (either as a key, or as the start of a key sequence) as
67 it is already bound: it switches the menu to a menu of the
68 reverse tagging operations. The reverse of a tagging operation is
69 the same list of individual tag-ops but with `+tag' replaced by
70 `-tag' and vice versa.
72 If setting this variable outside of customize then it should be a
73 list of triples (lists of three elements). Each triple should be
74 of the form (key-binding tagging-operations name). KEY-BINDING
75 can be a single character or a key sequence; TAGGING-OPERATIONS
76 should either be a list of individual tag operations each of the
77 form `+tag' or `-tag', or the variable name of a variable that is
78 a list of tagging operations; NAME should be a name for the
79 tagging operation, if omitted or empty than then name is taken
80 from TAGGING-OPERATIONS."
81 :tag "List of tagging bindings"
82 :type '(repeat notmuch-tag-key-type)
87 (define-widget 'notmuch-tag-format-type 'lazy
88 "Customize widget for notmuch-tag-format and friends."
89 :type '(alist :key-type (regexp :tag "Tag")
93 (const :tag "Hidden" nil)
95 (string :tag "Display as")
96 (list :tag "Face" :extra-offset -4
97 (const :format "" :inline t
98 (notmuch-apply-face tag))
100 (const :format "" quote)
102 (list :format "%v" :extra-offset -4
103 (const :format "" :inline t
104 (notmuch-tag-format-image-data tag))
107 (notmuch-tag-star-icon))
108 (const :tag "Empty star"
109 (notmuch-tag-star-empty-icon))
111 (notmuch-tag-tag-icon))
112 (string :tag "Custom")))
113 (sexp :tag "Custom")))))
115 (defface notmuch-tag-unread
116 '((t :foreground "red"))
117 "Default face used for the unread tag.
119 Used in the default value of `notmuch-tag-formats'."
120 :group 'notmuch-faces)
122 (defface notmuch-tag-flagged
125 (:foreground "LightBlue1"))
128 (:foreground "blue")))
129 "Face used for the flagged tag.
131 Used in the default value of `notmuch-tag-formats'."
132 :group 'notmuch-faces)
134 (defcustom notmuch-tag-formats
135 '(("unread" (propertize tag 'face 'notmuch-tag-unread))
136 ("flagged" (propertize tag 'face 'notmuch-tag-flagged)
137 (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
138 "Custom formats for individual tags.
140 This is an association list of the form ((MATCH EXPR...)...),
141 mapping tag name regexps to lists of formatting expressions.
143 The first entry whose MATCH regexp-matches a tag is used to
144 format that tag. The regexp is implicitly anchored, so to match
145 a literal tag name, just use that tag name (if it contains
146 special regexp characters like \".\" or \"*\", these have to be
149 The cdr of the matching entry gives a list of Elisp expressions
150 that modify the tag. If the list is empty, the tag is simply
151 hidden. Otherwise, each expression EXPR is evaluated in order:
152 for the first expression, the variable `tag' is bound to the tag
153 name; for each later expression, the variable `tag' is bound to
154 the result of the previous expression. In this way, each
155 expression can build on the formatting performed by the previous
156 expression. The result of the last expression is displayed in
159 For example, to replace a tag with another string, simply use
160 that string as a formatting expression. To change the foreground
161 of a tag to red, use the expression
162 (propertize tag \\='face \\='(:foreground \"red\"))
164 See also `notmuch-tag-format-image', which can help replace tags
166 :group 'notmuch-search
168 :group 'notmuch-faces
169 :type 'notmuch-tag-format-type)
171 (defface notmuch-tag-deleted
172 '((((class color) (supports :strike-through "red")) :strike-through "red")
173 (t :inverse-video t))
174 "Face used to display deleted tags.
176 Used in the default value of `notmuch-tag-deleted-formats'."
177 :group 'notmuch-faces)
179 (defcustom notmuch-tag-deleted-formats
180 '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
181 (".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
182 "Custom formats for tags when deleted.
184 For deleted tags the formats in `notmuch-tag-formats' are applied
185 first and then these formats are applied on top; that is `tag'
186 passed to the function is the tag with all these previous
187 formattings applied. The formatted can access the original
188 unformatted tag as `bare-tag'.
190 By default this shows deleted tags with strike-through in red,
191 unless strike-through is not available (e.g., emacs is running in
192 a terminal) in which case it uses inverse video. To hide deleted
193 tags completely set this to
196 See `notmuch-tag-formats' for full documentation."
198 :group 'notmuch-faces
199 :type 'notmuch-tag-format-type)
201 (defface notmuch-tag-added
202 '((t :underline "green"))
203 "Default face used for added tags.
205 Used in the default value for `notmuch-tag-added-formats'."
206 :group 'notmuch-faces)
208 (defcustom notmuch-tag-added-formats
209 '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
210 "Custom formats for tags when added.
212 For added tags the formats in `notmuch-tag-formats' are applied
213 first and then these formats are applied on top.
215 To disable special formatting of added tags, set this variable to
218 See `notmuch-tag-formats' for full documentation."
220 :group 'notmuch-faces
221 :type 'notmuch-tag-format-type)
225 (defun notmuch-tag-format-image-data (tag data)
226 "Replace TAG with image DATA, if available.
228 This function returns a propertized string that will display image
229 DATA in place of TAG.This is designed for use in
230 `notmuch-tag-formats'.
232 DATA is the content of an SVG picture (e.g., as returned by
233 `notmuch-tag-star-icon')."
234 (propertize tag 'display
240 (defun notmuch-tag-star-icon ()
241 "Return SVG data representing a star icon.
242 This can be used with `notmuch-tag-format-image-data'."
243 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
244 <svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
245 <g transform=\"translate(-242.81601,-315.59635)\">
247 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\"
248 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
249 style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
253 (defun notmuch-tag-star-empty-icon ()
254 "Return SVG data representing an empty star icon.
255 This can be used with `notmuch-tag-format-image-data'."
256 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
257 <svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
258 <g transform=\"translate(-242.81601,-315.59635)\">
260 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\"
261 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
262 style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
266 (defun notmuch-tag-tag-icon ()
267 "Return SVG data representing a tag icon.
268 This can be used with `notmuch-tag-format-image-data'."
269 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
270 <svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
271 <g transform=\"translate(0,-1036.3622)\">
273 d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
274 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\" />
278 ;;; track history of tag operations
279 (defvar-local notmuch-tag-history nil
280 "Buffer local history of `notmuch-tag' function.")
281 (put 'notmuch-tag-history 'permanent-local t)
285 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
286 "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.")
288 (defun notmuch-tag-clear-cache ()
289 "Clear the internal cache of tag formats."
290 (clrhash notmuch-tag--format-cache))
292 (defun notmuch-tag--get-formats (tag alist)
293 "Find the first item whose car regexp-matches TAG."
295 ;; Don't use assoc-default since there's no way to distinguish a
296 ;; missing key from a present key with a null cdr.
298 :test (lambda (tag key)
299 (and (eq (string-match key tag) 0)
300 (= (match-end 0) (length tag)))))))
302 (defun notmuch-tag--do-format (bare-tag tag formats)
303 "Apply a tag-formats entry to TAG."
304 (cond ((null formats) ;; - Tag not in `formats',
305 tag) ;; the format is the tag itself.
306 ((null (cdr formats)) ;; - Tag was deliberately hidden,
307 nil) ;; no format must be returned
309 ;; Tag was found and has formats, we must apply all the
310 ;; formats. TAG may be null so treat that as a special case.
311 (let ((return-tag (copy-sequence (or tag ""))))
312 (dolist (format (cdr formats))
315 `((bare-tag . ,bare-tag)
316 (tag . ,return-tag)))))
317 (if (and (null tag) (equal return-tag ""))
321 (defun notmuch-tag-format-tag (tags orig-tags tag)
322 "Format TAG according to `notmuch-tag-formats'.
324 TAGS and ORIG-TAGS are lists of the current tags and the original
325 tags; tags which have been deleted (i.e., are in ORIG-TAGS but
326 are not in TAGS) are shown using formats from
327 `notmuch-tag-deleted-formats'; tags which have been added (i.e.,
328 are in TAGS but are not in ORIG-TAGS) are shown using formats
329 from `notmuch-tag-added-formats' and tags which have not been
330 changed (the normal case) are shown using formats from
331 `notmuch-tag-formats'."
332 (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
333 ((not (member tag orig-tags)) 'added)))
334 (formatted-tag (gethash (cons tag tag-state)
335 notmuch-tag--format-cache
337 (when (eq formatted-tag 'missing)
338 (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
339 (over (cl-case tag-state
340 (deleted (notmuch-tag--get-formats
341 tag notmuch-tag-deleted-formats))
342 (added (notmuch-tag--get-formats
343 tag notmuch-tag-added-formats))
345 (setq formatted-tag (notmuch-tag--do-format tag tag base))
346 (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
347 (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
350 (defun notmuch-tag-format-tags (tags orig-tags &optional face)
351 "Return a string representing formatted TAGS."
352 (let ((face (or face 'notmuch-tag-face))
353 (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
355 (mapconcat #'identity
356 ;; nil indicated that the tag was deliberately hidden
357 (delq nil (mapcar (apply-partially #'notmuch-tag-format-tag
366 (defcustom notmuch-before-tag-hook nil
367 "Hooks that are run before tags of a message are modified.
369 `tag-changes' will contain the tags that are about to be added or removed as
370 a list of strings of the form \"+TAG\" or \"-TAG\".
371 `query' will be a string containing the search query that determines
372 the messages that are about to be tagged."
374 :options '(notmuch-hl-line-mode)
375 :group 'notmuch-hooks)
377 (defcustom notmuch-after-tag-hook nil
378 "Hooks that are run after tags of a message are modified.
380 `tag-changes' will contain the tags that were added or removed as
381 a list of strings of the form \"+TAG\" or \"-TAG\".
382 `query' will be a string containing the search query that determines
383 the messages that were tagged."
385 :options '(notmuch-hl-line-mode)
386 :group 'notmuch-hooks)
390 (defvar notmuch-select-tag-history nil
391 "Minibuffer history of `notmuch-select-tag-with-completion' function.")
393 (defvar notmuch-read-tag-changes-history nil
394 "Minibuffer history of `notmuch-read-tag-changes' function.")
396 (defun notmuch-tag-completions (&rest search-terms)
397 "Return a list of tags for messages matching SEARCH-TERMS.
399 Return all tags if no search terms are given."
401 (setq search-terms (list "*")))
403 (with-output-to-string
404 (with-current-buffer standard-output
405 (apply 'notmuch--call-process notmuch-command nil t
406 nil "search" "--output=tags" "--exclude=false" search-terms)))
409 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
410 (completing-read prompt
411 (apply #'notmuch-tag-completions search-terms)
412 nil nil nil 'notmuch-select-tag-history))
414 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
415 "Prompt for tag changes in the minibuffer.
417 CURRENT-TAGS is a list of tags that are present on the message
418 or messages to be changed. These are offered as tag removal
419 completions. CURRENT-TAGS may contain duplicates. PROMPT, if
420 non-nil, is the query string to present in the minibuffer. It
421 defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
422 initial input in the minibuffer."
423 (let* ((all-tag-list (notmuch-tag-completions))
424 (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
425 (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
426 (tag-list (append add-tag-list remove-tag-list))
427 (prompt (concat (or prompt "Tags") " (+add -drop): "))
429 ;; By default, space is bound to "complete word" function.
430 ;; Re-bind it to insert a space instead. Note that <tab>
431 ;; still does the completion.
432 (crm-local-completion-map
433 (let ((map (make-sparse-keymap)))
434 (set-keymap-parent map crm-local-completion-map)
435 (define-key map " " 'self-insert-command)
437 (completing-read-multiple prompt tag-list
438 nil nil initial-input
439 'notmuch-read-tag-changes-history)))
443 (defun notmuch-update-tags (tags tag-changes)
444 "Return a copy of TAGS with additions and removals from TAG-CHANGES.
446 TAG-CHANGES must be a list of tags names, each prefixed with
447 either a \"+\" to indicate the tag should be added to TAGS if not
448 present or a \"-\" to indicate that the tag should be removed
449 from TAGS if present."
450 (let ((result-tags (copy-sequence tags)))
451 (dolist (tag-change tag-changes)
452 (let ((tag (and (not (string-empty-p tag-change))
453 (substring tag-change 1))))
454 (cl-case (aref tag-change 0)
455 (?+ (unless (member tag result-tags)
456 (push tag result-tags)))
457 (?- (setq result-tags (delete tag result-tags)))
459 (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
460 (sort result-tags 'string<)))
462 (defconst notmuch-tag-argument-limit 1000
463 "Use batch tagging if the tagging query is longer than this.
465 This limits the length of arguments passed to the notmuch CLI to
466 avoid system argument length limits and performance problems.
468 NOTE: this variable is no longer used.")
470 (make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36")
472 (defun notmuch-tag (query tag-changes &optional omit-hist)
473 "Add/remove tags in TAG-CHANGES to messages matching QUERY.
475 QUERY should be a string containing the search-terms.
476 TAG-CHANGES is a list of strings of the form \"+tag\" or \"-tag\"
477 to add or remove tags, respectively. OMIT-HIST disables history
480 Note: Other code should always use this function to alter tags of
481 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
482 directly, so that hooks specified in notmuch-before-tag-hook and
483 notmuch-after-tag-hook will be run."
484 ;; Perform some validation
485 (dolist (tag-change tag-changes)
486 (unless (string-match-p "^[-+]\\S-+$" tag-change)
487 (error "Tag must be of the form `+this_tag' or `-that_tag'")))
489 (error "Nothing to tag!"))
491 (notmuch-dlet ((tag-changes tag-changes)
493 (run-hooks 'notmuch-before-tag-hook))
495 (insert (concat (mapconcat #'notmuch-hex-encode tag-changes " ") " -- " query))
497 (notmuch--call-process-region
498 (point-min) (point-max) notmuch-command t t nil "tag" "--batch"))
499 (notmuch-logged-error "notmuch tag failed" (buffer-string))))
501 (push (list :query query :tag-changes tag-changes) notmuch-tag-history)))
502 (notmuch-dlet ((tag-changes tag-changes)
504 (run-hooks 'notmuch-after-tag-hook)))
506 (defun notmuch-tag-undo ()
507 "Undo the previous tagging operation in the current buffer. Uses
508 buffer local variable `notmuch-tag-history' to determine what
511 (when (null notmuch-tag-history)
512 (error "no further notmuch undo information"))
513 (let* ((action (pop notmuch-tag-history))
514 (query (plist-get action :query))
515 (changes (notmuch-tag-change-list (plist-get action :tag-changes) t)))
516 (notmuch-tag query changes t))
517 (notmuch-refresh-this-buffer))
519 (defun notmuch-tag-change-list (tags &optional reverse)
520 "Convert TAGS into a list of tag changes.
522 Add a \"+\" prefix to any tag in TAGS list that doesn't already
523 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
524 \"+\" prefixes with \"-\" and vice versa in the result."
525 (mapcar (lambda (str)
526 (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
528 (concat (if (= (string-to-char s) ?-) "+" "-")
533 (defvar notmuch-tag-jump-reverse-key "k"
534 "The key in tag-jump to switch to the reverse tag changes.")
536 (defun notmuch-tag-jump (reverse)
537 "Create a jump menu for tagging operations.
539 Creates and displays a jump menu for the tagging operations
540 specified in `notmuch-tagging-keys'. If REVERSE is set then it
541 offers a menu of the reverses of the operations specified in
542 `notmuch-tagging-keys'; i.e. each `+tag' is replaced by `-tag'
544 ;; In principle this function is simple, but it has to deal with
545 ;; lots of cases: different modes (search/show/tree), whether a name
546 ;; is specified, whether the tagging operations is a list of
547 ;; tag-ops, or a symbol that evaluates to such a list, and whether
548 ;; REVERSE is specified.
551 (pcase-dolist (`(,key ,tag ,name) notmuch-tagging-keys)
552 (let* ((tag-function (cl-case major-mode
553 (notmuch-search-mode #'notmuch-search-tag)
554 (notmuch-show-mode #'notmuch-show-tag)
555 (notmuch-tree-mode #'notmuch-tree-tag)))
556 (tag (if (symbolp tag)
559 (tag-change (if reverse
560 (notmuch-tag-change-list tag t)
562 (name (or (and (not (string= name ""))
565 (symbol-name name))))
566 (name-string (if name
568 (concat "Reverse " name)
570 (mapconcat #'identity tag-change " "))))
571 (push (list key name-string
572 (lambda () (funcall tag-function tag-change)))
574 (push (list notmuch-tag-jump-reverse-key
576 "Forward tag changes "
577 "Reverse tag changes")
578 (apply-partially 'notmuch-tag-jump (not reverse)))
580 (setq action-map (nreverse action-map))
581 (notmuch-jump action-map "Tag: ")))
585 (provide 'notmuch-tag)
587 ;;; notmuch-tag.el ends here