[PATCH 3/6] emacs: make "+" and "-" tagging operations more robust
Dmitry Kurochkin
dmitry.kurochkin at gmail.com
Fri Jan 27 20:41:21 PST 2012
Before the change, "+" and "-" tagging operations in notmuch-search
and notmuch-show views accepted only a single tag. The patch makes
them use the recently added `notmuch-select-tags-with-completion'
function, which allows to enter multiple tags with "+" and "-"
prefixes. So after the change, "+" and "-" bindings allow to both add
and remove multiple tags. The only difference between "+" and "-" is
the minibuffer initial input ("+" and "-" respectively).
---
emacs/notmuch-show.el | 65 +++++++------------
emacs/notmuch.el | 165 +++++++++++++++++++++++++------------------------
2 files changed, 107 insertions(+), 123 deletions(-)
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 84ac624..03eadfb 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -38,8 +38,9 @@
(declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
(declare-function notmuch-fontify-headers "notmuch" nil)
-(declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms))
+(declare-function notmuch-select-tags-with-completion "notmuch" (&optional initial-input &rest search-terms))
(declare-function notmuch-search-show-thread "notmuch" nil)
+(declare-function notmuch-update-tags "notmuch" (current-tags changed-tags))
(defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date")
"Headers that should be shown in a message, in this order.
@@ -1267,7 +1268,7 @@ Some useful entries are:
(defun notmuch-show-mark-read ()
"Mark the current message as read."
- (notmuch-show-remove-tag "unread"))
+ (notmuch-show-tag-message "-unread"))
;; Functions for getting attributes of several messages in the current
;; thread.
@@ -1470,51 +1471,33 @@ than only the current message."
(message (format "Command '%s' exited abnormally with code %d"
shell-command exit-code))))))))
-(defun notmuch-show-add-tags-worker (current-tags add-tags)
- "Add to `current-tags' with any tags from `add-tags' not
-currently present and return the result."
- (let ((result-tags (copy-sequence current-tags)))
- (mapc (lambda (add-tag)
- (unless (member add-tag current-tags)
- (setq result-tags (push add-tag result-tags))))
- add-tags)
- (sort result-tags 'string<)))
-
-(defun notmuch-show-del-tags-worker (current-tags del-tags)
- "Remove any tags in `del-tags' from `current-tags' and return
-the result."
- (let ((result-tags (copy-sequence current-tags)))
- (mapc (lambda (del-tag)
- (setq result-tags (delete del-tag result-tags)))
- del-tags)
- result-tags))
-
-(defun notmuch-show-add-tag (&rest toadd)
- "Add a tag to the current message."
- (interactive
- (list (notmuch-select-tag-with-completion "Tag to add: ")))
+(defun notmuch-show-tag-message (&rest changed-tags)
+ "Change tags for the current message.
+`Changed-tags' is a list of tag operations for \"notmuch tag\",
+i.e. a list of tags to change with '+' and '-' prefixes."
(let* ((current-tags (notmuch-show-get-tags))
- (new-tags (notmuch-show-add-tags-worker current-tags toadd)))
-
+ (new-tags (notmuch-update-tags current-tags changed-tags)))
(unless (equal current-tags new-tags)
- (apply 'notmuch-tag (notmuch-show-get-message-id)
- (mapcar (lambda (s) (concat "+" s)) toadd))
+ (apply 'notmuch-tag (notmuch-show-get-message-id) changed-tags)
(notmuch-show-set-tags new-tags))))
-(defun notmuch-show-remove-tag (&rest toremove)
- "Remove a tag from the current message."
- (interactive
- (list (notmuch-select-tag-with-completion
- "Tag to remove: " (notmuch-show-get-message-id))))
+(defun notmuch-show-tag (&optional initial-input)
+ "Change tags for the current message, read input from the minibuffer."
+ (interactive)
+ (let ((changed-tags (notmuch-select-tags-with-completion
+ initial-input (notmuch-show-get-message-id))))
+ (apply 'notmuch-show-tag-message changed-tags)))
- (let* ((current-tags (notmuch-show-get-tags))
- (new-tags (notmuch-show-del-tags-worker current-tags toremove)))
+(defun notmuch-show-add-tag ()
+ "Same as `notmuch-show-tag' but sets initial input to '+'."
+ (interactive)
+ (notmuch-show-tag "+"))
- (unless (equal current-tags new-tags)
- (apply 'notmuch-tag (notmuch-show-get-message-id)
- (mapcar (lambda (s) (concat "-" s)) toremove))
- (notmuch-show-set-tags new-tags))))
+(defun notmuch-show-remove-tag ()
+ "Same as `notmuch-show-tag' but sets initial input to '-'."
+ (interactive)
+ (notmuch-show-tag "-"))
(defun notmuch-show-toggle-headers ()
"Toggle the visibility of the current message headers."
@@ -1559,7 +1542,7 @@ argument, hide all of the messages."
(defun notmuch-show-archive-thread-internal (show-next)
;; Remove the tag from the current set of messages.
(goto-char (point-min))
- (loop do (notmuch-show-remove-tag "inbox")
+ (loop do (notmuch-show-tag-message "-inbox")
until (not (notmuch-show-goto-message-next)))
;; Move to the next item in the search results, if any.
(let ((parent-buffer notmuch-show-parent-buffer))
diff --git a/emacs/notmuch.el b/emacs/notmuch.el
index ff46617..24b0ea3 100644
--- a/emacs/notmuch.el
+++ b/emacs/notmuch.el
@@ -76,38 +76,56 @@ For example:
(defvar notmuch-query-history nil
"Variable to store minibuffer history for notmuch queries")
-(defun notmuch-tag-completions (&optional prefixes search-terms)
- (let ((tag-list
- (split-string
- (with-output-to-string
- (with-current-buffer standard-output
- (apply 'call-process notmuch-command nil t
- nil "search-tags" search-terms)))
- "\n+" t)))
- (if (null prefixes)
- tag-list
- (apply #'append
- (mapcar (lambda (tag)
- (mapcar (lambda (prefix)
- (concat prefix tag)) prefixes))
- tag-list)))))
+(defun notmuch-tag-completions (&optional search-terms)
+ (split-string
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (apply 'call-process notmuch-command nil t
+ nil "search-tags" search-terms)))
+ "\n+" t))
(defun notmuch-select-tag-with-completion (prompt &rest search-terms)
- (let ((tag-list (notmuch-tag-completions nil search-terms)))
+ (let ((tag-list (notmuch-tag-completions search-terms)))
(completing-read prompt tag-list)))
-(defun notmuch-select-tags-with-completion (prompt &optional prefixes &rest search-terms)
- (let ((tag-list (notmuch-tag-completions prefixes search-terms))
- (crm-separator " ")
- ;; By default, space is bound to "complete word" function.
- ;; Re-bind it to insert a space instead. Note that <tab>
- ;; still does the completion.
- (crm-local-completion-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map crm-local-completion-map)
- (define-key map " " 'self-insert-command)
- map)))
- (delete "" (completing-read-multiple prompt tag-list))))
+(defun notmuch-select-tags-with-completion (&optional initial-input &rest search-terms)
+ (let* ((add-tag-list (mapcar (apply-partially 'concat "+")
+ (notmuch-tag-completions)))
+ (remove-tag-list (mapcar (apply-partially 'concat "-")
+ (notmuch-tag-completions search-terms)))
+ (tag-list (append add-tag-list remove-tag-list))
+ (crm-separator " ")
+ ;; By default, space is bound to "complete word" function.
+ ;; Re-bind it to insert a space instead. Note that <tab>
+ ;; still does the completion.
+ (crm-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map crm-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ map)))
+ (delete "" (completing-read-multiple
+ "Operations (+add -drop): notmuch tag " tag-list nil
+ nil initial-input))))
+
+(defun notmuch-update-tags (current-tags changed-tags)
+ "Update `current-tags' with `changed-tags' and return the result.
+
+`Changed-tags' is a list of tag operations given to \"notmuch
+tag\", i.e. a list of changed tags with '+' and '-' prefixes."
+ (let ((result-tags (copy-sequence current-tags)))
+ (mapc (lambda (changed-tag)
+ (unless (string= changed-tag "")
+ (let ((op (substring changed-tag 0 1))
+ (tag (substring changed-tag 1)))
+ (cond ((string= op "+")
+ (unless (member tag result-tags)
+ (push tag result-tags)))
+ ((string= op "-")
+ (setq result-tags (delete tag result-tags)))
+ (t
+ (error "Changed tag must be of the form `+this_tag' or `-that_tag'"))))))
+ changed-tags)
+ (sort result-tags 'string<)))
(defun notmuch-foreach-mime-part (function mm-handle)
(cond ((stringp (car mm-handle))
@@ -447,6 +465,10 @@ Complete list of currently available key bindings:
"Return a list of threads for the current region"
(notmuch-search-properties-in-region 'notmuch-search-thread-id beg end))
+(defun notmuch-search-find-thread-id-region-search (beg end)
+ "Return a search string for threads for the current region"
+ (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or "))
+
(defun notmuch-search-find-authors ()
"Return the authors for the current thread"
(get-text-property (point) 'notmuch-search-authors))
@@ -590,74 +612,55 @@ the messages that were tagged"
(forward-line 1))
output)))
-(defun notmuch-search-add-tag-thread (tag)
- (notmuch-search-add-tag-region tag (point) (point)))
+(defun notmuch-search-tag-thread (&rest tags)
+ "Change tags for the currently selected thread.
-(defun notmuch-search-add-tag-region (tag beg end)
- (let ((search-id-string (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or ")))
- (notmuch-tag search-id-string (concat "+" tag))
- (save-excursion
- (let ((last-line (line-number-at-pos end))
- (max-line (- (line-number-at-pos (point-max)) 2)))
- (goto-char beg)
- (while (<= (line-number-at-pos) (min last-line max-line))
- (notmuch-search-set-tags (delete-dups (sort (cons tag (notmuch-search-get-tags)) 'string<)))
- (forward-line))))))
+See `notmuch-search-tag-region' for details."
+ (apply 'notmuch-search-tag-region (point) (point) tags))
-(defun notmuch-search-remove-tag-thread (tag)
- (notmuch-search-remove-tag-region tag (point) (point)))
+(defun notmuch-search-tag-region (beg end &rest tags)
+ "Change tags for threads in the given region.
-(defun notmuch-search-remove-tag-region (tag beg end)
- (let ((search-id-string (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or ")))
- (notmuch-tag search-id-string (concat "-" tag))
+`Tags' is a list of tag operations for \"notmuch tag\", i.e. a
+list of tags to change with '+' and '-' prefixes. The tags are
+added or removed for all threads in the region from `beg' to
+`end'."
+ (let ((search-string (notmuch-search-find-thread-id-region-search beg end)))
+ (apply 'notmuch-tag search-string tags)
(save-excursion
(let ((last-line (line-number-at-pos end))
(max-line (- (line-number-at-pos (point-max)) 2)))
(goto-char beg)
(while (<= (line-number-at-pos) (min last-line max-line))
- (notmuch-search-set-tags (delete tag (notmuch-search-get-tags)))
+ (notmuch-search-set-tags
+ (notmuch-update-tags (notmuch-search-get-tags) tags))
(forward-line))))))
-(defun notmuch-search-add-tag (tag)
- "Add a tag to the currently selected thread or region.
-
-The tag is added to all messages in the currently selected thread
-or threads in the current region."
- (interactive
- (list (notmuch-select-tag-with-completion "Tag to add: ")))
- (save-excursion
- (if (region-active-p)
- (let* ((beg (region-beginning))
- (end (region-end)))
- (notmuch-search-add-tag-region tag beg end))
- (notmuch-search-add-tag-thread tag))))
-
-(defun notmuch-search-remove-tag (tag)
- "Remove a tag from the currently selected thread or region.
+(defun notmuch-search-tag (&optional initial-input)
+ "Change tags for the currently selected thread or region."
+ (interactive)
+ (let* ((beg (if (region-active-p) (region-beginning) (point)))
+ (end (if (region-active-p) (region-end) (point)))
+ (search-string (notmuch-search-find-thread-id-region-search beg end))
+ (tags (notmuch-select-tags-with-completion initial-input search-string)))
+ (apply 'notmuch-search-tag-region beg end tags)))
+
+(defun notmuch-search-add-tag ()
+ "Same as `notmuch-search-tag' but sets initial input to '+'."
+ (interactive)
+ (notmuch-search-tag "+"))
-The tag is removed from all messages in the currently selected
-thread or threads in the current region."
- (interactive
- (list (notmuch-select-tag-with-completion
- "Tag to remove: "
- (if (region-active-p)
- (mapconcat 'identity
- (notmuch-search-find-thread-id-region (region-beginning) (region-end))
- " ")
- (notmuch-search-find-thread-id)))))
- (save-excursion
- (if (region-active-p)
- (let* ((beg (region-beginning))
- (end (region-end)))
- (notmuch-search-remove-tag-region tag beg end))
- (notmuch-search-remove-tag-thread tag))))
+(defun notmuch-search-remove-tag ()
+ "Same as `notmuch-search-tag' but sets initial input to '-'."
+ (interactive)
+ (notmuch-search-tag "-"))
(defun notmuch-search-archive-thread ()
"Archive the currently selected thread (remove its \"inbox\" tag).
This function advances the next thread when finished."
(interactive)
- (notmuch-search-remove-tag-thread "inbox")
+ (notmuch-search-tag-thread "-inbox")
(notmuch-search-next-thread))
(defvar notmuch-search-process-filter-data nil
@@ -893,9 +896,7 @@ will prompt for tags to be added or removed. Tags prefixed with
Each character of the tag name may consist of alphanumeric
characters as well as `_.+-'.
"
- (interactive (notmuch-select-tags-with-completion
- "Operations (+add -drop): notmuch tag "
- '("+" "-")))
+ (interactive (notmuch-select-tags-with-completion))
(apply 'notmuch-tag notmuch-search-query-string actions))
(defun notmuch-search-buffer-title (query)
--
1.7.8.3
More information about the notmuch
mailing list