X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=bc83e3de0fc3d30cc97f1325e2ebc87bc1bbfdeb;hp=ccc1321f4daf554c855a4c29893dab9d3d08ce68;hb=HEAD;hpb=73cc4105aa27f13464fcfdfe958e553842395789 diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index ccc1321f..81101828 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -1,4 +1,4 @@ -;;; notmuch-tag.el --- tag messages within emacs +;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*- ;; ;; Copyright © Damien Cassou ;; Copyright © Carl Worth @@ -20,13 +20,8 @@ ;; ;; Authors: Carl Worth ;; Damien Cassou -;; -;;; Code: -;; -(require 'cl-lib) -(eval-when-compile - (require 'pcase)) +;;; Code: (require 'crm) @@ -38,6 +33,8 @@ (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" @@ -69,15 +66,15 @@ 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. +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 +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." @@ -85,6 +82,8 @@ from TAGGING-OPERATIONS." :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") @@ -117,7 +116,7 @@ from TAGGING-OPERATIONS." '((t :foreground "red")) "Default face used for the unread tag. -Used in the default value of `notmuch-tag-formats`." +Used in the default value of `notmuch-tag-formats'." :group 'notmuch-faces) (defface notmuch-tag-flagged @@ -129,7 +128,7 @@ Used in the default value of `notmuch-tag-formats`." (:foreground "blue"))) "Face used for the flagged tag. -Used in the default value of `notmuch-tag-formats`." +Used in the default value of `notmuch-tag-formats'." :group 'notmuch-faces) (defcustom notmuch-tag-formats @@ -138,26 +137,29 @@ Used in the default value of `notmuch-tag-formats`." (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 +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 will displayed in +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\")) + (propertize tag \\='face \\='(:foreground \"red\")) See also `notmuch-tag-format-image', which can help replace tags with images." @@ -171,7 +173,7 @@ with images." (t :inverse-video t)) "Face used to display deleted tags. -Used in the default value of `notmuch-tag-deleted-formats`." +Used in the default value of `notmuch-tag-deleted-formats'." :group 'notmuch-faces) (defcustom notmuch-tag-deleted-formats @@ -179,7 +181,7 @@ Used in the default value of `notmuch-tag-deleted-formats`." (".*" (notmuch-apply-face tag `notmuch-tag-deleted))) "Custom formats for tags when deleted. -For deleted tags the formats in `notmuch-tag-formats` are applied +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 @@ -189,7 +191,7 @@ 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)) + \\='((\".*\" nil)) See `notmuch-tag-formats' for full documentation." :group 'notmuch-show @@ -200,14 +202,14 @@ See `notmuch-tag-formats' for full documentation." '((t :underline "green")) "Default face used for added tags. -Used in the default value for `notmuch-tag-added-formats`." +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 +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 @@ -218,6 +220,8 @@ See `notmuch-tag-formats' for full documentation." :group 'notmuch-faces :type 'notmuch-tag-format-type) +;;; Icons + (defun notmuch-tag-format-image-data (tag data) "Replace TAG with image DATA, if available. @@ -237,7 +241,7 @@ DATA is the content of an SVG picture (e.g., as returned by "Return SVG data representing a star 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'.") @@ -278,32 +289,34 @@ This can be used with `notmuch-tag-format-image-data'." "Clear the internal cache of tag formats." (clrhash notmuch-tag--format-cache)) -(defun notmuch-tag--get-formats (tag format-alist) +(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 format-alist + (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 (tag formatted-tag formats) +(defun notmuch-tag--do-format (bare-tag tag formats) "Apply a tag-formats entry to TAG." (cond ((null formats) ;; - Tag not in `formats', - formatted-tag) ;; the format is the tag itself. + 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 "")))) + (let ((return-tag (copy-sequence (or tag "")))) (dolist (format (cdr formats)) - (setq tag (eval format))) - (if (and (null formatted-tag) (equal tag "")) + (setq return-tag + (eval format + `((bare-tag . ,bare-tag) + (tag . ,return-tag))))) + (if (and (null tag) (equal return-tag "")) nil - tag))))) + return-tag))))) (defun notmuch-tag-format-tag (tags orig-tags tag) "Format TAG according to `notmuch-tag-formats'. @@ -348,12 +361,14 @@ changed (the normal case) are shown using formats from face t))) +;;; Hooks + (defcustom notmuch-before-tag-hook nil "Hooks that are run before tags of a message are modified. -'tag-changes' 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 +`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) @@ -362,44 +377,45 @@ 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. -'tag-changes' 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 +`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. -Returns all tags if no search terms are given." +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 (apply #'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. -CURRENT-TAGS is a list of tags that are present on the message or -messages to be changed. These are offered as tag removal +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 @@ -418,17 +434,11 @@ initial input in the minibuffer." (set-keymap-parent map crm-local-completion-map) (define-key map " " 'self-insert-command) map))) - (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)))) + (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. @@ -439,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)))) - (cl-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))) @@ -453,37 +463,59 @@ from TAGS if present." "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.") +avoid system argument length limits and performance problems. + +NOTE: this variable is no longer used.") -(defun notmuch-tag (query tag-changes) +(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 is a list of strings of the form \"+tag\" or -\"-tag\" to add or remove tags, respectively. +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 - (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) + (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!")) - (unless (null tag-changes) - (run-hooks 'notmuch-before-tag-hook) - (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"))) + (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. @@ -507,7 +539,7 @@ begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all 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` +`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 @@ -525,7 +557,7 @@ and vice versa." (symbol-value tag) tag)) (tag-change (if reverse - (notmuch-tag-change-list tag 't) + (notmuch-tag-change-list tag t) tag)) (name (or (and (not (string= name "")) name) @@ -537,7 +569,7 @@ and vice versa." name) (mapconcat #'identity tag-change " ")))) (push (list key name-string - `(lambda () (,tag-function ',tag-change))) + (lambda () (funcall tag-function tag-change))) action-map))) (push (list notmuch-tag-jump-reverse-key (if reverse @@ -548,6 +580,8 @@ and vice versa." (setq action-map (nreverse action-map)) (notmuch-jump action-map "Tag: "))) -;; +;;; _ (provide 'notmuch-tag) + +;;; notmuch-tag.el ends here