[elpa] externals/gnorb ca85930 197/449: First draft of trigger action reworking

[Stefan Monnier]

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

    First draft of trigger action reworking
    
    * lisp/gnorb-org.el (gnorb-org-trigger-actions): New option listing
      possible actions when triggering Org headings from relevant messages.
    
    * lisp/gnorb-utils.el (gnorb-trigger-todo-default): Obsoleted option
      (gnorb-trigger-todo-action): Allow the user to choose an action from
      gnorb-org-trigger-action. Capture to child and capture to sibling do
      not work yet. Function signature no longer accepts a prefix arg passed
      from other callers.
    
    * lisp/gnorb-gnus.el: Don't pass prefix arg to
      `gnorb-trigger-todo-action', it no longer accepts it.
---
 lisp/gnorb-gnus.el  |   6 +-
 lisp/gnorb-org.el   |  35 +++++++++++-
 lisp/gnorb-utils.el | 159 +++++++++++++++++++++++++++++++++-------------------
 3 files changed, 137 insertions(+), 63 deletions(-)

diff --git a/lisp/gnorb-gnus.el b/lisp/gnorb-gnus.el
index bc2c3c4..9bae8e2 100644
--- a/lisp/gnorb-gnus.el
+++ b/lisp/gnorb-gnus.el
@@ -516,16 +516,16 @@ to t (it is, by default)."
     ;; `gnorb-restore-layout'.
     (delete-other-windows)
     (if id
-       (gnorb-trigger-todo-action arg id)
+       (gnorb-trigger-todo-action id)
       (if (and offer-heading
               (y-or-n-p (format "Trigger action on %s"
                                 (gnorb-pretty-outline offer-heading))))
-         (gnorb-trigger-todo-action arg offer-heading)
+         (gnorb-trigger-todo-action 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)))
+       (gnorb-trigger-todo-action)))
     (message
      "Insert a link to the message with org-insert-link (%s)"
      (key-description
diff --git a/lisp/gnorb-org.el b/lisp/gnorb-org.el
index 0967ccd..07f3d71 100644
--- a/lisp/gnorb-org.el
+++ b/lisp/gnorb-org.el
@@ -46,6 +46,39 @@ org-todo regardless of TODO type."
   :group 'gnorb-org
   :type 'hook)
 
+(defcustom gnorb-org-trigger-actions
+  '(("todo state" . todo)
+    ("take note" . note)
+    ("don't associate" . no-assoc)
+    ("only associate" . assoc)
+    ("capture to child" . cap-child)
+    ("capture to sibling" . cap-sib))
+  "List of potential actions that can be taken on headings.
+
+When triggering an Org heading after receiving or sending a
+message, this option lists the possible actions to take. Built-in
+actions include:
+
+todo state: Associate the message, and change TODO state.
+take note: Associate the message, and take a note.
+don't associate: Do nothing at all, don't connect the message and TODO.
+only associate: Associate the message with this heading, do nothing else.
+capture to child: Associate this message with a new child heading.
+capture to sibling: Associate this message with a new sibling heading.
+
+You can reorder this list or remove items as suits your workflow.
+The two \"capture\" options will use the value of
+`gnorb-gnus-new-todo-capture-key' to find the appropriate
+template.
+
+You can also add custom actions to the list. Actions should be a
+cons of a string tag and a symbol indicating a custom function.
+This function will be called on the heading in question, and
+passed a plist containing information about the message from
+which we're triggering."
+  :group 'gnorb-org
+  :type 'list)
+
 (defcustom gnorb-org-msg-id-key "GNORB_MSG_ID"
   "The name of the org property used to store the Message-IDs
   from relevant messages. This is no longer used, and will be
@@ -198,7 +231,7 @@ might have been in the outgoing message's headers and call
     (set-window-configuration gnorb-window-conf)
     (goto-char gnorb-return-marker))
   (dolist (id gnorb-message-org-ids)
-    (gnorb-trigger-todo-action nil id))
+    (gnorb-trigger-todo-action id))
   ;; this is a little unnecessary, but it may save grief
   (setq gnorb-gnus-message-info nil)
   (setq gnorb-message-org-ids nil))
diff --git a/lisp/gnorb-utils.el b/lisp/gnorb-utils.el
index 0456a55..52d5ced 100644
--- a/lisp/gnorb-utils.el
+++ b/lisp/gnorb-utils.el
@@ -39,14 +39,11 @@
   "Glue code between Gnus, Org, and BBDB."
   :tag "Gnorb")
 
-(defcustom gnorb-trigger-todo-default 'prompt
-  "What default action should be taken when triggering TODO
-  state-change from a message? Valid values are the symbols note
-  and todo, or prompt to pick one of the two."
-  :group 'gnorb
-  :type '(choice (const note)
-                (const todo)
-                (const prompt)))
+(make-obsolete-variable
+ 'gnorb-trigger-todo-default
+ "This variable has been superseded by
+`gnorb-org-trigger-actions'"
+ "September 8, 2014" 'set)
 
 (defun gnorb-prompt-for-bbdb-record ()
   "Prompt the user for a BBDB record."
@@ -118,60 +115,104 @@ and Gnus and BBDB maps."
     (set-window-configuration gnorb-window-conf)
     (goto-char gnorb-return-marker)))
 
-(defun gnorb-trigger-todo-action (arg &optional id)
+(defun gnorb-trigger-todo-action (&optional id)
   "Do the actual restore action. Two main things here. First: if
 we were in the agenda when this was called, then keep us in the
-agenda. Second: try to figure out the correct thing to do once we
-reach the todo. That depends on `gnorb-trigger-todo-default', and
-the prefix arg."
-  (let* ((agenda-p (eq major-mode 'org-agenda-mode))
-        (todo-func (if agenda-p
-                       'org-agenda-todo
-                     'org-todo))
-        (note-func (if agenda-p
-                       'org-agenda-add-note
-                     'org-add-note))
-        root-marker ret-dest-todo action)
-    (when (and (not agenda-p) id)
-      (org-id-goto id))
-    (setq root-marker (if agenda-p
-                         (org-get-at-bol 'org-hd-marker)
-                       (point-at-bol))
-         ret-dest-todo (org-entry-get
-                        root-marker "TODO"))
-    (gnorb-registry-make-entry
-     (plist-get gnorb-gnus-message-info :msg-id)
-     (plist-get gnorb-gnus-message-info :from)
-     (plist-get gnorb-gnus-message-info :subject)
-     (org-with-point-at root-marker
-       (org-id-get-create))
-     (plist-get gnorb-gnus-message-info :group))
-    (setq action (cond ((not
-                        (or (and ret-dest-todo
-                                 (null gnorb-org-mail-todos))
-                            (member ret-dest-todo gnorb-org-mail-todos)))
-                       'note)
-                      ((eq gnorb-trigger-todo-default 'prompt)
-                       (intern (completing-read
-                                "Take note, or trigger TODO state change? "
-                                '("note" "todo") nil t)))
-                      ((null arg)
-                       gnorb-trigger-todo-default)
-                      (t
-                       (if (eq gnorb-trigger-todo-default 'todo)
-                           'note
-                         'todo))))
-    (map-y-or-n-p
-     (lambda (a)
-       (format "Attach %s to heading? "
-              (file-name-nondirectory a)))
-     (lambda (a) (org-attach-attach a nil 'mv))
-     gnorb-gnus-capture-attachments
-     '("file" "files" "attach"))
+agenda. Then let the user choose an action from the value of
+`gnorb-org-trigger-actions'."
+  (let ((agenda-p (eq major-mode 'org-agenda-mode))
+       (action (cdr (assoc
+                     (org-completing-read
+                      "Action to take: "
+                      gnorb-org-trigger-actions nil t)
+                     gnorb-org-trigger-actions)))
+       (root-marker (make-marker)))
+    ;; Place the marker for the relevant TODO heading.
+    (cond (agenda-p
+          (setq root-marker
+                (copy-marker
+                 (org-get-at-bol 'org-hd-marker))))
+         ((derived-mode-p 'org-mode)
+          (move-marker root-marker (point-at-bol)))
+         (id
+          (save-excursion
+            (org-id-goto id)
+            (move-marker root-marker (point-at-bol)))))
+    ;; Query about attaching email attachments.
+    (org-with-point-at root-marker
+      (map-y-or-n-p
+       (lambda (a)
+        (format "Attach %s to heading? "
+                (file-name-nondirectory a)))
+       (lambda (a) (org-attach-attach a nil 'mv))
+       gnorb-gnus-capture-attachments
+       '("file" "files" "attach")))
     (setq gnorb-gnus-capture-attachments nil)
-    (if (eq action 'note)
-       (call-interactively note-func)
-      (call-interactively todo-func))))
+    (cl-labels
+       ((make-entry
+         (id)
+         (gnorb-registry-make-entry
+          (plist-get gnorb-gnus-message-info :msg-id)
+          (plist-get gnorb-gnus-message-info :from)
+          (plist-get gnorb-gnus-message-info :subject)
+          (org-with-point-at root-marker
+            id)
+          (plist-get gnorb-gnus-message-info :group))))
+      ;; Handle our action.
+      (cond ((eq action 'note)
+            (org-with-point-at root-marker
+              (make-entry (org-id-get-create))
+              (call-interactively 'org-add-note)))
+           ((eq action 'todo)
+            (if agenda-p
+                (progn
+                  (org-agenda-with-point-at-orig-entry
+                   nil
+                   (make-entry (org-id-get-create)))
+                  (call-interactively 'org-agenda-todo))
+              (org-with-point-at root-marker
+                (make-entry (org-id-get-create))
+                (call-interactively 'org-todo))))
+           ((eq action 'no-associate)
+            nil)
+           ((eq action 'associate)
+            (org-with-point-at root-marker
+              (make-entry (org-id-get-create))))
+           ;; We're going to capture a new heading
+           ((memq action '(cap-child cap-sib))
+            (cl-labels
+                ;; Prepare a function for returning the template
+                ;; location. The function is supposed to leave point
+                ;; at the spot the new entry should be made.
+                ((capture-location
+                  ()
+                  (org-end-of-line)
+                  (if (eq action 'cap-child)
+                      (org-insert-subheading 1)
+                    (org-insert-heading-after-current))
+                  ;; Delete heading stars, the capture template
+                  ;; will insert them.
+                  (org-toggle-heading)))
+              (let ((entry
+                      ;; Use the capture template the user has
+                      ;; specified for new email-related TODOs.
+                      (or (copy-sequence
+                           (assoc gnorb-gnus-new-todo-capture-key
+                                  org-capture-templates))
+                          (user-error
+                           "Please customize 
gnorb-gnus-new-todo-capture-key"))))
+                ;; Do surgery on that template so that it finds
+                ;; its location using our `capture-location' function.
+                (setf (nth 3 entry) '(function capture-location))
+                (let ((org-capture-entry entry))
+                  ;; When org-capture-entry is let-bound, the capture
+                  ;; process will use that template instead of prompting
+                  ;; the user.
+                  (call-interactively 'org-capture)))))
+           ((fboundp action)
+            (org-with-point-at root-marker
+              (make-entry (org-id-get-create))
+              (funcall action gnorb-gnus-message-info)))))))
 
 (defun gnorb-pretty-outline (id &optional kw)
   "Return pretty outline path of the Org heading indicated by ID.