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 prompt
 234                 tag-list nil nil initial-input
 235                 'notmuch-read-tag-changes-history))))
 236
 237 (defun notmuch-update-tags (tags tag-changes)
 238   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 239
 240 TAG-CHANGES must be a list of tags names, each prefixed with
 241 either a \"+\" to indicate the tag should be added to TAGS if not
 242 present or a \"-\" to indicate that the tag should be removed
 243 from TAGS if present."
 244   (let ((result-tags (copy-sequence tags)))
 245     (dolist (tag-change tag-changes)
 246       (let ((op (string-to-char tag-change))
 247             (tag (unless (string= tag-change "") (substring tag-change 1))))
 248         (case op
 249           (?+ (unless (member tag result-tags)
 250                 (push tag result-tags)))
 251           (?- (setq result-tags (delete tag result-tags)))
 252           (otherwise
 253            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 254     (sort result-tags 'string<)))
 255
 256 (defun notmuch-tag (query &optional tag-changes)
 257   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 258
 259 QUERY should be a string containing the search-terms.
 260 TAG-CHANGES can take multiple forms.  If TAG-CHANGES is a list of
 261 strings of the form \"+tag\" or \"-tag\" then those are the tag
 262 changes applied.  If TAG-CHANGES is a string then it is
 263 interpreted as a single tag change.  If TAG-CHANGES is the string
 264 \"-\" or \"+\", or null, then the user is prompted to enter the
 265 tag changes.
 266
 267 Note: Other code should always use this function alter tags of
 268 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 269 directly, so that hooks specified in notmuch-before-tag-hook and
 270 notmuch-after-tag-hook will be run."
 271   ;; Perform some validation
 272   (if (string-or-null-p tag-changes)
 273       (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes))
 274           (setq tag-changes (notmuch-read-tag-changes
 275                              (notmuch-tag-completions query) nil tag-changes))
 276         (setq tag-changes (list tag-changes))))
 277   (mapc (lambda (tag-change)
 278           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 279             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 280         tag-changes)
 281   (unless (null tag-changes)
 282     (run-hooks 'notmuch-before-tag-hook)
 283     (apply 'notmuch-call-notmuch-process "tag"
 284            (append tag-changes (list "--" query)))
 285     (run-hooks 'notmuch-after-tag-hook))
 286   ;; in all cases we return tag-changes as a list
 287   tag-changes)
 288
 289 (defun notmuch-tag-change-list (tags &optional reverse)
 290   "Convert TAGS into a list of tag changes.
 291
 292 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 293 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 294 \"+\" prefixes with \"-\" and vice versa in the result."
 295   (mapcar (lambda (str)
 296             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 297               (if reverse
 298                   (concat (if (= (string-to-char s) ?-) "+" "-")
 299                           (substring s 1))
 300                 s)))
 301           tags))
 302
 303
 304 ;;
 305
 306 (provide 'notmuch-tag)
 307
 308 ;; Local Variables:
 309 ;; byte-compile-warnings: (not cl-functions)
 310 ;; End: