git.notmuchmail.org Git - notmuch/blob - emacs/notmuch-tag.el

   1 ;; notmuch-tag.el --- tag messages within emacs
   2 ;;
   3 ;; Copyright © Damien Cassou
   4 ;; Copyright © Carl Worth
   5 ;;
   6 ;; This file is part of Notmuch.
   7 ;;
   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.
  12 ;;
  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.
  17 ;;
  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/>.
  20 ;;
  21 ;; Authors: Carl Worth <cworth@cworth.org>
  22 ;;          Damien Cassou <damien.cassou@gmail.com>
  23 ;;
  24 ;;; Code:
  25 ;;
  26
  27 (require 'cl)
  28 (require 'crm)
  29 (require 'notmuch-lib)
  30
  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.
  36
  37 This is an association list that maps from tag name regexps to
  38 lists of formatting expressions.  The first entry whose car
  39 regexp-matches a tag will be used to format that tag.  The regexp
  40 is implicitly anchored, so to match a literal tag name, just use
  41 that tag name (if it contains special regexp characters like
  42 \".\" or \"*\", these have to be escaped).  The cdr of the
  43 matching entry gives a list of Elisp expressions that modify the
  44 tag.  If the list is empty, the tag will simply be hidden.
  45 Otherwise, each expression will be evaluated in order: for the
  46 first expression, the variable `tag' will be bound to the tag
  47 name; for each later expression, the variable `tag' will be bound
  48 to the result of the previous expression.  In this way, each
  49 expression can build on the formatting performed by the previous
  50 expression.  The result of the last expression will displayed in
  51 place of the tag.
  52
  53 For example, to replace a tag with another string, simply use
  54 that string as a formatting expression.  To change the foreground
  55 of a tag to red, use the expression
  56   (propertize tag 'face '(:foreground \"red\"))
  57
  58 See also `notmuch-tag-format-image', which can help replace tags
  59 with images."
  60
  61   :group 'notmuch-search
  62   :group 'notmuch-show
  63   :type '(alist :key-type (regexp :tag "Tag")
  64                 :extra-offset -3
  65                 :value-type
  66                 (radio :format "%v"
  67                        (const :tag "Hidden" nil)
  68                        (set :tag "Modified"
  69                             (string :tag "Display as")
  70                             (list :tag "Face" :extra-offset -4
  71                                   (const :format "" :inline t
  72                                          (propertize tag 'face))
  73                                   (list :format "%v"
  74                                         (const :format "" quote)
  75                                         custom-face-edit))
  76                             (list :format "%v" :extra-offset -4
  77                                   (const :format "" :inline t
  78                                          (notmuch-tag-format-image-data tag))
  79                                   (choice :tag "Image"
  80                                           (const :tag "Star"
  81                                                  (notmuch-tag-star-icon))
  82                                           (const :tag "Empty star"
  83                                                  (notmuch-tag-star-empty-icon))
  84                                           (const :tag "Tag"
  85                                                  (notmuch-tag-tag-icon))
  86                                           (string :tag "Custom")))
  87                             (sexp :tag "Custom")))))
  88
  89 (defun notmuch-tag-format-image-data (tag data)
  90   "Replace TAG with image DATA, if available.
  91
  92 This function returns a propertized string that will display image
  93 DATA in place of TAG.This is designed for use in
  94 `notmuch-tag-formats'.
  95
  96 DATA is the content of an SVG picture (e.g., as returned by
  97 `notmuch-tag-star-icon')."
  98   (propertize tag 'display
  99               `(image :type svg
 100                       :data ,data
 101                       :ascent center
 102                       :mask heuristic)))
 103
 104 (defun notmuch-tag-star-icon ()
 105   "Return SVG data representing a star icon.
 106 This can be used with `notmuch-tag-format-image-data'."
 107 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 108 <svg version=\"1.1\" width=\"16\" height=\"16\">
 109   <g transform=\"translate(-242.81601,-315.59635)\">
 110     <path
 111        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\"
 112        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 113        style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 114   </g>
 115 </svg>")
 116
 117 (defun notmuch-tag-star-empty-icon ()
 118   "Return SVG data representing an empty star icon.
 119 This can be used with `notmuch-tag-format-image-data'."
 120   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 121 <svg version=\"1.1\" width=\"16\" height=\"16\">
 122   <g transform=\"translate(-242.81601,-315.59635)\">
 123     <path
 124        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\"
 125        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 126        style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 127   </g>
 128 </svg>")
 129
 130 (defun notmuch-tag-tag-icon ()
 131   "Return SVG data representing a tag icon.
 132 This can be used with `notmuch-tag-format-image-data'."
 133   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 134 <svg version=\"1.1\" width=\"16\" height=\"16\">
 135   <g transform=\"translate(0,-1036.3622)\">
 136     <path
 137        d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
 138        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\" />
 139   </g>
 140 </svg>")
 141
 142 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
 143   "Cache of tag format lookup.  Internal to `notmuch-tag-format-tag'.")
 144
 145 (defun notmuch-tag-clear-cache ()
 146   "Clear the internal cache of tag formats."
 147   (clrhash notmuch-tag--format-cache))
 148
 149 (defun notmuch-tag-format-tag (tag)
 150   "Format TAG by according to `notmuch-tag-formats'.
 151
 152 Callers must ensure that the tag format cache has been recently cleared
 153 via `notmuch-tag-clear-cache' before using this function.  For example,
 154 it would be appropriate to clear the cache just prior to filling a
 155 buffer that uses formatted tags."
 156
 157   (let ((formatted (gethash tag notmuch-tag--format-cache 'missing)))
 158     (when (eq formatted 'missing)
 159       (let* ((formats
 160               (save-match-data
 161                 ;; Don't use assoc-default since there's no way to
 162                 ;; distinguish a missing key from a present key with a
 163                 ;; null cdr:.
 164                 (assoc* tag notmuch-tag-formats
 165                         :test (lambda (tag key)
 166                                 (and (eq (string-match key tag) 0)
 167                                      (= (match-end 0) (length tag))))))))
 168         (setq formatted
 169               (cond
 170                ((null formats)          ;; - Tag not in `notmuch-tag-formats',
 171                 tag)                    ;;   the format is the tag itself.
 172                ((null (cdr formats))    ;; - Tag was deliberately hidden,
 173                 nil)                    ;;   no format must be returned
 174                (t                       ;; - Tag was found and has formats,
 175                 (let ((tag tag))        ;;   we must apply all the formats.
 176                   (dolist (format (cdr formats) tag)
 177                     (setq tag (eval format)))))))
 178         (puthash tag formatted notmuch-tag--format-cache)))
 179     formatted))
 180
 181 (defun notmuch-tag-format-tags (tags &optional face)
 182   "Return a string representing formatted TAGS."
 183   (let ((face (or face 'notmuch-tag-face)))
 184     (notmuch-apply-face
 185      (mapconcat #'identity
 186                 ;; nil indicated that the tag was deliberately hidden
 187                 (delq nil (mapcar #'notmuch-tag-format-tag tags))
 188                 " ")
 189      face
 190      t)))
 191
 192 (defcustom notmuch-before-tag-hook nil
 193   "Hooks that are run before tags of a message are modified.
 194
 195 'tags' will contain the tags that are about to be added or removed as
 196 a list of strings of the form \"+TAG\" or \"-TAG\".
 197 'query' will be a string containing the search query that determines
 198 the messages that are about to be tagged"
 199
 200   :type 'hook
 201   :options '(notmuch-hl-line-mode)
 202   :group 'notmuch-hooks)
 203
 204 (defcustom notmuch-after-tag-hook nil
 205   "Hooks that are run after tags of a message are modified.
 206
 207 'tags' will contain the tags that were added or removed as
 208 a list of strings of the form \"+TAG\" or \"-TAG\".
 209 'query' will be a string containing the search query that determines
 210 the messages that were tagged"
 211   :type 'hook
 212   :options '(notmuch-hl-line-mode)
 213   :group 'notmuch-hooks)
 214
 215 (defvar notmuch-select-tag-history nil
 216   "Variable to store minibuffer history for
 217 `notmuch-select-tag-with-completion' function.")
 218
 219 (defvar notmuch-read-tag-changes-history nil
 220   "Variable to store minibuffer history for
 221 `notmuch-read-tag-changes' function.")
 222
 223 (defun notmuch-tag-completions (&rest search-terms)
 224   "Return a list of tags for messages matching SEARCH-TERMS.
 225
 226 Returns all tags if no search terms are given."
 227   (if (null search-terms)
 228       (setq search-terms (list "*")))
 229   (split-string
 230    (with-output-to-string
 231      (with-current-buffer standard-output
 232        (apply 'call-process notmuch-command nil t
 233               nil "search" "--output=tags" "--exclude=false" search-terms)))
 234    "\n+" t))
 235
 236 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
 237   (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
 238     (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
 239
 240 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
 241   "Prompt for tag changes in the minibuffer.
 242
 243 CURRENT-TAGS is a list of tags that are present on the message or
 244 messages to be changed.  These are offered as tag removal
 245 completions.  CURRENT-TAGS may contain duplicates.  PROMPT, if
 246 non-nil, is the query string to present in the minibuffer.  It
 247 defaults to \"Tags\".  INITIAL-INPUT, if non-nil, will be the
 248 initial input in the minibuffer."
 249
 250   (let* ((all-tag-list (notmuch-tag-completions))
 251          (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
 252          (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
 253          (tag-list (append add-tag-list remove-tag-list))
 254          (prompt (concat (or prompt "Tags") " (+add -drop): "))
 255          (crm-separator " ")
 256          ;; By default, space is bound to "complete word" function.
 257          ;; Re-bind it to insert a space instead.  Note that <tab>
 258          ;; still does the completion.
 259          (crm-local-completion-map
 260           (let ((map (make-sparse-keymap)))
 261             (set-keymap-parent map crm-local-completion-map)
 262             (define-key map " " 'self-insert-command)
 263             map)))
 264     (delete "" (completing-read-multiple
 265                 prompt
 266                 ;; Append the separator to each completion so when the
 267                 ;; user completes a tag they can immediately begin
 268                 ;; entering another.  `completing-read-multiple'
 269                 ;; ultimately splits the input on crm-separator, so we
 270                 ;; don't need to strip this back off (we just need to
 271                 ;; delete "empty" entries caused by trailing spaces).
 272                 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
 273                 nil nil initial-input
 274                 'notmuch-read-tag-changes-history))))
 275
 276 (defun notmuch-update-tags (tags tag-changes)
 277   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 278
 279 TAG-CHANGES must be a list of tags names, each prefixed with
 280 either a \"+\" to indicate the tag should be added to TAGS if not
 281 present or a \"-\" to indicate that the tag should be removed
 282 from TAGS if present."
 283   (let ((result-tags (copy-sequence tags)))
 284     (dolist (tag-change tag-changes)
 285       (let ((op (string-to-char tag-change))
 286             (tag (unless (string= tag-change "") (substring tag-change 1))))
 287         (case op
 288           (?+ (unless (member tag result-tags)
 289                 (push tag result-tags)))
 290           (?- (setq result-tags (delete tag result-tags)))
 291           (otherwise
 292            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 293     (sort result-tags 'string<)))
 294
 295 (defconst notmuch-tag-argument-limit 1000
 296   "Use batch tagging if the tagging query is longer than this.
 297
 298 This limits the length of arguments passed to the notmuch CLI to
 299 avoid system argument length limits and performance problems.")
 300
 301 (defun notmuch-tag (query tag-changes)
 302   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 303
 304 QUERY should be a string containing the search-terms.
 305 TAG-CHANGES is a list of strings of the form \"+tag\" or
 306 \"-tag\" to add or remove tags, respectively.
 307
 308 Note: Other code should always use this function alter tags of
 309 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 310 directly, so that hooks specified in notmuch-before-tag-hook and
 311 notmuch-after-tag-hook will be run."
 312   ;; Perform some validation
 313   (mapc (lambda (tag-change)
 314           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 315             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 316         tag-changes)
 317   (unless (null tag-changes)
 318     (run-hooks 'notmuch-before-tag-hook)
 319     (if (<= (length query) notmuch-tag-argument-limit)
 320         (apply 'notmuch-call-notmuch-process "tag"
 321                (append tag-changes (list "--" query)))
 322       ;; Use batch tag mode to avoid argument length limitations
 323       (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
 324                               " -- " query)))
 325         (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
 326     (run-hooks 'notmuch-after-tag-hook)))
 327
 328 (defun notmuch-tag-change-list (tags &optional reverse)
 329   "Convert TAGS into a list of tag changes.
 330
 331 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 332 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 333 \"+\" prefixes with \"-\" and vice versa in the result."
 334   (mapcar (lambda (str)
 335             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 336               (if reverse
 337                   (concat (if (= (string-to-char s) ?-) "+" "-")
 338                           (substring s 1))
 339                 s)))
 340           tags))
 341
 342
 343 ;;
 344
 345 (provide 'notmuch-tag)
 346
 347 ;; Local Variables:
 348 ;; byte-compile-warnings: (not cl-functions)
 349 ;; End: