[PATCH 2/3] emacs: Add thread-outline functionality

[Daniel Schoepe]

This patch adds some functionality to display the outline for threads
displayed by notmuch-show.  The entries in the outline buffer are
links to the corresponding message in the notmuch-show buffer.
---
 emacs/notmuch-lib.el  |    7 +++
 emacs/notmuch-show.el |  144 ++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 150 insertions(+), 1 deletions(-)

diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el
index a21dc14..6918218 100644
--- a/emacs/notmuch-lib.el
+++ b/emacs/notmuch-lib.el
@@ -91,9 +91,16 @@ the user hasn't set this variable with the old or new value."
   "Return the user.primary_email value (as a list) from the notmuch configuration."
   (split-string (notmuch-config-get "user.other_email") "\n"))
 
+(declare-function notmuch-show-outline-buffer-name  "notmuch-show" (&optional buf))
+
 (defun notmuch-kill-this-buffer ()
   "Kill the current buffer."
   (interactive)
+  ;; if we are in a notmuch-show buffer, kill the associated outline buffer, if any
+  (when (eq major-mode 'notmuch-show-mode)
+    (let ((outline-buf (get-buffer (notmuch-show-outline-buffer-name))))
+      (when outline-buf
+	(kill-buffer outline-buf))))
   (kill-buffer (current-buffer)))
 
 ;;
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index aecd35f..4f2a30e 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -107,6 +107,48 @@ same as that of the previous message."
   :group 'notmuch
   :type 'boolean)
 
+(defcustom notmuch-always-show-outline nil
+  "Should an outline of the thread always be opened?"
+  :group 'notmuch
+  :type 'boolean)
+
+(defcustom notmuch-outline-format
+  '(("author" . "%s")
+    "-"
+    ("reldate" . "%s"))
+  "Format in which thread-outline entries are displayed
+
+The following fields are supported: date, reldate, author,
+subject.  The list can also contain strings as elements which
+will be printed literally.  This variable can also be a function
+that will be given the message as returned by
+`notmuch-show-get-message-properties' and should return a
+string."
+  :group 'notmuch
+  :type '(repeat (choice (string :tag "string")
+			 (cons (choice (const :tag "author" "author")
+				       (const :tag "subject" "subject")
+				       (const :tag "date" "date")
+				       (const :tag "reldate" "reldate"))
+			       (string :tag "format specifier")))))
+
+(defface notmuch-outline '((t :inherit default))
+  "Face used to display (unhighlighted) lines in thread outlines"
+  :group 'notmuch)
+
+(defvar notmuch-outline-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map "n" 'next-line)
+    (define-key map "p" 'previous-line)
+    (define-key map "q" 'notmuch-kill-this-buffer)
+    map))
+
+(defvar notmuch-outline-button-map
+  (let ((map (copy-keymap button-map)))
+    (define-key map (kbd "<mouse-1>") 'push-button)
+    map)
+  "Keymap used for buttons in thread outlines.")
+
 (defmacro with-current-notmuch-show-message (&rest body)
   "Evaluate body with current buffer set to the text of current message"
   `(save-excursion
@@ -787,6 +829,103 @@ current buffer, if possible."
 (defvar notmuch-show-parent-buffer nil)
 (make-variable-buffer-local 'notmuch-show-parent-buffer)
 
+(defun notmuch-goto-marker (m)
+"Open corresponding buffer and go to marker position in another window."
+  (switch-to-buffer-other-window (marker-buffer m))
+  (goto-char (marker-position m)))
+
+(defun notmuch-show-message-is-visible ()
+  "Return t if current message is visible."
+  (plist-get (notmuch-show-get-message-properties) :message-visible))
+
+(defun notmuch-outline-render-format (format)
+  "Render FORMAT, interpreted as described for `notmuch-outline-format'"
+  (if (functionp format)
+      (funcall format (notmuch-show-get-message-properties))
+    (mapconcat
+     (lambda (entry)
+       (if (consp entry)
+	   (let ((key (car entry))
+		 (fmt (cdr entry)))
+	     (cond
+	      ((equal key "author") (format fmt (notmuch-show-get-from)))
+	      ((equal key "date") (format fmt (notmuch-show-get-date)))
+	      ((equal key "subject") (format fmt (notmuch-show-get-subject)))
+	      ((equal key "reldate")
+	       (format fmt (plist-get (notmuch-show-get-message-properties)
+				      :date_relative)))
+	      (t (concat "Unknown field: " (car entry)))))
+	 entry))
+     format
+     " ")))
+
+(defun notmuch-show-outline-buffer-name (&optional buf)
+  "Return the name of the outline buffer for BUF."
+  (concat (buffer-name buf) " - outline"))
+
+(defun notmuch-show-has-outline ()
+  "Returns non-nil if there is an outline for the current thread."
+  (get-buffer (notmuch-show-outline-buffer-name)))
+
+(defun notmuch-outline-message ()
+  "Outline the message under the point.
+
+Expects the point to be on the beginning of the first line of the message."
+  (lexical-let* ((extent (notmuch-show-message-extent))
+		 (buffer-name (notmuch-show-outline-buffer-name))
+		 (goto-message (lambda (btn)
+				 (select-window (get-buffer-window buffer-name))
+				 (when (marker-buffer (car extent))
+				   (notmuch-goto-marker (car extent))
+				   (when (not (notmuch-show-message-is-visible))
+				     (notmuch-show-toggle-message))))))
+    (let ((indentation 0)
+	  (button-label (notmuch-outline-render-format
+			 notmuch-outline-format)))
+      ;; this is not very robust if the output of notmuch-show changes
+      (while (string-equal (thing-at-point 'char) " ")
+	(incf indentation)
+	(forward-char))
+      (loop for i from 1 to indentation do
+	    (princ " ")) ;; somewhat ugly
+      (princ button-label)
+      (with-current-buffer standard-output
+	(make-button (line-beginning-position) (line-end-position)
+		     'action goto-message
+		     'keymap notmuch-outline-button-map
+		     'face 'notmuch-outline)
+	(put-text-property (line-beginning-position) (line-end-position)
+			   :message-start (car extent)))
+      (princ "\n"))))
+
+(defun notmuch-show-outline ()
+  "Generate an outline for the current buffer.
+
+This function must only be called in a notmuch-show buffer."
+  (interactive)
+  (let ((buf-name (notmuch-show-outline-buffer-name)))
+    ;; In the extremly rare case that the user might have been doing
+    ;; work in a buffer with the exact same name of the outline buffer
+    ;; we don't want to kill that buffer
+    (kill-buffer-if-not-modified buf-name)
+    (save-excursion
+      (with-output-to-temp-buffer buf-name
+	(with-current-buffer buf-name
+	  (notmuch-outline-mode))
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (notmuch-outline-message)
+	  (goto-char (marker-position (cdr (notmuch-show-message-extent)))))
+	(with-current-buffer buf-name
+	  (setq buffer-read-only t))))))
+    
+(defun notmuch-outline-mode ()
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map notmuch-outline-mode-map)
+  (setq major-mode 'notmuch-show-outline-mode
+	mode-name "notmuch-show-outline"))
+
 ;;;###autoload
 (defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name crypto-switch)
   "Run \"notmuch show\" with the given thread ID and display results.
@@ -846,7 +985,9 @@ function is used. "
     ;; Set the header line to the subject of the first open message.
     (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))
 
-    (notmuch-show-mark-read)))
+    (notmuch-show-mark-read)
+    (when notmuch-always-show-outline
+      (notmuch-show-outline))))
 
 (defvar notmuch-show-stash-map
   (let ((map (make-sparse-keymap)))
@@ -888,6 +1029,7 @@ function is used. "
 	(define-key map "P" 'notmuch-show-previous-message)
 	(define-key map "n" 'notmuch-show-next-open-message)
 	(define-key map "p" 'notmuch-show-previous-open-message)
+	(define-key map "o" 'notmuch-show-outline)
 	(define-key map (kbd "DEL") 'notmuch-show-rewind)
 	(define-key map " " 'notmuch-show-advance-and-archive)
 	(define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all)
-- 
1.7.5.4