X-Git-Url: https://git.notmuchmail.org/git?a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=b60f46c74d33ee5d70ec0feca703efb39fc60ecb;hb=a760e4ab47e152a9d3b4fa9b733f82723ebaaefe;hp=c25cff84ff75fa05a9e6af4971bec4966f74a12f;hpb=eb8feb16664fd0296ea0e07f4924c2a87a5b3bc3;p=notmuch diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index c25cff84..b60f46c7 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -1,5 +1,6 @@ ;; notmuch-tag.el --- tag messages within emacs ;; +;; Copyright © Damien Cassou ;; Copyright © Carl Worth ;; ;; This file is part of Notmuch. @@ -18,11 +19,145 @@ ;; along with Notmuch. If not, see . ;; ;; Authors: Carl Worth +;; Damien Cassou +;; +;;; Code: +;; -(eval-when-compile (require 'cl)) +(require 'cl) (require 'crm) (require 'notmuch-lib) +(defcustom notmuch-tag-formats + '(("unread" (propertize tag 'face '(:foreground "red"))) + ("flagged" (propertize tag 'face '(:foreground "blue")) + (notmuch-tag-format-image-data tag (notmuch-tag-star-icon)))) + "Custom formats for individual tags. + +This gives a list that maps from tag names to lists of formatting +expressions. The car of each element gives a tag name and the +cdr gives a list of Elisp expressions that modify the tag. If +the list is empty, the tag will simply be hidden. Otherwise, +each expression will be evaluated in order: for the first +expression, the variable `tag' will be bound to the tag name; for +each later expression, the variable `tag' will be bound to the +result of the previous expression. In this way, each expression +can build on the formatting performed by the previous expression. +The result of the last expression will displayed in place of the +tag. + +For example, to replace a tag with another string, simply use +that string as a formatting expression. To change the foreground +of a tag to red, use the expression + (propertize tag 'face '(:foreground \"red\")) + +See also `notmuch-tag-format-image', which can help replace tags +with images." + + :group 'notmuch-search + :group 'notmuch-show + :type '(alist :key-type (string :tag "Tag") + :extra-offset -3 + :value-type + (radio :format "%v" + (const :tag "Hidden" nil) + (set :tag "Modified" + (string :tag "Display as") + (list :tag "Face" :extra-offset -4 + (const :format "" :inline t + (propertize tag 'face)) + (list :format "%v" + (const :format "" quote) + custom-face-edit)) + (list :format "%v" :extra-offset -4 + (const :format "" :inline t + (notmuch-tag-format-image-data tag)) + (choice :tag "Image" + (const :tag "Star" + (notmuch-tag-star-icon)) + (const :tag "Empty star" + (notmuch-tag-star-empty-icon)) + (const :tag "Tag" + (notmuch-tag-tag-icon)) + (string :tag "Custom"))) + (sexp :tag "Custom"))))) + +(defun notmuch-tag-format-image-data (tag data) + "Replace TAG with image DATA, if available. + +This function returns a propertized string that will display image +DATA in place of TAG.This is designed for use in +`notmuch-tag-formats'. + +DATA is the content of an SVG picture (e.g., as returned by +`notmuch-tag-star-icon')." + (propertize tag 'display + `(image :type svg + :data ,data + :ascent center + :mask heuristic))) + +(defun notmuch-tag-star-icon () + "Return SVG data representing a star icon. +This can be used with `notmuch-tag-format-image-data'." +" + + + + +") + +(defun notmuch-tag-star-empty-icon () + "Return SVG data representing an empty star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-tag-icon () + "Return SVG data representing a tag icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-format-tag (tag) + "Format TAG by looking into `notmuch-tag-formats'." + (let ((formats (assoc tag notmuch-tag-formats))) + (cond + ((null formats) ;; - Tag not in `notmuch-tag-formats', + tag) ;; the format is the tag itself. + ((null (cdr formats)) ;; - Tag was deliberately hidden, + nil) ;; no format must be returned + (t ;; - Tag was found and has formats, + (let ((tag tag)) ;; we must apply all the formats. + (dolist (format (cdr formats) tag) + (setq tag (eval format)))))))) + +(defun notmuch-tag-format-tags (tags) + "Return a string representing formatted TAGS." + (notmuch-combine-face-text-property-string + (mapconcat #'identity + ;; nil indicated that the tag was deliberately hidden + (delq nil (mapcar #'notmuch-tag-format-tag tags)) + " ") + 'notmuch-tag-face + t)) + (defcustom notmuch-before-tag-hook nil "Hooks that are run before tags of a message are modified. @@ -54,7 +189,10 @@ the messages that were tagged" "Variable to store minibuffer history for `notmuch-read-tag-changes' function.") -(defun notmuch-tag-completions (&optional search-terms) +(defun notmuch-tag-completions (&rest search-terms) + "Return a list of tags for messages matching SEARCH-TERMS. + +Returns all tags if no search terms are given." (if (null search-terms) (setq search-terms (list "*"))) (split-string @@ -65,17 +203,24 @@ the messages that were tagged" "\n+" t)) (defun notmuch-select-tag-with-completion (prompt &rest search-terms) - (let ((tag-list (notmuch-tag-completions search-terms))) + (let ((tag-list (apply #'notmuch-tag-completions search-terms))) (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history))) -(defun notmuch-read-tag-changes (&optional initial-input &rest search-terms) +(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input) + "Prompt for tag changes in the minibuffer. + +CURRENT-TAGS is a list of tags that are present on the message or +messages to be changed. These are offered as tag removal +completions. CURRENT-TAGS may contain duplicates. PROMPT, if +non-nil, is the query string to present in the minibuffer. It +defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the +initial input in the minibuffer." + (let* ((all-tag-list (notmuch-tag-completions)) (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list)) - (remove-tag-list (mapcar (apply-partially 'concat "-") - (if (null search-terms) - all-tag-list - (notmuch-tag-completions search-terms)))) + (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags)) (tag-list (append add-tag-list remove-tag-list)) + (prompt (concat (or prompt "Tags") " (+add -drop): ")) (crm-separator " ") ;; By default, space is bound to "complete word" function. ;; Re-bind it to insert a space instead. Note that @@ -85,8 +230,16 @@ the messages that were tagged" (set-keymap-parent map crm-local-completion-map) (define-key map " " 'self-insert-command) map))) - (delete "" (completing-read-multiple "Tags (+add -drop): " - tag-list nil nil initial-input + (delete "" (completing-read-multiple + prompt + ;; Append the separator to each completion so when the + ;; user completes a tag they can immediately begin + ;; entering another. `completing-read-multiple' + ;; ultimately splits the input on crm-separator, so we + ;; don't need to strip this back off (we just need to + ;; delete "empty" entries caused by trailing spaces). + (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list) + nil nil initial-input 'notmuch-read-tag-changes-history)))) (defun notmuch-update-tags (tags tag-changes) @@ -108,12 +261,18 @@ from TAGS if present." (error "Changed tag must be of the form `+this_tag' or `-that_tag'"))))) (sort result-tags 'string<))) -(defun notmuch-tag (query &rest tag-changes) +(defconst notmuch-tag-argument-limit 1000 + "Use batch tagging if the tagging query is longer than this. + +This limits the length of arguments passed to the notmuch CLI to +avoid system argument length limits and performance problems.") + +(defun notmuch-tag (query tag-changes) "Add/remove tags in TAG-CHANGES to messages matching QUERY. -TAG-CHANGES should be a list of strings of the form \"+tag\" or -\"-tag\" and QUERY should be a string containing the -search-query. +QUERY should be a string containing the search-terms. +TAG-CHANGES is a list of strings of the form \"+tag\" or +\"-tag\" to add or remove tags, respectively. Note: Other code should always use this function alter tags of messages instead of running (notmuch-call-notmuch-process \"tag\" ..) @@ -126,10 +285,34 @@ notmuch-after-tag-hook will be run." tag-changes) (unless (null tag-changes) (run-hooks 'notmuch-before-tag-hook) - (apply 'notmuch-call-notmuch-process "tag" - (append tag-changes (list "--" query))) + (if (<= (length query) notmuch-tag-argument-limit) + (apply 'notmuch-call-notmuch-process "tag" + (append tag-changes (list "--" query))) + ;; Use batch tag mode to avoid argument length limitations + (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ") + " -- " query))) + (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch"))) (run-hooks 'notmuch-after-tag-hook))) +(defun notmuch-tag-change-list (tags &optional reverse) + "Convert TAGS into a list of tag changes. + +Add a \"+\" prefix to any tag in TAGS list that doesn't already +begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all +\"+\" prefixes with \"-\" and vice versa in the result." + (mapcar (lambda (str) + (let ((s (if (string-match "^[+-]" str) str (concat "+" str)))) + (if reverse + (concat (if (= (string-to-char s) ?-) "+" "-") + (substring s 1)) + s))) + tags)) + + ;; (provide 'notmuch-tag) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: