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