X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=c7a1e3220946ad3a2ec1c1f8afc7b320d9c7ae83;hp=a4dea39df71a732154770a008977bd24417ac226;hb=df3fab18fe70ea750f6f06da30291c67de7e74f2;hpb=b9a777e0a3983a5b2062e927c5b426ca669da644

diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el
index a4dea39d..c7a1e322 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
 ;;
 ;; Copyright © Damien Cassou
 ;; Copyright © Carl Worth
@@ -16,20 +16,76 @@
 ;; General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License
-;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
+;; along with Notmuch.  If not, see <https://www.gnu.org/licenses/>.
 ;;
 ;; Authors: Carl Worth <cworth@cworth.org>
 ;;          Damien Cassou <damien.cassou@gmail.com>
-;;
+
 ;;; Code:
-;;
 
-(require 'cl)
+(require 'cl-lib)
+(eval-when-compile
+  (require 'pcase))
+
 (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))
+
+(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)
+
 (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
@@ -39,7 +95,7 @@
 			    (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))
@@ -56,9 +112,28 @@
 					  (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 '(:foreground "red")))
-    ("flagged" (propertize tag 'face '(:foreground "blue"))
+  '(("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.
 
@@ -87,6 +162,59 @@ 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)
 
 (defun notmuch-tag-format-image-data (tag data)
@@ -107,7 +235,7 @@ DATA is the content of an SVG picture (e.g., as returned by
 (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\"?>
+  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
 <svg version=\"1.1\" width=\"16\" height=\"16\">
   <g transform=\"translate(-242.81601,-315.59635)\">
     <path
@@ -149,45 +277,72 @@ 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-format-tag (tag)
-  "Format TAG by according to `notmuch-tag-formats'.
-
-Callers must ensure that the tag format cache has been recently cleared
-via `notmuch-tag-clear-cache' before using this function.  For example,
-it would be appropriate to clear the cache just prior to filling a
-buffer that uses formatted tags."
-
-  (let ((formatted (gethash tag notmuch-tag--format-cache 'missing)))
-    (when (eq formatted 'missing)
-      (let* ((formats
-	      (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 notmuch-tag-formats
-			:test (lambda (tag key)
-				(and (eq (string-match key tag) 0)
-				     (= (match-end 0) (length tag))))))))
-	(setq formatted
-	      (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)))))))
-	(puthash tag formatted notmuch-tag--format-cache)))
-    formatted))
-
-(defun notmuch-tag-format-tags (tags &optional face)
+(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.
+    (cl-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 (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)))
+  (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 #'notmuch-tag-format-tag tags))
+		(delq nil (mapcar (apply-partially #'notmuch-tag-format-tag
+						   tags orig-tags)
+				  all-tags))
 		" ")
      face
      t)))
@@ -195,11 +350,10 @@ buffer that uses formatted tags."
 (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"
-
+the messages that are about to be tagged."
   :type 'hook
   :options '(notmuch-hl-line-mode)
   :group 'notmuch-hooks)
@@ -207,10 +361,10 @@ 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"
+the messages that were tagged."
   :type 'hook
   :options '(notmuch-hl-line-mode)
   :group 'notmuch-hooks)
@@ -227,8 +381,8 @@ the messages that were tagged"
   "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 "*")))
+  (unless search-terms
+    (setq search-terms (list "*")))
   (split-string
    (with-output-to-string
      (with-current-buffer standard-output
@@ -249,7 +403,6 @@ 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))
@@ -287,7 +440,7 @@ from TAGS if present."
     (dolist (tag-change tag-changes)
       (let ((op (string-to-char tag-change))
 	    (tag (unless (string= tag-change "") (substring tag-change 1))))
-	(case op
+	(cl-case op
 	  (?+ (unless (member tag result-tags)
 		(push tag result-tags)))
 	  (?- (setq result-tags (delete tag result-tags)))
@@ -308,7 +461,7 @@ 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.
 
-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."
@@ -317,6 +470,8 @@ notmuch-after-tag-hook will be run."
 	  (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)
     (if (<= (length query) notmuch-tag-argument-limit)
@@ -342,11 +497,56 @@ begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
 		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 () (,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)
-
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End: