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--get-formats (tag format-alist)
 197   "Find the first item whose car regexp-matches TAG."
 198   (save-match-data
 199     ;; Don't use assoc-default since there's no way to distinguish a
 200     ;; missing key from a present key with a null cdr.
 201     (assoc* tag format-alist
 202             :test (lambda (tag key)
 203                     (and (eq (string-match key tag) 0)
 204                          (= (match-end 0) (length tag)))))))
 205
 206 (defun notmuch-tag--do-format (tag formatted-tag formats)
 207   "Apply a tag-formats entry to TAG."
 208   (cond ((null formats)         ;; - Tag not in `formats',
 209          formatted-tag)         ;;   the format is the tag itself.
 210         ((null (cdr formats))   ;; - Tag was deliberately hidden,
 211          nil)                   ;;   no format must be returned
 212         (t
 213          ;; Tag was found and has formats, we must apply all the
 214          ;; formats.  TAG may be null so treat that as a special case.
 215          (let ((bare-tag tag)
 216                (tag (copy-sequence (or formatted-tag ""))))
 217            (dolist (format (cdr formats))
 218              (setq tag (eval format)))
 219            (if (and (null formatted-tag) (equal tag ""))
 220                nil
 221              tag)))))
 222
 223 (defun notmuch-tag-format-tag (tags orig-tags tag)
 224   "Format TAG according to `notmuch-tag-formats'.
 225
 226 TAGS and ORIG-TAGS are lists of the current tags and the original
 227 tags; tags which have been deleted (i.e., are in ORIG-TAGS but
 228 are not in TAGS) are shown using formats from
 229 `notmuch-tag-deleted-formats'; tags which have been added (i.e.,
 230 are in TAGS but are not in ORIG-TAGS) are shown using formats
 231 from `notmuch-tag-added-formats' and tags which have not been
 232 changed (the normal case) are shown using formats from
 233 `notmuch-tag-formats'"
 234   (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
 235                           ((not (member tag orig-tags)) 'added)))
 236          (formatted-tag (gethash (cons tag tag-state) notmuch-tag--format-cache 'missing)))
 237     (when (eq formatted-tag 'missing)
 238       (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
 239             (over (case tag-state
 240                     (deleted (notmuch-tag--get-formats
 241                               tag notmuch-tag-deleted-formats))
 242                     (added (notmuch-tag--get-formats
 243                             tag notmuch-tag-added-formats))
 244                     (otherwise nil))))
 245         (setq formatted-tag (notmuch-tag--do-format tag tag base))
 246         (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
 247
 248         (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
 249     formatted-tag))
 250
 251 (defun notmuch-tag-format-tags (tags orig-tags &optional face)
 252   "Return a string representing formatted TAGS."
 253   (let ((face (or face 'notmuch-tag-face))
 254         (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
 255     (notmuch-apply-face
 256      (mapconcat #'identity
 257                 ;; nil indicated that the tag was deliberately hidden
 258                 (delq nil (mapcar
 259                            (apply-partially #'notmuch-tag-format-tag tags orig-tags)
 260                            all-tags))
 261                 " ")
 262      face
 263      t)))
 264
 265 (defcustom notmuch-before-tag-hook nil
 266   "Hooks that are run before tags of a message are modified.
 267
 268 'tags' will contain the tags that are about to be added or removed as
 269 a list of strings of the form \"+TAG\" or \"-TAG\".
 270 'query' will be a string containing the search query that determines
 271 the messages that are about to be tagged"
 272
 273   :type 'hook
 274   :options '(notmuch-hl-line-mode)
 275   :group 'notmuch-hooks)
 276
 277 (defcustom notmuch-after-tag-hook nil
 278   "Hooks that are run after tags of a message are modified.
 279
 280 'tags' will contain the tags that were added or removed as
 281 a list of strings of the form \"+TAG\" or \"-TAG\".
 282 'query' will be a string containing the search query that determines
 283 the messages that were tagged"
 284   :type 'hook
 285   :options '(notmuch-hl-line-mode)
 286   :group 'notmuch-hooks)
 287
 288 (defvar notmuch-select-tag-history nil
 289   "Variable to store minibuffer history for
 290 `notmuch-select-tag-with-completion' function.")
 291
 292 (defvar notmuch-read-tag-changes-history nil
 293   "Variable to store minibuffer history for
 294 `notmuch-read-tag-changes' function.")
 295
 296 (defun notmuch-tag-completions (&rest search-terms)
 297   "Return a list of tags for messages matching SEARCH-TERMS.
 298
 299 Returns all tags if no search terms are given."
 300   (if (null search-terms)
 301       (setq search-terms (list "*")))
 302   (split-string
 303    (with-output-to-string
 304      (with-current-buffer standard-output
 305        (apply 'call-process notmuch-command nil t
 306               nil "search" "--output=tags" "--exclude=false" search-terms)))
 307    "\n+" t))
 308
 309 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
 310   (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
 311     (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
 312
 313 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
 314   "Prompt for tag changes in the minibuffer.
 315
 316 CURRENT-TAGS is a list of tags that are present on the message or
 317 messages to be changed.  These are offered as tag removal
 318 completions.  CURRENT-TAGS may contain duplicates.  PROMPT, if
 319 non-nil, is the query string to present in the minibuffer.  It
 320 defaults to \"Tags\".  INITIAL-INPUT, if non-nil, will be the
 321 initial input in the minibuffer."
 322
 323   (let* ((all-tag-list (notmuch-tag-completions))
 324          (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
 325          (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
 326          (tag-list (append add-tag-list remove-tag-list))
 327          (prompt (concat (or prompt "Tags") " (+add -drop): "))
 328          (crm-separator " ")
 329          ;; By default, space is bound to "complete word" function.
 330          ;; Re-bind it to insert a space instead.  Note that <tab>
 331          ;; still does the completion.
 332          (crm-local-completion-map
 333           (let ((map (make-sparse-keymap)))
 334             (set-keymap-parent map crm-local-completion-map)
 335             (define-key map " " 'self-insert-command)
 336             map)))
 337     (delete "" (completing-read-multiple
 338                 prompt
 339                 ;; Append the separator to each completion so when the
 340                 ;; user completes a tag they can immediately begin
 341                 ;; entering another.  `completing-read-multiple'
 342                 ;; ultimately splits the input on crm-separator, so we
 343                 ;; don't need to strip this back off (we just need to
 344                 ;; delete "empty" entries caused by trailing spaces).
 345                 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
 346                 nil nil initial-input
 347                 'notmuch-read-tag-changes-history))))
 348
 349 (defun notmuch-update-tags (tags tag-changes)
 350   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 351
 352 TAG-CHANGES must be a list of tags names, each prefixed with
 353 either a \"+\" to indicate the tag should be added to TAGS if not
 354 present or a \"-\" to indicate that the tag should be removed
 355 from TAGS if present."
 356   (let ((result-tags (copy-sequence tags)))
 357     (dolist (tag-change tag-changes)
 358       (let ((op (string-to-char tag-change))
 359             (tag (unless (string= tag-change "") (substring tag-change 1))))
 360         (case op
 361           (?+ (unless (member tag result-tags)
 362                 (push tag result-tags)))
 363           (?- (setq result-tags (delete tag result-tags)))
 364           (otherwise
 365            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 366     (sort result-tags 'string<)))
 367
 368 (defconst notmuch-tag-argument-limit 1000
 369   "Use batch tagging if the tagging query is longer than this.
 370
 371 This limits the length of arguments passed to the notmuch CLI to
 372 avoid system argument length limits and performance problems.")
 373
 374 (defun notmuch-tag (query tag-changes)
 375   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 376
 377 QUERY should be a string containing the search-terms.
 378 TAG-CHANGES is a list of strings of the form \"+tag\" or
 379 \"-tag\" to add or remove tags, respectively.
 380
 381 Note: Other code should always use this function alter tags of
 382 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 383 directly, so that hooks specified in notmuch-before-tag-hook and
 384 notmuch-after-tag-hook will be run."
 385   ;; Perform some validation
 386   (mapc (lambda (tag-change)
 387           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 388             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 389         tag-changes)
 390   (unless (null tag-changes)
 391     (run-hooks 'notmuch-before-tag-hook)
 392     (if (<= (length query) notmuch-tag-argument-limit)
 393         (apply 'notmuch-call-notmuch-process "tag"
 394                (append tag-changes (list "--" query)))
 395       ;; Use batch tag mode to avoid argument length limitations
 396       (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
 397                               " -- " query)))
 398         (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
 399     (run-hooks 'notmuch-after-tag-hook)))
 400
 401 (defun notmuch-tag-change-list (tags &optional reverse)
 402   "Convert TAGS into a list of tag changes.
 403
 404 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 405 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 406 \"+\" prefixes with \"-\" and vice versa in the result."
 407   (mapcar (lambda (str)
 408             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 409               (if reverse
 410                   (concat (if (= (string-to-char s) ?-) "+" "-")
 411                           (substring s 1))
 412                 s)))
 413           tags))
 414
 415
 416 ;;
 417
 418 (provide 'notmuch-tag)
 419
 420 ;; Local Variables:
 421 ;; byte-compile-warnings: (not cl-functions)
 422 ;; End: