X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=fa376b02b5f9ebc6fde1a2a4f8f23c665948e05d;hp=09d182dfb818d6844efdab4ca3d626e9f2dd7d89;hb=fc4cda07a9afbbb545dcc6cd835ca697f6ef2a1b;hpb=60ac94fe58635f9c40724afa0f35965fc9ff1afc diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index 09d182df..fa376b02 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,19 +20,24 @@ ;; ;; Authors: Carl Worth ;; Damien Cassou -;; + ;;; Code: -;; -(require 'cl) +(require 'cl-lib) +(eval-when-compile + (require 'pcase)) + (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." @@ -40,7 +45,9 @@ :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")))) @@ -63,15 +70,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." @@ -79,8 +86,10 @@ 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 @@ -111,7 +120,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 @@ -123,7 +132,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 @@ -165,7 +174,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 @@ -173,7 +182,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 @@ -194,14 +203,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 @@ -212,6 +221,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. @@ -230,7 +241,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'." -" + " ") +;;; Format Handling + (defvar notmuch-tag--format-cache (make-hash-table :test 'equal) "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.") @@ -277,27 +290,29 @@ This can be used with `notmuch-tag-format-image-data'." (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) +(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'. @@ -309,13 +324,15 @@ are not in TAGS) are shown using formats from 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 @@ -323,7 +340,6 @@ changed (the normal case) are shown using formats from (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)) @@ -334,21 +350,22 @@ changed (the normal case) are shown using formats from (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 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) @@ -359,11 +376,13 @@ the messages that are about to be tagged" '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) +;;; User Input + (defvar notmuch-select-tag-history nil "Variable to store minibuffer history for `notmuch-select-tag-with-completion' function.") @@ -376,8 +395,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 @@ -398,7 +417,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)) @@ -425,6 +443,8 @@ initial input in the minibuffer." 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. @@ -436,7 +456,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))) @@ -457,7 +477,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." @@ -502,7 +522,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 @@ -511,28 +531,28 @@ and vice versa." ;; 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 () (,tag-function ',tag-change))) action-map))) (push (list notmuch-tag-jump-reverse-key (if reverse @@ -543,10 +563,8 @@ and vice versa." (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