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 (defcustom notmuch-tag-formats
32 '(("unread" (propertize tag 'face '(:foreground "red")))
33 ("flagged" (propertize tag 'face '(:foreground "blue"))
34 (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
35 "Custom formats for individual tags.
37 This gives a list that maps from tag names to lists of formatting
38 expressions. The car of each element gives a tag name and the
39 cdr gives a list of Elisp expressions that modify the tag. If
40 the list is empty, the tag will simply be hidden. Otherwise,
41 each expression will be evaluated in order: for the first
42 expression, the variable `tag' will be bound to the tag name; for
43 each later expression, the variable `tag' will be bound to the
44 result of the previous expression. In this way, each expression
45 can build on the formatting performed by the previous expression.
46 The result of the last expression will displayed in place of the
49 For example, to replace a tag with another string, simply use
50 that string as a formatting expression. To change the foreground
51 of a tag to red, use the expression
52 (propertize tag 'face '(:foreground \"red\"))
54 See also `notmuch-tag-format-image', which can help replace tags
57 :group 'notmuch-search
59 :type '(alist :key-type (string :tag "Tag")
63 (const :tag "Hidden" nil)
65 (string :tag "Display as")
66 (list :tag "Face" :extra-offset -4
67 (const :format "" :inline t
68 (propertize tag 'face))
70 (const :format "" quote)
72 (list :format "%v" :extra-offset -4
73 (const :format "" :inline t
74 (notmuch-tag-format-image-data tag))
77 (notmuch-tag-star-icon))
78 (const :tag "Empty star"
79 (notmuch-tag-star-empty-icon))
81 (notmuch-tag-tag-icon))
82 (string :tag "Custom")))
83 (sexp :tag "Custom")))))
85 (defun notmuch-tag-format-image-data (tag data)
86 "Replace TAG with image DATA, if available.
88 This function returns a propertized string that will display image
89 DATA in place of TAG.This is designed for use in
90 `notmuch-tag-formats'.
92 DATA is the content of an SVG picture (e.g., as returned by
93 `notmuch-tag-star-icon')."
94 (propertize tag 'display
100 (defun notmuch-tag-star-icon ()
101 "Return SVG data representing a star icon.
102 This can be used with `notmuch-tag-format-image-data'."
103 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
104 <svg version=\"1.1\" width=\"16\" height=\"16\">
105 <g transform=\"translate(-242.81601,-315.59635)\">
107 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\"
108 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
109 style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
113 (defun notmuch-tag-star-empty-icon ()
114 "Return SVG data representing an empty star icon.
115 This can be used with `notmuch-tag-format-image-data'."
116 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
117 <svg version=\"1.1\" width=\"16\" height=\"16\">
118 <g transform=\"translate(-242.81601,-315.59635)\">
120 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\"
121 transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
122 style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
126 (defun notmuch-tag-tag-icon ()
127 "Return SVG data representing a tag icon.
128 This can be used with `notmuch-tag-format-image-data'."
129 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
130 <svg version=\"1.1\" width=\"16\" height=\"16\">
131 <g transform=\"translate(0,-1036.3622)\">
133 d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
134 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\" />
138 (defun notmuch-tag-format-tag (tag)
139 "Format TAG by looking into `notmuch-tag-formats'."
140 (let ((formats (assoc tag notmuch-tag-formats)))
142 ((null formats) ;; - Tag not in `notmuch-tag-formats',
143 tag) ;; the format is the tag itself.
144 ((null (cdr formats)) ;; - Tag was deliberately hidden,
145 nil) ;; no format must be returned
146 (t ;; - Tag was found and has formats,
147 (let ((tag tag)) ;; we must apply all the formats.
148 (dolist (format (cdr formats) tag)
149 (setq tag (eval format))))))))
151 (defun notmuch-tag-format-tags (tags)
152 "Return a string representing formatted TAGS."
153 (notmuch-combine-face-text-property-string
154 (mapconcat #'identity
155 ;; nil indicated that the tag was deliberately hidden
156 (delq nil (mapcar #'notmuch-tag-format-tag tags))
161 (defcustom notmuch-before-tag-hook nil
162 "Hooks that are run before tags of a message are modified.
164 'tags' will contain the tags that are about to be added or removed as
165 a list of strings of the form \"+TAG\" or \"-TAG\".
166 'query' will be a string containing the search query that determines
167 the messages that are about to be tagged"
170 :options '(notmuch-hl-line-mode)
171 :group 'notmuch-hooks)
173 (defcustom notmuch-after-tag-hook nil
174 "Hooks that are run after tags of a message are modified.
176 'tags' will contain the tags that were added or removed as
177 a list of strings of the form \"+TAG\" or \"-TAG\".
178 'query' will be a string containing the search query that determines
179 the messages that were tagged"
181 :options '(notmuch-hl-line-mode)
182 :group 'notmuch-hooks)
184 (defvar notmuch-select-tag-history nil
185 "Variable to store minibuffer history for
186 `notmuch-select-tag-with-completion' function.")
188 (defvar notmuch-read-tag-changes-history nil
189 "Variable to store minibuffer history for
190 `notmuch-read-tag-changes' function.")
192 (defun notmuch-tag-completions (&rest search-terms)
193 "Return a list of tags for messages matching SEARCH-TERMS.
195 Returns all tags if no search terms are given."
196 (if (null search-terms)
197 (setq search-terms (list "*")))
199 (with-output-to-string
200 (with-current-buffer standard-output
201 (apply 'call-process notmuch-command nil t
202 nil "search" "--output=tags" "--exclude=false" search-terms)))
205 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
206 (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
207 (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
209 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
210 "Prompt for tag changes in the minibuffer.
212 CURRENT-TAGS is a list of tags that are present on the message or
213 messages to be changed. These are offered as tag removal
214 completions. CURRENT-TAGS may contain duplicates. PROMPT, if
215 non-nil, is the query string to present in the minibuffer. It
216 defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
217 initial input in the minibuffer."
219 (let* ((all-tag-list (notmuch-tag-completions))
220 (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
221 (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
222 (tag-list (append add-tag-list remove-tag-list))
223 (prompt (concat (or prompt "Tags") " (+add -drop): "))
225 ;; By default, space is bound to "complete word" function.
226 ;; Re-bind it to insert a space instead. Note that <tab>
227 ;; still does the completion.
228 (crm-local-completion-map
229 (let ((map (make-sparse-keymap)))
230 (set-keymap-parent map crm-local-completion-map)
231 (define-key map " " 'self-insert-command)
233 (delete "" (completing-read-multiple prompt
234 tag-list nil nil initial-input
235 'notmuch-read-tag-changes-history))))
237 (defun notmuch-update-tags (tags tag-changes)
238 "Return a copy of TAGS with additions and removals from TAG-CHANGES.
240 TAG-CHANGES must be a list of tags names, each prefixed with
241 either a \"+\" to indicate the tag should be added to TAGS if not
242 present or a \"-\" to indicate that the tag should be removed
243 from TAGS if present."
244 (let ((result-tags (copy-sequence tags)))
245 (dolist (tag-change tag-changes)
246 (let ((op (string-to-char tag-change))
247 (tag (unless (string= tag-change "") (substring tag-change 1))))
249 (?+ (unless (member tag result-tags)
250 (push tag result-tags)))
251 (?- (setq result-tags (delete tag result-tags)))
253 (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
254 (sort result-tags 'string<)))
256 (defun notmuch-tag (query &optional tag-changes)
257 "Add/remove tags in TAG-CHANGES to messages matching QUERY.
259 QUERY should be a string containing the search-terms.
260 TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of
261 strings of the form \"+tag\" or \"-tag\" then those are the tag
262 changes applied. If TAG-CHANGES is a string then it is
263 interpreted as a single tag change. If TAG-CHANGES is the string
264 \"-\" or \"+\", or null, then the user is prompted to enter the
267 Note: Other code should always use this function alter tags of
268 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
269 directly, so that hooks specified in notmuch-before-tag-hook and
270 notmuch-after-tag-hook will be run."
271 ;; Perform some validation
272 (if (string-or-null-p tag-changes)
273 (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes))
274 (setq tag-changes (notmuch-read-tag-changes
275 (notmuch-tag-completions query) nil tag-changes))
276 (setq tag-changes (list tag-changes))))
277 (mapc (lambda (tag-change)
278 (unless (string-match-p "^[-+]\\S-+$" tag-change)
279 (error "Tag must be of the form `+this_tag' or `-that_tag'")))
281 (unless (null tag-changes)
282 (run-hooks 'notmuch-before-tag-hook)
283 (apply 'notmuch-call-notmuch-process "tag"
284 (append tag-changes (list "--" query)))
285 (run-hooks 'notmuch-after-tag-hook))
286 ;; in all cases we return tag-changes as a list
289 (defun notmuch-tag-change-list (tags &optional reverse)
290 "Convert TAGS into a list of tag changes.
292 Add a \"+\" prefix to any tag in TAGS list that doesn't already
293 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
294 \"+\" prefixes with \"-\" and vice versa in the result."
295 (mapcar (lambda (str)
296 (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
298 (concat (if (= (string-to-char s) ?-) "+" "-")
306 (provide 'notmuch-tag)
309 ;; byte-compile-warnings: (not cl-functions)