;;
;; 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
(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.
: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
- (if (display-supports-face-attributes-p '(:strike-through "red"))
- '(:strike-through "red")
- '(:inverse-video t))))
- (".*" (notmuch-apply-face tag
- (if (display-supports-face-attributes-p '(:strike-through "red"))
- '(:strike-through "red")
- '(:inverse-video t)))))
+ '(("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
: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 '(:underline "green"))))
+ '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
"Custom formats for tags when added.
For added tags the formats in `notmuch-tag-formats` are applied
(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
(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 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."
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)))
'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)
'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)
"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
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))
(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)))
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."
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:
projects / notmuch / blobdiff