X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=c7f62c90974995caf64aea212e0a5eae9fa97b5e;hp=75a438bfc5de5895183d6fee3208672dee66f332;hb=3b348ab1e11339ccbef1b56ceeb96e96e44eb079;hpb=b714a808a692a99c1b936be43186a40ab251aeca diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index 75a438bf..c7f62c90 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -28,34 +28,9 @@ (require 'crm) (require 'notmuch-lib) -(defcustom notmuch-tag-formats - '(("unread" (propertize tag 'face '(:foreground "red"))) - ("flagged" (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") +(define-widget 'notmuch-tag-format-type 'lazy + "Customize widget for notmuch-tag-format and friends" + :type '(alist :key-type (regexp :tag "Tag") :extra-offset -3 :value-type (radio :format "%v" @@ -64,7 +39,7 @@ with images." (string :tag "Display as") (list :tag "Face" :extra-offset -4 (const :format "" :inline t - (propertize tag 'face)) + (notmuch-apply-face tag)) (list :format "%v" (const :format "" quote) custom-face-edit)) @@ -81,6 +56,83 @@ with images." (string :tag "Custom"))) (sexp :tag "Custom"))))) +(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 is an association list that maps from tag name regexps to +lists of formatting expressions. The first entry whose car +regexp-matches a tag will be used to format that tag. The regexp +is implicitly anchored, so to match a literal tag name, just use +that tag name (if it contains special regexp characters like +\".\" or \"*\", these have to be escaped). The cdr of the +matching entry 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 + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +(defcustom notmuch-tag-deleted-formats + '(("unread" (notmuch-apply-face bare-tag + (if (display-supports-face-attributes-p '(:strike-through "red")) + '(:strike-through "red") + '(:inverse-video t)))) + (".*" (notmuch-apply-face tag + (if (display-supports-face-attributes-p '(:strike-through "red")) + '(:strike-through "red") + '(:inverse-video t))))) + "Custom formats for tags when deleted. + +For deleted tags the formats in `notmuch-tag-formats` are applied +first and then these formats are applied on top; that is `tag' +passed to the function is the tag with all these previous +formattings applied. The formatted can access the original +unformatted tag as `bare-tag'. + +By default this shows deleted tags with strike-through in red, +unless strike-through is not available (e.g., emacs is running in +a terminal) in which case it uses inverse video. To hide deleted +tags completely set this to + '((\".*\" nil)) + +See `notmuch-tag-formats' for full documentation." + :group 'notmuch-show + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +(defcustom notmuch-tag-added-formats + '((".*" (notmuch-apply-face tag '(:underline "green")))) + "Custom formats for tags when added. + +For added tags the formats in `notmuch-tag-formats` are applied +first and then these formats are applied on top. + +To disable special formatting of added tags, set this variable to +nil. + +See `notmuch-tag-formats' for full documentation." + :group 'notmuch-show + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + (defun notmuch-tag-format-image-data (tag data) "Replace TAG with image DATA, if available. @@ -134,33 +186,86 @@ 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) +(defvar notmuch-tag--format-cache (make-hash-table :test 'equal) + "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.") + +(defun notmuch-tag-clear-cache () + "Clear the internal cache of tag formats." + (clrhash notmuch-tag--format-cache)) + +(defun notmuch-tag--get-formats (tag format-alist) + "Find the first item whose car regexp-matches TAG." + (save-match-data + ;; Don't use assoc-default since there's no way to distinguish a + ;; missing key from a present key with a null cdr. + (assoc* tag format-alist + :test (lambda (tag key) + (and (eq (string-match key tag) 0) + (= (match-end 0) (length tag))))))) + +(defun notmuch-tag--do-format (tag formatted-tag formats) + "Apply a tag-formats entry to TAG." + (cond ((null formats) ;; - Tag not in `formats', + formatted-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, we must apply all the + ;; formats. TAG may be null so treat that as a special case. + (let ((bare-tag tag) + (tag (copy-sequence (or formatted-tag "")))) + (dolist (format (cdr formats)) + (setq tag (eval format))) + (if (and (null formatted-tag) (equal tag "")) + nil + tag))))) + +(defun notmuch-tag-format-tag (tags orig-tags tag) + "Format TAG according to `notmuch-tag-formats'. + +TAGS and ORIG-TAGS are lists of the current tags and the original +tags; tags which have been deleted (i.e., are in ORIG-TAGS but +are not in TAGS) are shown using formats from +`notmuch-tag-deleted-formats'; tags which have been added (i.e., +are in TAGS but are not in ORIG-TAGS) are shown using formats +from `notmuch-tag-added-formats' and tags which have not been +changed (the normal case) are shown using formats from +`notmuch-tag-formats'" + (let* ((tag-state (cond ((not (member tag tags)) 'deleted) + ((not (member tag orig-tags)) 'added))) + (formatted-tag (gethash (cons tag tag-state) notmuch-tag--format-cache 'missing))) + (when (eq formatted-tag 'missing) + (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats)) + (over (case tag-state + (deleted (notmuch-tag--get-formats + tag notmuch-tag-deleted-formats)) + (added (notmuch-tag--get-formats + tag notmuch-tag-added-formats)) + (otherwise nil)))) + (setq formatted-tag (notmuch-tag--do-format tag tag base)) + (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over)) + + (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache))) + formatted-tag)) + +(defun notmuch-tag-format-tags (tags orig-tags &optional face) "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)) + (let ((face (or face 'notmuch-tag-face)) + (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<))) + (notmuch-apply-face + (mapconcat #'identity + ;; nil indicated that the tag was deliberately hidden + (delq nil (mapcar + (apply-partially #'notmuch-tag-format-tag tags orig-tags) + all-tags)) + " ") + face + t))) (defcustom notmuch-before-tag-hook nil "Hooks that are run before tags of a message are modified. -'tags' will contain the tags that are about to be added or removed as +'tag-changes' will contain the tags that are about to be added or removed as a list of strings of the form \"+TAG\" or \"-TAG\". 'query' will be a string containing the search query that determines the messages that are about to be tagged" @@ -172,7 +277,7 @@ the messages that are about to be tagged" (defcustom notmuch-after-tag-hook nil "Hooks that are run after tags of a message are modified. -'tags' will contain the tags that were added or removed as +'tag-changes' will contain the tags that were added or removed as a list of strings of the form \"+TAG\" or \"-TAG\". 'query' will be a string containing the search query that determines the messages that were tagged" @@ -188,7 +293,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 @@ -199,17 +307,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 @@ -219,8 +334,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) @@ -242,37 +365,40 @@ 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 &optional 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. QUERY should be a string containing the search-terms. -TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of -strings of the form \"+tag\" or \"-tag\" then those are the tag -changes applied. If TAG-CHANGES is a string then it is -interpreted as a single tag change. If TAG-CHANGES is the string -\"-\" or \"+\", or null, then the user is prompted to enter the -tag changes. +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\" ..) directly, so that hooks specified in notmuch-before-tag-hook and notmuch-after-tag-hook will be run." ;; Perform some validation - (if (string-or-null-p tag-changes) - (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes)) - (setq tag-changes (notmuch-read-tag-changes tag-changes query)) - (setq tag-changes (list tag-changes)))) (mapc (lambda (tag-change) (unless (string-match-p "^[-+]\\S-+$" tag-change) (error "Tag must be of the form `+this_tag' or `-that_tag'"))) tag-changes) + (unless query + (error "Nothing to tag!")) (unless (null tag-changes) (run-hooks 'notmuch-before-tag-hook) - (apply 'notmuch-call-notmuch-process "tag" - (append tag-changes (list "--" query))) - (run-hooks 'notmuch-after-tag-hook)) - ;; in all cases we return tag-changes as a list - tag-changes) + (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. @@ -292,3 +418,7 @@ begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all ;; (provide 'notmuch-tag) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: