X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=0500927d37ce2b1e0173fb0f6ff7bc159a85018e;hp=0c0fc87583ad3439c04984b8879310d72062c1ed;hb=HEAD;hpb=97aa3c06593847c0f7b353cf5167d70cc9e53dd3 diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index 0c0fc875..81101828 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -1,5 +1,6 @@ -;; notmuch-tag.el --- tag messages within emacs +;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*- ;; +;; Copyright © Damien Cassou ;; Copyright © Carl Worth ;; ;; This file is part of Notmuch. @@ -15,22 +16,360 @@ ;; General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Notmuch. If not, see . +;; along with Notmuch. If not, see . ;; ;; Authors: Carl Worth +;; Damien Cassou + +;;; Code: -(eval-when-compile (require 'cl)) (require 'crm) + (require 'notmuch-lib) +(declare-function notmuch-search-tag "notmuch" + (tag-changes &optional beg end only-matched)) +(declare-function notmuch-show-tag "notmuch-show" (tag-changes)) +(declare-function notmuch-tree-tag "notmuch-tree" (tag-changes)) +(declare-function notmuch-jump "notmuch-jump" (action-map prompt)) + +;;; Keys + +(define-widget 'notmuch-tag-key-type 'list + "A single key tagging binding." + :format "%v" + :args '((list :inline t + :format "%v" + (key-sequence :tag "Key") + (radio :tag "Tag operations" + (repeat :tag "Tag list" + (string :format "%v" :tag "change")) + (variable :tag "Tag variable")) + (string :tag "Name")))) + +(defcustom notmuch-tagging-keys + `((,(kbd "a") notmuch-archive-tags "Archive") + (,(kbd "u") notmuch-show-mark-read-tags "Mark read") + (,(kbd "f") ("+flagged") "Flag") + (,(kbd "s") ("+spam" "-inbox") "Mark as spam") + (,(kbd "d") ("+deleted" "-inbox") "Delete")) + "A list of keys and corresponding tagging operations. + +For each key (or key sequence) you can specify a sequence of +tagging operations to apply, or a variable which contains a list +of tagging operations such as `notmuch-archive-tags'. The final +element is a name for this tagging operation. If the name is +omitted or empty then the list of tag changes, or the variable +name is used as the name. + +The key `notmuch-tag-jump-reverse-key' (k by default) should not +be used (either as a key, or as the start of a key sequence) as +it is already bound: it switches the menu to a menu of the +reverse tagging operations. The reverse of a tagging operation is +the same list of individual tag-ops but with `+tag' replaced by +`-tag' and vice versa. + +If setting this variable outside of customize then it should be a +list of triples (lists of three elements). Each triple should be +of the form (key-binding tagging-operations name). KEY-BINDING +can be a single character or a key sequence; TAGGING-OPERATIONS +should either be a list of individual tag operations each of the +form `+tag' or `-tag', or the variable name of a variable that is +a list of tagging operations; NAME should be a name for the +tagging operation, if omitted or empty than then name is taken +from TAGGING-OPERATIONS." + :tag "List of tagging bindings" + :type '(repeat notmuch-tag-key-type) + :group 'notmuch-tag) + +;;; Faces and Formats + +(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" + (const :tag "Hidden" nil) + (set :tag "Modified" + (string :tag "Display as") + (list :tag "Face" :extra-offset -4 + (const :format "" :inline t + (notmuch-apply-face tag)) + (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"))))) + +(defface notmuch-tag-unread + '((t :foreground "red")) + "Default face used for the unread tag. + +Used in the default value of `notmuch-tag-formats'." + :group 'notmuch-faces) + +(defface notmuch-tag-flagged + '((((class color) + (background dark)) + (:foreground "LightBlue1")) + (((class color) + (background light)) + (:foreground "blue"))) + "Face used for the flagged tag. + +Used in the default value of `notmuch-tag-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-formats + '(("unread" (propertize tag 'face 'notmuch-tag-unread)) + ("flagged" (propertize tag 'face 'notmuch-tag-flagged) + (notmuch-tag-format-image-data tag (notmuch-tag-star-icon)))) + "Custom formats for individual tags. + +This is an association list of the form ((MATCH EXPR...)...), +mapping tag name regexps to lists of formatting expressions. + +The first entry whose MATCH regexp-matches a tag is 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 is simply +hidden. Otherwise, each expression EXPR is evaluated in order: +for the first expression, the variable `tag' is bound to the tag +name; for each later expression, the variable `tag' is 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 is 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) + +(defface notmuch-tag-deleted + '((((class color) (supports :strike-through "red")) :strike-through "red") + (t :inverse-video t)) + "Face used to display deleted tags. + +Used in the default value of `notmuch-tag-deleted-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-deleted-formats + '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted)) + (".*" (notmuch-apply-face tag `notmuch-tag-deleted))) + "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) + +(defface notmuch-tag-added + '((t :underline "green")) + "Default face used for added tags. + +Used in the default value for `notmuch-tag-added-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-added-formats + '((".*" (notmuch-apply-face tag 'notmuch-tag-added))) + "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) + +;;; Icons + +(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'." + " + + + + +") + +;;; track history of tag operations +(defvar-local notmuch-tag-history nil + "Buffer local history of `notmuch-tag' function.") +(put 'notmuch-tag-history 'permanent-local t) + +;;; Format Handling + +(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 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. + (cl-assoc tag alist + :test (lambda (tag key) + (and (eq (string-match key tag) 0) + (= (match-end 0) (length tag))))))) + +(defun notmuch-tag--do-format (bare-tag tag formats) + "Apply a tag-formats entry to TAG." + (cond ((null formats) ;; - Tag not in `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, we must apply all the + ;; formats. TAG may be null so treat that as a special case. + (let ((return-tag (copy-sequence (or tag "")))) + (dolist (format (cdr formats)) + (setq return-tag + (eval format + `((bare-tag . ,bare-tag) + (tag . ,return-tag))))) + (if (and (null tag) (equal return-tag "")) + nil + return-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 (cl-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." + (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))) + +;;; Hooks + (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" - +`query' will be a string containing the search query that determines +the messages that are about to be tagged." :type 'hook :options '(notmuch-hl-line-mode) :group 'notmuch-hooks) @@ -38,44 +377,54 @@ 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" +`query' will be a string containing the search query that determines +the messages that were tagged." :type 'hook :options '(notmuch-hl-line-mode) :group 'notmuch-hooks) +;;; User Input + (defvar notmuch-select-tag-history nil - "Variable to store minibuffer history for -`notmuch-select-tag-with-completion' function.") + "Minibuffer history of `notmuch-select-tag-with-completion' function.") (defvar notmuch-read-tag-changes-history nil - "Variable to store minibuffer history for -`notmuch-read-tag-changes' function.") + "Minibuffer history of `notmuch-read-tag-changes' function.") + +(defun notmuch-tag-completions (&rest search-terms) + "Return a list of tags for messages matching SEARCH-TERMS. -(defun notmuch-tag-completions (&optional search-terms) - (if (null search-terms) - (setq search-terms (list "*"))) +Return all tags if no search terms are given." + (unless search-terms + (setq search-terms (list "*"))) (split-string (with-output-to-string (with-current-buffer standard-output - (apply 'call-process notmuch-command nil t + (apply 'notmuch--call-process notmuch-command nil t nil "search" "--output=tags" "--exclude=false" search-terms))) "\n+" t)) (defun notmuch-select-tag-with-completion (prompt &rest search-terms) - (let ((tag-list (notmuch-tag-completions search-terms))) - (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history))) + (completing-read prompt + (apply #'notmuch-tag-completions search-terms) + nil nil nil 'notmuch-select-tag-history)) + +(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input) + "Prompt for tag changes in the minibuffer. -(defun notmuch-read-tag-changes (&optional initial-input &rest search-terms) +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,9 +434,11 @@ 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 - 'notmuch-read-tag-changes-history)))) + (completing-read-multiple prompt tag-list + nil nil initial-input + 'notmuch-read-tag-changes-history))) + +;;; Tagging (defun notmuch-update-tags (tags tag-changes) "Return a copy of TAGS with additions and removals from TAG-CHANGES. @@ -98,9 +449,9 @@ present or a \"-\" to indicate that the tag should be removed from TAGS if present." (let ((result-tags (copy-sequence tags))) (dolist (tag-change tag-changes) - (let ((op (string-to-char tag-change)) - (tag (unless (string= tag-change "") (substring tag-change 1)))) - (case op + (let ((tag (and (not (string-empty-p tag-change)) + (substring tag-change 1)))) + (cl-case (aref tag-change 0) (?+ (unless (member tag result-tags) (push tag result-tags))) (?- (setq result-tags (delete tag result-tags))) @@ -108,38 +459,129 @@ 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. + +NOTE: this variable is no longer used.") + +(make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36") + +(defun notmuch-tag (query tag-changes &optional omit-hist) "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. - -Note: Other code should always use this function alter tags of +TAG-CHANGES is a list of strings of the form \"+tag\" or \"-tag\" +to add or remove tags, respectively. OMIT-HIST disables history +tracking if non-nil. + +Note: Other code should always use this function to 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 (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) + (dolist (tag-change tag-changes) + (unless (string-match-p "^[-+]\\S-+$" tag-change) + (error "Tag must be of the form `+this_tag' or `-that_tag'"))) + (unless query + (error "Nothing to tag!")) + (when tag-changes + (notmuch-dlet ((tag-changes tag-changes) + (query query)) + (run-hooks 'notmuch-before-tag-hook)) + (with-temp-buffer + (insert (concat (mapconcat #'notmuch-hex-encode tag-changes " ") " -- " query)) + (unless (= 0 + (notmuch--call-process-region + (point-min) (point-max) notmuch-command t t nil "tag" "--batch")) + (notmuch-logged-error "notmuch tag failed" (buffer-string)))) + (unless omit-hist + (push (list :query query :tag-changes tag-changes) notmuch-tag-history))) + (notmuch-dlet ((tag-changes tag-changes) + (query query)) + (run-hooks 'notmuch-after-tag-hook))) -;; +(defun notmuch-tag-undo () + "Undo the previous tagging operation in the current buffer. Uses +buffer local variable `notmuch-tag-history' to determine what +that operation was." + (interactive) + (when (null notmuch-tag-history) + (error "no further notmuch undo information")) + (let* ((action (pop notmuch-tag-history)) + (query (plist-get action :query)) + (changes (notmuch-tag-change-list (plist-get action :tag-changes) t))) + (notmuch-tag query changes t)) + (notmuch-refresh-this-buffer)) + +(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)) + +(defvar notmuch-tag-jump-reverse-key "k" + "The key in tag-jump to switch to the reverse tag changes.") + +(defun notmuch-tag-jump (reverse) + "Create a jump menu for tagging operations. + +Creates and displays a jump menu for the tagging operations +specified in `notmuch-tagging-keys'. If REVERSE is set then it +offers a menu of the reverses of the operations specified in +`notmuch-tagging-keys'; i.e. each `+tag' is replaced by `-tag' +and vice versa." + ;; In principle this function is simple, but it has to deal with + ;; lots of cases: different modes (search/show/tree), whether a name + ;; is specified, whether the tagging operations is a list of + ;; tag-ops, or a symbol that evaluates to such a list, and whether + ;; REVERSE is specified. + (interactive "P") + (let (action-map) + (pcase-dolist (`(,key ,tag ,name) notmuch-tagging-keys) + (let* ((tag-function (cl-case major-mode + (notmuch-search-mode #'notmuch-search-tag) + (notmuch-show-mode #'notmuch-show-tag) + (notmuch-tree-mode #'notmuch-tree-tag))) + (tag (if (symbolp tag) + (symbol-value tag) + tag)) + (tag-change (if reverse + (notmuch-tag-change-list tag t) + tag)) + (name (or (and (not (string= name "")) + name) + (and (symbolp name) + (symbol-name name)))) + (name-string (if name + (if reverse + (concat "Reverse " name) + name) + (mapconcat #'identity tag-change " ")))) + (push (list key name-string + (lambda () (funcall tag-function tag-change))) + action-map))) + (push (list notmuch-tag-jump-reverse-key + (if reverse + "Forward tag changes " + "Reverse tag changes") + (apply-partially 'notmuch-tag-jump (not reverse))) + action-map) + (setq action-map (nreverse action-map)) + (notmuch-jump action-map "Tag: "))) + +;;; _ (provide 'notmuch-tag) + +;;; notmuch-tag.el ends here