[PATCH v4 1/2] emacs: Add thread-outline functionality
Daniel Schoepe
daniel at schoepe.org
Fri Dec 16 16:35:25 PST 2011
From: Daniel Schoepe <daniel.schoepe at 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
More information about the notmuch
mailing list