emacs: make headings outline-minor-mode compatible

[notmuch] / emacs / notmuch-tag.el

diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el
index 49662c2034ce3c4d13f8bb980695b14ae5541616..817ea99fcfc33c5b7770ffb0dfc8f44d2f7593c0 100644 (file)
--- a/emacs/notmuch-tag.el
+++ b/emacs/notmuch-tag.el
@@ -20,19 +20,24 @@
 ;;
 ;; Authors: Carl Worth <cworth@cworth.org>
 ;;          Damien Cassou <damien.cassou@gmail.com>
 ;;
 ;; Authors: Carl Worth <cworth@cworth.org>
 ;;          Damien Cassou <damien.cassou@gmail.com>

-;;
+

 ;;; Code:
 ;;; Code:

-;;

 
 

-(require 'cl)
+(require 'cl-lib)
+(eval-when-compile
+  (require 'pcase))
+

 (require 'crm)
 (require 'crm)

+

 (require 'notmuch-lib)
 
 (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."
 
 (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")
   :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"))))
 
                       (variable :tag "Tag variable"))
                (string :tag "Name"))))
 


@@ -57,18 +64,21 @@ 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
 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
 
 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."
 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."


@@ -76,8 +86,10 @@ from TAGGING-OPERATIONS."
   :type '(repeat notmuch-tag-key-type)
   :group 'notmuch-tag)
 
   :type '(repeat notmuch-tag-key-type)
   :group 'notmuch-tag)
 

+;;; Faces and Formats
+

 (define-widget 'notmuch-tag-format-type 'lazy
 (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
   :type '(alist :key-type (regexp :tag "Tag")
                :extra-offset -3
                :value-type


@@ -108,14 +120,19 @@ from TAGGING-OPERATIONS."
   '((t :foreground "red"))
   "Default face used for the unread tag.
 
   '((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
   :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.
 
   "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
   :group 'notmuch-faces)
 
 (defcustom notmuch-tag-formats


@@ -157,7 +174,7 @@ with images."
     (t :inverse-video t))
   "Face used to display deleted tags.
 
     (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
   :group 'notmuch-faces)
 
 (defcustom notmuch-tag-deleted-formats


@@ -165,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.
 
     (".*" (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
 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


@@ -186,14 +203,14 @@ See `notmuch-tag-formats' for full documentation."
   '((t :underline "green"))
   "Default face used for added tags.
 
   '((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.
 
   :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
 first and then these formats are applied on top.
 
 To disable special formatting of added tags, set this variable to


@@ -204,6 +221,8 @@ See `notmuch-tag-formats' for full documentation."
   :group 'notmuch-faces
   :type 'notmuch-tag-format-type)
 
   :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-format-image-data (tag data)
   "Replace TAG with image DATA, if available.
 


@@ -222,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'."
 (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
 <svg version=\"1.1\" width=\"16\" height=\"16\">
   <g transform=\"translate(-242.81601,-315.59635)\">
     <path


@@ -257,6 +276,8 @@ This can be used with `notmuch-tag-format-image-data'."
   </g>
 </svg>")
 
   </g>
 </svg>")
 

+;;; Format Handling
+

 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
   "Cache of tag format lookup.  Internal to `notmuch-tag-format-tag'.")
 
 (defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
   "Cache of tag format lookup.  Internal to `notmuch-tag-format-tag'.")
 


@@ -269,10 +290,10 @@ 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.
   (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."
 
 (defun notmuch-tag--do-format (tag formatted-tag formats)
   "Apply a tag-formats entry to TAG."


@@ -301,13 +322,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
 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)))
   (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))
     (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
                    (deleted (notmuch-tag--get-formats
                              tag notmuch-tag-deleted-formats))
                    (added (notmuch-tag--get-formats


@@ -315,7 +338,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))
                    (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))
 
        (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
     formatted-tag))
 


@@ -326,21 +348,22 @@ changed (the normal case) are shown using formats from
     (notmuch-apply-face
      (mapconcat #'identity
                ;; nil indicated that the tag was deliberately hidden
     (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)))
 
                " ")
      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
 (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)
   :type 'hook
   :options '(notmuch-hl-line-mode)
   :group 'notmuch-hooks)


@@ -351,11 +374,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
 '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)
 
   :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.")
 (defvar notmuch-select-tag-history nil
   "Variable to store minibuffer history for
 `notmuch-select-tag-with-completion' function.")


@@ -368,8 +393,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."
   "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
   (split-string
    (with-output-to-string
      (with-current-buffer standard-output


@@ -390,7 +415,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."
 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))
   (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))


@@ -417,6 +441,8 @@ initial input in the minibuffer."
                nil nil initial-input
                'notmuch-read-tag-changes-history))))
 
                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.
 
 (defun notmuch-update-tags (tags tag-changes)
   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
 


@@ -428,7 +454,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))))
     (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)))
          (?+ (unless (member tag result-tags)
                (push tag result-tags)))
          (?- (setq result-tags (delete tag result-tags)))


@@ -449,7 +475,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.
 
 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."
 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."


@@ -485,13 +511,16 @@ begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
                s)))
          tags))
 
                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
 (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`
+`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
 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


@@ -500,41 +529,40 @@ and vice versa."
   ;; REVERSE is specified.
   (interactive "P")
   (let (action-map)
   ;; 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)))
                             (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
             (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
             (name-string (if name

-                             (if reverse (concat "Reverse " name)
+                             (if reverse
+                                 (concat "Reverse " name)

                                name)
                            (mapconcat #'identity tag-change " "))))
        (push (list key name-string
                                name)
                            (mapconcat #'identity tag-change " "))))
        (push (list key name-string

-                    `(lambda () (,tag-function ',tag-change)))
+                   `(lambda () (,tag-function ',tag-change)))

              action-map)))
              action-map)))

-    (push (list "r" (if reverse
-                       "Forward tag changes "
-                     "Reverse tag changes")
+    (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: ")))
 
                (apply-partially 'notmuch-tag-jump (not reverse)))
          action-map)
     (setq action-map (nreverse action-map))
     (notmuch-jump action-map "Tag: ")))
 

-;;
+;;; _

 
 (provide 'notmuch-tag)
 
 
 (provide 'notmuch-tag)
 

-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
+;;; notmuch-tag.el ends here