-;;; notmuch-tag.el --- tag messages within emacs
+;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*-
;;
;; Copyright © Damien Cassou
;; Copyright © Carl Worth
;;
;; Authors: Carl Worth <cworth@cworth.org>
;; Damien Cassou <damien.cassou@gmail.com>
-;;
+
;;; Code:
-;;
-(require 'cl)
(require 'crm)
+
(require 'notmuch-lib)
-(declare-function notmuch-search-tag "notmuch" tag-changes)
-(declare-function notmuch-show-tag "notmuch-show" tag-changes)
-(declare-function notmuch-tree-tag "notmuch-tree" tag-changes)
+(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))
-(autoload 'notmuch-jump "notmuch-jump")
+;;; Keys
(define-widget 'notmuch-tag-key-type 'list
"A single key tagging binding."
:args '((list :inline t
:format "%v"
(key-sequence :tag "Key")
- (radio :tag "Tag operations" (repeat :tag "Tag list" (string :format "%v" :tag "change"))
+ (radio :tag "Tag operations"
+ (repeat :tag "Tag list"
+ (string :format "%v" :tag "change"))
(variable :tag "Tag variable"))
(string :tag "Name"))))
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 `r` should not be used as that
-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.
+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
+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."
: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"
+ "Customize widget for notmuch-tag-format and friends."
:type '(alist :key-type (regexp :tag "Tag")
:extra-offset -3
:value-type
'((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
- '((t :foreground "blue"))
+ '((((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`."
+Used in the default value of `notmuch-tag-formats'."
:group 'notmuch-faces)
(defcustom 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."
(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
(".*" (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
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
'((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
:group 'notmuch-faces
:type 'notmuch-tag-format-type)
+;;; Icons
+
(defun notmuch-tag-format-image-data (tag data)
"Replace TAG with image DATA, if available.
(defun notmuch-tag-star-icon ()
"Return SVG data representing a star icon.
This can be used with `notmuch-tag-format-image-data'."
-"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
-<svg version=\"1.1\" width=\"16\" height=\"16\">
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(-242.81601,-315.59635)\">
<path
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\"
"Return SVG data representing an empty star icon.
This can be used with `notmuch-tag-format-image-data'."
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
-<svg version=\"1.1\" width=\"16\" height=\"16\">
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(-242.81601,-315.59635)\">
<path
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\"
"Return SVG data representing a tag icon.
This can be used with `notmuch-tag-format-image-data'."
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
-<svg version=\"1.1\" width=\"16\" height=\"16\">
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(0,-1036.3622)\">
<path
d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
</g>
</svg>")
+;;; 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'.")
"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.
- (assoc* tag format-alist
- :test (lambda (tag key)
- (and (eq (string-match key tag) 0)
- (= (match-end 0) (length tag)))))))
+ (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'.
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'"
+`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)))
+ (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
+ (over (cl-case tag-state
(deleted (notmuch-tag--get-formats
tag notmuch-tag-deleted-formats))
(added (notmuch-tag--get-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))
(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))
+ (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.
-'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
-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)
(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
-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.
-Returns all tags if no search terms are given."
- (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 (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
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 "-") current-tags))
(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.
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)))
"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.")
+
+(make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36")
-(defun notmuch-tag (query tag-changes)
+(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 alter tags of
+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.
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
;; REVERSE is specified.
(interactive "P")
(let (action-map)
- (dolist (binding notmuch-tagging-keys)
- (let* ((tag-function (case major-mode
+ (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)))
- (key (first binding))
- (forward-tag-change (if (symbolp (second binding))
- (symbol-value (second binding))
- (second binding)))
+ (tag (if (symbolp tag)
+ (symbol-value tag)
+ tag))
(tag-change (if reverse
- (notmuch-tag-change-list forward-tag-change 't)
- forward-tag-change))
- (name (or (and (not (string= (third binding) ""))
- (third binding))
- (and (symbolp (second binding))
- (symbol-name (second binding)))))
+ (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)
+ (if reverse
+ (concat "Reverse " name)
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
(setq action-map (nreverse action-map))
(notmuch-jump action-map "Tag: ")))
-;;
+;;; _
(provide 'notmuch-tag)
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
+;;; notmuch-tag.el ends here
projects / notmuch / blobdiff