X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tree.el;h=b3c2c992486fd9e5ccd7f7510c138728f72f7c37;hp=57843e256f437d5f6206ef31e5aab9915d10e49a;hb=HEAD;hpb=adfded9ed0a5a4b06886f462314cd4511cb72d47 diff --git a/emacs/notmuch-tree.el b/emacs/notmuch-tree.el index 57843e25..faec89c4 100644 --- a/emacs/notmuch-tree.el +++ b/emacs/notmuch-tree.el @@ -1,4 +1,4 @@ -;;; notmuch-tree.el --- displaying notmuch forests +;;; notmuch-tree.el --- displaying notmuch forests -*- lexical-binding: t -*- ;; ;; Copyright © Carl Worth ;; Copyright © David Edmondson @@ -24,20 +24,18 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'mail-parse) (require 'notmuch-lib) -(require 'notmuch-query) (require 'notmuch-show) (require 'notmuch-tag) (require 'notmuch-parser) (require 'notmuch-jump) (declare-function notmuch-search "notmuch" - (&optional query oldest-first target-thread target-line)) -(declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) + (&optional query oldest-first target-thread target-line + no-display)) +(declare-function notmuch-call-notmuch-process "notmuch-lib" (&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" ()) @@ -47,13 +45,12 @@ (declare-function notmuch-search-previous-thread "notmuch" ()) (declare-function notmuch-tree-from-search-thread "notmuch" ()) -;; the following variable is defined in notmuch.el -(defvar notmuch-search-query-string) - ;; this variable distinguishes the unthreaded display from the normal tree display (defvar-local notmuch-tree-unthreaded nil "A buffer local copy of argument unthreaded to the function notmuch-tree.") +;;; Options + (defgroup notmuch-tree nil "Showing message and thread structure." :group 'notmuch) @@ -73,24 +70,66 @@ notmuch-unthreaded-show-out notmuch-tree-show-out)) +(defcustom notmuch-tree-thread-symbols + '((prefix . " ") + (top . "─") + (top-tee . "┬") + (vertical . "│") + (vertical-tee . "├") + (bottom . "╰") + (arrow . "►")) + "Strings used to draw trees in notmuch tree results. +Symbol keys denote where the corresponding string value is used: +`prefix' is used at the top of the tree, followed by `top' if it +has no children or `top-tee' if it does; `vertical' is a bar +connecting with a response down the list skipping the current +one, while `vertical-tee' marks the current message as a reply to +the previous one; `bottom' is used at the bottom of threads. +Finally, the `arrrow' string in the list is used as a pointer to +every message. + +Common customizations include setting `prefix' to \"-\", to see +equal-length prefixes, and `arrow' to an empty string or to a +different kind of arrow point." + :type '(alist :key-type symbol :value-type string) + :group 'notmuch-tree) + +(defconst notmuch-tree--field-names + '(choice :tag "Field" + (const :tag "Date" "date") + (const :tag "Authors" "authors") + (const :tag "Subject" "subject") + (const :tag "Tree" "tree") + (const :tag "Tags" "tags") + (function))) + (defcustom notmuch-tree-result-format `(("date" . "%12s ") ("authors" . "%-20s") - ((("tree" . "%s")("subject" . "%s")) ." %-54s ") + ((("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)) + "Result formatting for tree view. + +List of pairs of (field . format-string). Supported field +strings are: \"date\", \"authors\", \"subject\", \"tree\", +\"tags\". It is also supported to pass a function in place of a +field-name. In this case the function is passed the thread +object (plist) and format string. + +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 that the author string should not contain whitespace +\(put it in the neighbouring fields instead)." + + :type `(alist :key-type (choice ,notmuch-tree--field-names + (alist :key-type ,notmuch-tree--field-names + :value-type (string :tag "Format"))) + :value-type (string :tag "Format")) :group 'notmuch-tree) (defcustom notmuch-unthreaded-result-format @@ -98,19 +137,26 @@ For example: ("authors" . "%-20s") ((("subject" . "%s")) ." %-54s ") ("tags" . "(%s)")) - "Result formatting for unthreaded 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)) + "Result formatting for unthreaded tree view. + +List of pairs of (field . format-string). Supported field +strings are: \"date\", \"authors\", \"subject\", \"tree\", +\"tags\". It is also supported to pass a function in place of a +field-name. In this case the function is passed the thread +object (plist) and format string. + +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 that the author string should not contain whitespace +\(put it in the neighbouring fields instead)." + + :type `(alist :key-type (choice ,notmuch-tree--field-names + (alist :key-type ,notmuch-tree--field-names + :value-type (string :tag "Format"))) + :value-type (string :tag "Format")) :group 'notmuch-tree) (defun notmuch-tree-result-format () @@ -118,7 +164,9 @@ For example: notmuch-unthreaded-result-format notmuch-tree-result-format)) -;; Faces for messages that match the query. +;;; Faces +;;;; Faces for messages that match the query + (defface notmuch-tree-match-face '((t :inherit default)) "Default face used in tree mode face for matching messages" @@ -140,7 +188,7 @@ For example: (:foreground "dark blue")) (t (:bold t))) - "Face used in tree mode for the date in messages matching the query." + "Face used in tree mode for the author in messages matching the query." :group 'notmuch-tree :group 'notmuch-faces) @@ -152,7 +200,8 @@ For example: (defface notmuch-tree-match-tree-face nil - "Face used in tree mode for the thread tree block graphics in messages matching the query." + "Face used in tree mode for the thread tree block graphics in +messages matching the query." :group 'notmuch-tree :group 'notmuch-faces) @@ -169,7 +218,8 @@ For example: :group 'notmuch-tree :group 'notmuch-faces) -;; Faces for messages that do not match the query. +;;;; Faces for messages that do not match the query + (defface notmuch-tree-no-match-face '((t (:foreground "gray"))) "Default face used in tree mode face for non-matching messages." @@ -190,13 +240,14 @@ For example: (defface notmuch-tree-no-match-tree-face nil - "Face used in tree mode for the thread tree block graphics in messages matching the query." + "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 nil - "Face used in tree mode for the date in messages matching the query." + "Face used in tree mode for non-matching authors." :group 'notmuch-tree :group 'notmuch-faces) @@ -206,6 +257,8 @@ For example: :group 'notmuch-tree :group 'notmuch-faces) +;;; Variables + (defvar-local notmuch-tree-previous-subject "The subject of the most recent result shown during the async display.") @@ -238,6 +291,8 @@ 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.") (put 'notmuch-tree-message-buffer 'permanent-local t) +;;; Tree wrapper commands + (defmacro notmuch-tree--define-do-in-message-window (name cmd) "Define NAME as a command that calls CMD interactively in the message window. If the message pane is closed then this command does nothing. @@ -305,17 +360,21 @@ then NAME behaves like CMD." notmuch-tree-view-raw-message notmuch-show-view-raw-message) +;;; Keymap + (defvar notmuch-tree-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map notmuch-common-keymap) ;; These bindings shadow common bindings with variants ;; that additionally close the message window. (define-key map [remap notmuch-bury-or-kill-this-buffer] 'notmuch-tree-quit) - (define-key map [remap notmuch-search] 'notmuch-tree-to-search) - (define-key map [remap notmuch-help] 'notmuch-tree-help) - (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail) - (define-key map [remap notmuch-jump-search] 'notmuch-tree-jump-search) + (define-key map [remap notmuch-search] 'notmuch-tree-to-search) + (define-key map [remap notmuch-help] 'notmuch-tree-help) + (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail) + (define-key map [remap notmuch-jump-search] 'notmuch-tree-jump-search) + (define-key map "o" 'notmuch-tree-toggle-order) + (define-key map "i" 'notmuch-tree-toggle-hide-excluded) (define-key map "S" 'notmuch-search-from-tree-current-query) (define-key map "U" 'notmuch-unthreaded-from-tree-current-query) (define-key map "Z" 'notmuch-tree-from-unthreaded-current-query) @@ -338,6 +397,9 @@ then NAME behaves like CMD." (define-key map "r" 'notmuch-tree-reply-sender) (define-key map "R" 'notmuch-tree-reply) (define-key map "V" 'notmuch-tree-view-raw-message) + (define-key map "l" 'notmuch-tree-filter) + (define-key map "t" 'notmuch-tree-filter-by-tag) + (define-key map "E" 'notmuch-tree-edit-search) ;; The main tree view bindings (define-key map (kbd "RET") 'notmuch-tree-show-message) @@ -363,6 +425,8 @@ then NAME behaves like CMD." map) "Keymap for \"notmuch tree\" buffers.") +;;; Message properties + (defun notmuch-tree-get-message-properties () "Return the properties of the current message as a plist. @@ -388,9 +452,8 @@ Some useful entries are: (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))) + (plist-get (or props (notmuch-tree-get-message-properties)) + prop)) (defun notmuch-tree-set-tags (tags) "Set the tags of the current message." @@ -411,9 +474,10 @@ Some useful entries are: (defun notmuch-tree-get-match () "Return whether the current message is a match." - (interactive) (notmuch-tree-get-prop :match)) +;;; Update display + (defun notmuch-tree-refresh-result () "Redisplay the current message line. @@ -456,6 +520,8 @@ NOT change the database." (when (string= tree-msg-id (notmuch-show-get-message-id)) (notmuch-show-update-tags new-tags))))))) +;;; Commands (and some helper functions used by them) + (defun notmuch-tree-tag (tag-changes) "Change tags for the current message." (interactive @@ -525,7 +591,9 @@ NOT change the database." "Call notmuch search with the current query." (interactive) (notmuch-tree-close-message-window) - (notmuch-search (notmuch-tree-get-query))) + (notmuch-search (notmuch-tree-get-query) + notmuch-search-oldest-first + notmuch-search-hide-excluded)) (defun notmuch-tree-message-window-kill-hook () "Close the message pane when exiting the show buffer." @@ -561,7 +629,7 @@ NOT change the database." (with-selected-window notmuch-tree-message-window (let (;; Since we are only displaying one message do not indent. (notmuch-show-indent-messages-width 0) - (notmuch-show-only-matching-messages t) + (notmuch-show-single-message t) ;; Ensure that `pop-to-buffer-same-window' uses the ;; window we want it to use. (display-buffer-overriding-action @@ -581,12 +649,13 @@ NOT change the database." "Show the current message (in whole window)." (interactive) (let ((id (notmuch-tree-get-message-id)) - (inhibit-read-only t) - buffer) + (inhibit-read-only t)) (when id ;; We close the window to kill off un-needed buffers. (notmuch-tree-close-message-window) - (notmuch-show id)))) + ;; n-s-s-m is buffer local, so use inner let. + (let ((notmuch-show-single-message t)) + (notmuch-show id))))) (defun notmuch-tree-show-message (arg) "Show the current message. @@ -736,7 +805,9 @@ nil otherwise." query-context target nil - unthreaded))) + unthreaded + notmuch-search-oldest-first + notmuch-search-hide-excluded))) (defun notmuch-tree-thread-top () (when (notmuch-tree-get-message-properties) @@ -775,8 +846,7 @@ search results instead." (notmuch-tree-from-search-thread)))) (defun notmuch-tree-next-thread (&optional previous) - "Move to the next thread in the current tree or parent search -results + "Move to the next thread in the current tree or parent search results. If PREVIOUS is non-nil, move to the previous thread in the tree or search results instead." @@ -786,14 +856,13 @@ search results instead." (notmuch-tree-next-thread-from-search previous))) (defun notmuch-tree-prev-thread () - "Move to the previous thread in the current tree or parent search -results" + "Move to the previous thread in the current tree or parent search results." (interactive) (notmuch-tree-next-thread t)) (defun notmuch-tree-thread-mapcar (function) - "Iterate through all messages in the current thread - and call FUNCTION for side effects." + "Call FUNCTION for each message in the current thread. +FUNCTION is called for side effects only." (save-excursion (notmuch-tree-thread-top) (cl-loop collect (funcall function) @@ -835,7 +904,7 @@ buffer." (notmuch-tree-tag-thread (notmuch-tag-change-list notmuch-archive-tags unarchive)))) -;; Functions below here display the tree buffer itself. +;;; Functions for displaying the tree buffer itself (defun notmuch-tree-clean-address (address) "Try to clean a single email ADDRESS for display. Return @@ -856,6 +925,9 @@ unchanged ADDRESS if parsing fails." ((listp field) (format format-string (notmuch-tree-format-field-list field msg))) + ((functionp field) + (funcall field format-string msg)) + ((string-equal field "date") (let ((face (if match 'notmuch-tree-match-date-face @@ -939,7 +1011,8 @@ unchanged ADDRESS if parsing fails." (goto-char (point-max)) (forward-line -1) (when notmuch-tree-open-target - (notmuch-tree-show-message-in))))) + (notmuch-tree-show-message-in) + (notmuch-tree-command-hook))))) (defun notmuch-tree-insert-tree (tree depth tree-status first last) "Insert the message tree TREE at depth DEPTH in the current thread. @@ -947,36 +1020,41 @@ unchanged ADDRESS if parsing fails." 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))) + (replies (cadr tree)) + ;; outline level, computed from the message's depth and + ;; whether or not it's the first message in the tree. + (level (1+ (if (and (eq 0 depth) (not first)) 1 depth)))) (cond ((and (< 0 depth) (not last)) - (push "├" tree-status)) + (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status)) ((and (< 0 depth) last) - (push "╰" tree-status)) + (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) ((and (eq 0 depth) first last) - ;; Choice between these two variants is a matter of taste. - ;; (push "─" tree-status)) - (push " " tree-status)) + (push (alist-get 'prefix notmuch-tree-thread-symbols) tree-status)) ((and (eq 0 depth) first (not last)) - (push "┬" tree-status)) + (push (alist-get 'top-tee notmuch-tree-thread-symbols) tree-status)) ((and (eq 0 depth) (not first) last) - (push "╰" tree-status)) + (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) ((and (eq 0 depth) (not first) (not last)) - (push "├" tree-status))) - (push (concat (if replies "┬" "─") "►") tree-status) + (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status))) + (push (concat (alist-get (if replies 'top-tee 'top) notmuch-tree-thread-symbols) + (alist-get 'arrow notmuch-tree-thread-symbols)) + tree-status) (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 level)) (notmuch-tree-goto-and-insert-msg msg) (pop tree-status) (pop tree-status) (if last (push " " tree-status) - (push "│" tree-status)) + (push (alist-get 'vertical notmuch-tree-thread-symbols) 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." + "Insert the collection of sibling sub-threads THREAD at depth +DEPTH in the current forest." (let ((n (length thread))) (cl-loop for tree in thread for count from 1 to n @@ -986,10 +1064,9 @@ message together with all its descendents." (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))) + ;; Reset at the start of each main thread. + (setq notmuch-tree-previous-subject nil) + (notmuch-tree-insert-thread forest-thread 0 nil)) (defun notmuch-tree-insert-forest (forest) "Insert a forest of threads. @@ -1014,21 +1091,26 @@ Complete list of currently available key bindings: (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view) (hl-line-mode 1) (setq buffer-read-only t) - (setq truncate-lines t)) + (setq truncate-lines t) + (when notmuch-tree-outline-enabled (notmuch-tree-outline-mode 1))) + +(defvar notmuch-tree-process-exit-functions nil + "Functions called when the process inserting a tree of results finishes. + +Functions in this list are called with one argument, the process +object, and with the tree results buffer as the current buffer.") -(defun notmuch-tree-process-sentinel (proc msg) +(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)) + (exit-status (process-exit-status proc))) (when (memq status '(exit signal)) (kill-buffer (process-get proc 'parse-buf)) (when (buffer-live-p buffer) (with-current-buffer buffer (save-excursion - (let ((inhibit-read-only t) - (atbob (bobp))) + (let ((inhibit-read-only t)) (goto-char (point-max)) (when (eq status 'signal) (insert "Incomplete search results (tree view process was killed).\n")) @@ -1036,14 +1118,14 @@ Complete list of currently available key bindings: (insert "End of search results.") (unless (= exit-status 0) (insert (format " (process returned %d)" exit-status))) - (insert "\n"))))))))) + (insert "\n")))) + (run-hook-with-args 'notmuch-tree-process-exit-functions proc)))))) (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) + (inhibit-read-only t)) (if (not (buffer-live-p results-buf)) (delete-process proc) (with-current-buffer parse-buf @@ -1054,7 +1136,9 @@ Complete list of currently available key bindings: (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread results-buf))))) -(defun notmuch-tree-worker (basic-query &optional query-context target open-target unthreaded) +(defun notmuch-tree-worker (basic-query &optional query-context target + open-target unthreaded oldest-first + exclude) "Insert the tree view of the search in the current buffer. This is is a helper function for notmuch-tree. The arguments are @@ -1062,6 +1146,8 @@ the same as for the function notmuch-tree." (interactive) (notmuch-tree-mode) (add-hook 'post-command-hook #'notmuch-tree-command-hook t t) + (setq notmuch-search-oldest-first oldest-first) + (setq notmuch-search-hide-excluded exclude) (setq notmuch-tree-unthreaded unthreaded) (setq notmuch-tree-basic-query basic-query) (setq notmuch-tree-query-context (if (or (string= query-context "") @@ -1080,14 +1166,16 @@ the same as for the function notmuch-tree." (let* ((search-args (concat basic-query (and query-context (concat " and (" query-context ")")))) - (message-arg (if unthreaded "--unthreaded" "--entire-thread"))) - (when (equal (car (process-lines notmuch-command "count" search-args)) "0") + (sort-arg (if oldest-first "--sort=oldest-first" "--sort=newest-first")) + (message-arg (if unthreaded "--unthreaded" "--entire-thread")) + (exclude-arg (if exclude "--exclude=true" "--exclude=false"))) + (when (equal (car (notmuch--process-lines notmuch-command "count" search-args)) "0") (setq search-args basic-query)) (notmuch-tag-clear-cache) (let ((proc (notmuch-start-notmuch "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel - "show" "--body=false" "--format=sexp" "--format-version=4" - message-arg search-args)) + "show" "--body=false" "--format=sexp" "--format-version=5" + sort-arg message-arg exclude-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. @@ -1105,7 +1193,28 @@ the same as for the function notmuch-tree." ")") notmuch-tree-basic-query)) -(defun notmuch-tree (&optional query query-context target buffer-name open-target unthreaded parent-buffer) +(defun notmuch-tree-toggle-order () + "Toggle the current search order. + +This command toggles the sort order for the current search. The +default sort order is defined by `notmuch-search-oldest-first'." + (interactive) + (setq notmuch-search-oldest-first (not notmuch-search-oldest-first)) + (notmuch-tree-refresh-view)) + +(defun notmuch-tree-toggle-hide-excluded () + "Toggle whether to hide excluded messages. + +This command toggles whether to hide excluded messages for the current +search. The default value for this is defined by `notmuch-search-hide-excluded'." + (interactive) + (setq notmuch-search-hide-excluded (not notmuch-search-hide-excluded)) + (notmuch-tree-refresh-view)) + +;;;###autoload +(defun notmuch-tree (&optional query query-context target buffer-name + open-target unthreaded parent-buffer + oldest-first hide-excluded) "Display threads matching QUERY in tree view. The arguments are: @@ -1120,29 +1229,275 @@ The arguments are: it is nil \"*notmuch-tree\" followed by QUERY is used. OPEN-TARGET: If TRUE open the target message in the message pane. UNTHREADED: If TRUE only show matching messages in an unthreaded view." - (interactive) + (interactive + (list + ;; Prompt for a query + nil + ;; Fill other args with nil. + nil nil nil nil nil nil + ;; Populate these from the default value of these options. + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) (unless query (setq query (notmuch-read-query (concat "Notmuch " (if unthreaded "unthreaded " "tree ") "view search: ")))) - (let ((buffer (get-buffer-create (generate-new-buffer-name - (or buffer-name - (concat "*notmuch-" - (if unthreaded "unthreaded-" "tree-") - query "*"))))) + (let* ((name + (or buffer-name + (notmuch-search-buffer-title query + (if unthreaded "unthreaded" "tree")))) + (buffer (get-buffer-create (generate-new-buffer-name name))) (inhibit-read-only t)) (pop-to-buffer-same-window buffer)) ;; Don't track undo information for this buffer - (set 'buffer-undo-list t) - (notmuch-tree-worker query query-context target open-target unthreaded) + (setq buffer-undo-list t) + (notmuch-tree-worker query query-context target open-target + unthreaded oldest-first hide-excluded) (setq notmuch-tree-parent-buffer parent-buffer) (setq truncate-lines t)) -(defun notmuch-unthreaded (&optional query query-context target buffer-name open-target) +(defun notmuch-unthreaded (&optional query query-context target buffer-name + open-target oldest-first hide-excluded) + "Display threads matching QUERY in unthreaded view. + +See function NOTMUCH-TREE for documentation of the arguments" + (interactive + (list + ;; Prompt for a query + nil + ;; Fill other args with nil. + nil nil nil nil + ;; Populate these from the default value of these options. + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) + (notmuch-tree query query-context target buffer-name open-target + t nil oldest-first hide-excluded)) + +(defun notmuch-tree-filter (query) + "Filter or LIMIT the current search results based on an additional query string. + +Runs a new tree search matching only messages that match both the +current search results AND the additional query string provided." + (interactive (list (notmuch-read-query "Filter search: "))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)) + (grouped-query (notmuch-group-disjunctive-query-string query)) + (grouped-original-query (notmuch-group-disjunctive-query-string + (notmuch-tree-get-query)))) + (notmuch-tree-close-message-window) + (notmuch-tree (if (string= grouped-original-query "*") + grouped-query + (concat grouped-original-query " and " grouped-query))))) + +(defun notmuch-tree-filter-by-tag (tag) + "Filter the current search results based on a single TAG. + +Run a new search matching only messages that match the current +search results and that are also tagged with the given TAG." + (interactive + (list (notmuch-select-tag-with-completion "Filter by tag: " + notmuch-tree-basic-query))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) + (notmuch-tree-close-message-window) + (notmuch-tree (concat notmuch-tree-basic-query " and tag:" tag) + notmuch-tree-query-context + nil + nil + nil + notmuch-tree-unthreaded + nil + notmuch-search-oldest-first + notmuch-search-hide-excluded))) + +(defun notmuch-tree-edit-search (query) + "Edit the current search" + (interactive (list (read-from-minibuffer "Edit search: " + notmuch-tree-basic-query))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) + (notmuch-tree-close-message-window) + (notmuch-tree query + notmuch-tree-query-context + nil + nil + nil + notmuch-tree-unthreaded + 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) + +(defcustom notmuch-tree-outline-open-on-next nil + "Open new messages under point if they are closed when moving to next one. + +When this flag is set, using the command +`notmuch-tree-outline-next' with point on a header for a new +message that is not shown will open its `notmuch-show' buffer +instead of moving point to next matching 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--set-visibility () + (when (and notmuch-tree-outline-mode (> (point-max) (point-min))) + (cl-case notmuch-tree-outline-visibility + (hide-others (notmuch-tree-outline-hide-others)) + (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)) + +(defsubst notmuch-tree-outline--message-open-p () + (and (buffer-live-p notmuch-tree-message-buffer) + (get-buffer-window notmuch-tree-message-buffer) + (let ((id (notmuch-tree-get-message-id))) + (and id + (with-current-buffer notmuch-tree-message-buffer + (string= (notmuch-show-get-message-id) id)))))) + +(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 open-new) + (cond (thread + (notmuch-tree-thread-top) + (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)) + ((and (or open-new notmuch-tree-outline-open-on-next) + (notmuch-tree-outline--at-original-match-p) + (not (notmuch-tree-outline--message-open-p))) + (notmuch-tree-outline-hide-others t)) + (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) - (notmuch-tree query query-context target buffer-name open-target t)) + (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 "^[^\n]+") + (setq-local outline-level #'notmuch-tree-outline--level) + (notmuch-tree-outline--set-visibility)) + (setq-local outline-regexp (default-value 'outline-regexp)) + (setq-local outline-level (default-value 'outline-level)))) + +;;; _ (provide 'notmuch-tree)