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)
 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))
 157               " ")
 158    'notmuch-tag-face
 159    t))
 160
 161 (defcustom notmuch-before-tag-hook nil
 162   "Hooks that are run before tags of a message are modified.
 163
 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"
 168
 169   :type 'hook
 170   :options '(notmuch-hl-line-mode)
 171   :group 'notmuch-hooks)
 172
 173 (defcustom notmuch-after-tag-hook nil
 174   "Hooks that are run after tags of a message are modified.
 175
 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"
 180   :type 'hook
 181   :options '(notmuch-hl-line-mode)
 182   :group 'notmuch-hooks)
 183
 184 (defvar notmuch-select-tag-history nil
 185   "Variable to store minibuffer history for
 186 `notmuch-select-tag-with-completion' function.")
 187
 188 (defvar notmuch-read-tag-changes-history nil
 189   "Variable to store minibuffer history for
 190 `notmuch-read-tag-changes' function.")
 191
 192 (defun notmuch-tag-completions (&rest search-terms)
 193   "Return a list of tags for messages matching SEARCH-TERMS.
 194
 195 Returns all tags if no search terms are given."
 196   (if (null search-terms)
 197       (setq search-terms (list "*")))
 198   (split-string
 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)))
 203    "\n+" t))
 204
 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)))
 208
 209 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
 210   "Prompt for tag changes in the minibuffer.
 211
 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."
 218
 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): "))
 224          (crm-separator " ")
 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)
 232             map)))
 233     (delete "" (completing-read-multiple
 234                 prompt
 235                 ;; Append the separator to each completion so when the
 236                 ;; user completes a tag they can immediately begin
 237                 ;; entering another.  `completing-read-multiple'
 238                 ;; ultimately splits the input on crm-separator, so we
 239                 ;; don't need to strip this back off (we just need to
 240                 ;; delete "empty" entries caused by trailing spaces).
 241                 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
 242                 nil nil initial-input
 243                 'notmuch-read-tag-changes-history))))
 244
 245 (defun notmuch-update-tags (tags tag-changes)
 246   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 247
 248 TAG-CHANGES must be a list of tags names, each prefixed with
 249 either a \"+\" to indicate the tag should be added to TAGS if not
 250 present or a \"-\" to indicate that the tag should be removed
 251 from TAGS if present."
 252   (let ((result-tags (copy-sequence tags)))
 253     (dolist (tag-change tag-changes)
 254       (let ((op (string-to-char tag-change))
 255             (tag (unless (string= tag-change "") (substring tag-change 1))))
 256         (case op
 257           (?+ (unless (member tag result-tags)
 258                 (push tag result-tags)))
 259           (?- (setq result-tags (delete tag result-tags)))
 260           (otherwise
 261            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 262     (sort result-tags 'string<)))
 263
 264 (defconst notmuch-tag-argument-limit 1000
 265   "Use batch tagging if the tagging query is longer than this.
 266
 267 This limits the length of arguments passed to the notmuch CLI to
 268 avoid system argument length limits and performance problems.")
 269
 270 (defun notmuch-tag (query tag-changes)
 271   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 272
 273 QUERY should be a string containing the search-terms.
 274 TAG-CHANGES is a list of strings of the form \"+tag\" or
 275 \"-tag\" to add or remove tags, respectively.
 276
 277 Note: Other code should always use this function alter tags of
 278 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 279 directly, so that hooks specified in notmuch-before-tag-hook and
 280 notmuch-after-tag-hook will be run."
 281   ;; Perform some validation
 282   (mapc (lambda (tag-change)
 283           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 284             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 285         tag-changes)
 286   (unless (null tag-changes)
 287     (run-hooks 'notmuch-before-tag-hook)
 288     (if (<= (length query) notmuch-tag-argument-limit)
 289         (apply 'notmuch-call-notmuch-process "tag"
 290                (append tag-changes (list "--" query)))
 291       ;; Use batch tag mode to avoid argument length limitations
 292       (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
 293                               " -- " query)))
 294         (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
 295     (run-hooks 'notmuch-after-tag-hook)))
 296
 297 (defun notmuch-tag-change-list (tags &optional reverse)
 298   "Convert TAGS into a list of tag changes.
 299
 300 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 301 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 302 \"+\" prefixes with \"-\" and vice versa in the result."
 303   (mapcar (lambda (str)
 304             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 305               (if reverse
 306                   (concat (if (= (string-to-char s) ?-) "+" "-")
 307                           (substring s 1))
 308                 s)))
 309           tags))
 310
 311
 312 ;;
 313
 314 (provide 'notmuch-tag)
 315
 316 ;; Local Variables:
 317 ;; byte-compile-warnings: (not cl-functions)
 318 ;; End: