From 30d591f40939dfa2fa3a3b5aee9e666b7686b87b Mon Sep 17 00:00:00 2001
From: jao <jao@gnu.org>
Date: Fri, 11 Mar 2022 21:18:32 +0000
Subject: automatic notmuch tagging on gnus' moves

---
 lib/net/jao-notmuch-gnus.el | 46 ++++++++++++++++++++++++++++++++++-----------
 1 file changed, 35 insertions(+), 11 deletions(-)

(limited to 'lib/net')

diff --git a/lib/net/jao-notmuch-gnus.el b/lib/net/jao-notmuch-gnus.el
index 8b4b9be..4bc86c4 100644
--- a/lib/net/jao-notmuch-gnus.el
+++ b/lib/net/jao-notmuch-gnus.el
@@ -30,16 +30,17 @@
 
 
 ;;; Tagging in notmuch from Gnus buffers
-(defun jao-notmuch-gnus-message-id ()
+
+(defun jao-notmuch-gnus--notmuch-id (id)
+  (when id (if (string-match "<\\(.+\\)>" id) (match-string 1 id) id)))
+
+(defun jao-notmuch-gnus-message-id (&optional no-show)
   "Find the id of currently selected message in Gnus or notmuch."
-  (when (derived-mode-p 'gnus-summary-mode)
+  (when (and (not no-show) (derived-mode-p 'gnus-summary-mode))
     (save-window-excursion (gnus-summary-show-article)))
   (cond (gnus-original-article-buffer
          (with-current-buffer gnus-original-article-buffer
-           (when-let (id (message-field-value "message-id"))
-             (if (string-match "<\\(.+\\)>" id)
-                 (match-string 1 id)
-               id))))
+           (jao-notmuch-gnus--notmuch-id (message-field-value "message-id"))))
         ((derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode)
          (notmuch-show-get-message-id))))
 
@@ -48,15 +49,16 @@
   (let ((cmd (format "notmuch search --output=tags 'id:%s'" id)))
     (split-string (shell-command-to-string cmd))))
 
-(defun jao-notmuch-gnus-tag-message (&optional id tags)
+(defun jao-notmuch-gnus-tag-message (&optional id tags no-log)
   "Interactively add or remove tags to the current message."
   (interactive)
   (let* ((id (or id (jao-notmuch-gnus-message-id)))
-         (current (jao-notmuch-gnus-message-tags id))
+         (current (unless tags (jao-notmuch-gnus-message-tags id)))
          (prompt (format "Change tags %s" (string-join current "/")))
          (tags (or tags (notmuch-read-tag-changes current prompt))))
     (notmuch-tag (concat "id:" id) tags)
-    (message "%s -> %s" current (jao-notmuch-gnus-message-tags id))))
+    (unless no-log
+      (message "%s -> %s" current (jao-notmuch-gnus-message-tags id)))))
 
 (defun jao-notmuch-gnus-show-tags ()
   "Display in the echo area the tags of the current message."
@@ -64,9 +66,9 @@
   (when-let (id (jao-notmuch-gnus-message-id))
     (message "%s" (string-join (jao-notmuch-gnus-message-tags id) " "))))
 
-(defun jao-notmuch-gnus-toggle-tags (tags)
+(defun jao-notmuch-gnus-toggle-tags (tags &optional id)
   "Toggle the given TAGS list for the current Gnus message."
-  (let* ((id (jao-notmuch-gnus-message-id))
+  (let* ((id (or id (jao-notmuch-gnus-message-id)))
          (current (jao-notmuch-gnus-message-tags id))
          (tags (mapcar (lambda (x)
                          (concat (if (member x current) "-" "+") x))
@@ -74,6 +76,28 @@
     (notmuch-tag (concat "id:" id) tags)
     (message "New tags: %s" (jao-notmuch-gnus-message-tags id))))
 
+(defun jao-notmuch-gnus-tag-mark ()
+  "Remove the new tag for an article when it's marked as seen by Gnus."
+  (when-let (id (jao-notmuch-gnus-message-id t))
+    (jao-notmuch-gnus-tag-message id '("-new") t)))
+
+(add-hook 'gnus-mark-article-hook #'jao-notmuch-gnus-tag-mark)
+
+(defun jao-notmuch-gnus--group-tags (group)
+  (when (string-match ".+:\\(.+\\)" group)
+    (split-string (match-string 1 group) "\\.")))
+
+(defun jao-notmuch-gnus-tag-on-move (operation headers from to d)
+  (when-let (id (and to (jao-notmuch-gnus--notmuch-id (mail-header-id headers))))
+    (when-let* ((to-tags (jao-notmuch-gnus--group-tags to))
+                (from-tags (jao-notmuch-gnus--group-tags from))
+                (new-tags (seq-difference to-tags from-tags))
+                (new-tags (mapcar (lambda (x) (concat "+" x)) new-tags)))
+      (notmuch-tag (concat "id:" id) new-tags))))
+
+(add-hook 'gnus-summary-article-move-hook #'jao-notmuch-gnus-tag-on-move)
+(add-hook 'gnus-summary-article-expire-hook #'jao-notmuch-gnus-tag-on-move)
+
 
 ;;;; Displaying search results in Gnus
 
-- 
cgit v1.2.3