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                                          (propertize tag 'face))
  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   :type 'notmuch-tag-format-type)
  91
  92 (defun notmuch-tag-format-image-data (tag data)
  93   "Replace TAG with image DATA, if available.
  94
  95 This function returns a propertized string that will display image
  96 DATA in place of TAG.This is designed for use in
  97 `notmuch-tag-formats'.
  98
  99 DATA is the content of an SVG picture (e.g., as returned by
 100 `notmuch-tag-star-icon')."
 101   (propertize tag 'display
 102               `(image :type svg
 103                       :data ,data
 104                       :ascent center
 105                       :mask heuristic)))
 106
 107 (defun notmuch-tag-star-icon ()
 108   "Return SVG data representing a star icon.
 109 This can be used with `notmuch-tag-format-image-data'."
 110 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 111 <svg version=\"1.1\" width=\"16\" height=\"16\">
 112   <g transform=\"translate(-242.81601,-315.59635)\">
 113     <path
 114        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\"
 115        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 116        style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 117   </g>
 118 </svg>")
 119
 120 (defun notmuch-tag-star-empty-icon ()
 121   "Return SVG data representing an empty star icon.
 122 This can be used with `notmuch-tag-format-image-data'."
 123   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 124 <svg version=\"1.1\" width=\"16\" height=\"16\">
 125   <g transform=\"translate(-242.81601,-315.59635)\">
 126     <path
 127        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\"
 128        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 129        style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 130   </g>
 131 </svg>")
 132
 133 (defun notmuch-tag-tag-icon ()
 134   "Return SVG data representing a tag icon.
 135 This can be used with `notmuch-tag-format-image-data'."
 136   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 137 <svg version=\"1.1\" width=\"16\" height=\"16\">
 138   <g transform=\"translate(0,-1036.3622)\">
 139     <path
 140        d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
 141        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\" />
 142   </g>
 143 </svg>")
 144
 145 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
 146   "Cache of tag format lookup.  Internal to `notmuch-tag-format-tag'.")
 147
 148 (defun notmuch-tag-clear-cache ()
 149   "Clear the internal cache of tag formats."
 150   (clrhash notmuch-tag--format-cache))
 151
 152 (defun notmuch-tag-format-tag (tag)
 153   "Format TAG by according to `notmuch-tag-formats'.
 154
 155 Callers must ensure that the tag format cache has been recently cleared
 156 via `notmuch-tag-clear-cache' before using this function.  For example,
 157 it would be appropriate to clear the cache just prior to filling a
 158 buffer that uses formatted tags."
 159
 160   (let ((formatted (gethash tag notmuch-tag--format-cache 'missing)))
 161     (when (eq formatted 'missing)
 162       (let* ((formats
 163               (save-match-data
 164                 ;; Don't use assoc-default since there's no way to
 165                 ;; distinguish a missing key from a present key with a
 166                 ;; null cdr:.
 167                 (assoc* tag notmuch-tag-formats
 168                         :test (lambda (tag key)
 169                                 (and (eq (string-match key tag) 0)
 170                                      (= (match-end 0) (length tag))))))))
 171         (setq formatted
 172               (cond
 173                ((null formats)          ;; - Tag not in `notmuch-tag-formats',
 174                 tag)                    ;;   the format is the tag itself.
 175                ((null (cdr formats))    ;; - Tag was deliberately hidden,
 176                 nil)                    ;;   no format must be returned
 177                (t                       ;; - Tag was found and has formats,
 178                 (let ((tag tag))        ;;   we must apply all the formats.
 179                   (dolist (format (cdr formats) tag)
 180                     (setq tag (eval format)))))))
 181         (puthash tag formatted notmuch-tag--format-cache)))
 182     formatted))
 183
 184 (defun notmuch-tag-format-tags (tags &optional face)
 185   "Return a string representing formatted TAGS."
 186   (let ((face (or face 'notmuch-tag-face)))
 187     (notmuch-apply-face
 188      (mapconcat #'identity
 189                 ;; nil indicated that the tag was deliberately hidden
 190                 (delq nil (mapcar #'notmuch-tag-format-tag tags))
 191                 " ")
 192      face
 193      t)))
 194
 195 (defcustom notmuch-before-tag-hook nil
 196   "Hooks that are run before tags of a message are modified.
 197
 198 'tags' will contain the tags that are about to be added or removed as
 199 a list of strings of the form \"+TAG\" or \"-TAG\".
 200 'query' will be a string containing the search query that determines
 201 the messages that are about to be tagged"
 202
 203   :type 'hook
 204   :options '(notmuch-hl-line-mode)
 205   :group 'notmuch-hooks)
 206
 207 (defcustom notmuch-after-tag-hook nil
 208   "Hooks that are run after tags of a message are modified.
 209
 210 'tags' will contain the tags that were added or removed as
 211 a list of strings of the form \"+TAG\" or \"-TAG\".
 212 'query' will be a string containing the search query that determines
 213 the messages that were tagged"
 214   :type 'hook
 215   :options '(notmuch-hl-line-mode)
 216   :group 'notmuch-hooks)
 217
 218 (defvar notmuch-select-tag-history nil
 219   "Variable to store minibuffer history for
 220 `notmuch-select-tag-with-completion' function.")
 221
 222 (defvar notmuch-read-tag-changes-history nil
 223   "Variable to store minibuffer history for
 224 `notmuch-read-tag-changes' function.")
 225
 226 (defun notmuch-tag-completions (&rest search-terms)
 227   "Return a list of tags for messages matching SEARCH-TERMS.
 228
 229 Returns all tags if no search terms are given."
 230   (if (null search-terms)
 231       (setq search-terms (list "*")))
 232   (split-string
 233    (with-output-to-string
 234      (with-current-buffer standard-output
 235        (apply 'call-process notmuch-command nil t
 236               nil "search" "--output=tags" "--exclude=false" search-terms)))
 237    "\n+" t))
 238
 239 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
 240   (let ((tag-list (apply #'notmuch-tag-completions search-terms)))
 241     (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
 242
 243 (defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
 244   "Prompt for tag changes in the minibuffer.
 245
 246 CURRENT-TAGS is a list of tags that are present on the message or
 247 messages to be changed.  These are offered as tag removal
 248 completions.  CURRENT-TAGS may contain duplicates.  PROMPT, if
 249 non-nil, is the query string to present in the minibuffer.  It
 250 defaults to \"Tags\".  INITIAL-INPUT, if non-nil, will be the
 251 initial input in the minibuffer."
 252
 253   (let* ((all-tag-list (notmuch-tag-completions))
 254          (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
 255          (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
 256          (tag-list (append add-tag-list remove-tag-list))
 257          (prompt (concat (or prompt "Tags") " (+add -drop): "))
 258          (crm-separator " ")
 259          ;; By default, space is bound to "complete word" function.
 260          ;; Re-bind it to insert a space instead.  Note that <tab>
 261          ;; still does the completion.
 262          (crm-local-completion-map
 263           (let ((map (make-sparse-keymap)))
 264             (set-keymap-parent map crm-local-completion-map)
 265             (define-key map " " 'self-insert-command)
 266             map)))
 267     (delete "" (completing-read-multiple
 268                 prompt
 269                 ;; Append the separator to each completion so when the
 270                 ;; user completes a tag they can immediately begin
 271                 ;; entering another.  `completing-read-multiple'
 272                 ;; ultimately splits the input on crm-separator, so we
 273                 ;; don't need to strip this back off (we just need to
 274                 ;; delete "empty" entries caused by trailing spaces).
 275                 (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list)
 276                 nil nil initial-input
 277                 'notmuch-read-tag-changes-history))))
 278
 279 (defun notmuch-update-tags (tags tag-changes)
 280   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 281
 282 TAG-CHANGES must be a list of tags names, each prefixed with
 283 either a \"+\" to indicate the tag should be added to TAGS if not
 284 present or a \"-\" to indicate that the tag should be removed
 285 from TAGS if present."
 286   (let ((result-tags (copy-sequence tags)))
 287     (dolist (tag-change tag-changes)
 288       (let ((op (string-to-char tag-change))
 289             (tag (unless (string= tag-change "") (substring tag-change 1))))
 290         (case op
 291           (?+ (unless (member tag result-tags)
 292                 (push tag result-tags)))
 293           (?- (setq result-tags (delete tag result-tags)))
 294           (otherwise
 295            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 296     (sort result-tags 'string<)))
 297
 298 (defconst notmuch-tag-argument-limit 1000
 299   "Use batch tagging if the tagging query is longer than this.
 300
 301 This limits the length of arguments passed to the notmuch CLI to
 302 avoid system argument length limits and performance problems.")
 303
 304 (defun notmuch-tag (query tag-changes)
 305   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 306
 307 QUERY should be a string containing the search-terms.
 308 TAG-CHANGES is a list of strings of the form \"+tag\" or
 309 \"-tag\" to add or remove tags, respectively.
 310
 311 Note: Other code should always use this function alter tags of
 312 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 313 directly, so that hooks specified in notmuch-before-tag-hook and
 314 notmuch-after-tag-hook will be run."
 315   ;; Perform some validation
 316   (mapc (lambda (tag-change)
 317           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 318             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 319         tag-changes)
 320   (unless (null tag-changes)
 321     (run-hooks 'notmuch-before-tag-hook)
 322     (if (<= (length query) notmuch-tag-argument-limit)
 323         (apply 'notmuch-call-notmuch-process "tag"
 324                (append tag-changes (list "--" query)))
 325       ;; Use batch tag mode to avoid argument length limitations
 326       (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ")
 327                               " -- " query)))
 328         (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch")))
 329     (run-hooks 'notmuch-after-tag-hook)))
 330
 331 (defun notmuch-tag-change-list (tags &optional reverse)
 332   "Convert TAGS into a list of tag changes.
 333
 334 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 335 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 336 \"+\" prefixes with \"-\" and vice versa in the result."
 337   (mapcar (lambda (str)
 338             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 339               (if reverse
 340                   (concat (if (= (string-to-char s) ?-) "+" "-")
 341                           (substring s 1))
 342                 s)))
 343           tags))
 344
 345
 346 ;;
 347
 348 (provide 'notmuch-tag)
 349
 350 ;; Local Variables:
 351 ;; byte-compile-warnings: (not cl-functions)
 352 ;; End: