From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from localhost (localhost [127.0.0.1]) by olra.theworths.org (Postfix) with ESMTP id 723CF429E31 for ; Fri, 16 Dec 2011 16:32:18 -0800 (PST) X-Virus-Scanned: Debian amavisd-new at olra.theworths.org X-Spam-Flag: NO X-Spam-Score: -0.8 X-Spam-Level: X-Spam-Status: No, score=-0.8 tagged_above=-999 required=5 tests=[DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, RCVD_IN_DNSWL_LOW=-0.7] autolearn=disabled Received: from olra.theworths.org ([127.0.0.1]) by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id CLgW0jZ2i8V9 for ; Fri, 16 Dec 2011 16:32:17 -0800 (PST) Received: from mail-ee0-f53.google.com (mail-ee0-f53.google.com [74.125.83.53]) (using TLSv1 with cipher RC4-SHA (128/128 bits)) (No client certificate requested) by olra.theworths.org (Postfix) with ESMTPS id 049CD429E30 for ; Fri, 16 Dec 2011 16:32:16 -0800 (PST) Received: by mail-ee0-f53.google.com with SMTP id d41so4346943eek.26 for ; Fri, 16 Dec 2011 16:32:16 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=schoepe.org; s=google; h=from:to:cc:subject:date:message-id:x-mailer:in-reply-to:references; bh=6WLk3lB0KgzEPW/HdNJ7zzRC/n8KncJo6WJZbcWxzRQ=; b=AJATkQiiT+sCHgo9R+Vz0HZSHN/Hhsi9TVus/uvzmzeHxDGHMw7RYiW8CcVGzngYTq 3ssrBGea0VUV169c+pH2M8TdV3bAX1bF66sLP9UL7Ws4brLRtLV+kBWTjLjjwzWpP22Y iB7XE+kWWU3g+7oiwETHOR7E50k2+XarTISrs= Received: by 10.213.26.77 with SMTP id d13mr738786ebc.132.1324081936547; Fri, 16 Dec 2011 16:32:16 -0800 (PST) Received: from localhost (dslb-088-069-153-158.pools.arcor-ip.net. [88.69.153.158]) by mx.google.com with ESMTPS id 39sm222289eei.1.2011.12.16.16.32.14 (version=TLSv1/SSLv3 cipher=OTHER); Fri, 16 Dec 2011 16:32:15 -0800 (PST) From: Daniel Schoepe 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> X-Mailer: git-send-email 1.7.7.3 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 X-BeenThere: notmuch@notmuchmail.org X-Mailman-Version: 2.1.13 Precedence: list List-Id: "Use and development of the notmuch mail system." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 17 Dec 2011 00:32:18 -0000 From: 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 | 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