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 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
  47 tag.
  48
  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\"))
  53
  54 See also `notmuch-tag-format-image', which can help replace tags
  55 with images."
  56
  57   :group 'notmuch-search
  58   :group 'notmuch-show
  59   :type '(alist :key-type (string :tag "Tag")
  60                 :extra-offset -3
  61                 :value-type
  62                 (radio :format "%v"
  63                        (const :tag "Hidden" nil)
  64                        (set :tag "Modified"
  65                             (string :tag "Display as")
  66                             (list :tag "Face" :extra-offset -4
  67                                   (const :format "" :inline t
  68                                          (propertize tag 'face))
  69                                   (list :format "%v"
  70                                         (const :format "" quote)
  71                                         custom-face-edit))
  72                             (list :format "%v" :extra-offset -4
  73                                   (const :format "" :inline t
  74                                          (notmuch-tag-format-image-data tag))
  75                                   (choice :tag "Image"
  76                                           (const :tag "Star"
  77                                                  (notmuch-tag-star-icon))
  78                                           (const :tag "Empty star"
  79                                                  (notmuch-tag-star-empty-icon))
  80                                           (const :tag "Tag"
  81                                                  (notmuch-tag-tag-icon))
  82                                           (string :tag "Custom")))
  83                             (sexp :tag "Custom")))))
  84
  85 (defun notmuch-tag-format-image-data (tag data)
  86   "Replace TAG with image DATA, if available.
  87
  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'.
  91
  92 DATA is the content of an SVG picture (e.g., as returned by
  93 `notmuch-tag-star-icon')."
  94   (propertize tag 'display
  95               `(image :type svg
  96                       :data ,data
  97                       :ascent center
  98                       :mask heuristic)))
  99
 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)\">
 106     <path
 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\" />
 110   </g>
 111 </svg>")
 112
 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)\">
 119     <path
 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\" />
 123   </g>
 124 </svg>")
 125
 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)\">
 132     <path
 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\" />
 135   </g>
 136 </svg>")
 137
 138 (defun notmuch-tag-format-tag (tag)
 139   "Format TAG by looking into `notmuch-tag-formats'."
 140   (let ((formats (assoc tag notmuch-tag-formats)))
 141     (cond
 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))))))))
 150
 151 (defun notmuch-tag-format-tags (tags &optional face)
 152   "Return a string representing formatted TAGS."
 153   (let ((face (or face 'notmuch-tag-face)))
 154     (notmuch-combine-face-text-property-string
 155      (mapconcat #'identity
 156                 ;; nil indicated that the tag was deliberately hidden
 157                 (delq nil (mapcar #'notmuch-tag-format-tag tags))
 158                 " ")
 159      face
 160      t)))
 161
 162 (defcustom notmuch-before-tag-hook nil
 163   "Hooks that are run before tags of a message are modified.
 164
 165 'tags' will contain the tags that are about to be added or removed as
 166 a list of strings of the form \"+TAG\" or \"-TAG\".
 167 'query' will be a string containing the search query that determines
 168 the messages that are about to be tagged"
 169
 170   :type 'hook
 171   :options '(notmuch-hl-line-mode)
 172   :group 'notmuch-hooks)
 173
 174 (defcustom notmuch-after-tag-hook nil
 175   "Hooks that are run after tags of a message are modified.
 176
 177 'tags' will contain the tags that were added or removed as
 178 a list of strings of the form \"+TAG\" or \"-TAG\".
 179 'query' will be a string containing the search query that determines
 180 the messages that were tagged"
 181   :type 'hook
 182   :options '(notmuch-hl-line-mode)
 183   :group 'notmuch-hooks)
 184
 185 (defvar notmuch-select-tag-history nil
 186   "Variable to store minibuffer history for
 187 `notmuch-select-tag-with-completion' function.")
 188
 189 (defvar notmuch-read-tag-changes-history nil
 190   "Variable to store minibuffer history for
 191 `notmuch-read-tag-changes' function.")
 192
 193 (defun notmuch-tag-completions (&rest search-terms)
 194   "Return a list of tags for messages matching SEARCH-TERMS.
 195
 196 Returns all tags if no search terms are given."
 197   (if (null search-terms)
 198       (setq search-terms (list "*")))
 199   (split-string
 200    (with-output-to-string
 201      (with-current-buffer standard-output
 202        (apply 'call-process notmuch-command nil t
 203               nil "search" "--output=tags" "--exclude=false" search-terms)))
 204    "\n+" t))
 205
 206 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
 207   (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
 208     (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
 209
 210 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
 211   "Prompt for tag changes in the minibuffer.
 212
 213 CURRENT-TAGS is a list of tags that are present on the message or
 214 messages to be changed.  These are offered as tag removal
 215 completions.  CURRENT-TAGS may contain duplicates.  PROMPT, if
 216 non-nil, is the query string to present in the minibuffer.  It
 217 defaults to \"Tags\".  INITIAL-INPUT, if non-nil, will be the
 218 initial input in the minibuffer."
 219
 220   (let* ((all-tag-list (notmuch-tag-completions))
 221          (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
 222          (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
 223          (tag-list (append add-tag-list remove-tag-list))
 224          (prompt (concat (or prompt "Tags") " (+add -drop): "))
 225          (crm-separator " ")
 226          ;; By default, space is bound to "complete word" function.
 227          ;; Re-bind it to insert a space instead.  Note that <tab>
 228          ;; still does the completion.
 229          (crm-local-completion-map
 230           (let ((map (make-sparse-keymap)))
 231             (set-keymap-parent map crm-local-completion-map)
 232             (define-key map " " 'self-insert-command)
 233             map)))
 234     (delete "" (completing-read-multiple
 235                 prompt
 236                 ;; Append the separator to each completion so when the
 237                 ;; user completes a tag they can immediately begin
 238                 ;; entering another.  `completing-read-multiple'
 239                 ;; ultimately splits the input on crm-separator, so we
 240                 ;; don't need to strip this back off (we just need to
 241                 ;; delete "empty" entries caused by trailing spaces).
 242                 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
 243                 nil nil initial-input
 244                 'notmuch-read-tag-changes-history))))
 245
 246 (defun notmuch-update-tags (tags tag-changes)
 247   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 248
 249 TAG-CHANGES must be a list of tags names, each prefixed with
 250 either a \"+\" to indicate the tag should be added to TAGS if not
 251 present or a \"-\" to indicate that the tag should be removed
 252 from TAGS if present."
 253   (let ((result-tags (copy-sequence tags)))
 254     (dolist (tag-change tag-changes)
 255       (let ((op (string-to-char tag-change))
 256             (tag (unless (string= tag-change "") (substring tag-change 1))))
 257         (case op
 258           (?+ (unless (member tag result-tags)
 259                 (push tag result-tags)))
 260           (?- (setq result-tags (delete tag result-tags)))
 261           (otherwise
 262            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 263     (sort result-tags 'string<)))
 264
 265 (defconst notmuch-tag-argument-limit 1000
 266   "Use batch tagging if the tagging query is longer than this.
 267
 268 This limits the length of arguments passed to the notmuch CLI to
 269 avoid system argument length limits and performance problems.")
 270
 271 (defun notmuch-tag (query tag-changes)
 272   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 273
 274 QUERY should be a string containing the search-terms.
 275 TAG-CHANGES is a list of strings of the form \"+tag\" or
 276 \"-tag\" to add or remove tags, respectively.
 277
 278 Note: Other code should always use this function alter tags of
 279 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 280 directly, so that hooks specified in notmuch-before-tag-hook and
 281 notmuch-after-tag-hook will be run."
 282   ;; Perform some validation
 283   (mapc (lambda (tag-change)
 284           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 285             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 286         tag-changes)
 287   (unless (null tag-changes)
 288     (run-hooks 'notmuch-before-tag-hook)
 289     (if (<= (length query) notmuch-tag-argument-limit)
 290         (apply 'notmuch-call-notmuch-process "tag"
 291                (append tag-changes (list "--" query)))
 292       ;; Use batch tag mode to avoid argument length limitations
 293       (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
 294                               " -- " query)))
 295         (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
 296     (run-hooks 'notmuch-after-tag-hook)))
 297
 298 (defun notmuch-tag-change-list (tags &optional reverse)
 299   "Convert TAGS into a list of tag changes.
 300
 301 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 302 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 303 \"+\" prefixes with \"-\" and vice versa in the result."
 304   (mapcar (lambda (str)
 305             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 306               (if reverse
 307                   (concat (if (= (string-to-char s) ?-) "+" "-")
 308                           (substring s 1))
 309                 s)))
 310           tags))
 311
 312
 313 ;;
 314
 315 (provide 'notmuch-tag)
 316
 317 ;; Local Variables:
 318 ;; byte-compile-warnings: (not cl-functions)
 319 ;; End: