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