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" (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
  34   "Custom formats for individual tags.
  35
  36 This gives a list that maps from tag names to lists of formatting
  37 expressions.  The car of each element gives a tag name and the
  38 cdr gives a list of Elisp expressions that modify the tag.  If
  39 the list is empty, the tag will simply be hidden.  Otherwise,
  40 each expression will be evaluated in order: for the first
  41 expression, the variable `tag' will be bound to the tag name; for
  42 each later expression, the variable `tag' will be bound to the
  43 result of the previous expression.  In this way, each expression
  44 can build on the formatting performed by the previous expression.
  45 The result of the last expression will displayed in place of the
  46 tag.
  47
  48 For example, to replace a tag with another string, simply use
  49 that string as a formatting expression.  To change the foreground
  50 of a tag to red, use the expression
  51   (propertize tag 'face '(:foreground \"red\"))
  52
  53 See also `notmuch-tag-format-image', which can help replace tags
  54 with images."
  55
  56   :group 'notmuch-search
  57   :group 'notmuch-show
  58   :type '(alist :key-type (string :tag "Tag")
  59                 :extra-offset -3
  60                 :value-type
  61                 (radio :format "%v"
  62                        (const :tag "Hidden" nil)
  63                        (set :tag "Modified"
  64                             (string :tag "Display as")
  65                             (list :tag "Face" :extra-offset -4
  66                                   (const :format "" :inline t
  67                                          (propertize tag 'face))
  68                                   (list :format "%v"
  69                                         (const :format "" quote)
  70                                         custom-face-edit))
  71                             (list :format "%v" :extra-offset -4
  72                                   (const :format "" :inline t
  73                                          (notmuch-tag-format-image-data tag))
  74                                   (choice :tag "Image"
  75                                           (const :tag "Star"
  76                                                  (notmuch-tag-star-icon))
  77                                           (const :tag "Empty star"
  78                                                  (notmuch-tag-star-empty-icon))
  79                                           (const :tag "Tag"
  80                                                  (notmuch-tag-tag-icon))
  81                                           (string :tag "Custom")))
  82                             (sexp :tag "Custom")))))
  83
  84 (defun notmuch-tag-format-image-data (tag data)
  85   "Replace TAG with image DATA, if available.
  86
  87 This function returns a propertized string that will display image
  88 DATA in place of TAG.This is designed for use in
  89 `notmuch-tag-formats'.
  90
  91 DATA is the content of an SVG picture (e.g., as returned by
  92 `notmuch-tag-star-icon')."
  93   (propertize tag 'display
  94               `(image :type svg
  95                       :data ,data
  96                       :ascent center
  97                       :mask heuristic)))
  98
  99 (defun notmuch-tag-star-icon ()
 100   "Return SVG data representing a star icon.
 101 This can be used with `notmuch-tag-format-image-data'."
 102 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 103 <svg version=\"1.1\" width=\"16\" height=\"16\">
 104   <g transform=\"translate(-242.81601,-315.59635)\">
 105     <path
 106        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\"
 107        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 108        style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 109   </g>
 110 </svg>")
 111
 112 (defun notmuch-tag-star-empty-icon ()
 113   "Return SVG data representing an empty star icon.
 114 This can be used with `notmuch-tag-format-image-data'."
 115   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 116 <svg version=\"1.1\" width=\"16\" height=\"16\">
 117   <g transform=\"translate(-242.81601,-315.59635)\">
 118     <path
 119        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\"
 120        transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
 121        style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
 122   </g>
 123 </svg>")
 124
 125 (defun notmuch-tag-tag-icon ()
 126   "Return SVG data representing a tag icon.
 127 This can be used with `notmuch-tag-format-image-data'."
 128   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 129 <svg version=\"1.1\" width=\"16\" height=\"16\">
 130   <g transform=\"translate(0,-1036.3622)\">
 131     <path
 132        d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
 133        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\" />
 134   </g>
 135 </svg>")
 136
 137 (defun notmuch-tag-format-tag (tag)
 138   "Format TAG by looking into `notmuch-tag-formats'."
 139   (let ((formats (assoc tag notmuch-tag-formats)))
 140     (cond
 141      ((null formats)            ;; - Tag not in `notmuch-tag-formats',
 142       tag)                      ;;   the format is the tag itself.
 143      ((null (cdr formats))      ;; - Tag was deliberately hidden,
 144       nil)                      ;;   no format must be returned
 145      (t                         ;; - Tag was found and has formats,
 146       (let ((tag tag))          ;;   we must apply all the formats.
 147         (dolist (format (cdr formats) tag)
 148           (setq tag (eval format))))))))
 149
 150 (defun notmuch-tag-format-tags (tags)
 151   "Return a string representing formatted TAGS."
 152   (notmuch-combine-face-text-property-string
 153    (mapconcat #'identity
 154               ;; nil indicated that the tag was deliberately hidden
 155               (delq nil (mapcar #'notmuch-tag-format-tag tags))
 156               " ")
 157    'notmuch-tag-face
 158    t))
 159
 160 (defcustom notmuch-before-tag-hook nil
 161   "Hooks that are run before tags of a message are modified.
 162
 163 'tags' will contain the tags that are about to be added or removed as
 164 a list of strings of the form \"+TAG\" or \"-TAG\".
 165 'query' will be a string containing the search query that determines
 166 the messages that are about to be tagged"
 167
 168   :type 'hook
 169   :options '(notmuch-hl-line-mode)
 170   :group 'notmuch-hooks)
 171
 172 (defcustom notmuch-after-tag-hook nil
 173   "Hooks that are run after tags of a message are modified.
 174
 175 'tags' will contain the tags that were added or removed as
 176 a list of strings of the form \"+TAG\" or \"-TAG\".
 177 'query' will be a string containing the search query that determines
 178 the messages that were tagged"
 179   :type 'hook
 180   :options '(notmuch-hl-line-mode)
 181   :group 'notmuch-hooks)
 182
 183 (defvar notmuch-select-tag-history nil
 184   "Variable to store minibuffer history for
 185 `notmuch-select-tag-with-completion' function.")
 186
 187 (defvar notmuch-read-tag-changes-history nil
 188   "Variable to store minibuffer history for
 189 `notmuch-read-tag-changes' function.")
 190
 191 (defun notmuch-tag-completions (&optional search-terms)
 192   (if (null search-terms)
 193       (setq search-terms (list "*")))
 194   (split-string
 195    (with-output-to-string
 196      (with-current-buffer standard-output
 197        (apply 'call-process notmuch-command nil t
 198               nil "search" "--output=tags" "--exclude=false" search-terms)))
 199    "\n+" t))
 200
 201 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
 202   (let ((tag-list (notmuch-tag-completions search-terms)))
 203     (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
 204
 205 (defun notmuch-read-tag-changes (&optional initial-input &rest search-terms)
 206   (let* ((all-tag-list (notmuch-tag-completions))
 207          (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
 208          (remove-tag-list (mapcar (apply-partially 'concat "-")
 209                                   (if (null search-terms)
 210                                       all-tag-list
 211                                     (notmuch-tag-completions search-terms))))
 212          (tag-list (append add-tag-list remove-tag-list))
 213          (crm-separator " ")
 214          ;; By default, space is bound to "complete word" function.
 215          ;; Re-bind it to insert a space instead.  Note that <tab>
 216          ;; still does the completion.
 217          (crm-local-completion-map
 218           (let ((map (make-sparse-keymap)))
 219             (set-keymap-parent map crm-local-completion-map)
 220             (define-key map " " 'self-insert-command)
 221             map)))
 222     (delete "" (completing-read-multiple "Tags (+add -drop): "
 223                 tag-list nil nil initial-input
 224                 'notmuch-read-tag-changes-history))))
 225
 226 (defun notmuch-update-tags (tags tag-changes)
 227   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 228
 229 TAG-CHANGES must be a list of tags names, each prefixed with
 230 either a \"+\" to indicate the tag should be added to TAGS if not
 231 present or a \"-\" to indicate that the tag should be removed
 232 from TAGS if present."
 233   (let ((result-tags (copy-sequence tags)))
 234     (dolist (tag-change tag-changes)
 235       (let ((op (string-to-char tag-change))
 236             (tag (unless (string= tag-change "") (substring tag-change 1))))
 237         (case op
 238           (?+ (unless (member tag result-tags)
 239                 (push tag result-tags)))
 240           (?- (setq result-tags (delete tag result-tags)))
 241           (otherwise
 242            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 243     (sort result-tags 'string<)))
 244
 245 (defun notmuch-tag (query &optional tag-changes)
 246   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 247
 248 QUERY should be a string containing the search-terms.
 249 TAG-CHANGES can take multiple forms.  If TAG-CHANGES is a list of
 250 strings of the form \"+tag\" or \"-tag\" then those are the tag
 251 changes applied.  If TAG-CHANGES is a string then it is
 252 interpreted as a single tag change.  If TAG-CHANGES is the string
 253 \"-\" or \"+\", or null, then the user is prompted to enter the
 254 tag changes.
 255
 256 Note: Other code should always use this function alter tags of
 257 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
 258 directly, so that hooks specified in notmuch-before-tag-hook and
 259 notmuch-after-tag-hook will be run."
 260   ;; Perform some validation
 261   (if (string-or-null-p tag-changes)
 262       (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes))
 263           (setq tag-changes (notmuch-read-tag-changes tag-changes query))
 264         (setq tag-changes (list tag-changes))))
 265   (mapc (lambda (tag-change)
 266           (unless (string-match-p "^[-+]\\S-+$" tag-change)
 267             (error "Tag must be of the form `+this_tag' or `-that_tag'")))
 268         tag-changes)
 269   (unless (null tag-changes)
 270     (run-hooks 'notmuch-before-tag-hook)
 271     (apply 'notmuch-call-notmuch-process "tag"
 272            (append tag-changes (list "--" query)))
 273     (run-hooks 'notmuch-after-tag-hook))
 274   ;; in all cases we return tag-changes as a list
 275   tag-changes)
 276
 277 (defun notmuch-tag-change-list (tags &optional reverse)
 278   "Convert TAGS into a list of tag changes.
 279
 280 Add a \"+\" prefix to any tag in TAGS list that doesn't already
 281 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 282 \"+\" prefixes with \"-\" and vice versa in the result."
 283   (mapcar (lambda (str)
 284             (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
 285               (if reverse
 286                   (concat (if (= (string-to-char s) ?-) "+" "-")
 287                           (substring s 1))
 288                 s)))
 289           tags))
 290
 291
 292 ;;
 293
 294 (provide 'notmuch-tag)
 295
 296 ;; Local Variables:
 297 ;; byte-compile-warnings: (not cl-functions)
 298 ;; End: