From bb5fb8ea25b9f0c68110917ba514e6292a114c6f Mon Sep 17 00:00:00 2001
From: Mark Walters <markwalters1009@gmail.com>
Date: Tue, 29 Oct 2013 22:55:30 +0000
Subject: emacs: move notmuch-tree from contrib to mainline

---
 emacs/notmuch-tree.el | 946 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 946 insertions(+)
 create mode 100644 emacs/notmuch-tree.el

(limited to 'emacs')

diff --git a/emacs/notmuch-tree.el b/emacs/notmuch-tree.el
new file mode 100644
index 00000000..d3330a06
--- /dev/null
+++ b/emacs/notmuch-tree.el
@@ -0,0 +1,946 @@
+;; notmuch-tree.el --- displaying notmuch forests.
+;;
+;; Copyright © Carl Worth
+;; Copyright © David Edmondson
+;; Copyright © Mark Walters
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+;;          Mark Walters <markwalters1009@gmail.com>
+
+(require 'mail-parse)
+
+(require 'notmuch-lib)
+(require 'notmuch-query)
+(require 'notmuch-show)
+(require 'notmuch-tag)
+(require 'notmuch-parser)
+(require 'notmuch) ;; XXX ATM, as notmuch-search-mode-map is defined here
+
+(eval-when-compile (require 'cl))
+(declare-function notmuch-search "notmuch" (&optional query oldest-first target-thread target-line))
+(declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
+(declare-function notmuch-read-query "notmuch" (prompt))
+(declare-function notmuch-search-find-thread-id "notmuch" (&optional bare))
+(declare-function notmuch-search-find-subject "notmuch" ())
+
+;; the following variable is defined in notmuch.el
+(defvar notmuch-search-query-string)
+
+(defgroup notmuch-tree nil
+  "Showing message and thread structure."
+  :group 'notmuch)
+
+(defcustom notmuch-tree-show-out nil
+  "View selected messages in new window rather than split-pane."
+  :type 'boolean
+  :group 'notmuch-tree)
+
+(defcustom notmuch-tree-result-format
+  `(("date" . "%12s  ")
+    ("authors" . "%-20s")
+    ((("tree" . "%s")("subject" . "%s")) ." %-54s ")
+    ("tags" . "(%s)"))
+  "Result formatting for Tree view. Supported fields are: date,
+        authors, subject, tree, tags.  Tree means the thread tree
+        box graphics. The field may also be a list in which case
+        the formatting rules are applied recursively and then the
+        output of all the fields in the list is inserted
+        according to format-string.
+
+Note the author string should not contain
+        whitespace (put it in the neighbouring fields instead).
+        For example:
+        (setq notmuch-tree-result-format \(\(\"authors\" . \"%-40s\"\)
+                                             \(\"subject\" . \"%s\"\)\)\)"
+  :type '(alist :key-type (string) :value-type (string))
+  :group 'notmuch-tree)
+
+;; Faces for messages that match the query.
+(defface notmuch-tree-match-date-face
+  '((t :inherit default))
+  "Face used in tree mode for the date in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-match-author-face
+  '((((class color)
+      (background dark))
+     (:foreground "OliveDrab1"))
+    (((class color)
+      (background light))
+     (:foreground "dark blue"))
+    (t
+     (:bold t)))
+  "Face used in tree mode for the date in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-match-subject-face
+  '((t :inherit default))
+  "Face used in tree mode for the subject in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-match-tree-face
+  '((t :inherit default))
+  "Face used in tree mode for the thread tree block graphics in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-match-tag-face
+  '((((class color)
+      (background dark))
+     (:foreground "OliveDrab1"))
+    (((class color)
+      (background light))
+     (:foreground "navy blue" :bold t))
+    (t
+     (:bold t)))
+  "Face used in tree mode for tags in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+;; Faces for messages that do not match the query.
+(defface notmuch-tree-no-match-date-face
+  '((t (:foreground "gray")))
+  "Face used in tree mode for non-matching dates."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-subject-face
+  '((t (:foreground "gray")))
+  "Face used in tree mode for non-matching subjects."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-tree-face
+  '((t (:foreground "gray")))
+  "Face used in tree mode for the thread tree block graphics in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-author-face
+  '((t (:foreground "gray")))
+  "Face used in tree mode for the date in messages matching the query."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-tag-face
+  '((t (:foreground "gray")))
+  "Face used in tree mode face for non-matching tags."
+  :group 'notmuch-tree
+  :group 'notmuch-faces)
+
+(defvar notmuch-tree-previous-subject
+  "The subject of the most recent result shown during the async display")
+(make-variable-buffer-local 'notmuch-tree-previous-subject)
+
+(defvar notmuch-tree-basic-query nil
+  "A buffer local copy of argument query to the function notmuch-tree")
+(make-variable-buffer-local 'notmuch-tree-basic-query)
+
+(defvar notmuch-tree-query-context nil
+  "A buffer local copy of argument query-context to the function notmuch-tree")
+(make-variable-buffer-local 'notmuch-tree-query-context)
+
+(defvar notmuch-tree-target-msg nil
+  "A buffer local copy of argument target to the function notmuch-tree")
+(make-variable-buffer-local 'notmuch-tree-target-msg)
+
+(defvar notmuch-tree-open-target nil
+  "A buffer local copy of argument open-target to the function notmuch-tree")
+(make-variable-buffer-local 'notmuch-tree-open-target)
+
+(defvar notmuch-tree-message-window nil
+  "The window of the message pane.
+
+It is set in both the tree buffer and the child show buffer. It
+is used to try and close the message pane when quitting tree view
+or the child show buffer.")
+(make-variable-buffer-local 'notmuch-tree-message-window)
+(put 'notmuch-tree-message-window 'permanent-local t)
+
+(defvar notmuch-tree-message-buffer nil
+  "The buffer name of the show buffer in the message pane.
+
+This is used to try and make sure we don't close the message pane
+if the user has loaded a different buffer in that window.")
+(make-variable-buffer-local 'notmuch-tree-message-buffer)
+(put 'notmuch-tree-message-buffer 'permanent-local t)
+
+(defun notmuch-tree-to-message-pane (func)
+  "Execute FUNC in message pane.
+
+This function returns a function (so can be used as a keybinding)
+which executes function FUNC in the message pane if it is
+open (if the message pane is closed it does nothing)."
+  `(lambda ()
+      ,(concat "(In message pane) " (documentation func t))
+     (interactive)
+     (when (window-live-p notmuch-tree-message-window)
+       (with-selected-window notmuch-tree-message-window
+	 (call-interactively #',func)))))
+
+(defun notmuch-tree-button-activate (&optional button)
+  "Activate BUTTON or button at point
+
+This function does not give an error if there is no button."
+  (interactive)
+  (let ((button (or button (button-at (point)))))
+    (when button (button-activate button))))
+
+(defun notmuch-tree-close-message-pane-and (func)
+  "Close message pane and execute FUNC.
+
+This function returns a function (so can be used as a keybinding)
+which closes the message pane if open and then executes function
+FUNC."
+  `(lambda ()
+      ,(concat "(Close message pane and) " (documentation func t))
+     (interactive)
+     (notmuch-tree-close-message-window)
+     (call-interactively #',func)))
+
+(defvar notmuch-tree-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map notmuch-common-keymap)
+    ;; The following override the global keymap.
+    ;; Override because we want to close message pane first.
+    (define-key map "?" (notmuch-tree-close-message-pane-and #'notmuch-help))
+    ;; Override because we first close message pane and then close tree buffer.
+    (define-key map "q" 'notmuch-tree-quit)
+    ;; Override because we close message pane after the search query is entered.
+    (define-key map "s" 'notmuch-tree-to-search)
+    ;; Override because we want to close message pane first.
+    (define-key map "m" (notmuch-tree-close-message-pane-and #'notmuch-mua-new-mail))
+
+    ;; these use notmuch-show functions directly
+    (define-key map "|" 'notmuch-show-pipe-message)
+    (define-key map "w" 'notmuch-show-save-attachments)
+    (define-key map "v" 'notmuch-show-view-all-mime-parts)
+    (define-key map "c" 'notmuch-show-stash-map)
+
+    ;; these apply to the message pane
+    (define-key map (kbd "M-TAB") (notmuch-tree-to-message-pane #'notmuch-show-previous-button))
+    (define-key map (kbd "<backtab>")  (notmuch-tree-to-message-pane #'notmuch-show-previous-button))
+    (define-key map (kbd "TAB") (notmuch-tree-to-message-pane #'notmuch-show-next-button))
+    (define-key map "e" (notmuch-tree-to-message-pane #'notmuch-tree-button-activate))
+
+    ;; bindings from show (or elsewhere) but we close the message pane first.
+    (define-key map "f" (notmuch-tree-close-message-pane-and #'notmuch-show-forward-message))
+    (define-key map "r" (notmuch-tree-close-message-pane-and #'notmuch-show-reply-sender))
+    (define-key map "R" (notmuch-tree-close-message-pane-and #'notmuch-show-reply))
+    (define-key map "V" (notmuch-tree-close-message-pane-and #'notmuch-show-view-raw-message))
+
+    ;; The main tree view bindings
+    (define-key map (kbd "RET") 'notmuch-tree-show-message)
+    (define-key map [mouse-1] 'notmuch-tree-show-message)
+    (define-key map "x" 'notmuch-tree-quit)
+    (define-key map "A" 'notmuch-tree-archive-thread)
+    (define-key map "a" 'notmuch-tree-archive-message-then-next)
+    (define-key map "=" 'notmuch-tree-refresh-view)
+    (define-key map "z" 'notmuch-tree-to-tree)
+    (define-key map "n" 'notmuch-tree-next-matching-message)
+    (define-key map "p" 'notmuch-tree-prev-matching-message)
+    (define-key map "N" 'notmuch-tree-next-message)
+    (define-key map "P" 'notmuch-tree-prev-message)
+    (define-key map (kbd "M-p") 'notmuch-tree-prev-thread)
+    (define-key map (kbd "M-n") 'notmuch-tree-next-thread)
+    (define-key map "-" 'notmuch-tree-remove-tag)
+    (define-key map "+" 'notmuch-tree-add-tag)
+    (define-key map "*" 'notmuch-tree-tag-thread)
+    (define-key map " " 'notmuch-tree-scroll-or-next)
+    (define-key map "b" 'notmuch-tree-scroll-message-window-back)
+    map))
+(fset 'notmuch-tree-mode-map notmuch-tree-mode-map)
+
+(defun notmuch-tree-get-message-properties ()
+  "Return the properties of the current message as a plist.
+
+Some useful entries are:
+:headers - Property list containing the headers :Date, :Subject, :From, etc.
+:tags - Tags for this message"
+  (save-excursion
+    (beginning-of-line)
+    (get-text-property (point) :notmuch-message-properties)))
+
+;; XXX This should really be a lib function but we are trying to
+;; reduce impact on the code base.
+(defun notmuch-show-get-prop (prop &optional props)
+  "This is a tree view overridden version of notmuch-show-get-prop
+
+It gets property PROP from PROPS or, if PROPS is nil, the current
+message in either tree or show. This means that several functions
+in notmuch-show now work unchanged in tree as they just need the
+correct message properties."
+  (let ((props (or props
+		   (cond ((eq major-mode 'notmuch-show-mode)
+			  (notmuch-show-get-message-properties))
+			 ((eq major-mode 'notmuch-tree-mode)
+			  (notmuch-tree-get-message-properties))))))
+    (plist-get props prop)))
+
+(defun notmuch-tree-set-message-properties (props)
+  (save-excursion
+    (beginning-of-line)
+    (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
+
+(defun notmuch-tree-set-prop (prop val &optional props)
+  (let ((inhibit-read-only t)
+	(props (or props
+		   (notmuch-tree-get-message-properties))))
+    (plist-put props prop val)
+    (notmuch-tree-set-message-properties props)))
+
+(defun notmuch-tree-get-prop (prop &optional props)
+  (let ((props (or props
+		   (notmuch-tree-get-message-properties))))
+    (plist-get props prop)))
+
+(defun notmuch-tree-set-tags (tags)
+  "Set the tags of the current message."
+  (notmuch-tree-set-prop :tags tags))
+
+(defun notmuch-tree-get-tags ()
+  "Return the tags of the current message."
+  (notmuch-tree-get-prop :tags))
+
+(defun notmuch-tree-get-message-id ()
+  "Return the message id of the current message."
+  (let ((id (notmuch-tree-get-prop :id)))
+    (if id
+	(notmuch-id-to-query id)
+      nil)))
+
+(defun notmuch-tree-get-match ()
+  "Return whether the current message is a match."
+  (interactive)
+  (notmuch-tree-get-prop :match))
+
+(defun notmuch-tree-refresh-result ()
+  "Redisplay the current message line.
+
+This redisplays the current line based on the messages
+properties (as they are now). This is used when tags are
+updated."
+  (let ((init-point (point))
+	(end (line-end-position))
+	(msg (notmuch-tree-get-message-properties))
+	(inhibit-read-only t))
+    (beginning-of-line)
+    ;; This is a little tricky: we override
+    ;; notmuch-tree-previous-subject to get the decision between
+    ;; ... and a subject right and it stops notmuch-tree-insert-msg
+    ;; from overwriting the buffer local copy of
+    ;; notmuch-tree-previous-subject if this is called while the
+    ;; buffer is displaying.
+    (let ((notmuch-tree-previous-subject (notmuch-tree-get-prop :previous-subject)))
+      (delete-region (point) (1+ (line-end-position)))
+      (notmuch-tree-insert-msg msg))
+    (let ((new-end (line-end-position)))
+      (goto-char (if (= init-point end)
+		     new-end
+		   (min init-point (- new-end 1)))))))
+
+(defun notmuch-tree-tag-update-display (&optional tag-changes)
+  "Update display for TAG-CHANGES to current message.
+
+Does NOT change the database."
+  (let* ((current-tags (notmuch-tree-get-tags))
+	 (new-tags (notmuch-update-tags current-tags tag-changes)))
+    (unless (equal current-tags new-tags)
+      (notmuch-tree-set-tags new-tags)
+      (notmuch-tree-refresh-result))))
+
+(defun notmuch-tree-tag (tag-changes)
+  "Change tags for the current message"
+  (interactive
+   (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message")))
+  (notmuch-tag (notmuch-tree-get-message-id) tag-changes)
+  (notmuch-tree-tag-update-display tag-changes))
+
+(defun notmuch-tree-add-tag (tag-changes)
+  "Same as `notmuch-tree-tag' but sets initial input to '+'."
+  (interactive
+   (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+")))
+  (notmuch-tree-tag tag-changes))
+
+(defun notmuch-tree-remove-tag (tag-changes)
+  "Same as `notmuch-tree-tag' but sets initial input to '-'."
+  (interactive
+   (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-")))
+  (notmuch-tree-tag tag-changes))
+
+;; The next two functions close the message window before calling
+;; notmuch-search or notmuch-tree but they do so after the user has
+;; entered the query (in case the user was basing the query on
+;; something in the message window).
+
+(defun notmuch-tree-to-search ()
+  "Run \"notmuch search\" with the given `query' and display results."
+  (interactive)
+  (let ((query (notmuch-read-query "Notmuch search: ")))
+    (notmuch-tree-close-message-window)
+    (notmuch-search query)))
+
+(defun notmuch-tree-to-tree ()
+  "Run a query and display results in Tree view"
+  (interactive)
+  (let ((query (notmuch-read-query "Notmuch tree view search: ")))
+    (notmuch-tree-close-message-window)
+    (notmuch-tree query)))
+
+;; This function should be in notmuch-show.el but be we trying to
+;; minimise impact on the rest of the codebase.
+(defun notmuch-tree-from-show-current-query ()
+  "Call notmuch tree with the current query"
+  (interactive)
+  (notmuch-tree notmuch-show-thread-id
+		notmuch-show-query-context
+		(notmuch-show-get-message-id)))
+
+;; This function should be in notmuch.el but be we trying to minimise
+;; impact on the rest of the codebase.
+(defun notmuch-tree-from-search-current-query ()
+  "Call notmuch tree with the current query"
+  (interactive)
+  (notmuch-tree notmuch-search-query-string))
+
+;; This function should be in notmuch.el but be we trying to minimise
+;; impact on the rest of the codebase.
+(defun notmuch-tree-from-search-thread ()
+  "Show the selected thread with notmuch-tree"
+  (interactive)
+  (notmuch-tree (notmuch-search-find-thread-id)
+                notmuch-search-query-string
+		nil
+                (notmuch-prettify-subject (notmuch-search-find-subject))
+		t))
+
+(defun notmuch-tree-message-window-kill-hook ()
+  "Close the message pane when exiting the show buffer."
+  (let ((buffer (current-buffer)))
+    (when (and (window-live-p notmuch-tree-message-window)
+	       (eq (window-buffer notmuch-tree-message-window) buffer))
+      ;; We do not want an error if this is the sole window in the
+      ;; frame and I do not know how to test for that in emacs pre
+      ;; 24. Hence we just ignore-errors.
+      (ignore-errors
+	(delete-window notmuch-tree-message-window)))))
+
+(defun notmuch-tree-show-message-in ()
+  "Show the current message (in split-pane)."
+  (interactive)
+  (let ((id (notmuch-tree-get-message-id))
+	(inhibit-read-only t)
+	buffer)
+    (when id
+      ;; We close and reopen the window to kill off un-needed buffers
+      ;; this might cause flickering but seems ok.
+      (notmuch-tree-close-message-window)
+      (setq notmuch-tree-message-window
+	    (split-window-vertically (/ (window-height) 4)))
+      (with-selected-window notmuch-tree-message-window
+	;; Since we are only displaying one message do not indent.
+	(let ((notmuch-show-indent-messages-width 0)
+	      (notmuch-show-only-matching-messages t))
+	  (setq buffer (notmuch-show id))))
+      ;; We need the `let' as notmuch-tree-message-window is buffer local.
+      (let ((window notmuch-tree-message-window))
+	(with-current-buffer buffer
+	  (setq notmuch-tree-message-window window)
+	  (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook)))
+      (when notmuch-show-mark-read-tags
+	(notmuch-tree-tag-update-display notmuch-show-mark-read-tags))
+      (setq notmuch-tree-message-buffer buffer))))
+
+(defun notmuch-tree-show-message-out ()
+  "Show the current message (in whole window)."
+  (interactive)
+  (let ((id (notmuch-tree-get-message-id))
+	(inhibit-read-only t)
+	buffer)
+    (when id
+      ;; We close the window to kill off un-needed buffers.
+      (notmuch-tree-close-message-window)
+      (notmuch-show id))))
+
+(defun notmuch-tree-show-message (arg)
+  "Show the current message.
+
+Shows in split pane or whole window according to value of
+`notmuch-tree-show-out'. A prefix argument reverses the choice."
+  (interactive "P")
+  (if (or (and notmuch-tree-show-out  (not arg))
+	  (and (not notmuch-tree-show-out) arg))
+      (notmuch-tree-show-message-out)
+    (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-scroll-message-window ()
+  "Scroll the message window (if it exists)"
+  (interactive)
+  (when (window-live-p notmuch-tree-message-window)
+    (with-selected-window notmuch-tree-message-window
+      (if (pos-visible-in-window-p (point-max))
+	  t
+	(scroll-up)))))
+
+(defun notmuch-tree-scroll-message-window-back ()
+  "Scroll the message window back(if it exists)"
+  (interactive)
+  (when (window-live-p notmuch-tree-message-window)
+    (with-selected-window notmuch-tree-message-window
+      (if (pos-visible-in-window-p (point-min))
+	  t
+	(scroll-down)))))
+
+(defun notmuch-tree-scroll-or-next ()
+  "Scroll the message window. If it at end go to next message."
+  (interactive)
+  (when (notmuch-tree-scroll-message-window)
+    (notmuch-tree-next-matching-message)))
+
+(defun notmuch-tree-quit ()
+  "Close the split view or exit tree."
+  (interactive)
+  (unless (notmuch-tree-close-message-window)
+    (kill-buffer (current-buffer))))
+
+(defun notmuch-tree-close-message-window ()
+  "Close the message-window. Return t if close succeeds."
+  (interactive)
+  (when (and (window-live-p notmuch-tree-message-window)
+	     (eq (window-buffer notmuch-tree-message-window) notmuch-tree-message-buffer))
+    (delete-window notmuch-tree-message-window)
+    (unless (get-buffer-window-list notmuch-tree-message-buffer)
+      (kill-buffer notmuch-tree-message-buffer))
+    t))
+
+(defun notmuch-tree-archive-message (&optional unarchive)
+  "Archive the current message.
+
+Archive the current message by applying the tag changes in
+`notmuch-archive-tags' to it. If a prefix argument is given, the
+message will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed."
+  (interactive "P")
+  (when notmuch-archive-tags
+    (notmuch-tree-tag (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+(defun notmuch-tree-archive-message-then-next (&optional unarchive)
+  "Archive the current message and move to next matching message."
+  (interactive "P")
+  (notmuch-tree-archive-message unarchive)
+  (notmuch-tree-next-matching-message))
+
+(defun notmuch-tree-next-message ()
+  "Move to next message."
+  (interactive)
+  (forward-line)
+  (when (window-live-p notmuch-tree-message-window)
+    (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-prev-message ()
+  "Move to previous message."
+  (interactive)
+  (forward-line -1)
+  (when (window-live-p notmuch-tree-message-window)
+    (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-prev-matching-message ()
+  "Move to previous matching message."
+  (interactive)
+  (forward-line -1)
+  (while (and (not (bobp)) (not (notmuch-tree-get-match)))
+    (forward-line -1))
+  (when (window-live-p notmuch-tree-message-window)
+    (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-next-matching-message ()
+  "Move to next matching message."
+  (interactive)
+  (forward-line)
+  (while (and (not (eobp)) (not (notmuch-tree-get-match)))
+    (forward-line))
+  (when (window-live-p notmuch-tree-message-window)
+    (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-refresh-view ()
+  "Refresh view."
+  (interactive)
+  (let ((inhibit-read-only t)
+	(basic-query notmuch-tree-basic-query)
+	(query-context notmuch-tree-query-context)
+	(target (notmuch-tree-get-message-id)))
+    (erase-buffer)
+    (notmuch-tree-worker basic-query
+			 query-context
+			 target)))
+
+(defun notmuch-tree-thread-top ()
+  (when (notmuch-tree-get-message-properties)
+    (while (not (or (notmuch-tree-get-prop :first) (eobp)))
+      (forward-line -1))))
+
+(defun notmuch-tree-prev-thread ()
+  (interactive)
+  (forward-line -1)
+  (notmuch-tree-thread-top))
+
+(defun notmuch-tree-next-thread ()
+  (interactive)
+  (forward-line 1)
+  (while (not (or (notmuch-tree-get-prop :first) (eobp)))
+    (forward-line 1)))
+
+(defun notmuch-tree-thread-mapcar (function)
+  "Iterate through all messages in the current thread
+ and call FUNCTION for side effects."
+  (save-excursion
+    (notmuch-tree-thread-top)
+    (loop collect (funcall function)
+	  do (forward-line)
+	  while (and (notmuch-tree-get-message-properties)
+		     (not (notmuch-tree-get-prop :first))))))
+
+(defun notmuch-tree-get-messages-ids-thread-search ()
+  "Return a search string for all message ids of messages in the current thread."
+  (mapconcat 'identity
+	     (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id)
+	     " or "))
+
+(defun notmuch-tree-tag-thread (tag-changes)
+  "Tag all messages in the current thread"
+  (interactive
+   (let ((tags (apply #'append (notmuch-tree-thread-mapcar
+				(lambda () (notmuch-tree-get-tags))))))
+     (list (notmuch-read-tag-changes tags "Tag thread"))))
+  (when (notmuch-tree-get-message-properties)
+    (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes)
+    (notmuch-tree-thread-mapcar
+     (lambda () (notmuch-tree-tag-update-display tag-changes)))))
+
+(defun notmuch-tree-archive-thread (&optional unarchive)
+  "Archive each message in thread.
+
+Archive each message currently shown by applying the tag changes
+in `notmuch-archive-tags' to each. If a prefix argument is given,
+the messages will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed.
+
+Note: This command is safe from any race condition of new messages
+being delivered to the same thread. It does not archive the
+entire thread, but only the messages shown in the current
+buffer."
+  (interactive "P")
+  (when notmuch-archive-tags
+    (notmuch-tree-tag-thread
+     (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+;; Functions below here display the tree buffer itself.
+
+(defun notmuch-tree-clean-address (address)
+  "Try to clean a single email ADDRESS for display. Return
+AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return
+unchanged ADDRESS if parsing fails."
+  (let* ((clean-address (notmuch-clean-address address))
+	 (p-address (car clean-address))
+	 (p-name (cdr clean-address)))
+
+    ;; If we have a name return that otherwise return the address.
+    (or p-name p-address)))
+
+(defun notmuch-tree-format-field (field format-string msg)
+  "Format a FIELD of MSG according to FORMAT-STRING and return string"
+  (let* ((headers (plist-get msg :headers))
+	 (match (plist-get msg :match)))
+    (cond
+     ((listp field)
+      (format format-string (notmuch-tree-format-field-list field msg)))
+
+     ((string-equal field "date")
+      (let ((face (if match
+		      'notmuch-tree-match-date-face
+		    'notmuch-tree-no-match-date-face)))
+	(propertize (format format-string (plist-get msg :date_relative)) 'face face)))
+
+     ((string-equal field "tree")
+      (let ((tree-status (plist-get msg :tree-status))
+	    (face (if match
+		      'notmuch-tree-match-tree-face
+		    'notmuch-tree-no-match-tree-face)))
+
+	(propertize (format format-string
+			    (mapconcat #'identity (reverse tree-status) ""))
+		    'face face)))
+
+     ((string-equal field "subject")
+      (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))
+	    (previous-subject notmuch-tree-previous-subject)
+	    (face (if match
+		      'notmuch-tree-match-subject-face
+		    'notmuch-tree-no-match-subject-face)))
+
+	(setq notmuch-tree-previous-subject bare-subject)
+	(propertize (format format-string
+			    (if (string= previous-subject bare-subject)
+				" ..."
+			      bare-subject))
+		    'face face)))
+
+     ((string-equal field "authors")
+      (let ((author (notmuch-tree-clean-address (plist-get headers :From)))
+	    (len (length (format format-string "")))
+	    (face (if match
+		      'notmuch-tree-match-author-face
+		    'notmuch-tree-no-match-author-face)))
+	(when (> (length author) len)
+	  (setq author (substring author 0 len)))
+	(propertize (format format-string author) 'face face)))
+
+     ((string-equal field "tags")
+      (let ((tags (plist-get msg :tags))
+	    (face (if match
+		      'notmuch-tree-match-tag-face
+		    'notmuch-tree-no-match-tag-face)))
+	(propertize (format format-string
+			    (mapconcat #'identity tags ", "))
+		    'face face))))))
+
+
+(defun notmuch-tree-format-field-list (field-list msg)
+  "Format fields of MSG according to FIELD-LIST and return string"
+  (let (result-string)
+    (dolist (spec field-list result-string)
+      (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg)))
+	(setq result-string (concat result-string field-string))))))
+
+(defun notmuch-tree-insert-msg (msg)
+  "Insert the message MSG according to notmuch-tree-result-format"
+  ;; We need to save the previous subject as it will get overwritten
+  ;; by the insert-field calls.
+  (let ((previous-subject notmuch-tree-previous-subject))
+    (insert (notmuch-tree-format-field-list notmuch-tree-result-format msg))
+    (notmuch-tree-set-message-properties msg)
+    (notmuch-tree-set-prop :previous-subject previous-subject)
+    (insert "\n")))
+
+(defun notmuch-tree-goto-and-insert-msg (msg)
+  "Insert msg at the end of the buffer. Move point to msg if it is the target"
+  (save-excursion
+    (goto-char (point-max))
+    (notmuch-tree-insert-msg msg))
+  (let ((msg-id (notmuch-id-to-query (plist-get msg :id)))
+	(target notmuch-tree-target-msg))
+    (when (or (and (not target) (plist-get msg :match))
+	      (string= msg-id target))
+      (setq notmuch-tree-target-msg "found")
+      (goto-char (point-max))
+      (forward-line -1)
+      (when notmuch-tree-open-target
+	(notmuch-tree-show-message-in)))))
+
+(defun notmuch-tree-insert-tree (tree depth tree-status first last)
+  "Insert the message tree TREE at depth DEPTH in the current thread.
+
+A message tree is another name for a single sub-thread: i.e., a
+message together with all its descendents."
+  (let ((msg (car tree))
+	(replies (cadr tree)))
+
+      (cond
+       ((and (< 0 depth) (not last))
+	(push "├" tree-status))
+       ((and (< 0 depth) last)
+	(push "╰" tree-status))
+       ((and (eq 0 depth) first last)
+;;	  (push "─" tree-status)) choice between this and next line is matter of taste.
+	(push " " tree-status))
+       ((and (eq 0 depth) first (not last))
+	  (push "┬" tree-status))
+       ((and (eq 0 depth) (not first) last)
+	(push "╰" tree-status))
+       ((and (eq 0 depth) (not first) (not last))
+	(push "├" tree-status)))
+
+      (push (concat (if replies "┬" "─") "►") tree-status)
+      (plist-put msg :first (and first (eq 0 depth)))
+      (notmuch-tree-goto-and-insert-msg (plist-put msg :tree-status tree-status))
+      (pop tree-status)
+      (pop tree-status)
+
+      (if last
+	  (push " " tree-status)
+	(push "│" tree-status))
+
+    (notmuch-tree-insert-thread replies (1+ depth) tree-status)))
+
+(defun notmuch-tree-insert-thread (thread depth tree-status)
+  "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest."
+  (let ((n (length thread)))
+    (loop for tree in thread
+	  for count from 1 to n
+
+	  do (notmuch-tree-insert-tree tree depth tree-status (eq count 1) (eq count n)))))
+
+(defun notmuch-tree-insert-forest-thread (forest-thread)
+  "Insert a single complete thread."
+  (let (tree-status)
+    ;; Reset at the start of each main thread.
+    (setq notmuch-tree-previous-subject nil)
+    (notmuch-tree-insert-thread forest-thread 0 tree-status)))
+
+(defun notmuch-tree-insert-forest (forest)
+  "Insert a forest of threads.
+
+This function inserts a collection of several complete threads as
+passed to it by notmuch-tree-process-filter."
+  (mapc 'notmuch-tree-insert-forest-thread forest))
+
+(defun notmuch-tree-mode ()
+  "Major mode displaying messages (as opposed to threads) of of a notmuch search.
+
+This buffer contains the results of a \"notmuch tree\" of your
+email archives. Each line in the buffer represents a single
+message giving the relative date, the author, subject, and any
+tags.
+
+Pressing \\[notmuch-tree-show-message] on any line displays that message.
+
+Complete list of currently available key bindings:
+
+\\{notmuch-tree-mode-map}"
+
+  (interactive)
+  (kill-all-local-variables)
+  (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view)
+  (use-local-map notmuch-tree-mode-map)
+  (setq major-mode 'notmuch-tree-mode
+	mode-name "notmuch-tree")
+  (hl-line-mode 1)
+  (setq buffer-read-only t
+	truncate-lines t))
+
+(defun notmuch-tree-process-sentinel (proc msg)
+  "Add a message to let user know when \"notmuch tree\" exits"
+  (let ((buffer (process-buffer proc))
+	(status (process-status proc))
+	(exit-status (process-exit-status proc))
+	(never-found-target-thread nil))
+    (when (memq status '(exit signal))
+        (kill-buffer (process-get proc 'parse-buf))
+	(if (buffer-live-p buffer)
+	    (with-current-buffer buffer
+	      (save-excursion
+		(let ((inhibit-read-only t)
+		      (atbob (bobp)))
+		  (goto-char (point-max))
+		  (if (eq status 'signal)
+		      (insert "Incomplete search results (tree view process was killed).\n"))
+		  (when (eq status 'exit)
+		    (insert "End of search results.")
+		    (unless (= exit-status 0)
+		      (insert (format " (process returned %d)" exit-status)))
+		    (insert "\n")))))))))
+
+(defun notmuch-tree-process-filter (proc string)
+  "Process and filter the output of \"notmuch show\" for tree view"
+  (let ((results-buf (process-buffer proc))
+        (parse-buf (process-get proc 'parse-buf))
+        (inhibit-read-only t)
+        done)
+    (if (not (buffer-live-p results-buf))
+        (delete-process proc)
+      (with-current-buffer parse-buf
+        ;; Insert new data
+        (save-excursion
+          (goto-char (point-max))
+          (insert string))
+	(notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread
+					 results-buf)))))
+
+(defun notmuch-tree-worker (basic-query &optional query-context target open-target)
+  "Insert the tree view of the search in the current buffer.
+
+This is is a helper function for notmuch-tree. The arguments are
+the same as for the function notmuch-tree."
+  (interactive)
+  (notmuch-tree-mode)
+  (setq notmuch-tree-basic-query basic-query)
+  (setq notmuch-tree-query-context query-context)
+  (setq notmuch-tree-target-msg target)
+  (setq notmuch-tree-open-target open-target)
+
+  (erase-buffer)
+  (goto-char (point-min))
+  (let* ((search-args (concat basic-query
+		       (if query-context (concat " and (" query-context ")"))
+		       ))
+	 (message-arg "--entire-thread"))
+    (if (equal (car (process-lines notmuch-command "count" search-args)) "0")
+	(setq search-args basic-query))
+    (let ((proc (notmuch-start-notmuch
+		 "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel
+		 "show" "--body=false" "--format=sexp"
+		 message-arg search-args))
+	  ;; Use a scratch buffer to accumulate partial output.
+	  ;; This buffer will be killed by the sentinel, which
+	  ;; should be called no matter how the process dies.
+	  (parse-buf (generate-new-buffer " *notmuch tree parse*")))
+      (process-put proc 'parse-buf parse-buf)
+      (set-process-filter proc 'notmuch-tree-process-filter)
+      (set-process-query-on-exit-flag proc nil))))
+
+(defun notmuch-tree (&optional query query-context target buffer-name open-target)
+  "Display threads matching QUERY in Tree View.
+
+The arguments are:
+  QUERY: the main query. This can be any query but in many cases will be
+      a single thread. If nil this is read interactively from the minibuffer.
+  QUERY-CONTEXT: is an additional term for the query. The query used
+      is QUERY and QUERY-CONTEXT unless that does not match any messages
+      in which case we fall back to just QUERY.
+  TARGET: A message ID (with the id: prefix) that will be made
+      current if it appears in the tree view results.
+  BUFFER-NAME: the name of the buffer to display the tree view. If
+      it is nil \"*notmuch-tree\" followed by QUERY is used.
+  OPEN-TARGET: If TRUE open the target message in the message pane."
+  (interactive)
+  (if (null query)
+      (setq query (notmuch-read-query "Notmuch tree view search: ")))
+  (let ((buffer (get-buffer-create (generate-new-buffer-name
+				    (or buffer-name
+					(concat "*notmuch-tree-" query "*")))))
+	(inhibit-read-only t))
+
+    (switch-to-buffer buffer))
+  ;; Don't track undo information for this buffer
+  (set 'buffer-undo-list t)
+
+  (notmuch-tree-worker query query-context target open-target)
+
+  (setq truncate-lines t))
+
+
+;; Set up key bindings from the rest of notmuch.
+(define-key notmuch-common-keymap "z" 'notmuch-tree)
+(define-key notmuch-search-mode-map "Z" 'notmuch-tree-from-search-current-query)
+(define-key notmuch-show-mode-map "Z" 'notmuch-tree-from-show-current-query)
+(message "Initialised notmuch-tree")
+
+(provide 'notmuch-tree)
-- 
cgit v1.2.3