[elpa] externals/gnorb cd1f289 076/449: Guess which Org TODO is related to this message

[Stefan Monnier]

branch: externals/gnorb
commit cd1f289faf27f0cd7ba74dc7a12f18860d9922d5
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>

    Guess which Org TODO is related to this message
    
    lisp/gnorb-org.el: New function `gnorb-org-find-visit-candidates'. Used
                   when triggering a TODO state-change from a message:
                   now we make an intelligent guess as to which TODO
                   heading is wanted.
    
    lisp/gnorb-gnus.el: Alter `gnorb-gnus-incoming-do-todo' to use the above
                    new function
---
 lisp/gnorb-gnus.el | 46 ++++++++++++++++++++++++++++++++++------------
 lisp/gnorb-org.el  | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 87 insertions(+), 12 deletions(-)

diff --git a/lisp/gnorb-gnus.el b/lisp/gnorb-gnus.el
index 575f8f5..ae5b574 100644
--- a/lisp/gnorb-gnus.el
+++ b/lisp/gnorb-gnus.el
@@ -111,6 +111,8 @@ Basically behave as if all attachments have 
\":gnus-attachments t\"."
 (defun gnorb-gnus-attach-part (handle &optional org-heading)
   "Attach HANDLE to an existing org heading."
   (let ((filename (gnorb-gnus-save-part handle))
+       ;; we should probably do the automatic location routine here,
+       ;; as well.
        (org-heading (or org-heading
                         (org-refile-get-location "Attach part to" nil t))))
     (require 'org-attach)
@@ -340,26 +342,46 @@ link to the message, prompt for a related Org heading, 
visit the
 heading, and either add a note or trigger a TODO state change.
 Set `gnorb-trigger-todo-default' to 'note or 'todo (you can
 get the non-default behavior by calling this function with a
-prefix argument), or to 'prompt to always be prompted."
-  ;; this whole function isn't going to be that awesome until we teach
-  ;; it how to guess the relevant org heading using message-ids from
-  ;; the References or In-Reply-To headers of the incoming message.
+prefix argument), or to 'prompt to always be prompted.
+
+In some cases, Gnorb can guess for you which Org heading you
+probably want to trigger, which can save some time. It does this
+by looking in the References and In-Reply-To headers, and seeing
+if any of the IDs there match the value of the
+`gnorb-org-msg-id-key' property for any headings."
   (interactive "P")
   (if (not (memq major-mode '(gnus-summary-mode gnus-article-mode)))
       (error "Only works in gnus summary or article mode")
     (call-interactively 'org-store-link)
-    (let* ((org-refile-targets gnorb-gnus-trigger-refile-args)
-          (targ (or id
-                    (org-refile-get-location
-                     "Trigger heading" nil t))))
+    (let* ((org-refile-targets gnorb-gnus-trigger-refile-targets)
+          (ref-msg-ids (with-current-buffer gnus-original-article-buffer
+                         (nnheader-narrow-to-headers)
+                         (gnus-extract-message-id-from-in-reply-to
+                          (or (message-fetch-field "in-reply-to")
+                              (message-fetch-field "references")))))
+          (offer-heading
+           (when (and (not id) ref-msg-ids)
+             ;; for now we're basically ignoring the fact that
+             ;; multiple candidates could exist; just do the first
+             ;; one.
+             (car (gnorb-org-find-visit-candidates
+                   (list ref-msg-ids)))))
+          targ)
       (if id
          (gnorb-trigger-todo-action arg id)
-       (find-file (nth 1 targ))
-       (goto-char (nth 3 targ))
-       (gnorb-trigger-todo-action arg)
+       (if (and offer-heading
+                (y-or-n-p (format "Trigger action on %s"
+                           (org-format-outline-path (cadr offer-heading)))))
+           (gnorb-trigger-todo-action arg (car offer-heading))
+         (setq targ (org-refile-get-location
+                     "Trigger heading" nil t))
+         (find-file (nth 1 targ))
+         (goto-char (nth 3 targ))
+         (gnorb-trigger-todo-action arg))
        (message
         "Insert a link to the message with org-insert-link (%s)"
-        (mapconcat 'key-description (where-is-internal 'org-insert-link) ", 
"))))))
+        (mapconcat 'key-description
+                   (where-is-internal 'org-insert-link) ", "))))))
 
 (provide 'gnorb-gnus)
 ;;; gnorb-gnus.el ends here
diff --git a/lisp/gnorb-org.el b/lisp/gnorb-org.el
index 4f3cb3e..1515749 100644
--- a/lisp/gnorb-org.el
+++ b/lisp/gnorb-org.el
@@ -369,6 +369,59 @@ current heading."
      (first mail-stuff) (second mail-stuff)
      attachments nil org-id)))
 
+(defun gnorb-org-find-visit-candidates (ids)
+  "For all message-ids in IDS (which should be a list of
+Message-ID strings, with angle brackets), produce a list of Org
+ids (and ol-paths) for headings that contain one of those id
+values in their `gnorb-org-org-msg-id-key' property."
+  ;; org-id actually uses an external file to make this whole process
+  ;; faster, but we don't really need that kind of efficiency, I don't
+  ;; think. Visiting `org-agenda-files' and collecting property values
+  ;; should be okay. Speedups later, if and when needed. Right now
+  ;; this only happens on an interactive function call by the user, so
+  ;; a little pause is acceptable. Later we might try to add it to a
+  ;; notice-message type of hook, in which case I'll think about some
+  ;; sort of primitive caching. Since all we need is a mapping between
+  ;; Org ids and lists of message ids, maybe a hash table with Org id
+  ;; keys. It would need to be refreshed whenever the
+  ;; `gnorb-org-msg-id-key' was set. Deletions we could ignore: visit
+  ;; the ID, and if it doesn't exist or doesn't have the msg-id-key
+  ;; property, then refresh the cache and start over.
+
+  ;; Or see how org-id does it -- since the whole things relies on
+  ;; org-id, we could maybe just refresh our table when org-id
+  ;; refreshes.
+
+  ;; use `org-format-outline-path' to show the path at the other end.
+
+  ;; Probably I should have this function return a value that can be
+  ;; pushed to the front of org-refile-history, so that it's just
+  ;; offered as a default. Then things like
+  ;; `org-refile-goto-last-stored' and all that will work without my
+  ;; having to write new equivalents.
+  (let (ret-val)
+    (setq ret-val
+         (append
+          (org-map-entries
+           (lambda ()
+             (catch 'done
+               (dolist (id ids)
+                 (when
+                     (org-entry-member-in-multivalued-property
+                      (point) gnorb-org-msg-id-key id)
+                   (throw 'done
+                          (list (org-id-get-create)
+                                (append
+                                 (org-get-outline-path)
+                                 (list (org-get-heading nil t)))))))))
+           nil ;; allow customize here, default to
+               ;; `gnorb-org-mail-todos', but maybe provide a
+               ;; separate option.
+           'agenda 'archive 'comment)
+          ret-val))
+    (setq ret-val (delete-dups
+                  (delq nil ret-val)))))
+
 ;;; Email subtree
 
 (defcustom gnorb-org-email-subtree-text-parameters nil