From: Daniel Schoepe <daniel@schoepe.org>
To: notmuch@notmuchmail.org
Subject: [PATCH v3 1/2] emacs: Add thread-outline functionality
Date: Sat, 17 Dec 2011 01:32:08 +0100
Message-Id: <1324081929-23025-2-git-send-email-daniel@schoepe.org>
In-Reply-To: <1324081929-23025-1-git-send-email-daniel@schoepe.org>
References: <1307921480-17130-1-git-send-email-daniel.schoepe@googlemail.com>
	<1324081929-23025-1-git-send-email-daniel@schoepe.org>
Cc: Daniel Schoepe <daniel.schoepe@googlemail.com>
Precedence: list

From: Daniel Schoepe <daniel.schoepe@googlemail.com>

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  |   12 +++
 emacs/notmuch-show.el |  195 ++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 206 insertions(+), 1 deletions(-)

diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el
index 0f856bf..a8be8b1 100644
--- a/emacs/notmuch-lib.el
+++ b/emacs/notmuch-lib.el
@@ -43,6 +43,10 @@
 (defvar notmuch-folders nil
   "Deprecated name for what is now known as `notmuch-saved-searches'.")
 
+(defvar notmuch-show-outline-buffer nil
+  "Outline buffer associated with a notmuch-show buffer.")
+(make-variable-buffer-local 'notmuch-show-outline-buffer)
+
 (defun notmuch-saved-searches ()
   "Common function for querying the notmuch-saved-searches variable.
 
@@ -91,9 +95,17 @@ the user hasn't set this variable with the old or new value."
   "Return the user.other_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 notmuch-show-outline-buffer))
+      (when outline-buf
+	(mapc #'delete-window (get-buffer-window-list outline-buf))
+	(kill-buffer outline-buf))))
   (kill-buffer (current-buffer)))
 
 ;;
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 63b01e5..e7ce811 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -107,6 +107,57 @@ indentation."
   :group 'notmuch
   :type 'boolean)
 
+(defcustom notmuch-always-show-outline nil
+  "Always open an outline buffer when viewing a thread?"
+  :group 'notmuch
+  :type 'boolean)
+
+(defcustom notmuch-outline-format
+  (list "%a - %r")
+  "Format used for thread-outline lines.
+
+This is a list supporting the following types of elements:
+For a symbol, its value is used if non-nil.
+A string is inserted verbatim with the exception
+ of the following %-constructs:
+ %a - Author
+ %d - Date
+ %s - Subject
+ %r - Relative date
+For a list of the form `(:eval FORM)', form is evaluated
+ and its result displayed.
+
+The variables author, subject, date and reldate will be bound to
+their respective values when this is interpreted, and can be
+used in (:eval ..)-elements or directly as symbols."
+  :group 'notmuch
+  :type
+  '(repeat (choice (const :tag "Author" author)
+		   (const :tag "Date" date)
+		   (const :tag "Relative date" reldate)
+		   (string :tag "Format string")
+		   (list :tag "Custom expression (will be evaluated when rendering)"
+			 (const :tag "" :eval)
+			 sexp))))
+
+(defface notmuch-outline '((t :inherit default))
+  "Face used to display (unhighlighted) lines in thread outlines"
+  :group 'notmuch)
+
+(defface notmuch-outline-highlighted
+  '((((class color) (background light)) (:background "#f0f0f0"))
+    (((class color) (background dark)) (:background "#303030")))
+  "Face used to display highlight the current message in the outline buffer"
+  :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" 'kill-buffer-and-window)
+    (define-key map "x" 'kill-buffer-and-window)
+    map))
+
 (defmacro with-current-notmuch-show-message (&rest body)
   "Evaluate body with current buffer set to the text of current message"
   `(save-excursion
@@ -747,12 +798,27 @@ current buffer, if possible."
     ;; message.
     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
 
+    ;; Save the indentation depth, used by `notmuch-show-outline'
+    (put-text-property message-start message-end :notmuch-depth depth)
+
     (let ((headers-overlay (make-overlay headers-start headers-end))
           (invis-specs (list headers-invis-spec message-invis-spec)))
       (overlay-put headers-overlay 'invisible invis-specs)
       (overlay-put headers-overlay 'priority 10))
     (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
 
+    ;; Add callbacks that update the outline buffer when moving between messages.
+    ;; Due to the mindbogglingly absurd semantics of point-entered and point-left
+    ;; this function will will be run up to _four_ times when moving between messages:
+    (let ((goto-msg-func
+	   `(lambda (before after)
+	      (if (and (>= after (marker-position ,message-start))
+		       (< after (marker-position ,message-end)))
+		  (notmuch-outline-highlight-message ,message-start)))))
+      (add-text-properties message-start message-end
+			   (list 'point-entered goto-msg-func
+				 'point-left goto-msg-func)))
+
     ;; Save the properties for this message. Currently this saves the
     ;; entire message (augmented it with other stuff), which seems
     ;; like overkill. We might save a reduced subset (for example, not
@@ -808,6 +874,130 @@ a corresponding notmuch search."
 			'help-echo "Mouse-1, RET: search for this message"
 			'face goto-address-mail-face))))
 
+(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, as described in `notmuch-outline-format'"
+  (let ((author (notmuch-show-get-from))
+	(date (notmuch-show-get-date))
+	(subject (notmuch-show-get-subject))
+	(reldate (plist-get (notmuch-show-get-message-properties)
+			    :date_relative)))
+    (mapconcat (lambda (elem)
+		 (cond
+		  ((symbolp elem) (or (symbol-value elem) ""))
+		  ((stringp elem)
+		   (let ((str elem))
+		     (mapc (lambda (subst)
+			     (setq str
+				   (replace-regexp-in-string (car subst)
+							     (cdr subst)
+							     str)))
+			   `(("%a" . ,author)
+			     ("%s" . ,subject)
+			     ("%d" . ,date)
+			     ("%r" . ,reldate)))
+		     str))
+		  ((and (listp elem) (eq (car elem) :eval))
+		   (eval (second elem)))
+		  (t (error "Unknown element in `notmuch-outline-format': %S" elem))))
+	       format
+	       "")))
+
+(defun notmuch-outline-highlight-message (msg-start)
+  "Highlight message starting at MSG-START.
+
+The highlighting will take place in the outline buffer, while
+MSG-START refers to a position in the corresponding notmuch-show buffer."
+  (when (buffer-live-p notmuch-show-outline-buffer)
+    (with-current-buffer notmuch-show-outline-buffer
+      (remove-overlays nil nil 'current-message t)
+      (save-excursion
+	(goto-char (point-min))
+	(while (and (not (equal (get-text-property (point) :message-start)
+			    msg-start))
+		  (not (eobp)))
+	  (forward-line))
+	(unless (eobp)
+	  (let ((ovl
+		 (make-overlay (line-beginning-position)
+			       (line-end-position))))
+	  (overlay-put ovl 'face 'notmuch-outline-highlighted)
+	  (overlay-put ovl 'current-message t)))))))
+
+(defun notmuch-show-create-outline-buffer (&optional buf)
+  "Create an outline buffer for show-buffer BUF.
+
+Returns the created buffer."
+
+  (generate-new-buffer (concat (buffer-name buf) " - outline")))
+
+(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*
+      ((msg-start (car (notmuch-show-message-extent)))
+       (outline-buf notmuch-show-outline-buffer)
+       (goto-message
+	(lambda (btn)
+	  (let ((win (get-buffer-window outline-buf)))
+	    (when win
+	      (select-window (get-buffer-window outline-buf))
+	      (when (marker-buffer msg-start)
+		(switch-to-buffer-other-window (marker-buffer msg-start))
+		(notmuch-outline-highlight-message msg-start)
+		(goto-char (marker-position msg-start))
+		(when (not (notmuch-show-message-is-visible))
+		  (notmuch-show-toggle-message))))))))
+    (let ((indentation (or (get-text-property (point) :notmuch-depth) 0))
+	  (button-label (notmuch-outline-render-format
+			 notmuch-outline-format)))
+      (with-current-buffer outline-buf
+	(indent-to indentation)
+	(insert button-label)
+	(make-text-button (line-beginning-position) (line-end-position)
+			  'action goto-message
+			  'follow-link t
+			  'help-echo "mouse-1, RET: show this message"
+			  'face 'notmuch-outline)
+	(put-text-property (line-beginning-position) (line-end-position)
+			   :message-start msg-start)
+	(insert "\n")))))
+
+(defun notmuch-show-outline ()
+  "Generate an outline for the current buffer.
+
+This function must only be called in a notmuch-show buffer."
+  (interactive)
+  (if (buffer-live-p notmuch-show-outline-buffer)
+      (switch-to-buffer-other-window notmuch-show-outline-buffer)
+    (let ((outline-buf (notmuch-show-create-outline-buffer))
+	  (inhibit-point-motion-hooks t))
+      (setq notmuch-show-outline-buffer outline-buf)
+      (save-excursion
+	(with-current-buffer outline-buf
+	  (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 outline-buf
+	  (setq buffer-read-only t)))
+      (notmuch-outline-highlight-message (car (notmuch-show-message-extent)))
+      (let ((win (selected-window)))
+	(switch-to-buffer-other-window outline-buf)
+	(select-window win)))))
+
+(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.
@@ -881,7 +1071,9 @@ buffer."
     ;; 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))))
 
 (defun notmuch-show-refresh-view (&optional crypto-switch)
   "Refresh the current view (with crypto switch if prefix given).
@@ -941,6 +1133,7 @@ thread id.  If a prefix is given, crypto processing is toggled."
 	(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.7.3