[PATCH v4] emacs: notmuch-tree-outline-mode

[PATCH v4] emacs: notmuch-tree-outline-mode

[jao]

With this mode, one can fold trees in the notmuch-tree buffer as if
they were outlines, using all the commands provided by
outline-minor-mode.  We also define a couple of movement commands
that, optional, will ensure that only the thread around point is
unfolded.

The implementation is based on the trick of inserting an invisible
prefix before each thread head that is then used as the regexp used by
outline-minor-mode to recognise headers.  The message plist is also
augmented with a :level property that provides a fast outline-level
function.

---
This version supesedes v3 (id:20220921225510.3159023-1-jao@gnu.org)
by allowing notmuch-tree-ouline-mode to be enabled manually, not only
automatically via notmuch-tree-outline-enabled, which was misnamed in
the defcustom, by the way: we use now that name, as documented).

Signed-off-by: jao <jao@gnu.org>
---
 doc/notmuch-emacs.rst |  20 +++++
 emacs/notmuch-tree.el | 176 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 196 insertions(+)

diff --git a/doc/notmuch-emacs.rst b/doc/notmuch-emacs.rst
index 846f5e67..53e68c4d 100644
--- a/doc/notmuch-emacs.rst
+++ b/doc/notmuch-emacs.rst
@@ -606,6 +606,26 @@ can be controlled by the variable ``notmuch-search-oldest-first``.
    See also :el:defcustom:`notmuch-search-result-format` and
    :el:defcustom:`notmuch-unthreaded-result-format`.
 
+It is also possible to enable outlines in notmuch tree buffers, via
+``notmuch-tree-outline-mode``.
+
+|docstring::notmuch-tree-outline-mode|
+
+The behaviour of this minor mode is affected by the following
+customizable variables:
+
+.. el:defcustom:: notmuch-tree-outline-enabled
+
+   |docstring::notmuch-tree-outline-enabled|
+
+.. el:defcustom:: notmuch-tree-outline-visibility
+
+   |docstring::notmuch-tree-outline-visibility|
+
+.. el:defcustom:: notmuch-tree-outline-auto-close
+
+   |docstring::notmuch-tree-outline-auto-close|
+
 
 .. _notmuch-unthreaded:
 
diff --git a/emacs/notmuch-tree.el b/emacs/notmuch-tree.el
index 7ceddee2..bff29351 100644
--- a/emacs/notmuch-tree.el
+++ b/emacs/notmuch-tree.el
@@ -989,6 +989,7 @@ unchanged ADDRESS if parsing fails."
   ;; We need to save the previous subject as it will get overwritten
   ;; by the insert-field calls.
   (let ((previous-subject notmuch-tree-previous-subject))
+    (notmuch-tree-outline--insert-prefix msg)
     (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)
@@ -1036,6 +1037,8 @@ message together with all its descendents."
     (setq msg (plist-put msg :first (and first (eq 0 depth))))
     (setq msg (plist-put msg :tree-status tree-status))
     (setq msg (plist-put msg :orig-tags (plist-get msg :tags)))
+    (setq msg (plist-put msg
+			 :level (1+ (if (and (eq 0 depth) (not first)) 1 depth))))
     (notmuch-tree-goto-and-insert-msg msg)
     (pop tree-status)
     (pop tree-status)
@@ -1265,6 +1268,179 @@ search results and that are also tagged with the given TAG."
 		  nil
 		  notmuch-search-oldest-first)))
 
+;;; Tree outline mode
+;;;; Custom variables
+(defcustom notmuch-tree-outline-enabled nil
+  "Whether to automatically activate `notmuch-tree-outline-mode' in tree views."
+  :type 'boolean)
+
+(defcustom notmuch-tree-outline-visibility 'hide-others
+  "Default state of the forest outline for `notmuch-tree-outline-mode'.
+This variable controls the state of a forest initially and after
+a movement command.  If set to nil, all trees are displayed while
+the symbol hide-all indicates that all trees in the forest should
+be folded and hide-other that only the first one should be
+unfolded."
+  :type '(choice (const :tag "Show all" nil)
+		 (const :tag "Hide others" hide-others)
+		 (const :tag "Hide all" hide-all)))
+
+(defcustom notmuch-tree-outline-auto-close nil
+  "Close message and tree windows when moving past the last message."
+  :type 'boolean)
+
+;;;; Helper functions
+(defsubst notmuch-tree-outline--pop-at-end (pop-at-end)
+  (if notmuch-tree-outline-auto-close (not pop-at-end) pop-at-end))
+
+(defun notmuch-tree-outline--enable-mode ()
+  (when notmuch-tree-outline-enabled (notmuch-tree-outline-mode 1)))
+
+(add-hook 'notmuch-tree-mode-hook #'notmuch-tree-outline--enable-mode)
+
+(defun notmuch-tree-outline--set-visibility ()
+  (when (and notmuch-tree-outline-mode (> (point-max) (point-min)))
+    (cond ((eq notmuch-tree-outline-visibility 'hide-others)
+	   (notmuch-tree-outline-hide-others))
+	  ((eq notmuch-tree-outline-visibility 'hide-all)
+	   (outline-hide-body)))))
+
+(defun notmuch-tree-outline--on-exit (proc)
+  (when (eq (process-status proc) 'exit)
+    (notmuch-tree-outline--set-visibility)))
+
+(add-hook 'notmuch-tree-process-exit-functions #'notmuch-tree-outline--on-exit)
+
+(defsubst notmuch-tree-outline--level (&optional props)
+  (or (plist-get (or props (notmuch-tree-get-message-properties)) :level) 0))
+
+(defun notmuch-tree-outline--insert-prefix (msg)
+  (let ((pref (make-string (notmuch-tree-outline--level msg) ?>)))
+    (insert (propertize (concat pref " ") 'display ""))))
+
+(defsubst notmuch-tree-outline--message-open-p ()
+  (and (buffer-live-p notmuch-tree-message-buffer)
+       (get-buffer-window notmuch-tree-message-buffer)
+       (string-match-p (regexp-quote (or (notmuch-tree-get-message-id) ""))
+		       (buffer-name notmuch-tree-message-buffer))))
+
+(defsubst notmuch-tree-outline--at-original-match-p ()
+  (and (notmuch-tree-get-prop :match)
+       (equal (notmuch-tree-get-prop :orig-tags)
+              (notmuch-tree-get-prop :tags))))
+
+(defun notmuch-tree-outline--next (prev thread pop-at-end &optional ignore-new)
+  (cond ((and (not ignore-new)
+	      (notmuch-tree-outline--at-original-match-p)
+	      (not (notmuch-tree-outline--message-open-p)))
+	 (notmuch-tree-outline-hide-others t))
+	(thread
+	 (notmuch-tree-thread-top)
+	 (ignore-errors
+	   (if prev
+	       (outline-backward-same-level 1)
+	     (outline-forward-same-level 1))
+	   (when (> (notmuch-tree--outline-level) 0) (outline-show-branches)))
+	 (notmuch-tree-outline--next nil nil pop-at-end))
+	(t (outline-next-visible-heading (if prev -1 1))
+	   (unless (notmuch-tree-get-prop :match)
+	     (notmuch-tree-matching-message prev pop-at-end))
+	   (notmuch-tree-outline-hide-others t))))
+
+;;;; User commands
+(defun notmuch-tree-outline-hide-others (&optional and-show)
+  "Fold all threads except the one around point.
+If AND-SHOW is t, make the current message visible if it's not."
+  (interactive)
+  (save-excursion
+    (while (and (not (bobp)) (> (notmuch-tree-outline--level) 1))
+      (outline-previous-heading))
+    (outline-hide-sublevels 1))
+  (when (> (notmuch-tree-outline--level) 0)
+    (outline-show-subtree)
+    (when and-show (notmuch-tree-show-message nil))))
+
+(defun notmuch-tree-outline-next (&optional pop-at-end)
+  "Next matching message in a forest, taking care of thread visibility.
+A prefix argument reverses the meaning of `notmuch-tree-outline-auto-close'."
+  (interactive "P")
+  (let ((pop (notmuch-tree-outline--pop-at-end pop-at-end)))
+    (if (null notmuch-tree-outline-visibility)
+	(notmuch-tree-matching-message nil pop)
+      (notmuch-tree-outline--next nil nil pop))))
+
+(defun notmuch-tree-outline-previous (&optional pop-at-end)
+  "Previous matching message in forest, taking care of thread visibility.
+With prefix, quit the tree view if there is no previous message."
+  (interactive "P")
+  (if (null notmuch-tree-outline-visibility)
+      (notmuch-tree-prev-matching-message pop-at-end)
+    (notmuch-tree-outline--next t nil pop-at-end)))
+
+(defun notmuch-tree-outline-next-thread ()
+  "Next matching thread in forest, taking care of thread visibility."
+  (interactive)
+  (if (null notmuch-tree-outline-visibility)
+      (notmuch-tree-next-thread)
+    (notmuch-tree-outline--next nil t nil)))
+
+(defun notmuch-tree-outline-previous-thread ()
+  "Previous matching thread in forest, taking care of thread visibility."
+  (interactive)
+  (if (null notmuch-tree-outline-visibility)
+      (notmuch-tree-prev-thread)
+    (notmuch-tree-outline--next t t nil)))
+
+;;;; Mode definition
+(defvar notmuch-tree-outline-mode-lighter nil
+  "The lighter mark for notmuch-tree-outline mode.
+Usually empty since outline-minor-mode's lighter will be active.")
+
+(define-minor-mode notmuch-tree-outline-mode
+  "Minor mode allowing message trees to be folded as outlines.
+
+When this mode is set, each thread and subthread in the results
+list is treated as a foldable section, with its first message as
+its header.
+
+The mode just makes available in the tree buffer all the
+keybindings in `outline-minor-mode', and binds the following
+additional keys:
+
+\\{notmuch-tree-outline-mode-map}
+
+The customizable variable `notmuch-tree-outline-visibility'
+controls how navigation in the buffer is affected by this mode:
+
+  - If it is set to nil, `notmuch-tree-outline-previous',
+    `notmuch-tree-outline-next', and their thread counterparts
+    behave just as the corresponding notmuch-tree navigation keys
+    when this mode is not enabled.
+
+  - If, on the other hand, `notmuch-tree-outline-visibility' is
+    set to a non-nil value, these commands hiding the outlines of
+    the trees you are not reading as you move to new messages.
+
+To enable notmuch-tree-outline-mode by default in all
+notmuch-tree buffers, just set
+`notmuch-tree-outline-mode-enabled' to t."
+  :lighter notmuch-tree-outline-mode-lighter
+  :keymap `((,(kbd "TAB") . outline-cycle)
+	    (,(kbd "M-TAB") . outline-cycle-buffer)
+	    ("n" . notmuch-tree-outline-next)
+	    ("p" . notmuch-tree-outline-previous)
+	    (,(kbd "M-n") . notmuch-tree-outline-next-thread)
+	    (,(kbd "M-p") . notmuch-tree-outline-previous-thread))
+  (outline-minor-mode notmuch-tree-outline-mode)
+  (unless (derived-mode-p 'notmuch-tree-mode)
+    (user-error "notmuch-tree-outline-mode is only meaningful for notmuch trees!"))
+  (if notmuch-tree-outline-mode
+      (progn (setq-local outline-regexp "^>+ \\|^En"
+			 outline-level #'notmuch-tree-outline--level)
+	     (notmuch-tree-outline--set-visibility))
+    (setq-local outline-regexp (default-value 'outline-regexp)
+		outline-level (default-value 'outline-level))))
+
 ;;; _
 
 (provide 'notmuch-tree)
-- 
2.37.2